File Coverage

blib/lib/Encode/Escape/Unicode.pm

Criterion	Covered	Total	%
statement	27	86	31.4
branch	4	34	11.7
condition	0	6	0.0
subroutine	8	21	38.1
pod	2	15	13.3
total	41	162	25.3

# Encoding of Unicode Escape Sequences (or Escaped Unicode)

# $Id: Unicode.pm,v 1.13 2007-12-05 22:11:11+09 you Exp $

package Encode::Escape::Unicode;

our $VERSION  = do { q$Revision: 1.13 $ =~ /\d+\.(\d+)/; sprintf "%.2f", $1 / 100  };

use 5.008008;
use strict;
use warnings;

use Encode::Encoding;
use base qw(Encode::Encoding);

__PACKAGE__->Define(qw/unicode-escape unicode_escape/);

sub import {

    __PACKAGE__->enmode('default');
    __PACKAGE__->demode('default');

    require Encode;
    Encode->export_to_level(1, @_);
}

our $enmode;
our $demode;
sub encoder($);
sub decoder($);

#
# == encoder/decoder modes ==
#
our %encoder = (
    undef   => \&perl_encoder,
    ''      => \&perl_encoder,
    default => \&perl_encoder,
    perl    => \&perl_encoder,
    java    => \&python_encoder,
    python  => \&python_encoder,
    csharp  => \&python_encoder,
);

our %decoder = (
    undef   => \&perl_decoder,
    ''      => \&perl_decoder,
    default => \&perl_decoder,
    perl    => \&perl_decoder,
    java    => \&python_decoder,
    python  => \&python_decoder,
    csharp  => \&python_decoder,
);

#
# == encode/decode ==
#

sub encode($$;$) {
    my ($obj, $str, $chk) = @_;
    $_[1] = '' if $chk;
    return encoder $str;
}


sub decode($$;$) {
    my ($obj, $str, $chk) = @_;
    $_[1] = '' if $chk;
    return decoder $str;
}

#
# == enmode/demode ==
#

sub enmode ($$) {
   my ($class, $mode) = @_;
   $mode = 'undef' unless defined $mode;
   unless (exists $encoder{$mode}) {
        require Carp;
        Carp::croak(
            "Unknown enmode '$mode' for encoding '" . $class->name() . "'"
        );
   }
   $enmode = $mode;
}

sub demode ($$) {
   my ($class, $mode) = @_;
   $mode = 'undef' unless defined $mode;
   unless (exists $decoder{$mode}) {
        require Carp;
        Carp::croak(
            "Unknown demode '$mode' for encoding '" . $class->name() . "'"
        );
   }
   $demode = $mode;
}


#
# = DATA AND SUBROUTINES FOR INTERNAL USE =
#


#
# == encoder/decoder ==
#

sub encoder($) {
    local $_ = ( defined $_[0] ? $_[0] : '' );
    return $encoder{$enmode}->($_);
}
sub decoder($) {
    local $_ = ( defined $_[0] ? $_[0] : '' );
    return $decoder{$demode}->($_);
}

#
# == enmode_encoder / demode_decoder ==
#

# default (perl) escape sequences
#
sub perl_encoder($) {

    local $_ = ( defined $_[0] ? $_[0] : '' );

    $_ = escape($_);
    s/([\x00-\x1f\x{7f}-\x{ffff}])/"\\x\{".uc(chr2hex($1))."\}"/gse;

    return $_;
}

sub perl_decoder($) {

    local $_ = ( defined $_[0] ? $_[0] : '' );

    s/((?:\A|\G|[^\\]))\\x([\da-fA-F]{1,2})/$1.hex2chr($2)/gse;
    s/((?:\A|\G|[^\\]))\\x\{([\da-fA-F]{1,4})\}/$1.hex2chr($2)/gse;

    return unescape($_);
}

# python (or java, c#) escape sequences
#
sub python_encoder($) {

    local $_ = ( defined $_[0] ? $_[0] : '' );

    $_ = escape($_);
    s/([\x00-\x1f\x{7f}-\x{ffff}])/'\u'.chr2hex($1)/gse;

    return $_;
}

sub python_decoder {

    local $_ = ( defined $_[0] ? $_[0] : '' );

    s/((?:\A|\G|[^\\]))\\u([\da-fA-F]{4})/$1.hex2chr($2)/gse;

    return unescape($_);
}

#
# == common data and subroutines ==
#

my %ESCAPED = (
    "\\" => '\\',
    "\r" => 'r',
    "\n" => 'n',
    "\t" => 't',
    "\a" => 'a',
    "\b" => 'b',
    "\e" => 'e',
    "\f" => 'f',
    "\"" => '"',
    "\$" => '$',
    "\@" => '@',
);

my %UNESCAPED = ( reverse %ESCAPED );

sub escape ($) {
    local $_ = ( defined $_[0] ? $_[0] : '' );
    s/([\a\b\e\f\r\n\t\"\\\$\@])/\\$ESCAPED{$1}/sg;
    return $_;
}

sub unescape ($) {
    local $_ = ( defined $_[0] ? $_[0] : '' );

    s/((?:\A|\G|[^\\]))\\([0-7]{1,3})/$1.oct2chr($2)/gse;

    s/((?:\A|\G|[^\\]))\\([^aAbBeEfFrRnNtT\\\"\$\@])/$1$2/g;

    s/((?:\A|\G|[^\\]))\\([aAbBeEfFrRnNtT\\\"\$\@])/$1.$UNESCAPED{lc($2)}/gse;

    return $_;
}



sub chr2hex {
    my($c) = @_;
    if ( ord($c) < 65536 ) {
        return sprintf("%04x", ord($c));
    }
    else {
        require Carp;
        Carp::croak (
            "'unicode-escape' codec can't encode character: ordinal " . ord($c)
        );
    }
}

sub hex2chr {
    my($hex) = @_;
    if ( hex($hex) >= 0 and hex($hex) < 65536) {
        return chr(hex($hex));
    }
    else {
        require Carp;
        Carp::croak(
            "'unicode-escape' codec can't decode escape sequence: "
            . "\\x$hex (ordinal " . hex($hex) . ")"
        );
    }
}

sub oct2chr {
    my($oct) = @_;
    if ( oct($oct) >= 0 and oct($oct) < 256 ) {
        return chr(oct($oct));
    }
    else {
        require Carp;
        Carp::croak (
            "'unicode-escape' codec can't decode escape sequence: "
            . "\\$oct (ordinal " . oct($oct). ")"
        );
    }
}

$\ = "\n";


1;
__END__