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++;
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..1275\n"};
+BEGIN{print "1..1347\n"};
projects / p5sagit/p5-mst-13.2.git / blobdiff