X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fpat.t;h=5516ce595c9526d23c40b74d5a710ec1710a8e35;hb=ce862d02de7e5d8ac2078735cf4bd004193e837d;hp=8c3adc975d289079d44b04e7785fbce1bc176fb4;hpb=1462b684862954f3522657efc93a3264698e4a9f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/pat.t b/t/op/pat.t old mode 100644 new mode 100755 index 8c3adc9..5516ce5 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -1,8 +1,8 @@ #!./perl -# $RCSfile: pat.t,v $$Revision: 4.0.1.2 $$Date: 91/06/10 01:29:34 $ +# $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $ -print "1..51\n"; +print "1..107\n"; $x = "abc\ndef\n"; @@ -67,13 +67,13 @@ $XXX{234} = 234; $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'; } -while (($key,$val) = each(XXX)) { +while (($key,$val) = each(%XXX)) { print "not ok 27\n"; exit; } @@ -134,17 +134,19 @@ print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" : "not ok 45\n"; @words = (); +pos = 0; while (/to/g) { push(@words, $&); } print join(':',@words) eq "to:to" ? "ok 46\n" - : "not ok 46 @words\n"; + : "not ok 46 `@words'\n"; +pos $_ = 0; @words = /to/g; print join(':',@words) eq "to:to" ? "ok 47\n" - : "not ok 47 @words\n"; + : "not ok 47 `@words'\n"; $_ = "abcdefghi"; @@ -182,3 +184,216 @@ print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n"; eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; print $@ eq "" ? "ok 50\n" : "not ok 50\n"; print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n"; + + +$_="abcfooabcbar"; +$x=/abc/g; +print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x; +$x=/abc/g; +print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x; +$x=/abc/g; +print $x == 0 ? "ok 54\n" : "not ok 54\n"; +pos = 0; +$x=/ABC/gi; +print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x; +$x=/ABC/gi; +print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x; +$x=/ABC/gi; +print $x == 0 ? "ok 57\n" : "not ok 57\n"; +pos = 0; +$x=/abc/g; +print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x; +$x=/abc/g; +print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x; +$_ .= ''; +@x=/abc/g; +print scalar @x == 2 ? "ok 60\n" : "not ok 60\n"; + +$_ = "abdc"; +pos $_ = 2; +/\Gc/gc; +print "not " if (pos $_) != 2; +print "ok 61\n"; +/\Gc/g; +print "not " if defined pos $_; +print "ok 62\n"; + +$out = 1; +'abc' =~ m'a(?{ $out = 2 })b'; +print "not " if $out != 2; +print "ok 63\n"; + +$out = 1; +'abc' =~ m'a(?{ $out = 3 })c'; +print "not " if $out != 1; +print "ok 64\n"; + +$_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; +@out = /(? 1, + 'ax13876y25677mcb' => 0, # not b. + 'ax13876y35677nbc' => 0, # Num too big + 'ax13876y25677y21378obc' => 1, + 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] + 'ax13876y25677y21378y21378kbc' => 1, + 'ax13876y25677y21378y21378kcb' => 0, # Not b. + 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs + ); + +for ( keys %ans ) { + print "# const-len `$_' not => $ans{$_}\nnot " + if $ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o; + print "ok $test\n"; + $test++; + print "# var-len `$_' not => $ans{$_}\nnot " + if $ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o; + print "ok $test\n"; + $test++; +} + +$_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; +$expect = "(bla()) ((l)u((e))) (l(e)e)"; + +sub matchit { + m/ + ( + \( + (?{ $c = 1 }) # Initialize + (?: + (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop + (?! + ) # Fail: will unwind one iteration back + ) + (?: + [^()]+ # Match a big chunk + (?= + [()] + ) # Do not try to match subchunks + | + \( + (?{ ++$c }) + | + \) + (?{ --$c }) + ) + )+ # This may not match with different subblocks + ) + (?(?{ $c != 0 }) + (?! + ) # Fail + ) # Otherwise the chunk 1 may succeed with $c>0 + /xg; +} + +push @ans, $res while $res = matchit; + +print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; +print "ok $test\n"; +$test++; + +@ans = matchit; + +print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; +print "ok $test\n"; +$test++; + +@ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad +print "not " if "@ans" ne 'a/ b'; +print "ok $test\n"; +$test++; + +$code = '{$blah = 45}'; +$blah = 12; +/(?$code)/; +print "not " if $blah != 45; +print "ok $test\n"; +$test++; + +$blah = 12; +/(?{$blah = 45})/; +print "not " if $blah != 45; +print "ok $test\n"; +$test++; + +$x = 'banana'; +$x =~ /.a/g; +print "not " unless pos($x) == 2; +print "ok $test\n"; +$test++; + +$x =~ /.z/gc; +print "not " unless pos($x) == 2; +print "ok $test\n"; +$test++; + +sub f { + my $p = $_[0]; + return $p; +} + +$x =~ /.a/g; +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++; + +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.]]/');