#!./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";
$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;
}
: "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";
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 = /(?<!foo)bar./g;
+print "not " if "@out" ne 'bar2 barf';
+print "ok 65\n";
+
+# Long Monsters
+$test = 66;
+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=/;
+ print "ok $test\n";
+ $test++;
+
+ print "not " if "b$a=" =~ /a$a=/;
+ print "ok $test\n";
+ $test++;
+}
+
+# 20000 nodes, each taking 3 words per string, and 1 per branch
+$long_constant_len = join '|', 12120 .. 32645;
+$long_var_len = join '|', 8120 .. 28645;
+%ans = ( 'ax13876y25677lbc' => 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.]]/');
projects / p5sagit/p5-mst-13.2.git / blobdiff