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