File Coverage

blib/lib/encoding/source.pm

Criterion	Covered	Total	%
statement	39	43	90.7
branch	4	6	66.6
condition	6	8	75.0
subroutine	11	12	91.6
pod	0	2	0.0
total	60	71	84.5

package encoding::source;

use 5.009005;
use strict;
use warnings;
use Encode qw(find_encoding);

our $VERSION = 0.02;

our $SINGLETON = bless {}, __PACKAGE__;

sub croak {
    require Carp;
    Carp::croak(__PACKAGE__ . ": @_");
}

my $LATIN1 = find_encoding('iso-8859-1')
    or croak("Can't load latin-1");

sub _find_encoding {
    my $name = shift;
    return $SINGLETON->{$name} // find_encoding($name);
}

sub import {
    my ($class, $name) = @_;
    my $enc = _find_encoding($name);
    if (!defined $enc) {
	croak("Unknown encoding '$name'");
    }
    # canonicalize the encoding name
    $name = $enc->name;
    # associate it to the currently compiled lexical unit
    $^H{$class} = $name;
    # remember the Encode object for that encoding
    $SINGLETON->{$name} //= $enc;
    # make sure to install our encoding handler
    ${^ENCODING} = $SINGLETON;
}

sub unimport {
    my $class = shift;
    undef $^H{$class};
}

# now, the three methods called by the core on ${^ENCODING}

# returns the name of the encoding which is in effect in the
# caller's lexical unit

sub name {
    my $level = $_[1] // 0;
    my $hinthash = (caller($level))[10];
    return $hinthash->{"" . __PACKAGE__};
}

# the other methods are just forwarded to the appropriate
# Encode object, retrieved in the $SINGLETON

for my $method (qw(decode cat_decode)) {
    no strict 'refs';
    *$method = sub {
	use strict;
	my $self = shift;
	my $name = $self->name(1);
	if ($name) {
	    my $enc = $self->{$name};
	    if (!defined $enc) {
		croak("Can't find compiled encoding for '$name'");
	    }
	    $enc->$method(@_);
	}
	else {
	    $LATIN1->$method(@_);
	}
    };
}

1;

__END__