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 => 5;
  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 }