t/re/reg_pmod.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10 use warnings;
  11
  12 our @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
  22 plan tests => 14 * @tests + 4;
  23 my $W = "";
  24
  25 $SIG{__WARN__} = sub { $W.=join("",@_); };
  26 sub _u($$) { "$_[0] is ".(defined $_[1] ? "'$_[1]'" : "undef") }
  27
  28 foreach 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 }
  71 is($W,"","No warnings should be produced");
  72 ok(!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 }