File Coverage

lib/Perl6/Str.pm

Criterion	Covered	Total	%
statement	133	145	91.7
branch	24	28	85.7
condition	2	2	100.0
subroutine	30	34	88.2
pod	13	19	68.4
total	202	228	88.6

package Perl6::Str;

# for documentation see end of file
# TODO: normalize, index, rindex, pack/unpack (?), quotemeta
# split, comb, sprintf

use strict;
use warnings;
our $VERSION = '0.0.5';
use Encode qw(encode_utf8);
use Unicode::Normalize qw();

use overload
    '""'    => \&Str,
    'cmp'   => \&compare,
    ;


sub new {
    my ($class, $str) = @_;
    $class = ref $class ? ref $class : $class;
    utf8::upgrade($str);
    return bless \$str, $class;
}

sub codes {
    return length(${$_[0]});
}

sub bytes {
    return length(encode_utf8(Unicode::Normalize::NFKC(${$_[0]})));
}

sub graphs {
    my $str = shift;
    return scalar(()= $$str =~ m/\X/g);
}

{
    no warnings 'once';
    *chars = \&graphs;
}

sub Str {
    return ${$_[0]};
}

sub compare {
    return $_[2] ?
              Unicode::Normalize::NFKC($_[1]) cmp Unicode::Normalize::NFKC($_[0])
            : Unicode::Normalize::NFKC($_[0]) cmp Unicode::Normalize::NFKC($_[1]) ;
}

no warnings 'redefine';

sub substr {
    my ($self, @args) = @_;
    my $start = shift @args;
    my $graph_start = $self->_graph_index($start);
    my $res;
    if (@args == 0) {
        $res = CORE::substr $$self, $graph_start;
    } else {
        my $end = $self->_graph_index(shift @args, $graph_start);
        if (@args == 0) {
            $res = substr $$self, $graph_start, $end - $graph_start;
        } else {
            # replacement
            $res = substr $$self, $graph_start, $end - $graph_start, $args[0];
        }
    }
    if (defined $res) {
        return $self->new($res);
    } else {
        return;
    }
}

sub _graph_index {
    # turn a grapheme index into a codepoint index
    # $offest is optional, and ignored if $idx < 0
    my ($self, $idx, $offset) = @_;
    $offset ||= 0;
#    warn "Offset: $offset\n" if $offset;
    $idx = int (0 + $idx);
    my $old_pos = pos $$self;
    my $result;
    my $re;
    if ( $idx >= 0) {
        $idx += $offset;
        $re =  qr{\A\X{$idx}};
    } else {
        $idx = abs($idx);
        $re = qr{(?=\X{$idx}\z)} ;
    }
    if ($$self =~ m/$re/g) {
        $result = pos $$self;
    } else {
        warn "substr outside of string";
        $result = undef;
    }
    pos $$self = $old_pos;
    return $result;
}

sub chop {
    my $self = shift;
    my $copy = $$self;
    $copy =~ s/\X\z//;
    return $self->new($copy);
}

sub chomp {
    # XXX should we check for $/ or \n?
    my $self = shift;
    my $delim = $self->new($/);
    my $dl = $delim->graphs;
    my $sl = $self->graphs;
    return $self->new('') if $sl < $dl;

    if ($self->substr(-$sl) eq $delim){
        return $self->substr(0, $sl - $dl);
    } else {
        # return a copy
        return $self->new($self);
    }
}

sub reverse {
    my $self = shift;
    my $copy = '';
    my $self_pos = pos $self;
    pos $$self = 0;
    while ($$self =~ m/(\X)/g){
        $copy = $1 . $copy;
    }
    pos $$self = $self_pos;
    return $self->new($copy);
}

sub _same_stuff {
    my $func = shift;
    return sub {
        my ($self, $pattern) = @_;
        my $old_self_pos = pos $$self;
        my $old_pattern_pos = pos $pattern;
        return $self unless length $pattern;
        pos $$self = 0;
        pos $pattern = 0;
        my $copy = '';
        my $last_pattern;
        while ($pattern =~ m/(\X)/g){
            $last_pattern = $1;
            last unless $$self =~ m/(\X)/g;
            my $s = $1;
            $copy .= $func->($s, $last_pattern);
        }
        if (pos($$self)){
            # $$self longer than $pattern
            while ($$self =~ m/(\X)/g){
                $copy .= $func->($1, $last_pattern);
            }
        }
        pos $$self = $old_self_pos;
        pos $pattern = $old_pattern_pos;
        return $self->new($copy);
    }
}

BEGIN {

    *samecase   = _same_stuff(\&_copy_case);
    *sameaccent = _same_stuff(\&_copy_markings);

    for (qw(uc lc ucfirst lcfirst)) {
        eval qq{
            sub $_ {
                return \$_[0]->new(CORE::$_ \${\$_[0]});
            }
        };
    }

    for (qw(NFD NFC NFKD NFKC)) {
        eval qq{
            sub $_ {
                return \$_[0]->new(Unicode::Normalize::$_ \${\$_[0]});
            }
        };
    }
}

sub capitalize {
    my $self = shift;
    my $copy = CORE::lc $$self;
    $copy =~ s/(\w+)/CORE::ucfirst $1/eg;
    return $self->new($copy);
}

sub _copy_case {
    my ($chr, $pattern) = @_;
    if ($pattern =~ m/\p{IsTitle}|\p{IsUpper}/){
        return CORE::uc $chr;
    } elsif ($pattern =~ m/\p{IsLower}/){
        return CORE::lc $chr;
    } else {
        return $chr;
    }
}

sub _split_markings {
    my $char = Unicode::Normalize::NFKD(shift);
    return split m//, $char, 2;
}

sub _copy_markings {
    my ($source, $pattern) = @_;
    my (undef, $accents) = _split_markings($pattern);
    my ($base, undef)    = _split_markings($source);
    return $base . $accents;
}

1;

__END__