1#!./perl 2 3BEGIN { 4 require Config; 5 if (($Config::Config{'extensions'} !~ /\bre\b/) ){ 6 print "1..0 # Skip -- Perl configured without re module\n"; 7 exit 0; 8 } 9} 10 11use strict; 12use warnings; 13 14use Test::More; # test count at bottom of file 15{ 16 use re qw{regmust}; 17 my $qr=qr/here .* there/x; 18 my ($anchored,$floating)=regmust($qr); 19 is($anchored,'here',"Regmust anchored - qr//"); 20 is($floating,'there',"Regmust floating - qr//"); 21 my $foo='blah'; 22 ($anchored,$floating)=regmust($foo); 23 is($anchored,undef,"Regmust anchored - non ref"); 24 is($floating,undef,"Regmust anchored - non ref"); 25 my $bar=['blah']; 26 ($anchored,$floating)=regmust($foo); 27 is($anchored,undef,"Regmust anchored - ref"); 28 is($floating,undef,"Regmust anchored - ref"); 29} 30 31{ 32 use re qw{optimization}; 33 # try to show each element is populated, without working the regexp 34 # engine any harder than necessary - the real work will be testing 35 # that optimization happens correctly using this under t/re. 36 37 is(optimization(undef), undef, "non-qr returns undef"); 38 is(optimization("foo"), undef, "non-qr returns undef"); 39 is(optimization(bless {}, "Regexp"), undef, "non-qr returns undef"); 40 41 my $o = optimization(qr{foo}); 42 is(ref($o), 'HASH', "qr returns a hashref"); 43 is($o->{minlen}, 3, "/foo/ has minlen"); 44 45 $o = optimization(qr{foo(?=bar)}); 46 is($o->{minlenret}, 3, "/foo(?=bar)/ has minlenret"); 47 48 $o = optimization(qr{.\G.}); 49 ok($o->{'anchor GPOS'}, "/.\\G./ has anchor GPOS"); 50 is($o->{gofs}, 1, "/.\\G./ has gofs"); 51 52 $o = optimization(qr{a|bc}); 53 is($o->{anchored}, undef, "/a|bc/ has no anchored substring"); 54 is($o->{floating}, undef, "/a|bc/ has no floating substring"); 55 is($o->{checking}, "none", "/a|bc/ is checking no substring"); 56 57 $o = optimization(qr{foo}); 58 ok($o->{isall}, "/foo/ has isall"); 59 is($o->{anchored}, "foo", "/foo/ has anchored substring"); 60 is($o->{'anchored utf8'}, undef, "/foo/ has no anchored utf8"); 61 is($o->{floating}, undef, "/foo/ has no floating substring"); 62 is($o->{checking}, "anchored", "/foo/ is checking anchored"); 63 64 $o = optimization(qr{.foo}); 65 is($o->{'anchored min offset'}, 1, "/.foo/ has anchored min offset"); 66 like($o->{'anchored max offset'}, qr{^[01]\z}, 67 "/.foo/ has valid anchored max offset"); 68 69 $o = optimization(qr{.foo\x{100}}); 70 is($o->{anchored}, undef, "/.foo\\x{100}/ has no anchored"); 71 is($o->{'anchored utf8'}, "foo\x{100}", "/.foo\\x{100}/ has anchored utf8"); 72 is($o->{'anchored min offset'}, 1, "/.foo\\x{100}/ has anchored min"); 73 like($o->{'anchored max offset'}, qr{^[01]\z}, 74 "/.foo\\x{100}/ has valid anchored max offset"); 75 76 $o = optimization(qr{.x?foo}); 77 is($o->{anchored}, undef, "/.x?foo/ has no anchored substring"); 78 is($o->{floating}, "foo", "/.x?foo/ has floating substring"); 79 is($o->{'floating utf8'}, undef, "/.x?foo/ has no floating utf8"); 80 is($o->{'floating min offset'}, 1, "/.x?foo/ has floating min offset"); 81 is($o->{'floating max offset'}, 2, "/.x?foo/ has floating max offset"); 82 is($o->{checking}, "floating", "/foo/ is checking floating"); 83 84 $o = optimization(qr{[ab]+}); 85 ok($o->{skip}, "/[ab]+/ has skip"); 86 like($o->{stclass}, qr{^ANYOF}, "/[ab]+/ has stclass"); 87 88 ok(optimization(qr{^foo})->{'anchor SBOL'}, "/^foo/ has anchor SBOL"); 89 ok(optimization(qr{^foo}m)->{'anchor MBOL'}, "/^foo/m has anchor MBOL"); 90 ok(optimization(qr{.*})->{implicit}, "/.*/ has implicit anchor"); 91 ok(optimization(qr{^.foo})->{noscan}, "/^.foo/ has noscan"); 92 93 # TODO: test anchored/floating end shift 94} 95# New tests above this line, don't forget to update the test count below! 96use Test::More tests => 40; 97# No tests here! 98 99# 100# ex: set ts=8 sts=4 sw=4 et: 101# 102