ext/Encode/t/unibench.pl

   1 #!./perl
   2
   3 use strict;
   4 use Encode;
   5 use Benchmark qw(:all);
   6
   7 my $Count = shift @ARGV;
   8 $Count ||= 16;
   9 my @sizes = @ARGV || (1, 4, 16);
  10
  11 my %utf8_seed;
  12 for my $i (0x00..0xff){
  13     my $c = chr($i);
  14     $utf8_seed{BMP} .= ($c =~ /^\p{IsPrint}/o) ? $c : " ";
  15 }
  16 utf8::upgrade($utf8_seed{BMP});
  17
  18 for my $i (0x00..0xff){
  19     my $c = chr(0x10000+$i);
  20     $utf8_seed{HIGH} .= ($c =~ /^\p{IsPrint}/o) ? $c : " ";
  21 }
  22 utf8::upgrade($utf8_seed{HIGH});
  23
  24 my %S;
  25 for my $i (@sizes){
  26     my $sz = 256 * $i;
  27     for my $cp (qw(BMP HIGH)){
  28     $S{utf8}{$sz}{$cp}  = $utf8_seed{$cp} x $i;
  29     $S{utf16}{$sz}{$cp} = encode('UTF-16BE', $S{utf8}{$sz}{$cp});
  30     }
  31 }
  32
  33 for my $i (@sizes){
  34     my $sz = $i * 256;
  35     my $count = $Count * int(256/$i);
  36     for my $cp (qw(BMP HIGH)){
  37     for my $op (qw(encode decode)){
  38         my ($meth, $from, $to) = ($op eq 'encode') ?
  39         (\&encode, 'utf8', 'utf16') : (\&decode, 'utf16', 'utf8');
  40         my $XS = sub {
  41         Encode::Unicode::set_transcoder("xs");
  42         $meth->('UTF-16BE', $S{$from}{$sz}{$cp})
  43              eq $S{$to}{$sz}{$cp}
  44              or die "$op,$from,$to,$sz,$cp";
  45         };
  46         my $modern = sub {
  47         Encode::Unicode::set_transcoder("modern");
  48         $meth->('UTF-16BE', $S{$from}{$sz}{$cp})
  49              eq $S{$to}{$sz}{$cp}
  50              or die "$op,$from,$to,$sz,$cp";
  51         };
  52         my $classic = sub {
  53         Encode::Unicode::set_transcoder("classic");
  54         $meth->('UTF-16BE', $S{$from}{$sz}{$cp})
  55              eq $S{$to}{$sz}{$cp} or
  56              die "$op,$from,$to,$sz,$cp";
  57         };
  58         print "---- $op length=$sz/range=$cp ----\n";
  59         my $r = timethese($count,
  60              {
  61               "XS"      => $XS,
  62               "Modern"  => $modern,
  63               "Classic" => $classic,
  64              },
  65              'none',
  66             );
  67         cmpthese($r);
  68     }
  69     }
  70 }