#!./perl
+#
+# This is a home for regular expression tests that don't fit into
+# the format supported by op/regexp.t. If you want to add a test
+# that does fit that format, add it to op/re_tests, not here.
# $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $
-print "1..101\n";
+print "1..130\n";
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = "../lib" if -d "../lib";
+}
+eval 'use Config'; # Defaults assumed if this fails
$x = "abc\ndef\n";
$XXX{345} = 345;
@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
-while ($_ = shift(XXX)) {
+while ($_ = shift(@XXX)) {
?(.*)? && (print $1,"\n");
/not/ && reset;
/not ok 26/ && reset 'X';
print "not " if "@out" ne 'bar2 barf';
print "ok 65\n";
+# Tests which depend on REG_INFTY
+$reg_infty = defined $Config{reg_infty} ? $Config{reg_infty} : 32767;
+$reg_infty_m = $reg_infty - 1; $reg_infty_p = $reg_infty + 1;
+
+# As well as failing if the pattern matches do unexpected things, the
+# next three tests will fail if you should have picked up a lower-than-
+# default value for $reg_infty from Config.pm, but have not.
+
+undef $@;
+print "not " if eval q(('aaa' =~ /(a{1,$reg_infty_m})/)[0] ne 'aaa') || $@;
+print "ok 66\n";
+
+undef $@;
+print "not " if eval q(('a' x $reg_infty_m) !~ /a{$reg_infty_m}/) || $@;
+print "ok 67\n";
+
+undef $@;
+print "not " if eval q(('a' x ($reg_infty_m - 1)) =~ /a{$reg_infty_m}/) || $@;
+print "ok 68\n";
+
+undef $@;
+eval "'aaa' =~ /a{1,$reg_infty}/";
+print "not " if $@ !~ m%^\Q/a{1,$reg_infty}/: Quantifier in {,} bigger than%;
+print "ok 69\n";
+
+eval "'aaa' =~ /a{1,$reg_infty_p}/";
+print "not "
+ if $@ !~ m%^\Q/a{1,$reg_infty_p}/: Quantifier in {,} bigger than%;
+print "ok 70\n";
+undef $@;
+
+# Poke a couple more parse failures
+
+$context = 'x' x 256;
+eval qq("${context}y" =~ /(?<=$context)y/);
+print "not " if $@ !~ m%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%;
+print "ok 71\n";
+
+# This one will fail when POSIX character classes do get implemented
+{
+ my $w;
+ local $^W = 1;
+ local $SIG{__WARN__} = sub{$w = shift};
+ eval q('a' =~ /[[:alpha:]]/);
+ print "not " if $w !~ /^\QCharacter class syntax [: :] is reserved/;
+}
+print "ok 72\n";
+
# Long Monsters
-$test = 66;
+$test = 73;
for $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
$a = 'a' x $l;
print "# length=$l\nnot " unless "ba$a=" =~ /a$a=/;
$code = '{$blah = 45}';
$blah = 12;
-/(?$code)/;
+eval { /(?$code)/ };
+print "not " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12;
+print "ok $test\n";
+$test++;
+
+for $code ('{$blah = 45}','=xx') {
+ $blah = 12;
+ $res = eval { "xx" =~ /(?$code)/o };
+ if ($code eq '=xx') {
+ print "#'$@','$res','$blah'\nnot " unless not $@ and $res;
+ } else {
+ print "#'$@','$res','$blah'\nnot " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12;
+ }
+ print "ok $test\n";
+ $test++;
+}
+
+$code = '{$blah = 45}';
+$blah = 12;
+eval "/(?$code)/";
print "not " if $blah != 45;
print "ok $test\n";
$test++;
print "not " unless f(pos($x)) == 4;
print "ok $test\n";
$test++;
+
+$x = $^R = 67;
+'foot' =~ /foo(?{$x = 12; 75})[t]/;
+print "not " unless $^R eq '75';
+print "ok $test\n";
+$test++;
+
+$x = $^R = 67;
+'foot' =~ /foo(?{$x = 12; 75})[xy]/;
+print "not " unless $^R eq '67' and $x eq '12';
+print "ok $test\n";
+$test++;
+
+$x = $^R = 67;
+'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/;
+print "not " unless $^R eq '79' and $x eq '12';
+print "ok $test\n";
+$test++;
+
+# This should be changed to qr/\b\v$/ ASAP
+print "not " unless study(/\b\v$/) eq '(?:\bv$)';
+print "ok $test\n";
+$test++;
+
+$_ = 'xabcx';
+foreach $ans ('', 'c') {
+ /(?<=(?=a)..)((?=c)|.)/g;
+ print "not " unless $1 eq $ans;
+ print "ok $test\n";
+ $test++;
+}
+
+$_ = 'a';
+foreach $ans ('', 'a', '') {
+ /^|a|$/g;
+ print "not " unless $& eq $ans;
+ print "ok $test\n";
+ $test++;
+}
+
+sub prefixify {
+ my($v,$a,$b,$res) = @_;
+ $v =~ s/\Q$a\E/$b/;
+ print "not " unless $res eq $v;
+ print "ok $test\n";
+ $test++;
+}
+prefixify('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch');
+prefixify('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch');
+
+$_ = 'var="foo"';
+/(\")/;
+print "not " unless $1 and /$1/;
+print "ok $test\n";
+$test++;
+
+$a=study/(?{++$b})/;
+$b = 7;
+/$a$a/;
+print "not " unless $b eq '9';
+print "ok $test\n";
+$test++;
+
+$c="$a";
+/$a$a/;
+print "not " unless $b eq '11';
+print "ok $test\n";
+$test++;
+
+{
+ use re "eval";
+ /$a$c$a/;
+ print "not " unless $b eq '14';
+ print "ok $test\n";
+ $test++;
+
+ no re "eval";
+ $match = eval { /$a$c$a/ };
+ print "not "
+ unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match;
+ print "ok $test\n";
+ $test++;
+}
+
+sub must_warn_pat {
+ my $warn_pat = shift;
+ return sub { print "not " unless $_[0] =~ /$warn_pat/ }
+}
+
+sub must_warn {
+ my ($warn_pat, $code) = @_;
+ local $^W; local %SIG;
+ eval 'BEGIN { $^W = 1; $SIG{__WARN__} = $warn_pat };' . $code;
+ print "ok $test\n";
+ $test++;
+}
+
+
+sub make_must_warn {
+ my $warn_pat = shift;
+ return sub { must_warn(must_warn_pat($warn_pat)) }
+}
+
+my $for_future = make_must_warn('reserved for future extensions');
+
+&$for_future('q(a:[b]:) =~ /[x[:foo:]]/');
+&$for_future('q(a=[b]=) =~ /[x[=foo=]]/');
+&$for_future('q(a.[b].) =~ /[x[.foo.]]/');
projects / p5sagit/p5-mst-13.2.git / blobdiff