Blame t/unibench.pl

Packit d0f5c2
#!./perl
Packit d0f5c2
Packit d0f5c2
use strict;
Packit d0f5c2
use Encode;
Packit d0f5c2
use Benchmark qw(:all);
Packit d0f5c2
Packit d0f5c2
my $Count = shift @ARGV;
Packit d0f5c2
$Count ||= 16;
Packit d0f5c2
my @sizes = @ARGV || (1, 4, 16);
Packit d0f5c2
Packit d0f5c2
my %utf8_seed;
Packit d0f5c2
for my $i (0x00..0xff){
Packit d0f5c2
    my $c = chr($i);
Packit d0f5c2
    $utf8_seed{BMP} .= ($c =~ /^\p{IsPrint}/o) ? $c : " ";
Packit d0f5c2
}
Packit d0f5c2
utf8::upgrade($utf8_seed{BMP});
Packit d0f5c2
Packit d0f5c2
for my $i (0x00..0xff){
Packit d0f5c2
    my $c = chr(0x10000+$i);
Packit d0f5c2
    $utf8_seed{HIGH} .= ($c =~ /^\p{IsPrint}/o) ? $c : " ";
Packit d0f5c2
}
Packit d0f5c2
utf8::upgrade($utf8_seed{HIGH});
Packit d0f5c2
Packit d0f5c2
my %S;
Packit d0f5c2
for my $i (@sizes){
Packit d0f5c2
    my $sz = 256 * $i;
Packit d0f5c2
    for my $cp (qw(BMP HIGH)){
Packit d0f5c2
    $S{utf8}{$sz}{$cp}  = $utf8_seed{$cp} x $i;
Packit d0f5c2
    $S{utf16}{$sz}{$cp} = encode('UTF-16BE', $S{utf8}{$sz}{$cp});
Packit d0f5c2
    }
Packit d0f5c2
}
Packit d0f5c2
Packit d0f5c2
for my $i (@sizes){
Packit d0f5c2
    my $sz = $i * 256;
Packit d0f5c2
    my $count = $Count * int(256/$i);
Packit d0f5c2
    for my $cp (qw(BMP HIGH)){
Packit d0f5c2
    for my $op (qw(encode decode)){
Packit d0f5c2
        my ($meth, $from, $to) = ($op eq 'encode') ?
Packit d0f5c2
        (\&encode, 'utf8', 'utf16') : (\&decode, 'utf16', 'utf8');
Packit d0f5c2
        my $XS = sub {
Packit d0f5c2
        Encode::Unicode::set_transcoder("xs");  
Packit d0f5c2
        $meth->('UTF-16BE', $S{$from}{$sz}{$cp})
Packit d0f5c2
             eq $S{$to}{$sz}{$cp} 
Packit d0f5c2
             or die "$op,$from,$to,$sz,$cp";
Packit d0f5c2
        };
Packit d0f5c2
        my $modern = sub {
Packit d0f5c2
        Encode::Unicode::set_transcoder("modern");  
Packit d0f5c2
        $meth->('UTF-16BE', $S{$from}{$sz}{$cp})
Packit d0f5c2
             eq $S{$to}{$sz}{$cp} 
Packit d0f5c2
             or die "$op,$from,$to,$sz,$cp";
Packit d0f5c2
        };
Packit d0f5c2
        my $classic = sub {
Packit d0f5c2
        Encode::Unicode::set_transcoder("classic");  
Packit d0f5c2
        $meth->('UTF-16BE', $S{$from}{$sz}{$cp})
Packit d0f5c2
             eq $S{$to}{$sz}{$cp} or 
Packit d0f5c2
             die "$op,$from,$to,$sz,$cp";
Packit d0f5c2
        };
Packit d0f5c2
        print "---- $op length=$sz/range=$cp ----\n";
Packit d0f5c2
        my $r = timethese($count,
Packit d0f5c2
             {
Packit d0f5c2
              "XS"      => $XS,
Packit d0f5c2
              "Modern"  => $modern,
Packit d0f5c2
              "Classic" => $classic,
Packit d0f5c2
             },
Packit d0f5c2
             'none',
Packit d0f5c2
            );
Packit d0f5c2
        cmpthese($r);
Packit d0f5c2
    }
Packit d0f5c2
    }
Packit d0f5c2
}