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