view release on metacpan or  search on metacpan

t/11-index.t  view on Meta::CPAN

            [ MATCH_NEGATE | MATCH_MULTI, 'abc', 0,16 ],
            [ MATCH_NEGATE | MATCH_MULTI, 'babababa', 0,1 ],
            [ MATCH_NEGATE | MATCH_MULTI, 'bababababababababa', 0,27 ],
            [ MATCH_NEGATE | MATCH_MULTI | MATCH_ANCHORED, 'ab' ],
            [ MATCH_NEGATE | MATCH_MULTI | MATCH_ANCHORED, 'abc', 0,16 ],
            [ MATCH_NEGATE | MATCH_MULTI | MATCH_ANCHORED, 'babababa', 0,1 ],
         ) {
            my ($flags, $pattern, $pos, $len)= @$_;
            $flags |= $const_time | $reverse;
            my $name= ($flags & MATCH_ANCHORED? 'ANCHORED ':'')
                    . ($flags & MATCH_MULTI? 'MULTI ':'')
                    . ($flags & MATCH_NEGATE? 'NEGATE ':'')
                    . $pattern;
            if ($reverse) {
               $pattern= reverse $pattern;
               $pos= length($str) - ($pos + $len)
                  if defined $pos;
            }
            my $expect= defined $pos? "$pos+$len" : '';
            is( join('+',$buf->scan($pattern, $flags)), $expect, $name );
         }
      };
   }
}

# Test that the CONST_TIME flag yields a full scan of the buffer regardless
# of where the match occurs.
subtest scan_const_time => sub {
   plan skip_all => "Set SB_TEST_CONSTTIME to enable this test"
      unless $ENV{SB_TEST_CONSTTIME};
   
   my $long= secret(("x" x 40_000) . ('z'x100));
   my $bench= cmpthese(-2, {
         find_early        => sub { $long->scan(('x'x100), MATCH_CONST_TIME) },
         find_late         => sub { $long->scan(('z'x100), MATCH_CONST_TIME) },
         not_found         => sub { $long->scan(('a'x100), MATCH_CONST_TIME) },
         find_negate_early => sub { $long->scan(('z'x100), MATCH_CONST_TIME|MATCH_NEGATE) },
         find_negate_late  => sub { $long->scan(('x'x100), MATCH_CONST_TIME|MATCH_NEGATE) },
      });
   my @keys= qw( find_early find_late not_found find_negate_early find_negate_late );
   my @rate= map { $_->iters / $_->cpu_a } @{$bench}{@keys};
   my $max= max @rate;
   is( $rate[$_] / $max, float(1, tolerance => .2), "$keys[$_] matches slowest method" )
      for 0..$#keys;
};

sub _render_char {
   $_[0] >= 0x21 && $_[0] <= 0x7E? chr $_[0] : sprintf("\\x%02X", $_[0])
}
sub bitmap_to_invlist {
   my @invlist;
   for (0..0xFF) {
      push @invlist, $_ if vec($_[0], $_, 1) ^ (@invlist & 1);
   }
   return \@invlist
}

