File Coverage

blib/lib/Unicode/Util.pm

Criterion	Covered	Total	%
statement	128	137	93.4
branch	68	88	77.2
condition	9	15	60.0
subroutine	25	25	100.0
pod	6	13	46.1
total	236	278	84.8

package Unicode::Util;

use 5.008;
use strict;
use warnings;
use utf8;
use parent 'Exporter';

our $VERSION = '0.10';
our @EXPORT_OK = qw(
    grapheme_length
    grapheme_chop
    grapheme_reverse
    grapheme_index
    grapheme_rindex
    grapheme_substr
    grapheme_split
    graph_length graph_chop graph_reverse
    byte_length code_length code_chop
);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

sub grapheme_substr (\$$;$$);

sub grapheme_length (;$) {
    my ($str) = @_;
    $str = $_ unless @_;
    return scalar( () = $str =~ m{ \X }xg );
}

sub grapheme_chop (;\[$@%]) {
    my ($ref) = @_;
    $ref = \$_ unless @_;

    if (ref $ref eq 'SCALAR') {
        $$ref =~ s{ ( \X ) \z }{}x;
        return defined $1 ? $1 : '';
    }
    elsif (ref $ref eq 'ARRAY') {
        return undef unless @$ref;

        for my $i ( 0 .. $#{$ref} ) {
            if ( $i < $#{$ref} ) {
                $ref->[$i] =~ s{ \X \z }{}x;
            }
            else {
                $ref->[$i] =~ s{ ( \X ) \z }{}x;
                return defined $1 ? $1 : '';
            }
        }
    }
    elsif (ref $ref eq 'HASH') {
        my $elems = keys %$ref;
        return undef unless $elems;

        my $count = 0;
        for my $str (values %$ref) {
            if (++$count < $elems) {
                $str =~ s{ \X \z }{}x;
            }
            else {
                $str =~ s{ ( \X ) \z }{}x;
                return defined $1 ? $1 : '';
            }
        }
    }
}

sub grapheme_reverse (;@) {
    my (@strings) = @_;
    return reverse @strings if wantarray;
    @strings = $_ unless @strings;
    return join '', map { reverse m{ \X }xg } reverse @strings;
}

sub grapheme_index ($$;$) {
    my ($str, $substr, $pos) = @_;

    if (!looks_like_number($pos) || $pos < 0) {
        $pos = 0;
    }
    elsif ($pos > (my $length = grapheme_length($str))) {
        $pos = $length;
    }

    return grapheme_length($1) + $[
        if $str =~ m{ ^ ( \X{$pos} \X*? ) \Q$substr\E }xg;

    return -1;
}

sub grapheme_rindex ($$;$) {
    my ($str, $substr, $pos) = @_;

    if (!looks_like_number($pos) || $pos < 0) {
        $pos = 0;
    }

    if ($pos) {
        $str = grapheme_substr($str, 0, $pos + ($substr ? 1 : 0));
    }

    return grapheme_length($1)
        if $str =~ m{ ^ ( \X* ) \Q$substr\E }xg;

    return -1;
}

sub grapheme_substr (\$$;$$) {
    my ($str, $offset, $length, $replacement) = @_;

    if (@_ == 2) {
        if ($offset >= 0) {
            return $1 if $$str =~ m{ ^ \X{$offset} ( .* ) }x;
        }
        else {
            my $abs_offset = abs $offset;
            return $1 if $$str =~ m{ ( \X{0,$abs_offset} ) \z }x;
        }
    }
    elsif (@_ == 3) {
        if ($offset >= 0) {
            if ($length >= 0) {
                return $1 if $$str =~ m{
                    ^ \X{$offset}
                    ( \X{0,$length} )
                }x;
            }
            else {
                my $abs_length = abs $length;
                return $1 if $$str =~ m{
                    ^ \X{$offset}
                    ( .*? )
                    \X{$abs_length} \z
                }x;
            }
        }
        else {
            my $abs_offset = abs $offset;
            if ($length >= 0) {
                return $1 if $$str =~ m{
                    (?= \X{$abs_offset} \z )
                    ( \X{0,$length} )
                }x;
            }
            else {
                my $abs_length = abs $length;
                return $1 if $$str =~ m{
                    (?= \X{$abs_offset} \z )
                    ( .*? )
                    ( \X{$abs_length} )
                }x;
            }
        }
    }
    elsif (@_ == 4) {
        if ($offset >= 0) {
            if ($length >= 0) {
                $$str =~ m{ ^ ( \X{$offset} ) }x;
                my $codepoint_offset = length $1;
                return $1 if $$str =~ s{
                    (?<= ^ .{$codepoint_offset} )
                    ( \X{0,$length} )
                }{$replacement}x;
            }
            else {
                $$str =~ m{ ^ ( \X{$offset} ) }x;
                my $codepoint_offset = length $1;
                my $abs_length = abs $length;
                return $1 if $$str =~ s{
                    (?<= ^ .{$codepoint_offset} )
                    ( .*? )
                    (?= \X{$abs_length} \z )
                }{$replacement}x;
            }
        }
        else {
            my $abs_offset = abs $offset;
            if ($length >= 0) {
                return $1 if $$str =~ s{
                    (?= \X{$abs_offset} \z )
                    ( \X{0,$length} )
                }{$replacement}x;
            }
            else {
                my $abs_length = abs $length;
                return $1 if $$str =~ s{
                    (?= \X{$abs_offset} \z )
                    ( .*? )
                    (?= \X{$abs_length} )
                }{$replacement}x;
            }
        }
    }
}

# experimental functions

sub grapheme_split (;$$) {
    my ($str) = @_;
    my @graphs = $str =~ m{ \X }xg;
    return @graphs;
}

# deprecated functions

use Encode qw( encode find_encoding );
use Unicode::Normalize qw( normalize );
use Scalar::Util qw( looks_like_number );

use constant DEFAULT_ENCODING => 'UTF-8';
use constant IS_NORMAL_FORM   => qr{^ (?:NF)? K? [CD] $}xi;

$EXPORT_TAGS{length} = [qw( graph_length code_length byte_length )];

sub graph_length {
    my ($str) = @_;
    utf8::upgrade($str);
    return scalar( () = $str =~ m{ \X }xg );
}

sub code_length {
    my ($str, $nf) = @_;
    utf8::upgrade($str);

    if ($nf && $nf =~ IS_NORMAL_FORM) {
        $str = normalize(uc $nf, $str);
    }

    return length $str;
}

sub byte_length {
    my ($str, $enc, $nf) = @_;
    utf8::upgrade($str);

    if ( !$enc || !find_encoding($enc) ) {
        $enc = DEFAULT_ENCODING;
    }

    if ($nf && $nf =~ IS_NORMAL_FORM) {
        $str = normalize(uc $nf, $str);
    }

    return length encode($enc, $str);
}

sub graph_chop {
    my ($str) = @_;
    utf8::upgrade($str);
    $str =~ s{ \X \z }{}x;
    return $str;
}

sub code_chop {
    my ($str) = @_;
    utf8::upgrade($str);
    chop $str;
    return $str;
}

sub graph_reverse {
    my ($str) = @_;
    utf8::upgrade($str);
    return join '', reverse $str =~ m{ \X }xg;
}

1;

__END__