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__
=head1 NAME
encoding::source - allows you to write your script in non-ascii or non-utf8
=head1 SYNOPSIS
use encoding::source 'utf8';
no encoding::source; # back to latin-1
{
use encoding::source 'utf8';
# ...
}
# back to latin-1
=head1 DESCRIPTION
This pragma allows to change the default encoding for string literals in the
current lexical compilation unit (block or file).
This is like the C<encoding> pragma, but done right:
=over 4
=item *
It doesn't mess with the STDIN and STDOUT filehandles.
=item *
It's lexically scoped and its effect doesn't leak into other files.
=back
=head1 SEE ALSO
L<Encode>, L<encoding>
=head1 COPYRIGHT
(c) Copyright 2007 by Rafael Garcia-Suarez.
Most test files are adapted from the tests of C<encoding>,
maintained by Dan Kogai as part of the C<Encode> distribution.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut