File Coverage

blib/lib/String/Multibyte.pm

Criterion	Covered	Total	%
statement	290	312	92.9
branch	265	334	79.3
condition	78	110	70.9
subroutine	27	28	96.4
pod	13	13	100.0
total	673	797	84.4

package String::Multibyte;

#
# /o never allowed!
#

BEGIN {
    if (ord("A") == 193) {
	die "String::Multibyte not ported to EBCDIC\n";
    }
}

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Carp;
require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw();

$VERSION = '1.10';

my $PACKAGE = 'String::Multibyte'; # __PACKAGE__

my $Msg_malfo  = $PACKAGE ." malformed %s character";
my $Msg_undef  = $PACKAGE ." undefined %s";
my $Msg_panic  = $PACKAGE ." panic in %s";
my $Msg_revrs  = $PACKAGE ." reverse in %s";
my $Msg_outstr = $PACKAGE ." substr outside of string";
my $Msg_lastc  = $PACKAGE ." reach the last char before end of char range";

(my $Path = $INC{'String/Multibyte.pm'}) =~ s/\.pm$//;

use vars qw($hasFS);
eval { require File::Spec; };
$hasFS = $@ ? 0 : 1;

#==========
# new
#
sub new {
    my $class   = shift;
    my $charset = shift;
    my $verbose = shift;
    my ($pm, $self);
    if (ref $charset) {
	$self = { %$charset };
    } else {
	$pm = $hasFS
	    ? File::Spec->catfile($Path, "$charset.pm")
	    : "$Path/$charset.pm";
	$self = do($pm) or croak "not exist $pm";
    }
    defined $self->{regexp}
	or croak sprintf $Msg_undef, "regexp";
    $] < 5.005
	or eval q{ $self->{regexp} = qr/$self->{regexp}/; };

    $verbose and $self->{verbose} = $verbose;
    defined $self->{charset}
	or $self->{charset} = "$charset"; # stringified
    return bless $self, $class;
}

#==========
# islegal
#
sub islegal {
    my $obj = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";
    for (@_) {
	my $str = $_;
	$str =~ s/$re//g;
	return '' if CORE::length($str);
    }
    return 1;
}

#==========
# length
#
sub length {
    my $obj = shift;
    my $str = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";

    if ($obj->{verbose} && ! $obj->islegal($str)) {
	carp sprintf $Msg_malfo, $obj->{charset};
    }
    return 0 + $str =~ s/$re//g;
}

#==========
# __strlen: for internal use
#
sub __strlen {
    my ($re, $str) = @_;
    return 0 + $str =~ s/$re//g;
}


#==========
# strrev
#
sub strrev {
    my $obj = shift;
    my $str = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";

    if ($obj->{verbose} && ! $obj->islegal($str)) {
	carp sprintf $Msg_malfo, $obj->{charset};
    }
    return join '', reverse $str =~ /$re/g;
}


#==========
# _check_n($re, $str, $sub, $len), internally used, non-OO
#
# like ($obj->substr($str, 0, $len) eq $sub);
# $len must be equal to $obj->length($sub);
#
sub _check_n {
    my($re, $str, $sub, $len) = @_;
    my $cnt = 0;
    my $temp = "";
    while ($str =~ /($re)/g) {
	last unless $cnt < $len;
	$temp .= $1;
	$cnt++;
    }
    return $sub eq $temp;
}

#==========
# index
#
sub index {
    my $obj = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";

    my $cnt = 0;
    my($str,$sub) = @_;
    if ($obj->{verbose} && ! $obj->islegal($str, $sub)) {
	carp sprintf $Msg_malfo, $obj->{charset};
    }
    my $len = __strlen($re, $str);
    my $pos = @_ == 3 ? $_[2] : 0;

    if ($sub eq "") {
	return $pos <= 0 ? 0 : $len < $pos ? $len : $pos;
    }
    return -1 if $len < $pos;
    my $pat = quotemeta($sub);
    my $sublen = __strlen($re, $sub);
    $str =~ s/^$re// ? $cnt++ : croak
	while CORE::length($str) && $cnt < $pos;
    while (CORE::length($str)) {
	last
	    if $str =~ /^$pat/ && _check_n($re, $str, $sub, $sublen);
	$str =~ s/^$re// ? $cnt++ : croak;
    }
    return CORE::length($str) ? $cnt : -1;
}

#==========
# rindex
#
sub rindex {
    my $obj = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";

    my $cnt = 0;
    my($str,$sub) = @_;
    if ($obj->{verbose} && ! $obj->islegal($str, $sub)) {
	carp sprintf $Msg_malfo, $obj->{charset};
    }
    my $len = __strlen($re, $str);
    my $pos = @_ == 3 ? $_[2] : $len;
    if ($sub eq "") {
	return $pos <= 0 ? 0 : $len <= $pos ? $len : $pos;
    }
    return -1 if $pos < 0;
    my $pat = quotemeta($sub);
    my $sublen = __strlen($re, $sub);
    my $ret = -1;
    while ($cnt <= $pos && CORE::length($str)) {
	$ret = $cnt
	    if $str =~ /^$pat/ && _check_n($re, $str, $sub, $sublen);
	$str =~ s/^$re// ? $cnt++ : croak;
    }
    return $ret;
}

#==========
# _splitlist
#
sub _splitlist {
    my @ret;
    my ($list, $re) = @_;
    for (ref $list eq 'ARRAY' ? @$list : $list) {
	push @ret, /\G$re/g;
    }
    return @ret;
}


#==========
# strspn
#
sub strspn {
    my $obj = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";

    my($str, $lst) = @_;
    if ($obj->{verbose} && ! $obj->islegal($str, $lst)) {
	carp sprintf $Msg_malfo, $obj->{charset};
    }
    my $ret = 0;
    my(%lst);
    @lst{ _splitlist($lst, $re) } = ();
    while ($str =~ /($re)/g) {
	last unless exists $lst{$1};
	$ret++;
    }
    return $ret;
}


#==========
# strcspn
#
sub strcspn {
    my $obj = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";

    my($str, $lst) = @_;
    if ($obj->{verbose} && ! $obj->islegal($str, $lst)) {
	carp sprintf $Msg_malfo, $obj->{charset};
    }
    my $ret = 0;
    my(%lst);
    @lst{ _splitlist($lst, $re) } = ();
    while ($str =~ /($re)/g) {
	last if exists $lst{$1};
	$ret++;
    }
    return $ret;
}

#==========
# substr
#
sub substr {
    my $obj = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";
    my(@chars, $slen, $ini, $fin, $except);
    my $arg = $_[0];
    my $off = $_[1];
    my $len = $_[2];
    my $rep = @_ > 3 ? $_[3] : '';

    my $str = ref $arg ? $$arg : $arg;
    if ($obj->{verbose} && ! $obj->islegal($str, $rep)) {
	carp sprintf $Msg_malfo, $obj->{charset};
    }

    $slen = __strlen($re, $str);
    $except = 1 if $slen < $off;
    if (@_ == 2) {
	$len = $slen - $off;
    } else {
	$except = 1 if $off + $slen < 0 && $len + $slen < 0;
	$except = 1 if 0 <= $len && $off + $len + $slen < 0;
    }
    if ($except) {
	if(@_ > 3) {
	    croak $Msg_outstr;
	} else {
	    return;
	}
    }
    $ini = $off < 0 ? $slen + $off : $off;
    $fin = $len < 0 ? $slen + $len : $ini + $len;
    $ini = 0     if $ini < 0;
    $fin = $ini  if $ini > $fin;
    $ini = $slen if $slen < $ini;
    $fin = $slen if $slen < $fin;

    my $cnt  = 0;
    my $plen = 0;
    my $clen = 0;
    while ($str =~ /($re)/g) {
	if ($cnt < $ini) {
	    $plen += CORE::length($1);
	} elsif ($cnt < $fin) {
	    $clen += CORE::length($1);
	} else {
	    last;
	}
	$cnt++;
    }
    my $temp = ref $arg
	? \ CORE::substr($$arg, $plen, $clen)
	:   CORE::substr($str,  $plen, $clen);

    if (@_ > 3) {
	$_[0] = CORE::substr($str, 0,      $plen) .$rep.
	        CORE::substr($str, $plen + $clen);
    }
    return $temp;
}

#==========
# mkrange
#
sub mkrange {
    my($s, @retv, $range);
    my $obj = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";
    my($str,$rev) = @_;
    my $hyp = exists $obj->{hyphen} ? $obj->{hyphen} : '-';
    my $esc = exists $obj->{escape} ? $obj->{escape} : '\\';

    if ($obj->{verbose} && ! $obj->islegal($str)) {
	carp sprintf "$Msg_malfo in mkrange", $obj->{charset};
    }
    if (!defined $obj->{nextchar}) {
	return wantarray ? $str =~ /$re/g : $str;
    }
    $str =~ s/^\Q$hyp\E/$esc$hyp/;
    $range = 0;
    foreach $s ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g) {
	if ($range) {
	    if ($s eq "$esc$hyp") {
		$s = $hyp;
	    } elsif ($s eq "$esc$esc") {
		$s = $esc;
	    }
	    my $p = @retv
		? pop(@retv)
		: croak(sprintf $Msg_panic, "mkrange: Parse exception" .
		    "; no initial character in a range");
	    push @retv, $obj->__expand($p, $s, $rev);
	    $range = 0;
	}
	else {
	    if ($s eq $hyp) {
		$range = 1;
	    } elsif($s eq "$esc$hyp") {
		push @retv, $hyp;
	    } elsif ($s eq "$esc$esc") {
		push @retv, $esc;
	    } else {
		push @retv, $s;
	    }
	}
    }
    push @retv, $hyp if $range;
    wantarray ? @retv : @retv ? join('', @retv) : '';
}

