t/50-num_buff/STORE.t

   1 use strict;
   2 use Test::More tests => 14;
   3
   4 my %rx_idx;
   5 BEGIN {
   6     %rx_idx = (
   7         q[$`] => -2,
   8         q[$'] => -1,
   9         q[$&] => 0,
  10     );
  11     if ("$]" >= 5.019_004) {
  12         # This should be the case since 5.17.4 but there's a bug in perl that
  13         # was fixed in 5.19.4 which caused the FETCH callback to get the old
  14         # indices.
  15         $rx_idx{q[${^PREMATCH}]}  = -5;
  16         $rx_idx{q[${^POSTMATCH}]} = -4;
  17         $rx_idx{q[${^MATCH}]}     = -3;
  18     } else {
  19         $rx_idx{q[${^PREMATCH}]}  = $rx_idx{q[$`]};
  20         $rx_idx{q[${^POSTMATCH}]} = $rx_idx{q[$']};
  21         $rx_idx{q[${^MATCH}]}     = $rx_idx{q[$&]};
  22     }
  23 }
  24
  25 use re::engine::Plugin (
  26     exec => sub {
  27         my $re = shift;
  28
  29         if ("$]" >= 5.017_004) {
  30             my %full_name_map = (
  31                 -2 => -5,
  32                 -1 => -4,
  33                  0 => -3,
  34             );
  35         }
  36
  37         $re->stash( [
  38             [ q[$`],            "a" ],
  39             [ q[${^PREMATCH}],  "a" ],
  40             [ q[$'],            "o" ],
  41             [ q[${^POSTMATCH}], "o" ],
  42             [ q[$&],            "e" ],
  43             [ q[${^MATCH}],     "e" ],
  44             [ \1,               "u" ],
  45         ]);
  46
  47         $re->num_captures(
  48             STORE => sub {
  49                 my ($re, $paren, $sv) = @_;
  50                 my $test = shift @{ $re->stash };
  51
  52                 my $desc;
  53                 my $idx = $test->[0];
  54                 if (ref $idx) {
  55                     $idx  = $$idx;
  56                     $desc = "STORE \$$idx";
  57                 } else {
  58                     $desc = "STORE $idx";
  59                     $idx  = $rx_idx{$idx};
  60                 }
  61
  62                 is($paren, $idx,       "$desc (index)");
  63                 is($sv,    $test->[1], "$desc (value)");
  64             },
  65         );
  66
  67         1;
  68     },
  69 );
  70
  71 "a" =~ /a/;
  72
  73 $` = "a";
  74 ${^PREMATCH} = "a";
  75 $' = "o";
  76 ${^POSTMATCH} = "o";
  77 $& = "e";
  78 ${^MATCH} = "e";
  79 $1 = "u";