#
# $Id: Encode.pm,v 2.35 2009/07/13 00:49:38 dankogai Exp $
#
package Encode;
use strict;
use warnings;
our $VERSION = sprintf "%d.%02d", q$Revision: 2.35 $ =~ /(\d+)/g;
sub DEBUG () { 0 }
use XSLoader ();
XSLoader::load( __PACKAGE__, $VERSION );
require Exporter;
use base qw/Exporter/;
# Public, encouraged API is exported by default
our @EXPORT = qw(
decode decode_utf8 encode encode_utf8 str2bytes bytes2str
encodings find_encoding clone_encoding
);
our @FB_FLAGS = qw(
DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC
PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL
);
our @FB_CONSTS = qw(
FB_DEFAULT FB_CROAK FB_QUIET FB_WARN
FB_PERLQQ FB_HTMLCREF FB_XMLCREF
);
our @EXPORT_OK = (
qw(
_utf8_off _utf8_on define_encoding from_to is_16bit is_8bit
is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade
),
@FB_FLAGS, @FB_CONSTS,
);
our %EXPORT_TAGS = (
all => [ @EXPORT, @EXPORT_OK ],
default => [ @EXPORT ],
fallbacks => [ @FB_CONSTS ],
fallback_all => [ @FB_CONSTS, @FB_FLAGS ],
);
# Documentation moved after __END__ for speed - NI-S
our $ON_EBCDIC = ( ord("A") == 193 );
use Encode::Alias;
# Make a %Encoding package variable to allow a certain amount of cheating
our %Encoding;
our %ExtModule;
require Encode::Config;
# See
# https://bugzilla.redhat.com/show_bug.cgi?id=435505#c2
# to find why sig handers inside eval{} are disabled.
eval {
local $SIG{__DIE__};
local $SIG{__WARN__};
require Encode::ConfigLocal;
};
sub encodings {
my $class = shift;
my %enc;
if ( @_ and $_[0] eq ":all" ) {
%enc = ( %Encoding, %ExtModule );
}
else {
%enc = %Encoding;
for my $mod ( map { m/::/o ? $_ : "Encode::$_" } @_ ) {
DEBUG and warn $mod;
for my $enc ( keys %ExtModule ) {
$ExtModule{$enc} eq $mod and $enc{$enc} = $mod;
}
}
}
return sort { lc $a cmp lc $b }
grep { !/^(?:Internal|Unicode|Guess)$/o } keys %enc;
}
sub perlio_ok {
my $obj = ref( $_[0] ) ? $_[0] : find_encoding( $_[0] );
$obj->can("perlio_ok") and return $obj->perlio_ok();
return 0; # safety net
}
sub define_encoding {
my $obj = shift;
my $name = shift;
$Encoding{$name} = $obj;
my $lc = lc($name);
define_alias( $lc => $obj ) unless $lc eq $name;
while (@_) {
my $alias = shift;
define_alias( $alias, $obj );
}
return $obj;
}
sub getEncoding {
my ( $class, $name, $skip_external ) = @_;
ref($name) && $name->can('renew') and return $name;
exists $Encoding{$name} and return $Encoding{$name};
my $lc = lc $name;
exists $Encoding{$lc} and return $Encoding{$lc};
my $oc = $class->find_alias($name);
defined($oc) and return $oc;
$lc ne $name and $oc = $class->find_alias($lc);
defined($oc) and return $oc;
unless ($skip_external) {
if ( my $mod = $ExtModule{$name} || $ExtModule{$lc} ) {
$mod =~ s,::,/,g;
$mod .= '.pm';
eval { require $mod; };
exists $Encoding{$name} and return $Encoding{$name};
}
}
return;
}
sub find_encoding($;$) {
my ( $name, $skip_external ) = @_;
return __PACKAGE__->getEncoding( $name, $skip_external );
}
sub resolve_alias($) {
my $obj = find_encoding(shift);
defined $obj and return $obj->name;
return;
}
sub clone_encoding($) {
my $obj = find_encoding(shift);
ref $obj or return;
eval { require Storable };
$@ and return;
return Storable::dclone($obj);
}
sub encode($$;$) {
my ( $name, $string, $check ) = @_;
return undef unless defined $string;
$string .= '' if ref $string; # stringify;
$check ||= 0;
unless ( defined $name ) {
require Carp;
Carp::croak("Encoding name should not be undef");
}
my $enc = find_encoding($name);
unless ( defined $enc ) {
require Carp;
Carp::croak("Unknown encoding '$name'");
}
my $octets = $enc->encode( $string, $check );
$_[1] = $string if $check and !ref $check and !( $check & LEAVE_SRC() );
return $octets;
}
*str2bytes = \&encode;
sub decode($$;$) {
my ( $name, $octets, $check ) = @_;
return undef unless defined $octets;
$octets .= '' if ref $octets;
$check ||= 0;
my $enc = find_encoding($name);
unless ( defined $enc ) {
require Carp;
Carp::croak("Unknown encoding '$name'");
}
my $string = $enc->decode( $octets, $check );
$_[1] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() );
return $string;
}
*bytes2str = \&decode;
sub from_to($$$;$) {
my ( $string, $from, $to, $check ) = @_;
return undef unless defined $string;
$check ||= 0;
my $f = find_encoding($from);
unless ( defined $f ) {
require Carp;
Carp::croak("Unknown encoding '$from'");
}
my $t = find_encoding($to);
unless ( defined $t ) {
require Carp;
Carp::croak("Unknown encoding '$to'");
}
my $uni = $f->decode($string);
$_[0] = $string = $t->encode( $uni, $check );
return undef if ( $check && length($uni) );
return defined( $_[0] ) ? length($string) : undef;
}
sub encode_utf8($) {
my ($str) = @_;
utf8::encode($str);
return $str;
}
sub decode_utf8($;$) {
my ( $str, $check ) = @_;
return $str if is_utf8($str);
if ($check) {
return decode( "utf8", $str, $check );
}
else {
return decode( "utf8", $str );
return $str;
}
}
predefine_encodings(1);
#
# This is to restore %Encoding if really needed;
#
sub predefine_encodings {
require Encode::Encoding;
no warnings 'redefine';
my $use_xs = shift;
if ($ON_EBCDIC) {
# was in Encode::UTF_EBCDIC
package Encode::UTF_EBCDIC;
push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding';
*decode = sub {
my ( $obj, $str, $chk ) = @_;
my $res = '';
for ( my $i = 0 ; $i < length($str) ; $i++ ) {
$res .=
chr(
utf8::unicode_to_native( ord( substr( $str, $i, 1 ) ) )
);
}
$_[1] = '' if $chk;
return $res;
};
*encode = sub {
my ( $obj, $str, $chk ) = @_;
my $res = '';
for ( my $i = 0 ; $i < length($str) ; $i++ ) {
$res .=
chr(
utf8::native_to_unicode( ord( substr( $str, $i, 1 ) ) )
);
}
$_[1] = '' if $chk;
return $res;
};
$Encode::Encoding{Unicode} =
bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC";
}
else {
package Encode::Internal;
push @Encode::Internal::ISA, 'Encode::Encoding';
*decode = sub {
my ( $obj, $str, $chk ) = @_;
utf8::upgrade($str);
$_[1] = '' if $chk;
return $str;
};
*encode = \&decode;
$Encode::Encoding{Unicode} =
bless { Name => "Internal" } => "Encode::Internal";
}
{
# was in Encode::utf8
package Encode::utf8;
push @Encode::utf8::ISA, 'Encode::Encoding';
#
if ($use_xs) {
Encode::DEBUG and warn __PACKAGE__, " XS on";
*decode = \&decode_xs;
*encode = \&encode_xs;
}
else {
Encode::DEBUG and warn __PACKAGE__, " XS off";
*decode = sub {
my ( $obj, $octets, $chk ) = @_;
my $str = Encode::decode_utf8($octets);
if ( defined $str ) {
$_[1] = '' if $chk;
return $str;
}
return undef;
};
*encode = sub {
my ( $obj, $string, $chk ) = @_;
my $octets = Encode::encode_utf8($string);
$_[1] = '' if $chk;
return $octets;
};
}
*cat_decode = sub { # ($obj, $dst, $src, $pos, $trm, $chk)
# currently ignores $chk
my ( $obj, undef, undef, $pos, $trm ) = @_;
my ( $rdst, $rsrc, $rpos ) = \@_[ 1, 2, 3 ];
use bytes;
if ( ( my $npos = index( $$rsrc, $trm, $pos ) ) >= 0 ) {
$$rdst .=
substr( $$rsrc, $pos, $npos - $pos + length($trm) );
$$rpos = $npos + length($trm);
return 1;
}
$$rdst .= substr( $$rsrc, $pos );
$$rpos = length($$rsrc);
return '';
};
$Encode::Encoding{utf8} =
bless { Name => "utf8" } => "Encode::utf8";
$Encode::Encoding{"utf-8-strict"} =
bless { Name => "utf-8-strict", strict_utf8 => 1 } =>
"Encode::utf8";
}
}
1;
__END__
=head1 NAME
Encode - character encodings
=head1 SYNOPSIS
use Encode;
=head2 Table of Contents
Encode consists of a collection of modules whose details are too big
to fit in one document. This POD itself explains the top-level APIs
and general topics at a glance. For other topics and more details,
see the PODs below:
Name Description
--------------------------------------------------------
Encode::Alias Alias definitions to encodings
Encode::Encoding Encode Implementation Base Class
Encode::Supported List of Supported Encodings
Encode::CN Simplified Chinese Encodings
Encode::JP Japanese Encodings
Encode::KR Korean Encodings
Encode::TW Traditional Chinese Encodings
--------------------------------------------------------
=head1 DESCRIPTION
The C module provides the interfaces between Perl's strings
and the rest of the system. Perl strings are sequences of
B.
The repertoire of characters that Perl can represent is at least that
defined by the Unicode Consortium. On most platforms the ordinal
values of the characters (as returned by C) is the "Unicode
codepoint" for the character (the exceptions are those platforms where
the legacy encoding is some variant of EBCDIC rather than a super-set
of ASCII - see L).
Traditionally, computer data has been moved around in 8-bit chunks
often called "bytes". These chunks are also known as "octets" in
networking standards. Perl is widely used to manipulate data of many
types - not only strings of characters representing human or computer
languages but also "binary" data being the machine's representation of
numbers, pixels in an image - or just about anything.
When Perl is processing "binary data", the programmer wants Perl to
process "sequences of bytes". This is not a problem for Perl - as a
byte has 256 possible values, it easily fits in Perl's much larger
"logical character".
=head2 TERMINOLOGY
=over 2
=item *
I: a character in the range 0..(2**32-1) (or more).
(What Perl's strings are made of.)
=item *
I: a character in the range 0..255
(A special case of a Perl character.)
=item *
I: 8 bits of data, with ordinal values 0..255
(Term for bytes passed to or from a non-Perl context, e.g. a disk file.)
=back
=head1 PERL ENCODING API
=over 2
=item $octets = encode(ENCODING, $string [, CHECK])
Encodes a string from Perl's internal form into I and returns
a sequence of octets. ENCODING can be either a canonical name or
an alias. For encoding names and aliases, see L.
For CHECK, see L.
For example, to convert a string from Perl's internal format to
iso-8859-1 (also known as Latin1),
$octets = encode("iso-8859-1", $string);
B: When you run C<$octets = encode("utf8", $string)>, then
$octets B $string. Though they both contain the
same data, the UTF8 flag for $octets is B off. When you
encode anything, UTF8 flag of the result is always off, even when it
contains completely valid utf8 string. See L below.
If the $string is C then C is returned.
=item $string = decode(ENCODING, $octets [, CHECK])
Decodes a sequence of octets assumed to be in I into Perl's
internal form and returns the resulting string. As in encode(),
ENCODING can be either a canonical name or an alias. For encoding names
and aliases, see L. For CHECK, see
L.
For example, to convert ISO-8859-1 data to a string in Perl's internal format:
$string = decode("iso-8859-1", $octets);
B: When you run C<$string = decode("utf8", $octets)>, then $string
B $octets. Though they both contain the same data,
the UTF8 flag for $string is on unless $octets entirely consists of
ASCII data (or EBCDIC on EBCDIC machines). See L
below.
If the $string is C then C is returned.
=item [$obj =] find_encoding(ENCODING)
Returns the I corresponding to ENCODING. Returns
undef if no matching ENCODING is find.
This object is what actually does the actual (en|de)coding.
$utf8 = decode($name, $bytes);
is in fact
$utf8 = do{
$obj = find_encoding($name);
croak qq(encoding "$name" not found) unless ref $obj;
$obj->decode($bytes)
};
with more error checking.
Therefore you can save time by reusing this object as follows;
my $enc = find_encoding("iso-8859-1");
while(<>){
my $utf8 = $enc->decode($_);
# and do someting with $utf8;
}
Besides C<< ->decode >> and C<< ->encode >>, other methods are
available as well. For instance, C<< -> name >> returns the canonical
name of the encoding object.
find_encoding("latin1")->name; # iso-8859-1
See L for details.
=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
Converts B data between two encodings. The data in $octets
must be encoded as octets and not as characters in Perl's internal
format. For example, to convert ISO-8859-1 data to Microsoft's CP1250
encoding:
from_to($octets, "iso-8859-1", "cp1250");
and to convert it back:
from_to($octets, "cp1250", "iso-8859-1");
Note that because the conversion happens in place, the data to be
converted cannot be a string constant; it must be a scalar variable.
from_to() returns the length of the converted string in octets on
success, I on error.
B: The following operations look the same but are not quite so;
from_to($data, "iso-8859-1", "utf8"); #1
$data = decode("iso-8859-1", $data); #2
Both #1 and #2 make $data consist of a completely valid UTF-8 string
but only #2 turns UTF8 flag on. #1 is equivalent to
$data = encode("utf8", decode("iso-8859-1", $data));
See L below.
Also note that
from_to($octets, $from, $to, $check);
is equivalent to
$octets = encode($to, decode($from, $octets), $check);
Yes, it does not respect the $check during decoding. It is
deliberately done that way. If you need minute control, C
then C as follows;
$octets = encode($to, decode($from, $octets, $check_from), $check_to);
=item $octets = encode_utf8($string);
Equivalent to C<$octets = encode("utf8", $string);> The characters
that comprise $string are encoded in Perl's internal format and the
result is returned as a sequence of octets. All possible
characters have a UTF-8 representation so this function cannot fail.
=item $string = decode_utf8($octets [, CHECK]);
equivalent to C<$string = decode("utf8", $octets [, CHECK])>.
The sequence of octets represented by
$octets is decoded from UTF-8 into a sequence of logical
characters. Not all sequences of octets form valid UTF-8 encodings, so
it is possible for this call to fail. For CHECK, see
L.
=back
=head2 Listing available encodings
use Encode;
@list = Encode->encodings();
Returns a list of the canonical names of the available encodings that
are loaded. To get a list of all available encodings including the
ones that are not loaded yet, say
@all_encodings = Encode->encodings(":all");
Or you can give the name of a specific module.
@with_jp = Encode->encodings("Encode::JP");
When "::" is not in the name, "Encode::" is assumed.
@ebcdic = Encode->encodings("EBCDIC");
To find out in detail which encodings are supported by this package,
see L.
=head2 Defining Aliases
To add a new alias to a given encoding, use:
use Encode;
use Encode::Alias;
define_alias(newName => ENCODING);
After that, newName can be used as an alias for ENCODING.
ENCODING may be either the name of an encoding or an
I
But before you do so, make sure the alias is nonexistent with
C, which returns the canonical name thereof.
i.e.
Encode::resolve_alias("latin1") eq "iso-8859-1" # true
Encode::resolve_alias("iso-8859-12") # false; nonexistent
Encode::resolve_alias($name) eq $name # true if $name is canonical
resolve_alias() does not need C