make failed matches return empty list in list context

[p5sagit/p5-mst-13.2.git] / t / op / pat.t

diff --git a/t/op/pat.t b/t/op/pat.t
index fecdf0c..ef014f2 100755 (executable)
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -4,14 +4,16 @@
 # 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..139\n";
 
-print "1..123\n";
-
-chdir 't' if -d 't';
-@INC = "../lib";
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = "../lib" if -d "../lib";
+}
 eval 'use Config';          #  Defaults assumed if this fails
 
+$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+
 $x = "abc\ndef\n";
 
 if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
@@ -379,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++;
@@ -429,8 +450,27 @@ 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 "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)';
 print "ok $test\n";
 $test++;
 
@@ -466,6 +506,34 @@ print "not " unless $1 and /$1/;
 print "ok $test\n";
 $test++;
 
+$a=qr/(?{++$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/ }
@@ -490,3 +558,26 @@ 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.]]/');
+
+# test if failure of patterns returns empty list
+$_ = 'aaa';
+@_ = /bbb/;
+print "not " if @_;
+print "ok $test\n";
+$test++;
+
+@_ = /bbb/g;
+print "not " if @_;
+print "ok $test\n";
+$test++;
+
+@_ = /(bbb)/;
+print "not " if @_;
+print "ok $test\n";
+$test++;
+
+@_ = /(bbb)/g;
+print "not " if @_;
+print "ok $test\n";
+$test++;
+