X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fpat.t;h=90623fbfca62f091250d87f9b6e4b5ef52a9c1ae;hb=c70c8a0a59777ed7fb7075471185210bc2169b49;hp=5516ce595c9526d23c40b74d5a710ec1710a8e35;hpb=ce862d02de7e5d8ac2078735cf4bd004193e837d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/pat.t b/t/op/pat.t
index 5516ce5..90623fb 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -1,8 +1,18 @@
 #!./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..107\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";
 
@@ -233,8 +243,56 @@ $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
 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=/;
@@ -323,7 +381,26 @@ $test++;
 
 $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++;
@@ -373,6 +450,71 @@ 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/ }