??????????????
Warning: Cannot modify header information - headers already sent by (output started at /home/mybf1/public_html/mentol.bf1.my/SS1.php:4) in /home/mybf1/public_html/mentol.bf1.my/SS1.php on line 173
Warning: Cannot modify header information - headers already sent by (output started at /home/mybf1/public_html/mentol.bf1.my/SS1.php:4) in /home/mybf1/public_html/mentol.bf1.my/SS1.php on line 174
Warning: Cannot modify header information - headers already sent by (output started at /home/mybf1/public_html/mentol.bf1.my/SS1.php:4) in /home/mybf1/public_html/mentol.bf1.my/SS1.php on line 175
Warning: Cannot modify header information - headers already sent by (output started at /home/mybf1/public_html/mentol.bf1.my/SS1.php:4) in /home/mybf1/public_html/mentol.bf1.my/SS1.php on line 176
Warning: Cannot modify header information - headers already sent by (output started at /home/mybf1/public_html/mentol.bf1.my/SS1.php:4) in /home/mybf1/public_html/mentol.bf1.my/SS1.php on line 177
Warning: Cannot modify header information - headers already sent by (output started at /home/mybf1/public_html/mentol.bf1.my/SS1.php:4) in /home/mybf1/public_html/mentol.bf1.my/SS1.php on line 178
#
# $Id: Encode.pm,v 2.51 2013/04/29 22:19:11 dankogai Exp dankogai $
#
package Encode;
use strict;
use warnings;
our $VERSION = sprintf "%d.%02d", q$Revision: 2.51 $ =~ /(\d+)/g;
use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
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 %enc;
my $arg = $_[1] || '';
if ( $arg eq ":all" ) {
%enc = ( %Encoding, %ExtModule );
}
else {
%enc = %Encoding;
for my $mod ( map { m/::/ ? $_ : "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 ) = @_;
$name =~ s/\s+//g; # https://rt.cpan.org/Ticket/Display.html?id=65796
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 .= ''; # 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 .= '';
$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;
}
my $utf8enc;
sub decode_utf8($;$) {
my ( $octets, $check ) = @_;
return $octets if is_utf8($octets);
return undef unless defined $octets;
$octets .= '';
$check ||= 0;
$utf8enc ||= find_encoding('utf8');
my $string = $utf8enc->decode( $octets, $check );
$_[0] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() );
return $string;
}
# 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 ( undef, $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 ( undef, $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 ( undef, $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 ( undef, $octets, $chk ) = @_;
my $str = Encode::decode_utf8($octets);
if ( defined $str ) {
$_[1] = '' if $chk;
return $str;
}
return undef;
};
*encode = sub {
my ( undef, $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 ( undef, 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 in Perl
=head1 SYNOPSIS
use Encode qw(decode encode);
$characters = decode('UTF-8', $octets, Encode::FB_CROAK);
$octets = encode('UTF-8', $characters, Encode::FB_CROAK);
=head2 Table of Contents
Encode consists of a collection of modules whose details are too extensive
to fit in one document. This one itself explains the top-level APIs
and general topics at a glance. For other topics and more details,
see the documentation for these modules:
=over 2
=item L - Alias definitions to encodings
=item L - Encode Implementation Base Class
=item L - List of Supported Encodings
=item L - Simplified Chinese Encodings
=item L - Japanese Encodings
=item L - Korean Encodings
=item L - Traditional Chinese Encodings
=back
=head1 DESCRIPTION
The C module provides the interface between Perl strings
and the rest of the system. Perl strings are sequences of
I.
The repertoire of characters that Perl can represent is a superset of those
defined by the Unicode Consortium. On most platforms the ordinal
values of a character as returned by C)> is the I for that character. The exceptions are platforms where
the legacy encoding is some variant of EBCDIC rather than a superset
of ASCII; see L.
During recent history, data is moved around a computer in 8-bit chunks,
often called "bytes" but also known as "octets" in standards documents.
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: because a
byte has 256 possible values, it easily fits in Perl's much larger
"logical character".
This document mostly explains the I. L and L
explain the I.
=head2 TERMINOLOGY
=head3 character
A character in the range 0 .. 2**32-1 (or more);
what Perl's strings are made of.
=head3 byte
A character in the range 0..255;
a special case of a Perl character.
=head3 octet
8 bits of data, with ordinal values 0..255;
term for bytes passed to or from a non-Perl context, such as a disk file,
standard I/O stream, database, command-line argument, environment variable,
socket etc.
=head1 THE PERL ENCODING API
=head2 Basic methods
=head3 encode
$octets = encode(ENCODING, STRING[, CHECK])
Encodes the scalar value I from Perl's internal form into
I and returns a sequence of octets. I can be either a
canonical name or an alias. For encoding names and aliases, see
L"Defining Aliases">. For CHECK, see L"Handling Malformed Data">.
For example, to convert a string from Perl's internal format into
ISO-8859-1, also known as Latin1:
$octets = encode("iso-8859-1", $string);
B: When you run C<$octets = encode("utf8", $string)>, then
$octets I $string. Though both contain the
same data, the UTF8 flag for $octets is I off. When you
encode anything, the UTF8 flag on the result is always off, even when it
contains a completely valid utf8 string. See L"The UTF8 flag"> below.
If the $string is C, then C is returned.
=head3 decode
$string = decode(ENCODING, OCTETS[, CHECK])
This function returns the string that results from decoding the scalar
value I, assumed to be a sequence of octets in I, into
Perl's internal form. The returns the resulting string. As with encode(),
I can be either a canonical name or an alias. For encoding names
and aliases, see L"Defining Aliases">; for I, see L"Handling
Malformed Data">.
For example, to convert ISO-8859-1 data into a string in Perl's
internal format:
$string = decode("iso-8859-1", $octets);
B: When you run C<$string = decode("utf8", $octets)>, then $string
I $octets. Though both contain the same data, the
UTF8 flag for $string is on unless $octets consists entirely of ASCII data
on ASCII machines or EBCDIC on EBCDIC machines. See L"The UTF8 flag">
below.
If the $string is C, then C is returned.
=head3 find_encoding
[$obj =] find_encoding(ENCODING)
Returns the I corresponding to I. Returns
C if no matching I is find. The returned object is
what does the actual encoding or decoding.
$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.
You can therefore save time by reusing this object as follows;
my $enc = find_encoding("iso-8859-1");
while(<>) {
my $utf8 = $enc->decode($_);
... # now do something with $utf8;
}
Besides L and L, other methods are
available as well. For instance, C returns the canonical
name of the encoding object.
find_encoding("latin1")->name; # iso-8859-1
See L for details.
=head3 from_to
[$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
Converts I data between two encodings. The data in $octets
must be encoded as octets and I as characters in Perl's internal
format. For example, to convert ISO-8859-1 data into Microsoft's CP1250
encoding:
from_to($octets, "iso-8859-1", "cp1250");
and to convert it back:
from_to($octets, "cp1250", "iso-8859-1");
Because the conversion happens in place, the data to be
converted cannot be a string constant: it must be a scalar variable.
C returns the length of the converted string in octets on success,
and C on error.
B: The following operations may look the same, but are not:
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 the UTF8 flag on. #1 is equivalent to:
$data = encode("utf8", decode("iso-8859-1", $data));
See L"The UTF8 flag"> below.
Also note that:
from_to($octets, $from, $to, $check);
is equivalent t:o
$octets = encode($to, decode($from, $octets), $check);
Yes, it does I respect the $check during decoding. It is
deliberately done that way. If you need minute control, use C
followed by C as follows:
$octets = encode($to, decode($from, $octets, $check_from), $check_to);
=head3 encode_utf8
$octets = encode_utf8($string);
Equivalent to C<$octets = encode("utf8", $string)>. The characters in
$string are encoded in Perl's internal format, and the result is returned
as a sequence of octets. Because all possible characters in Perl have a
(loose, not strict) UTF-8 representation, this function cannot fail.
=head3 decode_utf8
$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.
Because not all sequences of octets are valid UTF-8,
it is quite possible for this function to fail.
For CHECK, see L"Handling Malformed Data">.
=head2 Listing available encodings
use Encode;
@list = Encode->encodings();
Returns a list of canonical names of available encodings that have already
been loaded. To get a list of all available encodings including those that
have not yet been loaded, say:
@all_encodings = Encode->encodings(":all");
Or you can give the name of a specific module:
@with_jp = Encode->encodings("Encode::JP");
When "C<::>" is not in the name, "C" 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, I can be used as an alias for I.
I may be either the name of an encoding or an
I.
Before you do that, first make sure the alias is nonexistent using
C, which returns the canonical name thereof.
For example:
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
C does not need C