File Coverage

blib/lib/String/Unescape.pm

Criterion	Covered	Total	%
statement	20	20	100.0
branch	4	6	66.6
condition	2	3	66.6
subroutine	6	6	100.0
pod	1	1	100.0
total	33	36	91.6

package String::Unescape;

use 5.008;
use strict;
use warnings;

# ABSTRACT: Unescape perl-escaped string
our $VERSION = 'v0.0.3'; # VERSION

require Exporter;
our (@EXPORT_OK) = qw(unescape);

use Carp;

my %map = (
    t => "\t",
    n => "\n",
    r => "\r",
    f => "\f",
    b => "\b",
    a => "\a",
    e => "\e",
);

my %mapc = map { chr($_) => chr($_ ^ 0x60) } 97..122;

my %convs = (
    l => sub { lcfirst shift },
    u => sub { ucfirst shift },
);

my %convp = (
    L => sub { lc shift },
    U => sub { uc shift },
    Q => sub { quotemeta shift },
);

if($^V ge v5.16.0) {
    # All constant stringy eval so this should be safe.
    eval q{use feature qw(fc); $convp{F} = sub { fc(shift) };}; ## no critic (ProhibitStringyEval)
} else {
    $convp{F} = sub { 'F'.shift }; # \E omitted
}

my $from_code = sub { chr(hex(shift)); };
my $from_name;

if($^V ge v5.14.0) {
    $from_name = sub {
        my $name = shift;
        return charnames::string_vianame($name) || die "Unknown charname $name";
    };
} else {
    $from_name = sub {
        my $name = shift;
        my $code = charnames::vianame($name);
        die "Unknown charname $name" if ! defined $code;
        return chr($code);
    };
}

my $re_single = qr/
    \\([tnrfbae]) |                  # $1 : one char
    \\c(.) |                         # $2 : control
    \\x\{([0-9a-fA-F]*)[^}]*\} |     # $3 : \x{}
    \\x([0-9a-fA-F]{0,2}) |          # $4 : \x
    \\([0-7]{1,3}) |                 # $5 : \077
    \\o\{([0-7]*)([^}]*)\} |         # $6, $7 : \o{}
    \\N\{U\+([^}]*)\} |              # $8 : \N{U+}
    \\N\{([^}]*)\} |                 # $9 : \N{name}

    \\(l|u)(.?) |                    # $10, $11 : \l, \u
    \\E |                            #
    \\?(.)                           # $12
/xs;

my $convert_single = sub {
    require charnames if defined $8 || defined $9;

    return $map{$1} if defined $1;
    return exists $mapc{$2} ? $mapc{$2} : chr(ord($2) ^ 0x40) if defined $2;
    return chr(hex($3)) if defined $3;
    return chr(hex($4)) if defined $4;
    return chr(oct($5)) if defined $5;
    return chr(oct($6)) if defined $6 && $^V ge v5.14.0;
    return 'o{'.$6.$7.'}' if defined $6;
# TODO: Need to check invalid cases
    return $from_code->($8) if defined $8;
    return $from_name->($9) if defined $9;
    return $convs{$10}($11) if defined $10;
    return $12 if defined $12;
    return ''; # \E
};

my $apply_single = sub {
    my $target = shift;
    while($target =~ s/\G$re_single/$convert_single->()/gxse) {
        last unless defined pos($target);
    }
    return $target;
};

# NOTE: I'm not sure the reason, but my $_re_recur; causes a error.
our $_re_recur;
$_re_recur = qr/
    \\([LUQF])
    (?:(?>(?:[^\\]|\\[^LUQFE])+)|(??{$_re_recur}))*
    (?:\\E|\Z)
/xs;

my $re_range = qr/
    ((?:[^\\]|\\[^LUQF])*)                                # $1: pre
    (?:
        \\([LUQF])                                        # $2: marker
        ((?:(?>(?:[^\\]|\\[^LUQFE])+)|(??{$_re_recur}))*) # $3: content
        (?:\\E|\Z)
    )*
/xs;

my $apply_range;

my $convert_range = sub {
    my ($pre, $marker, $content) = @_;
    return
        (defined $pre ? $apply_single->($pre) : '').
        (defined $marker ? $convp{$marker}($apply_range->($content)) : '');
};

$apply_range = sub {
    my $target = shift;
    while($target =~ s/\G$re_range/$convert_range->($1, $2, $3)/gxse) {
        last unless defined pos($target);
    }
    return $target;
};

sub unescape
{
    shift if @_ && eval { $_[0]->isa(__PACKAGE__); };
    croak 'No string is given' unless @_;
    croak 'More than one argument are given' unless @_ == 1;

    return $apply_range->($_[0]);
}

1;

__END__