File Coverage

blib/lib/String/UnicodeUTF8.pm

Criterion	Covered	Total	%
statement	90	105	85.7
branch	34	50	68.0
condition	11	18	61.1
subroutine	23	23	100.0
pod	16	16	100.0
total	174	212	82.0

package String::UnicodeUTF8;

use strict;
use warnings;

use String::Unquotemeta ();
use Module::Want 0.6 ();

$String::UnicodeUTF8::VERSION = '0.21';

sub import {
    return 1 if @_ == 1;    # no-op import()

    my $caller = caller();

    no strict 'refs';       ## no critic
    for ( @_[ 1 .. $#_ ] ) {
        next if $_ eq 'import' || $_ eq '_pre_581_is_utf8_hack';
        *{ $caller . '::' . $_ } = \&{$_} if defined &{$_};
    }
}

# is_utf8() is confusing, it really means “is this a Unicode string”, not “is this a utf-8 bytes string”)
*is_unicode = $] >= 5.008_001 ? \&utf8::is_utf8 : \&_pre_581_is_utf8_hack;    # or just 'use 5.8.1;' and drop this ?

my $pre_573_is_utf8_hack = $] >= 5.007_003 ? undef : {};

sub char_count {
    return CORE::length( get_unicode( $_[0] ) );
}

sub bytes_size {
    return CORE::length( get_utf8( $_[0] ) );
}

sub get_unicode {
    my ($string) = @_;

    if ( !is_unicode($string) ) {
        if ( defined &utf8::decode ) {
            utf8::decode($string);
        }
        else {    # decode() a hacky way:
            $string = pack( "U*", unpack( "C0U*", $string ) );    # 5.6+ at least
        }

        # if decode() did not fully do it (e.g. it only contained ascii characters and utf8::decode() was called)
        if ( !is_unicode($string) ) {

            # force strings without unicode characters to be unicode strings
            if ( defined &utf8::upgrade ) {
                utf8::upgrade($string);
            }
            else {                                                # upgrade() the hacky way: (TODO: how?)
                require Carp;
                Carp::carp("pack() did not result in unicode string and there is no way to emulate utf8::upgrade");
            }
        }
    }

    $pre_573_is_utf8_hack->{$string} = '' if ref $pre_573_is_utf8_hack;
    return $string;
}

sub get_utf8 {
    my ($string) = @_;
    if ( is_unicode($string) ) {
        if ( defined &utf8::encode ) {
            utf8::encode($string);
        }
        else {    # encode() the hacky way:
            $string = pack( "C0U*", unpack( "U*", $string ) );    # 5.6+ at least
        }
    }

    delete $pre_573_is_utf8_hack->{$string} if ref $pre_573_is_utf8_hack;
    return $string;
}

# ? want to serialize these too ?
# my %esc = ( "\n" => '\n', "\t" => '\t', "\r" => '\r', "\\" => '\\\\', "\a" => '\a', "\b" => '\b', "\f" => '\f' );