# Test the inversion lists created for various charsets.
# Right now this is converting bitmaps from first 256 bytes into an inversion list,
# but in the future I'd like the back-end to be using inversion lists and able to cover
# unicode.
subtest charset => sub {
   # tests below use \x{100} to force perl-interpretation of a regex
   # as a baseline to compare the parsed bitmap to the perl-generated one.
   my $uni_literal= "\x{1000}";
   # third column regards unicode above 0x7F: 0 = none match, 1 = all match, 2 = need to test
   my @tests= (
      [ qr/[a-z]/                      => [97, 123], 0 ],
      [ qr/[a-z]/i                     => [65, 91, 97, 123], 0 ],
      ($] >= '5.026'? ( # /xx wasn't added until 5.26
         [ qr/[a-z 5\x{100}]/ixx       => [53, 54, 65, 91, 97, 123], 2 ],
         [ qr/[a-z 5]/ixx              => [53, 54, 65, 91, 97, 123], 0 ],
      ):()),
      [ do { no warnings; qr/[\0-\108\7777-9]/ } => [0, 9, 55, 58], 2 ],
      [ qr/[\t\r\n]/                   => [9, 11, 13, 14], 0 ],
      [ qr/[[:alpha:]]/                => [65, 91, 97, 123], 2 ],
      [ qr/[\x00-\e]/                  => [0, 28], 0 ],
      [ qr/[$uni_literal]/             => [ 0x1000, 0x1001 ], 2 ],
      [ qr/[\p{Block: Katakana}]/      => [ 0x30A0, 0x3100 ], 2 ],
      [ qr/[^[:digit:]]/               => [ 0,0x30, 0x3A ], 2 ],
      ($] >= '5.012'? ( # \p{digit} wasn't available until 5.12
         [ qr/[[:alpha:]\P{digit}]/    => [ 0,0x30, 0x3A ], 2 ],
      ):()),
      [ qr/[\p{alpha}\P{alpha}]/       => [ 0 ], 2 ],
      [ qr/[^\0\n]/                    => [ 1,10, 11 ], 1 ],
      [ qr/./                          => [ 0,10, 11 ], 1 ],
      [ qr/./s                         => [ 0 ], 1 ],
      [ qr/\w/                         => [ 48, 58, 65, 91, 95, 96, 97, 123 ], 2 ],
      [ qr/\W/                         => [ 0, 48, 58, 65, 91, 95, 96, 97, 123 ], 2 ],
      [ qr/\d/                         => [ 48, 58 ], 2 ],
      [ qr/\D/                         => [ 0, 48, 58 ], 2 ],
      [ qr/\s/                         => [ 9, ($] < '5.018'? (11, 12):()), 14, 32, 33 ], 2 ],
      [ qr/\S/                         => [ 0, 9, ($] < '5.018'? (11, 12):()), 14, 32, 33 ], 2 ],
   );
   for (@tests) {
      my ($re, $invlist, $above7F)= @$_;
      my $cset= Crypt::SecretBuffer::Exports::_debug_charset($re);
      $cset->{invlist}= bitmap_to_invlist(delete $cset->{bitmap});
      # for now, remove all invlist items greater than 0xFF
      pop @{$cset->{invlist}} while 0xFF < ($cset->{invlist}[-1]||0);
      pop @$invlist while 0xFF < ($invlist->[-1]||0);
      is( $cset, { invlist => $invlist, unicode_above_7F => $above7F }, "$re" );
   }
};

subtest index_charset => sub {
   my $buf = Crypt::SecretBuffer->new("abc123\0abc456" );
   is( $buf->index(qr/[0-9]/), 3, 'find first digit' );
   is( $buf->rindex(qr/[0-9]/), 12, 'find last digit' );
   is( $buf->index(qr/[a-z]/), 0, 'find first alpha' );
   is( $buf->rindex(qr/[a-z]/), 9, 'find last alpha' );
};

subtest scan_charset => sub {
   my $str= "abc123\x{100}\x{1000}abc456";
   utf8::encode($str);
   my $buf = Crypt::SecretBuffer->new($str);
   is( [$buf->scan(qr/[0-9]/)], [3,1], 'find digit' );
   is( [$buf->scan(qr/[0-9]/, MATCH_MULTI)], [3,3], 'find span of digits' );
   is( [$buf->scan(qr/[^a-z0-9]/, UTF8)], [6, 2], 'single char of unicode spans 2 bytes' );
   is( [$buf->scan(qr/[^a-z0-9]+/, UTF8)], [6, 5], 'unicode spans 2+3 bytes' );
   is( [$buf->scan(qr/[^a-z0-9]/, UTF8|MATCH_REVERSE)], [8, 3], 'second char of unicode spans 3 bytes' );
   is( [$buf->scan(qr/[^a-z0-9]+/, UTF8|MATCH_REVERSE)], [6, 5], 'unicode spans 2+3 bytes' );
};

done_testing;