$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)=@_;
';
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
1 while /.(??{'(*PRUNE)'})(?{$count++})(*FAIL)/g;
iseq($count,4,"/.(*PRUNE)/");
}
+{ # Test the \v form of the (*PRUNE) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(?{$count++})(*FAIL)/;
+ iseq($count,9,"expect 9 for no \\v");
+ $count = 0;
+ 'aaab'=~/a+b?\v(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with \\v");
+ local $_='aaab';
+ $count=0;
+ 1 while /.\v(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.\\v/");
+ $count = 0;
+ 'aaab'=~/a+b?(??{'\v'})(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with \\v");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(??{'\v'})(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.\\v/");
+}
{ # Test the (*SKIP) pattern
our $count = 0;
'aaab'=~/a+b?(*SKIP)(?{$count++})(*FAIL)/;
iseq($count,2,"Expect 2 with (*SKIP)" );
iseq("@res","aaab aaab","adjacent (*SKIP) works as expected" );
}
+{ # Test the \V form of the (*SKIP) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?\V(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with \\V");
+ local $_='aaab';
+ $count=0;
+ 1 while /.\V(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.\\V/");
+ $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a+b?)\V(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,2,"Expect 2 with \\V" );
+ iseq("@res","aaab aaab","adjacent \\V works as expected" );
+}
{ # Test the (*SKIP) pattern
our $count = 0;
'aaab'=~/a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/;
}
{
local $Message = "http://nntp.perl.org/group/perl.perl5.porters/118663";
- my $qr_barR1 = qr/(bar)\R1/;
+ 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)\R1xyz/);
+ ok("foobarbarxyz" =~ qr/(foo)(bar)\g{-1}xyz/);
ok("foobarbarxyz" =~ qr/(foo${qr_barR1})xyz/);
- ok("foobarbarxyz" =~ qr/(foo(bar)\R1)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');
+}
+{
+ my $x;
+ $x = "abc.def.ghi.jkl";
+ $x =~ s/.*\K\..*//;
+ ok($x eq "abc.def.ghi");
+
+ $x = "one two three four";
+ $x =~ s/o+ \Kthree//g;
+ ok($x eq "one two four");
+
+ $x = "abcde";
+ $x =~ s/(.)\K/$1/g;
+ ok($x eq "aabbccddee");
+}
+sub kt
+{
+ return '4' if $_[0] eq '09028623';
+}
+
+{ # Nested EVAL using PL_curpm (via $1 or friends)
+ my $re;
+ our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x;
+ $re = qr/^ ( (??{ $grabit }) ) $ /x;
+ my @res = '0902862349' =~ $re;
+ iseq(join("-",@res),"0902862349",
+ 'PL_curpm is set properly on nested eval');
+
+ our $qr = qr/ (o) (??{ $1 }) /x;
+ ok( 'boob'=~/( b (??{ $qr }) b )/x && 1,
+ "PL_curpm, nested eval");
+}
+
+{
+ use charnames ":full";
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "I =~ Alphabetic");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/, "I =~ Uppercase");
+ ok("\N{ROMAN NUMERAL ONE}" !~ /\p{Lowercase}/, "I !~ Lowercase");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "I =~ ID_Start");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "I =~ ID_Continue");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "i =~ Alphabetic");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Uppercase}/, "i !~ Uppercase");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue");
+}
+
+{
+# requirement of Unicode Technical Standard #18, 1.7 Code Points
+# cf. http://www.unicode.org/reports/tr18/#Supplementary_Characters
+ for my $u (0x7FF, 0x800, 0xFFFF, 0x10000) {
+ no warnings 'utf8'; # oops
+ my $c = chr $u;
+ my $x = sprintf '%04X', $u;
+ ok( "A${c}B" =~ /A[\0-\x{10000}]B/, "unicode range - $x");
+ }
+}
+
+
# Test counter is at bottom of file. Put new tests above here.
#-------------------------------------------------------------------
# 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";
+eval '/\k/';
+ok($@=~/\QSequence \k... not terminated in regex;\E/);
+
{
local $Message = "substitution with lookahead (possible segv)";
$_="ns1ns1ns1";
iseq(0+$::test,$::TestCount,"Got the right number of tests!");
# Don't forget to update this!
BEGIN {
- $::TestCount = 1375;
+ $::TestCount = 1636;
print "1..$::TestCount\n";
}
https://perl5.git.perl.org / perl5.git / blobdiff