t/re/qr.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 plan tests => 6;
  10
  11 my $rx = qr//;
  12
  13 is(ref $rx, "Regexp", "qr// blessed into `Regexp' by default");
  14
  15
  16 # Make sure /$qr/ doesn’t clobber match vars before the match (bug 70764).
  17 {
  18  my $output = '';
  19  my $rx = qr/o/;
  20  my $a = "ooaoaoao";
  21
  22  my $foo = 0;
  23  $foo += () = ($a =~ /$rx/g);
  24  $output .= "$foo\n"; # correct
  25
  26  $foo = 0;
  27  for ($foo += ($a =~ /o/); $' && ($' =~ /o/) && ($foo++) ; ) { ; }
  28  $output .= "1: $foo\n"; # No error
  29
  30  $foo = 0;
  31  for ($foo += ($a =~ /$rx/); $' && ($' =~ /$rx/) && ($foo++) ; ) { ; }
  32  $output .= "2: $foo\n"; # initialization warning, incorrect results
  33
  34  is $output, "5\n1: 5\n2: 5\n", '$a_match_var =~ /$qr/';
  35 }
  36 for my $_($'){
  37  my $output = '';
  38  my $rx = qr/o/;
  39  my $a = "ooaoaoao";
  40
  41  my $foo = 0;
  42  $foo += () = ($a =~ /$rx/g);
  43  $output .= "$foo\n"; # correct
  44
  45  $foo = 0;
  46  for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; }
  47  $output .= "1: $foo\n"; # No error
  48
  49  $foo = 0;
  50  for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; }
  51  $output .= "2: $foo\n"; # initialization warning, incorrect results
  52
  53  is $output, "5\n1: 5\n2: 5\n", '/$qr/ with my $_ aliased to a match var';
  54 }
  55 for($'){
  56  my $output = '';
  57  my $rx = qr/o/;
  58  my $a = "ooaoaoao";
  59
  60  my $foo = 0;
  61  $foo += () = ($a =~ /$rx/g);
  62  $output .= "$foo\n"; # correct
  63
  64  $foo = 0;
  65  for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; }
  66  $output .= "1: $foo\n"; # No error
  67
  68  $foo = 0;
  69  for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; }
  70  $output .= "2: $foo\n"; # initialization warning, incorrect results
  71
  72  is $output, "5\n1: 5\n2: 5\n", q|/$qr/ with $'_ aliased to a match var|;
  73 }
  74
  75 # Make sure /$qr/ calls get-magic on its LHS (bug 71470).
  76 {
  77  my $scratch;
  78  sub qrBug::TIESCALAR{bless[], 'qrBug'}
  79  sub qrBug::FETCH { $scratch .= "[fetching]"; 'glat' }
  80  tie my $flile, "qrBug";
  81  $flile =~ qr/(?:)/;
  82  is $scratch, "[fetching]", '/$qr/ with magical LHS';
  83 }
  84
  85 {
  86     # [perl 72922]: A 'copy' of a Regex object which has magic should not crash
  87     # When a Regex object was copied and the copy weaken then the original regex object
  88     # could no longer be 'copied' with qr//
  89
  90     my $prog = tempfile();
  91     open my $fh, ">", $prog or die "Can't write to tempfile";
  92     print $fh <<'EOTEST';
  93 require "./test.pl";
  94 $verbose = 1;
  95 use Scalar::Util 'weaken';
  96 sub s1 {
  97     my $re = qr/abcdef/;
  98     my $re_copy1 = $re;
  99     my $re_weak_copy = $re;;
 100     weaken($re_weak_copy);
 101     my $re_copy2 = qr/$re/;
 102
 103     my $str_re = "$re";
 104     is("$$re_weak_copy", $str_re, "weak copy equals original");
 105     is("$re_copy1", $str_re, "copy1 equals original");
 106     is("$re_copy2", $str_re, "copy2 equals original");
 107
 108     my $refcnt_start = Internals::SvREFCNT($$re_weak_copy);
 109
 110     undef $re;
 111     is(Internals::SvREFCNT($$re_weak_copy), $refcnt_start - 1, "refcnt decreased");
 112     is("$re_weak_copy", $str_re, "weak copy still equals original");
 113
 114     undef $re_copy2;
 115     is(Internals::SvREFCNT($$re_weak_copy), $refcnt_start - 1, "refcnt not decreased");
 116     is("$re_weak_copy", $str_re, "weak copy still equals original");
 117 }
 118 s1();
 119 s1();
 120 EOTEST
 121     close $fh;
 122
 123     my $out = runperl(stderr => 1, progfile => $prog);
 124     unlink $prog;
 125
 126     my $expected = <<'EOOUT';
 127 ok 1 - weak copy equals original
 128 ok 2 - copy1 equals original
 129 ok 3 - copy2 equals original
 130 ok 4 - refcnt decreased
 131 ok 5 - weak copy still equals original
 132 ok 6 - refcnt not decreased
 133 ok 7 - weak copy still equals original
 134 ok 8 - weak copy equals original
 135 ok 9 - copy1 equals original
 136 ok 10 - copy2 equals original
 137 ok 11 - refcnt decreased
 138 ok 12 - weak copy still equals original
 139 ok 13 - refcnt not decreased
 140 ok 14 - weak copy still equals original
 141 EOOUT
 142
 143     is ($out, $expected, '[perl #72922] copy of a regex of which a weak copy exist');
 144 }