print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)';
+print "not " unless qr/\b\v$/i eq '(?i-xsm:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)';
+print "not " unless qr/\b\v$/s eq '(?s-xim:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)';
+print "not " unless qr/\b\v$/m eq '(?m-xis:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)';
+print "not " unless qr/\b\v$/x eq '(?x-ism:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)';
+print "not " unless qr/\b\v$/xism eq '(?msix:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)';
+print "not " unless qr/\b\v$/ eq '(?-xism:\b\v$)';
print "ok $test\n";
$test++;
$s=~s/(?'digits'\d+)\k'digits'/$+{digits}/;
ok($s eq '123456','Named capture (single quotes) s///');
}
+sub iseq($$;$) {
+ my ( $got, $expect, $name)=@_;
+
+ $_=defined($_) ? "'$_'" : "undef"
+ for $got, $expect;
+
+ my $ok= $got eq $expect;
+
+ printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name||'unnamed';
+
+ printf "# Failed test at line %d\n".
+ "# expected: %s\n".
+ "# result: %s\n",
+ (caller)[2], $expect, $got
+ unless $ok;
+
+ $test++;
+ return $ok;
+}
{
my $s='foo bar baz';
- my (@k,@v,$count);
+ my (@k,@v,@fetch,$res);
+ my $count= 0;
+ my @names=qw($+{A} $+{B} $+{C});
if ($s=~/(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/) {
while (my ($k,$v)=each(%+)) {
$count++;
}
@k=sort keys(%+);
@v=sort values(%+);
+ $res=1;
+ push @fetch,
+ [ "$+{A}", "$1" ],
+ [ "$+{B}", "$2" ],
+ [ "$+{C}", "$3" ],
+ ;
+ }
+ foreach (0..2) {
+ if ($fetch[$_]) {
+ iseq($fetch[$_][0],$fetch[$_][1],$names[$_]);
+ } else {
+ ok(0, $names[$_]);
+ }
}
- ok($count==3,"Got 3 keys in %+ via each ($count)");
- ok(@k == 3, 'Got 3 keys in %+ via keys');
- ok("@k" eq "A B C", "Got expected keys");
- ok("@v" eq "bar baz foo", "Got expected values");
+ iseq($res,1,"$s~=/(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/");
+ iseq($count,3,"Got 3 keys in %+ via each");
+ iseq(0+@k, 3, 'Got 3 keys in %+ via keys');
+ iseq("@k","A B C", "Got expected keys");
+ iseq("@v","bar baz foo", "Got expected values");
+ 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
# CURLYX and WHILEM blocks, except those related to LONGJMP, the
# super-linear cache and warnings. It executes about 0.5M regexes
-{
+if ($ENV{PERL_SKIP_PSYCHO_TEST}){
+ printf "ok %d Skip: No psycho tests\n", $test++;
+} else {
my $r = qr/^
(?:
( (?:a|z+)+ )
ok($ok, $msg);
}
+# \, breaks {3,4}
+ok("xaaay" !~ /xa{3\,4}y/, "\, in a pattern");
+ok("xa{3,4}y" =~ /xa{3\,4}y/, "\, in a pattern");
+
+# \c\ followed by _
+ok("x\c_y" !~ /x\c\_y/, "\_ in a pattern");
+ok("x\c\_y" =~ /x\c\_y/, "\_ in a pattern");
+
+# \c\ followed by other characters
+for my $c ("z", "\0", "!", chr(254), chr(256)) {
+ my $targ = "a\034$c";
+ my $reg = "a\\c\\$c";
+ ok(eval("qq/$targ/ =~ /$reg/"), "\\c\\ in pattern");
+}
+
+{
+ my $str='abc';
+ my $count=0;
+ my $mval=0;
+ my $pval=0;
+ while ($str=~/b/g) { $mval=$#-; $pval=$#+; $count++ }
+ iseq($mval,0,"\@- should be empty [RT#36046]");
+ iseq($pval,0,"\@+ should be empty [RT#36046]");
+ iseq($count,1,"should have matched once only [RT#36046]");
+}
+
+{ # Test the (*NOMATCH) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(?{$count++})(*FAIL)/;
+ iseq($count,9,"expect 9 for no (*NOMATCH)");
+ $count = 0;
+ 'aaab'=~/a+b?(*NOMATCH)(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with (*NOMATCH)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*NOMATCH)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*NOMATCH)/");
+ $count = 0;
+ 'aaab'=~/a+b?(??{'(*NOMATCH)'})(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with (*NOMATCH)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(??{'(*NOMATCH)'})(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*NOMATCH)/");
+}
+{ # Test the (*CUT) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(*CUT)(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with (*CUT)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*CUT)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*CUT)/");
+ $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a+b?)(*CUT)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,2,"Expect 2 with (*CUT)" );
+ iseq("@res","aaab aaab","adjacent (*CUT) works as expected" );
+}
+{ # Test the (*CUT) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(*MARK)(*CUT)(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with (*CUT)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*MARK)(*CUT)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*CUT)/");
+ $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a+b?)(*MARK)(*CUT)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,2,"Expect 2 with (*CUT)" );
+ iseq("@res","aaab aaab","adjacent (*CUT) works as expected" );
+}
+{ # Test the (*CUT) pattern
+ our $count = 0;
+ 'aaab'=~/a*(*MARK:a)b?(*MARK:b)(*CUT:a)(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with *MARK:a)b?(*MARK:b)(*CUT:a)");
+ local $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a*(*MARK:a)b?)(*MARK)(*CUT:a)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,5,"Expect 5 with (*MARK:a)b?)(*MARK)(*CUT:a)" );
+ iseq("@res","aaab b aaab b ","adjacent (*MARK:a)b?)(*MARK)(*CUT:a) works as expected" );
+}
+{ # Test the (*COMMIT) pattern
+ our $count = 0;
+ 'aaabaaab'=~/a+b?(*COMMIT)(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with (*COMMIT)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*COMMIT)(?{$count++})(*FAIL)/g;
+ iseq($count,1,"/.(*COMMIT)/");
+ $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a+b?)(*COMMIT)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,1,"Expect 1 with (*COMMIT)" );
+ iseq("@res","aaab","adjacent (*COMMIT) works as expected" );
+}
+{
+ # Test named commits and the $REGERROR var
+ our $REGERROR;
+ for my $name ('',':foo')
+ {
+ for my $pat ("(*NOMATCH$name)","(*MARK$name)(*CUT)",
+ "(*CUT$name)","(*COMMIT$name)")
+ {
+ for my $suffix ('(*FAIL)','')
+ {
+ 'aaaab'=~/a+b$pat$suffix/;
+ iseq(
+ $REGERROR,
+ ($suffix ? ($name ? 'foo' : "1") : ""),
+ "Test $pat and \$REGERROR $suffix"
+ );
+ }
+ }
+ }
+}
+{
+ # Test named commits and the $REGERROR var
+ package Fnorble;
+ our $REGERROR;
+ for my $name ('',':foo')
+ {
+ for my $pat ("(*NOMATCH$name)","(*MARK$name)(*CUT)",
+ "(*CUT$name)","(*COMMIT$name)")
+ {
+ for my $suffix ('(*FAIL)','')
+ {
+ 'aaaab'=~/a+b$pat$suffix/;
+ ::iseq(
+ $REGERROR,
+ ($suffix ? ($name ? 'foo' : "1") : ""),
+ "Test $pat and \$REGERROR $suffix"
+ );
+ }
+ }
+ }
+}
+{
+ # Test named commits and the $REGERROR var
+ our $REGERROR;
+ for $word (qw(bar baz bop)) {
+ $REGERROR="";
+ "aaaaa$word"=~/a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/;
+ iseq($REGERROR,$word);
+ }
+}
+{ #Regression test for perlbug 40684
+ my $s = "abc\ndef";
+ my $rex = qr'^abc$'m;
+ ok($s =~ m/$rex/);
+ ok($s =~ m/^abc$/m);
+}
+#-------------------------------------------------------------------
# Keep the following tests last -- they may crash perl
"Regexp /^(??{'(.)'x 100})/ crashes older perls")
or print "# Unexpected outcome: should pass or crash perl\n";
+{
+ $_="ns1ns1ns1";
+ s/ns(?=\d)/ns_/g;
+ iseq($_,"ns_1ns_1ns_1");
+ $_="ns1";
+ s/ns(?=\d)/ns_/;
+ iseq($_,"ns_1");
+ $_="123";
+ s/(?=\d+)|(?<=\d)/!Bang!/g;
+ iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!");
+}
+
+# Put new tests above the line, not here.
+
# Don't forget to update this!
-BEGIN{print "1..1270\n"};
+BEGIN{print "1..1347\n"};
projects / p5sagit/p5-mst-13.2.git / blobdiff