#!perl -w
use strict;
use Storable "dclone";
use Test::More;
my $version = int(($]-5)*1000);
$version >= 8
or plan skip_all => "regexps not supported before 5.8";
my @tests;
while (<DATA>) {
chomp;
next if /^\s*#/ || !/\S/;
my ($range, $code, $match, $name) = split /\s*;\s*/;
defined $name or die "Bad test line";
my $ascii_only = $range =~ s/A//;
next if $ascii_only and ord("A") != 65;
if ($range =~ /^(\d+)-$/) {
next if $version < $1
}
elsif ($range =~ /^-(\d+)$/) {
next if $version > $1
}
elsif ($range =~ /^(\d+)-(\d+)$/) {
next if $version < $1 || $version > $2;
}
elsif ($range ne "-") {
die "Invalid version range $range for $name";
}
my @match = split /\s*,\s*/, $match;
for my $m (@match) {
my $not = $m =~ s/^!//;
my $cmatch = eval $m;
die if $@;
push @tests, [ $code, $not, $cmatch, $m, $name ];
}
}
plan tests => 9 + 3*scalar(@tests);
SKIP:
{
$version >= 14 && $version < 20
or skip "p introduced in 5.14, pointless from 5.20", 4;
my $q1 = eval "qr/b/p";
my $q2 = eval "qr/b/";
my $c1 = dclone($q1);
my $c2 = dclone($q2);
ok("abc" =~ $c1, "abc matches $c1");
is(${^PREMATCH}, "a", "check p worked");
ok("cba" =~ $c2, "cba matches $c2");
isnt(${^PREMATCH}, "c", "check no p worked");
}
SKIP:
{
$version >= 24
or skip "n introduced in 5.22", 4;
my $c1 = dclone(eval "qr/(\\w)/");
my $c2 = dclone(eval "qr/(\\w)/n");
ok("a" =~ $c1, "a matches $c1");
is($1, "a", "check capturing preserved");
ok("b" =~ $c2, "b matches $c2");
isnt($1, "b", "check non-capturing preserved");
}
SKIP:
{
$version >= 8
or skip "Cannot retrieve before 5.8", 1;
my $x;
my $re = qr/a(?{ $x = 1 })/;
use re 'eval';
ok(!eval { dclone($re) }, "should fail to clone, even with use re 'eval'");
}
for my $test (@tests) {
my ($code, $not, $match, $matchc, $name) = @$test;
my $qr = eval $code;
die "Could not compile $code: $@" if $@;
if ($not) {
unlike($match, $qr, "$name: pre(not) match $matchc");
}
else {
like($match, $qr, "$name: prematch $matchc");
}
my $qr2 = dclone($qr);
if ($not) {
unlike($match, $qr2, "$name: (not) match $matchc");
}
else {
like($match, $qr2, "$name: match $matchc");
}
# this is unlikely to be a problem, but make sure regexps are frozen sanely
# as part of a data structure
my $a2 = dclone([ $qr ]);
if ($not) {
unlike($match, $a2->[0], "$name: (not) match $matchc (array)");
}
else {
like($match, $a2->[0], "$name: match $matchc (array)");
}
}
__DATA__
# semi-colon separated:
# perl version range; regexp qr; match string; name
# - version range is PERL_VERSION, ie 22 for 5.22 as from-to with both from
# and to optional (so "-" is all versions.
# - match string is , separated match strings
# - if a match string starts with ! it mustn't match, otherwise it must
# spaces around the commas ignored.
# The initial "!" is stripped and the remainder treated as perl code to define
# the string to (not) be matched
-; qr/foo/ ; "foo",!"fob" ; simple
-; qr/foo/i ; "foo","FOO",!"fob" ; simple case insensitive
-; qr/f o o/x ; "foo", !"f o o" ; /x
-; qr(a/b) ; "a/b" ; alt quotes
A-; qr(\x2E) ; ".", !"a" ; \x2E - hex meta
-; qr/\./ ; "." , !"a" ; \. - backslash meta
8- ; qr/\x{100}/ ; "\x{100}" ; simple unicode
12- ; qr/fss/i ; "f\xDF\x{101}" ; case insensive unicode promoted
22-; qr/fss/ui ; "f\xDF" ; case insensitive unicode SS /iu
22-; qr/fss/aai ; !"f\xDF" ; case insensitive unicode SS /iaa
22-; qr/f\w/a ; "fo", !"f\xff" ; simple /a flag