Change 31453 by [EMAIL PROTECTED] on 2007/06/23 19:53:53
Rename test files starting with regexp_ that do not
wrap regexp.t (and thus use re_tests) to reg_ to make
it clear they are standalone.
Affected files ...
... //depot/perl/MANIFEST#1591 edit
... //depot/perl/t/op/reg_email.t#1 branch
... //depot/perl/t/op/reg_mesg.t#1 branch
... //depot/perl/t/op/reg_namedcapture.t#1 branch
... //depot/perl/t/op/reg_nc_tie.t#1 branch
... //depot/perl/t/op/reg_pmod.t#1 branch
... //depot/perl/t/op/regexp_email.t#2 delete
... //depot/perl/t/op/regexp_namedcapture.t#3 delete
... //depot/perl/t/op/regexp_nc_tie.t#2 delete
... //depot/perl/t/op/regexp_pmod.t#2 delete
... //depot/perl/t/op/regmesg.t#20 delete
Differences ...
==== //depot/perl/MANIFEST#1591 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1590~31451~ 2007-06-23 12:04:04.000000000 -0700
+++ perl/MANIFEST 2007-06-23 12:53:53.000000000 -0700
@@ -3750,17 +3750,17 @@
t/op/read.t See if read() works
t/op/recurse.t See if deep recursion works
t/op/ref.t See if refs and objects work
-t/op/regexp_email.t See if regex recursion works by parsing email
addresses
-t/op/regexp_namedcapture.t Make sure glob assignment doesn't break named
capture
-t/op/regexp_nc_tie.t Test the tied methods of Tie::Hash::NamedCapture
t/op/regexp_noamp.t See if regular expressions work with
optimizations
t/op/regexp_notrie.t See if regular expressions work without trie
optimisation
-t/op/regexp_pmod.t See if regexp /p modifier works as expected
t/op/regexp_qr_embed.t See if regular expressions work with embedded
qr//
t/op/regexp_qr.t See if regular expressions work as qr//
t/op/regexp.t See if regular expressions work
t/op/regexp_trielist.t See if regular expressions work with trie
optimisation
-t/op/regmesg.t See if one can get regular expression errors
+t/op/reg_email.t See if regex recursion works by parsing email
addresses
+t/op/reg_mesg.t See if one can get regular expression
errors
+t/op/reg_namedcapture.t Make sure glob assignment doesn't break
named capture
+t/op/reg_nc_tie.t Test the tied methods of Tie::Hash::NamedCapture
+t/op/reg_pmod.t See if regexp /p modifier works as
expected
t/op/reg_unsafe.t Check for unsafe match vars
t/op/repeat.t See if x operator works
t/op/reset.t See if reset operator works
==== //depot/perl/t/op/reg_email.t#1 (text) ====
Index: perl/t/op/reg_email.t
--- /dev/null 2007-03-19 09:41:43.516454971 -0700
+++ perl/t/op/reg_email.t 2007-06-23 12:53:53.000000000 -0700
@@ -0,0 +1,94 @@
+#!./perl
+#
+# Tests to make sure the regexp engine doesn't run into limits too soon.
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..13\n";
+
+my $email = qr {
+ (?(DEFINE)
+ (?<address> (?&mailbox) | (?&group))
+ (?<mailbox> (?&name_addr) | (?&addr_spec))
+ (?<name_addr> (?&display_name)? (?&angle_addr))
+ (?<angle_addr> (?&CFWS)? < (?&addr_spec) > (?&CFWS)?)
+ (?<group> (?&display_name) : (?:(?&mailbox_list) | (?&CFWS))? ;
+ (?&CFWS)?)
+ (?<display_name> (?&phrase))
+ (?<mailbox_list> (?&mailbox) (?: , (?&mailbox))*)
+
+ (?<addr_spec> (?&local_part) \@ (?&domain))
+ (?<local_part> (?&dot_atom) | (?"ed_string))
+ (?<domain> (?&dot_atom) | (?&domain_literal))
+ (?<domain_literal> (?&CFWS)? \[ (?: (?&FWS)? (?&dcontent))* (?&FWS)?
+ \] (?&CFWS)?)
+ (?<dcontent> (?&dtext) | (?"ed_pair))
+ (?<dtext> (?&NO_WS_CTL) | [\x21-\x5a\x5e-\x7e])
+
+ (?<atext> (?&ALPHA) | (?&DIGIT) | [!#\$%&'*+-/=?^_`{|}~])
+ (?<atom> (?&CFWS)? (?&atext)+ (?&CFWS)?)
+ (?<dot_atom> (?&CFWS)? (?&dot_atom_text) (?&CFWS)?)
+ (?<dot_atom_text> (?&atext)+ (?: \. (?&atext)+)*)
+
+ (?<text> [\x01-\x09\x0b\x0c\x0e-\x7f])
+ (?<quoted_pair> \\ (?&text))
+
+ (?<qtext> (?&NO_WS_CTL) | [\x21\x23-\x5b\x5d-\x7e])
+ (?<qcontent> (?&qtext) | (?"ed_pair))
+ (?<quoted_string> (?&CFWS)? (?&DQUOTE) (?:(?&FWS)? (?&qcontent))*
+ (?&FWS)? (?&DQUOTE) (?&CFWS)?)
+
+ (?<word> (?&atom) | (?"ed_string))
+ (?<phrase> (?&word)+)
+
+ # Folding white space
+ (?<FWS> (?: (?&WSP)* (?&CRLF))? (?&WSP)+)
+ (?<ctext> (?&NO_WS_CTL) | [\x21-\x27\x2a-\x5b\x5d-\x7e])
+ (?<ccontent> (?&ctext) | (?"ed_pair) | (?&comment))
+ (?<comment> \( (?: (?&FWS)? (?&ccontent))* (?&FWS)? \) )
+ (?<CFWS> (?: (?&FWS)? (?&comment))*
+ (?: (?:(?&FWS)? (?&comment)) | (?&FWS)))
+
+ # No whitespace control
+ (?<NO_WS_CTL> [\x01-\x08\x0b\x0c\x0e-\x1f\x7f])
+
+ (?<ALPHA> [A-Za-z])
+ (?<DIGIT> [0-9])
+ (?<CRLF> \x0d \x0a)
+ (?<DQUOTE> ")
+ (?<WSP> [\x20\x09])
+ )
+
+ (?&address)
+}x;
+
+my $count = 0;
+
+$| = 1;
+while (<DATA>) {
+ chomp;
+ next if /^#/;
+ print /^$email$/ ? "ok " : "not ok ", ++ $count, "\n";
+}
+
+#
+# Acme::MetaSyntactic ++
+#
+__DATA__
[EMAIL PROTECTED]
+"Lady Penelope"@thunderbirds.org
+"The\ Hood"@thunderbirds.org
+fred @ flintstones.net
+barney (rubble) @ flintstones.org
+bammbamm (bam! bam! (bam! bam! (bam!)) bam!) @ flintstones.org
[EMAIL PROTECTED]
+Donatello @ [127.0.0.1]
+Raphael (He as well) @ [127.0.0.1]
+"Leonardo" @ [127.0.0.1]
+Barbapapa <barbapapa @ barbapapa.net>
+"Barba Mama" <barbamama @ [127.0.0.1]>
+Barbalala (lalalalalalalala) <barbalala (Yes, her!) @ (barba) barbapapa.net>
==== //depot/perl/t/op/reg_mesg.t#1 (text) ====
Index: perl/t/op/reg_mesg.t
--- /dev/null 2007-03-19 09:41:43.516454971 -0700
+++ perl/t/op/reg_mesg.t 2007-06-23 12:53:53.000000000 -0700
@@ -0,0 +1,194 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+my $debug = 1;
+
+##
+## If the markers used are changed (search for "MARKER1" in regcomp.c),
+## update only these two variables, and leave the {#} in the @death/@warning
+## arrays below. The {#} is a meta-marker -- it marks where the marker should
+## go.
+
+my $marker1 = "<-- HERE";
+my $marker2 = " <-- HERE ";
+
+##
+## Key-value pairs of code/error of code that should have fatal errors.
+##
+
+eval 'use Config'; # assume defaults if fail
+our %Config;
+my $inf_m1 = ($Config{reg_infty} || 32767) - 1;
+my $inf_p1 = $inf_m1 + 2;
+my @death =
+(
+ '/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions in
regex; marked by {#} in m/[[=foo=]{#}]/',
+
+ '/(?<= .*)/' => 'Variable length lookbehind not implemented in regex m/(?<=
.*)/',
+
+ '/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented in regex
m/(?<= x{1000})/',
+
+ '/(?@)/' => 'Sequence ([EMAIL PROTECTED]) not implemented in regex; marked by
{#} in m/([EMAIL PROTECTED])/',
+
+ '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced in regex;
marked by {#} in m/(?{{#} 1/',
+
+ '/(?(1x))/' => 'Switch condition not recognized in regex; marked by {#} in
m/(?(1x{#}))/',
+
+ '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches in
regex; marked by {#} in m/(?(1)x|y|{#}z)/',
+
+ '/(?(x)y|x)/' => 'Unknown switch condition (?(x) in regex; marked by {#} in
m/(?({#}x)y|x)/',
+
+ '/(?/' => 'Sequence (? incomplete in regex; marked by {#} in m/(?{#}/',
+
+ '/(?;x/' => 'Sequence (?;...) not recognized in regex; marked by {#} in
m/(?;{#}x/',
+ '/(?<;x/' => 'Sequence (?<;...) not recognized in regex; marked by {#} in
m/(?<;{#}x/',
+
+ '/(?\ix/' => 'Sequence (?\...) not recognized in regex; marked by {#} in
m/(?\{#}ix/',
+ '/(?\mx/' => 'Sequence (?\...) not recognized in regex; marked by {#} in
m/(?\{#}mx/',
+ '/(?\:x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in
m/(?\{#}:x/',
+ '/(?\=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in
m/(?\{#}=x/',
+ '/(?\!x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in
m/(?\{#}!x/',
+ '/(?\<=x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in
m/(?\{#}<=x/',
+ '/(?\<!x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in
m/(?\{#}<!x/',
+ '/(?\>x/' => 'Sequence (?\...) not recognized in regex; marked by {#} in
m/(?\{#}>x/',
+
+ '/((x)/' => 'Unmatched ( in regex; marked by {#} in m/({#}(x)/',
+
+ "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 in regex; marked by
{#} in m/x{{#}$inf_p1}/",
+
+ '/x{3,1}/' => 'Can\'t do {n,m} with n > m in regex; marked by {#} in
m/x{3,1}{#}/',
+
+ '/x**/' => 'Nested quantifiers in regex; marked by {#} in m/x**{#}/',
+
+ '/x[/' => 'Unmatched [ in regex; marked by {#} in m/x[{#}/',
+
+ '/*/', => 'Quantifier follows nothing in regex; marked by {#} in m/*{#}/',
+
+ '/\p{x/' => 'Missing right brace on \p{} in regex; marked by {#} in
m/\p{{#}x/',
+
+ '/[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in
m/[\p{{#}x]/',
+
+ '/(x)\2/' => 'Reference to nonexistent group in regex; marked by {#} in
m/(x)\2{#}/',
+
+ 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/',
+
+ '/\x{1/' => 'Missing right brace on \x{} in regex; marked by {#} in
m/\x{{#}1/',
+
+ '/[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in
m/[\x{{#}X]/',
+
+ '/[[:barf:]]/' => 'POSIX class [:barf:] unknown in regex; marked by {#} in
m/[[:barf:]{#}]/',
+
+ '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions in
regex; marked by {#} in m/[[=barf=]{#}]/',
+
+ '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions in
regex; marked by {#} in m/[[.barf.]{#}]/',
+
+ '/[z-a]/' => 'Invalid [] range "z-a" in regex; marked by {#} in m/[z-a{#}]/',
+
+ '/\p/' => 'Empty \p{} in regex; marked by {#} in m/\p{#}/',
+
+ '/\P{}/' => 'Empty \P{} in regex; marked by {#} in m/\P{{#}}/',
+);
+
+##
+## Key-value pairs of code/error of code that should have non-fatal warnings.
+##
[EMAIL PROTECTED] = (
+ 'm/\b*/' => '\b* matches null string many times in regex; marked by {#} in
m/\b*{#}/',
+
+ 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes in
regex; marked by {#} in m/[:blank:]{#}/',
+
+ "m'[\\y]'" => 'Unrecognized escape \y in character class passed
through in regex; marked by {#} in m/[\y{#}]/',
+
+ 'm/[a-\d]/' => 'False [] range "a-\d" in regex; marked by {#} in
m/[a-\d{#}]/',
+ 'm/[\w-x]/' => 'False [] range "\w-" in regex; marked by {#} in
m/[\w-{#}x]/',
+ 'm/[a-\pM]/' => 'False [] range "a-\pM" in regex; marked by {#} in
m/[a-\pM{#}]/',
+ 'm/[\pM-x]/' => 'False [] range "\pM-" in regex; marked by {#} in
m/[\pM-{#}x]/',
+ "m'\\y'" => 'Unrecognized escape \y passed through in regex; marked by
{#} in m/\y{#}/',
+);
+
+my $total = (@death + @warning)/2;
+
+# utf8 is a noop on EBCDIC platforms, it is not fatal
+my $Is_EBCDIC = (ord('A') == 193);
+if ($Is_EBCDIC) {
+ my @utf8_death = grep(/utf8/, @death);
+ $total = $total - @utf8_death;
+}
+
+print "1..$total\n";
+
+my $count = 0;
+
+while (@death)
+{
+ my $regex = shift @death;
+ my $result = shift @death;
+ # skip the utf8 test on EBCDIC since they do not die
+ next if ($Is_EBCDIC && $regex =~ /utf8/);
+ $count++;
+
+ $_ = "x";
+ eval $regex;
+ if (not $@) {
+ print "# oops, $regex didn't die\nnot ok $count\n";
+ next;
+ }
+ chomp $@;
+ $result =~ s/{\#}/$marker1/;
+ $result =~ s/{\#}/$marker2/;
+ $result .= " at ";
+ if ($@ !~ /^\Q$result/) {
+ print "# For $regex, expected:\n# $result\n# Got:\n# [EMAIL
PROTECTED] ";
+ }
+ print "ok $count - $regex\n";
+}
+
+
+our $warning;
+$SIG{__WARN__} = sub { $warning = shift };
+
+while (@warning)
+{
+ $count++;
+ my $regex = shift @warning;
+ my $result = shift @warning;
+
+ undef $warning;
+ $_ = "x";
+ eval $regex;
+
+ if ($@)
+ {
+ print "# oops, $regex died with:[EMAIL PROTECTED] ok $count\n";
+ next;
+ }
+
+ if (not $warning)
+ {
+ print "# oops, $regex didn't generate a warning\nnot ok $count\n";
+ next;
+ }
+ $result =~ s/{\#}/$marker1/;
+ $result =~ s/{\#}/$marker2/;
+ $result .= " at ";
+ if ($warning !~ /^\Q$result/)
+ {
+ print <<"EOM";
+# For $regex, expected:
+# $result
+# Got:
+# $warning
+#
+not ok $count
+EOM
+ next;
+ }
+ print "ok $count - $regex\n";
+}
+
+
+
==== //depot/perl/t/op/reg_namedcapture.t#1 (text) ====
Index: perl/t/op/reg_namedcapture.t
--- /dev/null 2007-03-19 09:41:43.516454971 -0700
+++ perl/t/op/reg_namedcapture.t 2007-06-23 12:53:53.000000000 -0700
@@ -0,0 +1,20 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# WARNING: Do not use anymodules as part of this test code.
+# We could get action at a distance that would invalidate the tests.
+
+print "1..2\n";
+
+# This tests whether glob assignment fails to load the tie.
+*X = *-;
+'X'=~/(?<X>X)/;
+print eval '*X{HASH}{X} || 1' ? "" :"not ","ok ",++$test,"\n";
+
+# And since its a similar case we check %! as well
+*Y = *!;
+print 0<keys(%Y) ? "" :"not ","ok ",++$test,"\n";
==== //depot/perl/t/op/reg_nc_tie.t#1 (text) ====
Index: perl/t/op/reg_nc_tie.t
--- /dev/null 2007-03-19 09:41:43.516454971 -0700
+++ perl/t/op/reg_nc_tie.t 2007-06-23 12:53:53.000000000 -0700
@@ -0,0 +1,48 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+# Do a basic test on all the tied methods of Tie::Hash::NamedCapture
+
+print "1..12\n";
+
+"hlagh" =~ /
+ (?<a>.)
+ (?<b>.)
+ (?<a>.)
+ .*
+ (?<e>$)
+/x;
+
+# FETCH
+is($+{a}, "h", "FETCH");
+is($+{b}, "l", "FETCH");
+is($-{a}[0], "h", "FETCH");
+is($-{a}[1], "a", "FETCH");
+
+# STORE
+eval { $+{a} = "yon" };
+ok(index($@, "read-only") != -1, "STORE");
+
+# DELETE
+eval { delete $+{a} };
+ok(index($@, "read-only") != -1, "DELETE");
+
+# CLEAR
+eval { %+ = () };
+ok(index($@, "read-only") != -1, "CLEAR");
+
+# EXISTS
+ok(exists $+{e}, "EXISTS");
+ok(!exists $+{d}, "EXISTS");
+
+# FIRSTKEY/NEXTKEY
+is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY");
+
+# SCALAR
+is(scalar(%+), 3, "SCALAR");
+is(scalar(%-), 3, "SCALAR");
==== //depot/perl/t/op/reg_pmod.t#1 (text) ====
Index: perl/t/op/reg_pmod.t
--- /dev/null 2007-03-19 09:41:43.516454971 -0700
+++ perl/t/op/reg_pmod.t 2007-06-23 12:53:53.000000000 -0700
@@ -0,0 +1,39 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use strict;
+use warnings;
+
+our @tests = (
+ # /p Pattern PRE MATCH POST
+ [ 'p', "456", "123-", "456", "-789"],
+ [ '', "(456)", "123-", "456", "-789"],
+ [ '', "456", undef, undef, undef ],
+);
+
+plan tests => 4 * @tests + 2;
+my $W = "";
+
+$SIG{__WARN__} = sub { $W.=join("",@_); };
+sub _u($$) { "$_[0] is ".(defined $_[1] ? "'$_[1]'" : "undef") }
+
+$_ = '123-456-789';
+foreach my $test (@tests) {
+ my ($p, $pat,$l,$m,$r) = @$test;
+ my $test_name = "/$pat/$p";
+ my $ok = ok($p ? /$pat/p : /$pat/, $test_name);
+ SKIP: {
+ skip "/$pat/$p failed to match", 3
+ unless $ok;
+ is(${^PREMATCH}, $l,_u "$test_name: ^PREMATCH",$l);
+ is(${^MATCH}, $m,_u "$test_name: ^MATCH",$m );
+ is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r );
+ }
+}
+is($W,"","No warnings should be produced");
+ok(!defined ${^MATCH}, "No /p in scope so ^MATCH is undef");
End of Patch.
