1#!perl -w
2use strict;
3use Storable "dclone";
4use Test::More;
5
6my $version = int(($]-5)*1000);
7
8$version >= 8
9  or plan skip_all => "regexps not supported before 5.8";
10
11my @tests;
12while (<DATA>) {
13    chomp;
14    next if /^\s*#/ || !/\S/;
15    my ($range, $code, $match, $name) = split /\s*;\s*/;
16    defined $name or die "Bad test line";
17    my $ascii_only = $range =~ s/A//;
18    next if $ascii_only and ord("A") != 65;
19    if ($range =~ /^(\d+)-$/) {
20        next if $version < $1
21    }
22    elsif ($range =~ /^-(\d+)$/) {
23        next if $version > $1
24    }
25    elsif ($range =~ /^(\d+)-(\d+)$/) {
26        next if $version < $1 || $version > $2;
27    }
28    elsif ($range ne "-") {
29        die "Invalid version range $range for $name";
30    }
31    my @match = split /\s*,\s*/, $match;
32    for my $m (@match) {
33	my $not = $m =~ s/^!//;
34	my $cmatch = eval $m;
35	die if $@;
36        push @tests, [ $code, $not, $cmatch, $m, $name ];
37    }
38}
39
40plan tests => 10 + 3*scalar(@tests);
41
42SKIP:
43{
44    $version >= 14 && $version < 20
45      or skip "p introduced in 5.14, pointless from 5.20", 4;
46    my $q1 = eval "qr/b/p";
47    my $q2 = eval "qr/b/";
48    my $c1 = dclone($q1);
49    my $c2 = dclone($q2);
50    ok("abc" =~ $c1, "abc matches $c1");
51    is(${^PREMATCH}, "a", "check p worked");
52    ok("cba" =~ $c2, "cba matches $c2");
53    isnt(${^PREMATCH}, "c", "check no p worked");
54}
55
56SKIP:
57{
58    $version >= 24
59      or skip "n introduced in 5.22", 4;
60    my $c1 = dclone(eval "qr/(\\w)/");
61    my $c2 = dclone(eval "qr/(\\w)/n");
62    ok("a" =~ $c1, "a matches $c1");
63    is($1, "a", "check capturing preserved");
64    ok("b" =~ $c2, "b matches $c2");
65    isnt($1, "b", "check non-capturing preserved");
66}
67
68SKIP:
69{
70    $version >= 8
71      or skip "Cannot retrieve before 5.8", 1;
72    my $x;
73    my $re = qr/a(?{ $x = 1 })/;
74    use re 'eval';
75    ok(!eval { dclone($re) }, "should fail to clone, even with use re 'eval'");
76}
77
78is(ref(dclone(bless qr//, "Foo")), "Foo", "check reblessed regexps");
79
80for my $test (@tests) {
81    my ($code, $not, $match, $matchc, $name) = @$test;
82    my $qr = eval $code;
83    die "Could not compile $code: $@" if $@;
84    if ($not) {
85	unlike($match, $qr, "$name: pre(not) match $matchc");
86    }
87    else {
88	like($match, $qr, "$name: prematch $matchc");
89    }
90    my $qr2 = dclone($qr);
91    if ($not) {
92	unlike($match, $qr2, "$name: (not) match $matchc");
93    }
94    else {
95	like($match, $qr2, "$name: match $matchc");
96    }
97
98    # this is unlikely to be a problem, but make sure regexps are frozen sanely
99    # as part of a data structure
100    my $a2 = dclone([ $qr ]);
101    if ($not) {
102	unlike($match, $a2->[0], "$name: (not) match $matchc (array)");
103    }
104    else {
105	like($match, $a2->[0], "$name: match $matchc (array)");
106    }
107}
108
109__DATA__
110# semi-colon separated:
111# perl version range; regexp qr; match string; name
112# - version range is PERL_VERSION, ie 22 for 5.22 as from-to with both from
113#   and to optional (so "-" is all versions.
114# - match string is , separated match strings
115# - if a match string starts with ! it mustn't match, otherwise it must
116#   spaces around the commas ignored.
117#   The initial "!" is stripped and the remainder treated as perl code to define
118#   the string to (not) be matched
119-; qr/foo/ ; "foo",!"fob" ; simple
120-; qr/foo/i ; "foo","FOO",!"fob" ; simple case insensitive
121-; qr/f o o/x ; "foo", !"f o o" ; /x
122-; qr(a/b) ; "a/b" ; alt quotes
123A-; qr(\x2E) ; ".", !"a" ; \x2E - hex meta
124-; qr/\./ ; "." , !"a" ; \. - backslash meta
1258- ; qr/\x{100}/ ; "\x{100}" ; simple unicode
126A12- ; qr/fss/i ; "f\xDF\x{101}" ; case insensive unicode promoted
127A22-; qr/fss/ui ; "f\xDF" ; case insensitive unicode SS /iu
128A22-; qr/fss/aai ; !"f\xDF" ; case insensitive unicode SS /iaa
129A22-; qr/f\w/a ; "fo", !"f\xff" ; simple /a flag
130