File Coverage

blib/lib/String/UnicodeUTF8.pm

Criterion	Covered	Total	%
statement	100	114	87.7
branch	45	60	75.0
condition	11	18	61.1
subroutine	24	24	100.0
pod	17	17	100.0
total	197	233	84.5

package String::UnicodeUTF8;

use strict;
use warnings;

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

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

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 &{$_};
    }
}

# characters the caller may or may not consider “safe” depending on context
my %specials = (
    'NO-BREAK SPACE'       => qr/\x{00A0}/,
    'LINE FEED (LF)'       => qr/\x{000A}/,
    'CARRIAGE RETURN (CR)' => qr/\x{000D}/,
    'CHARACTER TABULATION' => qr/\x{0009}/,
);

# `unichars '\p{WhiteSpace}'` sans SPACE/0020 and %specials
my $disallowed_whitespace = qr/(?:\x{000B}|\x{000C}|\x{0085}|\x{1680}|\x{180E}|\x{2000}|\x{2001}|\x{2002}|\x{2003}|\x{2004}|\x{2005}|\x{2006}|\x{2007}|\x{2008}|\x{2009}|\x{200A}|\x{2028}|\x{2029}|\x{202F}|\x{205F}|\x{3000})/;

# unichars '\p{Control}' ` sans %specials
my $control =
  qr/(?:\x{0000}|\x{0001}|\x{0002}|\x{0003}|\x{0004}|\x{0005}|\x{0006}|\x{0007}|\x{0008}|\x{000B}|\x{000C}|\x{000E}|\x{000F}|\x{0010}|\x{0011}|\x{0012}|\x{0013}|\x{0014}|\x{0015}|\x{0016}|\x{0017}|\x{0018}|\x{0019}|\x{001A}|\x{001B}|\x{001C}|\x{001D}|\x{001E}|\x{001F}|\x{007F}|\x{0080}|\x{0081}|\x{0082}|\x{0083}|\x{0084}|\x{0085}|\x{0086}|\x{0087}|\x{0088}|\x{0089}|\x{008A}|\x{008B}|\x{008C}|\x{008D}|\x{008E}|\x{008F}|\x{0090}|\x{0091}|\x{0092}|\x{0093}|\x{0094}|\x{0095}|\x{0096}|\x{0097}|\x{0098}|\x{0099}|\x{009A}|\x{009B}|\x{009C}|\x{009D}|\x{009E}|\x{009F})/;

# `uninames invisible`
my $invisible = qr/(?:\x{200B}|\x{2062}|\x{2063}|\x{2064})/;

sub contains_nonhuman_characters {
    my ( $string, %allow_specials ) = @_;
    my $uni_str = get_unicode($string);

    for my $name ( keys %specials ) {
        next if $allow_specials{$name};
        return 1 if $uni_str =~ m/$specials{$name}/;
    }

    return 1 if $uni_str =~ m/$invisible/;
    return 1 if $uni_str =~ m/$disallowed_whitespace/;
    return 1 if $uni_str =~ m/$control/;

    return;
}

# 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{([^A-Za-z_0-9])}
        {
            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__