fix occasional op/time.t failure

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

diff --git a/t/op/pat.t b/t/op/pat.t
index 774acf7..24aa38a 100755 (executable)
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -3663,6 +3663,33 @@ SKIP:{
     $s=~s/(?'digits'\d+)\k'digits'/$+{digits}/;
     ok($s eq '123456','Named capture (single quotes) s///');    
 }
+
+{
+    my @ary = (
+       pack('U', 0x00F1),            # n-tilde
+       '_'.pack('U', 0x00F1),        # _ + n-tilde
+       'c'.pack('U', 0x0327),        # c + cedilla
+       pack('U*', 0x00F1, 0x0327),   # n-tilde + cedilla
+       'a'.pack('U', 0x00B2),        # a + superscript two
+       pack('U', 0x0391),            # ALPHA
+       pack('U', 0x0391).'2',        # ALPHA + 2
+       pack('U', 0x0391).'_',        # ALPHA + _
+    );
+    for my $uni (@ary) {
+       my ($r1, $c1, $r2, $c2) = eval qq{
+           use utf8;
+           scalar("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/),
+               \$+{${uni}},
+           scalar("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/),
+               \$+{${uni}};
+       };
+       ok($r1,                         "Named capture UTF (?'')");
+       ok(defined $c1 && $c1 eq 'foo', "Named capture UTF \%+");
+       ok($r2,                         "Named capture UTF (?<>)");
+       ok(defined $c2 && $c2 eq 'bar', "Named capture UTF \%+");
+    }
+}
+
 sub iseq($$;$) { 
     my ( $got, $expect, $name)=@_;
     
@@ -3718,7 +3745,24 @@ sub iseq($$;$) {
     ';
     ok(!$@,'lvalue $+{...} should not throw an exception');
 }
-
+{
+    my $s='foo bar baz';
+    my @res;
+    if ('1234'=~/(?<A>1)(?<B>2)(?<A>3)(?<B>4)/) {
+        foreach my $name (sort keys(%-)) {
+            my $ary = $-{$name};
+            foreach my $idx (0..$#$ary) {
+                push @res,"$name:$idx:$ary->[$idx]";
+            }
+        }
+    }
+    my @expect=qw(A:0:1 A:1:3 B:0:2 B:1:4);
+    iseq("@res","@expect","Check %-");
+    eval'
+        print for $-{this_key_doesnt_exist};
+    ';
+    ok(!$@,'lvalue $-{...} should not throw an exception');
+}
 # stress test CURLYX/WHILEM.
 #
 # This test includes varying levels of nesting, and according to
@@ -4053,10 +4097,10 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) {
 {
     local $Message="RT#22395";
     our $count;
-    for my $l (1,10,100,1000) {
+    for my $l (10,100,1000) {
        $count=0;
        ('a' x $l) =~ /(.*)(?{$count++})[bc]/;
-       iseq($l+1,$count,"Should be L+1 not L*(L+3)/2 (L=$l)");
+       iseq( $count, $l + 1, "# TODO Should be L+1 not L*(L+3)/2 (L=$l)");
     }
 }
 {
@@ -4083,6 +4127,17 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) {
     iseq($count,3);
     iseq($text,' word2 word4 word6 ');
 }
+{
+    # RT#6893
+    local $_= qq(A\nB\nC\n); 
+    my @res;
+    while (m#(\G|\n)([^\n]*)\n#gsx) 
+    { 
+        push @res,"$2"; 
+        last if @res>3;
+    }
+    iseq("@res","A B C","RT#6893: /g pattern shouldn't infinite loop");
+}
 
 {
     # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus>
@@ -4094,6 +4149,65 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) {
     iseq($dow_name,$time_string,"UTF8 trie common prefix extraction");
 }
 
+{
+    my $v;
+    ($v='bar')=~/(\w+)/g;
+    $v='foo';
+    iseq("$1",'bar','$1 is safe after /g - may fail due to specialized config in pp_hot.c')
+}
+{
+    local $Message = "http://nntp.perl.org/group/perl.perl5.porters/118663";
+    my $qr_barR1 = qr/(bar)\g-1/;
+    ok("foobarbarxyz" =~ $qr_barR1);
+    ok("foobarbarxyz" =~ qr/foo${qr_barR1}xyz/);
+    ok("foobarbarxyz" =~ qr/(foo)${qr_barR1}xyz/);
+    ok("foobarbarxyz" =~ qr/(foo)(bar)\g{-1}xyz/);
+    ok("foobarbarxyz" =~ qr/(foo${qr_barR1})xyz/);
+    ok("foobarbarxyz" =~ qr/(foo(bar)\g{-1})xyz/);
+} 
+{
+    local $Message = "RT#41010";
+    my @tails=('','(?(1))','(|)','()?');    
+    my @quants=('*','+');
+    my $doit=sub {
+        my $pats= shift;
+        for (@_) {
+            for my $pat (@$pats) {
+                for my $quant (@quants) {
+                    for my $tail (@tails) {
+                        my $re = "($pat$quant\$)$tail";
+                        ok(/$re/ && $1 eq $_,"'$_'=~/$re/");
+                        ok(/$re/m && $1 eq $_,"'$_'=~/$re/m");
+                    }
+                }
+            }
+       }
+    };    
+    
+    my @dpats=( 
+                '\d',
+                '[1234567890]',
+                '(1|[23]|4|[56]|[78]|[90])',
+                '(?:1|[23]|4|[56]|[78]|[90])',
+                '(1|2|3|4|5|6|7|8|9|0)',
+                '(?:1|2|3|4|5|6|7|8|9|0)',
+             );
+    my @spats=('[ ]',' ','( |\t)','(?: |\t)','[ \t]','\s');
+    my @sstrs=('  ');
+    my @dstrs=('12345');
+    $doit->(\@spats,@sstrs);
+    $doit->(\@dpats,@dstrs);
+}
+{
+    local $Message = "\$REGMARK";
+    our @r=();
+    ok('foofoo' =~ /foo (*MARK:foo) (?{push @r,$REGMARK}) /x);
+    iseq("@r","foo");           
+    iseq($REGMARK,"foo");
+    ok('foofoo' !~ /foo (*MARK:foo) (*FAIL) /x);
+    ok(!$REGMARK);
+    iseq($REGERROR,'foo');
+}
 # Test counter is at bottom of file. Put new tests above here.
 #-------------------------------------------------------------------
 # Keep the following tests last -- they may crash perl
@@ -4123,8 +4237,11 @@ ok((q(a)x 100) =~ /^(??{'(.)'x 100})/,
         "Regexp /^(??{'(.)'x 100})/ crashes older perls")
     or print "# Unexpected outcome: should pass or crash perl\n";
 
+eval '/\k/';
+ok($@=~/\QSequence \k... not terminated in regex;\E/);
+
 {
-    local $Message = "substituation with lookahead (possible segv)";
+    local $Message = "substitution with lookahead (possible segv)";
     $_="ns1ns1ns1";
     s/ns(?=\d)/ns_/g;
     iseq($_,"ns_1ns_1ns_1");
@@ -4137,14 +4254,10 @@ ok((q(a)x 100) =~ /^(??{'(.)'x 100})/,
 }
 
 # Put new tests above the dotted line about a page above this comment
-
+iseq(0+$::test,$::TestCount,"Got the right number of tests!");
 # Don't forget to update this!
 BEGIN {
-    $::TestCount = 1367;
+    $::TestCount = 1608;
     print "1..$::TestCount\n";
 }
-END {
-    if ($::TestCount != $::count) {
-       warn "#\n### Got $::count test reports, but expected $::TestCount\n#\n";
-    }
-}
+