sub escape_utf8_or_unicode {
    my ( $s, $quotemeta ) = @_;    # undocumented second flag for internal use

    my $is_uni = is_unicode($s);   # otherwise you'll get \xae\x{301} instead of \x{ae}\x{301}

    # ick: patches uber welcome
    if ( $is_uni && $] < 5.008_001 && Module::Want::have_mod('Data::Dumper') ) {
        local $Data::Dumper::Terse = 1;
        $s = Data::Dumper::Dumper($s);
        $s =~ s/\A(["|'])//;
        my $quote = $1;
        $s =~ s/$quote\s*\z//;
        $s =~ s/'/\\'/g unless $quote eq "'";
        return get_utf8($s);
    }

    $s =~ s{([^!#&()*+,\-.\/0123456789:;<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]\^_`abcdefghijklmnopqrstuvwxyz{|}~ ])}
        {
            my $chr = "$1";
            my $n   = ord($chr);

            # if ( exists $esc{$chr} ) { # more universal way ???
            #     $esc{$chr};
            # }
            # els
            if ( $n < 32 || $n > 126 ) {
                sprintf( ( !$is_uni && $n < 255 ? '\x%02x' : '\x{%04x}' ), $n );
            }
            elsif ($quotemeta) {
                quotemeta($chr);
            }
            else {
                $chr
            }
        }ge;

    return get_utf8($s);
}

sub escape_utf8 {
    my ($string) = @_;
    $string = get_utf8($string);
    return escape_utf8_or_unicode($string);
}

sub escape_unicode {
    my ($string) = @_;
    $string = get_unicode($string);
    return escape_utf8_or_unicode($string);
}

sub unescape_utf8_or_unicode {
    my ( $string, $unquotemeta ) = @_;    # undocumented second flag for internal use
    my $is_uni = $string =~ m/\\x\{[0-9a-fA-f]+\}/ ? 1 : 0;

    $string =~ s/((?:\\x(?:[0-9a-fA-f]{2}|\{[0-9a-fA-f]+\}))+)/eval qq{"$1"}/eg;    ## no critic
    $string = String::Unquotemeta::unquotemeta($string) if $unquotemeta;
    return get_unicode($string) if $is_uni;
    return get_utf8($string);
}

sub unescape_utf8 {
    my ($string) = @_;
    $string = unescape_utf8_or_unicode($string);
    return get_utf8($string);
}

sub unescape_unicode {
    my ($string) = @_;
    $string = unescape_utf8_or_unicode($string);
    return get_unicode($string);
}

sub quotemeta_bytes {    # I ♥ perl\'s coolness
    my $utf8_quoted = quotemeta_utf8( $_[0] );
    return unescape_utf8_or_unicode($utf8_quoted);
}

sub quotemeta_utf8 {     # I \xe2\x99\xa5 perl\'s coolness
    my ($string) = @_;
    $string = get_utf8($string);
    return escape_utf8_or_unicode( $string, 1 );
}

sub quotemeta_unicode {    # I \x{2665} perl\'s coolness
    my ($string) = @_;
    $string = get_unicode($string);
    return escape_utf8_or_unicode( $string, 1 );
}

sub unquotemeta_bytes {
    goto &unquotemeta_utf8;
}

sub unquotemeta_utf8 {
    my ($escaped_string) = @_;
    $escaped_string = unescape_utf8_or_unicode( $escaped_string, 1 );
    return get_utf8($escaped_string);
}

sub unquotemeta_unicode {
    my ($escaped_string) = @_;
    $escaped_string = unescape_utf8_or_unicode( $escaped_string, 1 );
    return get_unicode($escaped_string);
}

sub _pre_581_is_utf8_hack {
    my ($string) = @_;

    # strings with unicode characters that are unicode strings
    require bytes;
    return 1 if bytes::length($string) != CORE::length($string);

    # strings without unicode characters that are unicode strings
    if ( Module::Want::have_mod('Encode') ) {
        return 1 if Encode::is_utf8($string);
    }
    else {

        # So we have a string without unicode characters and no utf8::is_utf8() or Encode::is_utf8(), time to get hacky!
        if ( Module::Want::have_mod('B::Flags') && defined &B::svref_2object ) {    # B::Flags brings in B *but* B::svref_2object can be compiled away in some specific circumstances
            return 1 if B::svref_2object( \$string )->flagspv() =~ m/UTF.?8/i;      # works on 5.6!
        }
        else {

            # oi, still nothing is available at this point so time to get reeeeeaaaallly hacky! (patches very very welcome, this is a terrible last ditch effort)

            # not fool proof (same text–different-string/variable or [down|up]grade() outside of get_[utf8|unicode])
            return 1 if exists $pre_573_is_utf8_hack->{$string};
        }
    }

    return;
}

1;

__END__