1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9use strict; 10use warnings; 11 12our @tests = ( 13 # /p Pattern PRE MATCH POST 14 [ '/p', "345", "012-", "345", "-6789"], 15 [ '/$r/p',"345", "012-", "345", "-6789"], 16 [ '(?p)', "345", "012-", "345", "-6789"], 17 [ '(?p:)',"345", "012-", "345", "-6789"], 18 [ '', "(345)", undef, undef, undef ], 19 [ '', "345", undef, undef, undef ], 20); 21 22plan tests => 14 * @tests + 4; 23my $W = ""; 24 25$SIG{__WARN__} = sub { $W.=join("",@_); }; 26sub _u($$) { "$_[0] is ".(defined $_[1] ? "'$_[1]'" : "undef") } 27 28foreach my $test (@tests) { 29 my ($p, $pat,$l,$m,$r) = @$test; 30 my $qr = qr/$pat/; 31 for my $sub (0,1) { 32 my $test_name = $p eq '/p' ? "/$pat/p" 33 : $p eq '/$r/p'? $p 34 : $p eq '(?p)' ? "/(?p)$pat/" 35 : $p eq '(?p:)'? "/(?p:$pat)/" 36 : "/$pat/"; 37 $test_name = "s$test_name" if $sub; 38 39 # 40 # Cannot use if/else due to the scope invalidating ${^MATCH} and friends. 41 # 42 $_ = '012-345-6789'; 43 my $ok = 44 $sub ? 45 ( $p eq '/p' ? s/$pat/abc/p 46 : $p eq '/$r/p'? s/$qr/abc/p 47 : $p eq '(?p)' ? s/(?p)$pat/abc/ 48 : $p eq '(?p:)'? s/(?p:$pat)/abc/ 49 : s/$pat/abc/ 50 ) 51 : 52 ( $p eq '/p' ? /$pat/p 53 : $p eq '/$r/p'? /$qr/p 54 : $p eq '(?p)' ? /(?p)$pat/ 55 : $p eq '(?p:)'? /(?p:$pat)/ 56 : /$pat/ 57 ); 58 ok $ok, $test_name; 59 SKIP: { 60 skip "/$pat/$p failed to match", 6 61 unless $ok; 62 is(${^PREMATCH}, $l,_u "$test_name: ^PREMATCH",$l); 63 is(${^MATCH}, $m,_u "$test_name: ^MATCH",$m ); 64 is(${^POSTMATCH}, $r,_u "$test_name: ^POSTMATCH",$r ); 65 is(length ${^PREMATCH}, length $l, "$test_name: ^PREMATCH length"); 66 is(length ${^MATCH}, length $m, "$test_name: ^MATCH length"); 67 is(length ${^POSTMATCH},length $r, "$test_name: ^POSTMATCH length"); 68 } 69 } 70} 71is($W,"","No warnings should be produced"); 72ok(!defined ${^MATCH}, "No /p in scope so ^MATCH is undef"); 73 74#RT 117135 75 76{ 77 my $m; 78 ok("a"=~ /(?p:a(?{ $m = ${^MATCH} }))/, '(?{})'); 79 is($m, 'a', '(?{}) ^MATCH'); 80} 81