encoding::source - allows you to write your script in non-ascii or non-utf8


encoding-source documentation Contained in the encoding-source distribution.

Index


Code Index:

NAME

Top

encoding::source - allows you to write your script in non-ascii or non-utf8

SYNOPSIS

Top

    use encoding::source 'utf8';
    no encoding::source; # back to latin-1

    {
      use encoding::source 'utf8';
      # ...
    }
    # back to latin-1

DESCRIPTION

Top

This pragma allows to change the default encoding for string literals in the current lexical compilation unit (block or file).

This is like the encoding pragma, but done right:

SEE ALSO

Top

Encode, encoding

COPYRIGHT

Top


encoding-source documentation Contained in the encoding-source distribution.

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__