sub __expand {
    my $obj = shift;
    my($fr,$to,$rev) = @_;

    if (defined $obj->{cmpchar} &&
	    &{ $obj->{cmpchar} }($fr,$to) > 0) {
	return if ! $rev;
	($fr,$to) = ($to,$fr);
    } else {
	$rev = 0;
    }

    my $c = $fr;
    my @retv;
    my $nextchar = $obj->{nextchar};
    while (1) {
	push @retv, $c;
	last if $c eq $to;
	$c = &$nextchar($c);
	croak $Msg_lastc if !defined $c;
    }
    return $rev ? reverse(@retv) : @retv;
}

#==========
# strtr
#
my %Cache;

sub strtr {
    my $obj = shift;
    my $re  = $obj->{regexp}
	or croak sprintf $Msg_undef, "regexp";
    my $str = shift;

    if ($obj->{verbose} && ! $obj->islegal(ref $str ? $$str : $str)) {
	carp sprintf "$Msg_malfo in strtr", $obj->{charset};
    }
    my $coderef;
    if (defined $_[2] && $_[2] =~ /o/) {
	$coderef = (
	    $Cache{ $obj->{charset} }{ $_[0] }{ $_[1] }
		{ defined $_[2] ? $_[2] : ''} ||= $obj->trclosure(@_)
	);
    }
    else {
	$coderef = $obj->trclosure(@_);
    }
    &$coderef($str);
}

#============
# trclosure
#
sub trclosure {
    my(@fr, @to, $h, $r, $R, $c, $d, $s, $v, $i, %hash);
    my $obj = shift;
    my $re  = $obj->{regexp} or croak sprintf $Msg_undef, "regexp";

    my $fr  = shift;
    my $to  = shift;
    my $mod = @_ ? shift : '';

    if ($obj->{verbose} && ! $obj->islegal($fr, $to)) {
	carp sprintf "$Msg_malfo in trclosure", $obj->{charset};
    }
    my $msg = sprintf "$Msg_malfo in closure", $obj->{charset};

    $h = $mod =~ /h/;
    $r = $mod =~ /r/;
    $R = $mod =~ /R/;
    $v = $obj->{verbose};

    for (ref $fr eq 'ARRAY' ? @$fr: $fr) {
	push @fr, $R ? /\G$re/g : $obj->mkrange($_, $r);
    }

    for (ref $to eq 'ARRAY' ? @$to : $to) {
	push @to, $R ? /\G$re/g : $obj->mkrange($_, $r);
    }

    $c = $mod =~ /c/;
    $d = $mod =~ /d/;
    $s = $mod =~ /s/;
    $mod = $s * 4 + $d * 2 + $c;

    for ($i = 0; $i < @fr; $i++) {
	next if exists $hash{ $fr[$i] };
	$hash{ $fr[$i] } = @to
	     ? defined $to[$i] ? $to[$i] : $d ? '' : $to[-1]
	     : $d && !$c ? '' : $fr[$i];
    }
    return
	$mod == 3 || $mod == 7 ?
	    sub { # $c: true, $d: true, $s: true/false, $mod: 3 or 7
		my $str = shift;
		if ($v && !$obj->islegal(ref $str ? $$str : $str)) {
		    carp $msg;
		}
		my $cnt = 0;
		my %cnt = ();
		(ref $str ? $$str : $str) =~ s{($re)}{
		    exists $hash{$1} ? $1 : ($h ? ++$cnt{$1} : ++$cnt, '');
		}ge;
		return $h
		    ? wantarray ? %cnt : \%cnt
		    : ref $str  ? $cnt : $str;
	    } :
	$mod == 5 ?
	    sub { # $c: true, $d: false, $s: true, $mod: 5
		my $str = shift;
		if ($v && !$obj->islegal(ref $str ? $$str : $str)) {
		    carp $msg;
		}
		my $cnt = 0;
		my %cnt = ();
		my $pre = '';
		my $now;
		(ref $str ? $$str : $str) =~ s{($re)}{
		    exists $hash{$1}
			? ($pre = '', $1)
			: ($h ? ++$cnt{$1} : ++$cnt,
			   $now = @to ? $to[-1] : $1,
			   $now eq $pre ? '' : ($pre = $now) );
		}ge;
		return $h
		    ? wantarray ? %cnt : \%cnt
		    : ref $str  ? $cnt : $str;
	    } :
	$mod == 4 || $mod == 6 ?
	    sub { # $c: false, $d: true/false, $s: true, $mod: 4 or 6
		my $str = shift;
		if ($v && !$obj->islegal(ref $str ? $$str : $str)) {
		    carp $msg;
		}
		my $cnt = 0;
		my %cnt = ();
		my $pre = '';
		(ref $str ? $$str : $str) =~ s{($re)}{
		    exists $hash{$1}
			? ($h ? ++$cnt{$1} : ++$cnt,
			    $hash{$1} eq '' || $hash{$1} eq $pre
				? '' : ($pre = $hash{$1}))
			: ($pre = '', $1);
		}ge;
		return $h
		    ? wantarray ? %cnt : \%cnt
		    : ref $str  ? $cnt : $str;
	    } :
	$mod == 1 ?
	    sub { # $c: true, $d: false, $s: false, $mod: 1
		my $str = shift;
		if ($v && !$obj->islegal(ref $str ? $$str : $str)) {
		    carp $msg;
		}
		my $cnt = 0;
		my %cnt = ();
		(ref $str ? $$str : $str) =~ s{($re)}{
		    exists $hash{$1}
			? $1
			: ($h ? ++$cnt{$1} : ++$cnt, @to) ? $to[-1] : $1;
		}ge;
	    return $h
		? wantarray ? %cnt : \%cnt
		: ref $str  ? $cnt : $str;
	    } :
	$mod == 0 || $mod == 2 ?
	    sub { # $c: false, $d: true/false, $s: false, $mod:  0 or 2
		my $str = shift;
		if ($v && !$obj->islegal(ref $str ? $$str : $str)) {
		    carp $msg;
		}
		my $cnt = 0;
		my %cnt = ();
		(ref $str ? $$str : $str) =~ s{($re)}{
		    exists $hash{$1}
			? ($h ? ++$cnt{$1} : ++$cnt, $hash{$1})
			: $1;
		}ge;
		return $h
		    ? wantarray ? %cnt : \%cnt
		    : ref $str  ? $cnt : $str;
	    } :
	    sub {
		croak sprintf $Msg_panic, "trclosure! Invalid Closure!";
	    }
}

#============
# strsplit
#
sub strsplit {
    my $obj = shift;
    my $re  = $obj->{regexp} or croak sprintf $Msg_undef, "regexp";
    my $sub = shift;
    my $str = shift;
    my $lim = shift || 0;

    if ($obj->{verbose} && ! $obj->islegal($str, $sub)) {
	carp sprintf $Msg_malfo, $obj->{charset};
    }
    if ($str eq '') {
	return wantarray ? () : 0;
    }
    if ($sub eq '' && $lim <= 0) {
	return wantarray
	    ? ($str =~ /$re/g, $lim < 0 ? '' : ())
	    : ($lim < 0) + $obj->length($str);
    }
    if ($lim == 1) {
	return wantarray ? ($str) : 1;
    }

    my $cnt = 0;
    my @ret = CORE::length($sub) ? ('') : ();

    if (CORE::length($sub)) {
	my $pat = quotemeta $sub;
	my $sublen = __strlen($re, $sub);

	while(($lim <= 0 || $cnt < $lim) && CORE::length($str)) {
	    if ($str =~ /^$pat/ && _check_n($re, $str, $sub, $sublen)) {
		$str =~ s/^$pat//
		    or croak sprintf($Msg_panic, "strsplit"),
			unpack('H*', CORE::length($str) > 15
			    ? CORE::substr($str, 0, 15) : $str);
		$cnt = push @ret, '';
	    } elsif ($str =~ s/^($re)//) {
		$ret[-1] .= $1;
	    } else {
		croak sprintf($Msg_panic, "strsplit").
		    unpack('H*', CORE::length($str) > 10
			? CORE::substr($str, 0, 10) : $str);
	    }
	}
    } else {
	while ($cnt < $lim && CORE::length($str)) {
	    $str =~ s/^($re)//
		or croak sprintf $Msg_panic, "strsplit ''";
	    $cnt = push @ret, $1;
	}
    }
    $ret[-1] .= $str if CORE::length($str);
    if ($lim == 0) {
	pop @ret
	    while defined $ret[-1] && $ret[-1] eq '';
    }
    return @ret;
}

1;
__END__