t/61-uplevel-args.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 3 + 2 + 6;
   7
   8 use Scope::Upper qw<uplevel HERE UP>;
   9
  10 # Basic
  11
  12 sub {
  13  uplevel { pass 'no @_: callback' };
  14  is "@_", 'dummy', 'no @_: @_ outside';
  15 }->('dummy');
  16
  17 sub {
  18  uplevel { is "@_", '', "no arguments, no context" }
  19 }->('dummy');
  20
  21 sub {
  22  uplevel { is "@_", '', "no arguments, with context" } HERE
  23 }->('dummy');
  24
  25 sub {
  26  uplevel { is "@_", '1', "one const argument" } 1, HERE
  27 }->('dummy');
  28
  29 my $x = 2;
  30 sub {
  31  uplevel { is "@_", '2', "one lexical argument" } $x, HERE
  32 }->('dummy');
  33
  34 our $y = 3;
  35 sub {
  36  uplevel { is "@_", '3', "one global argument" } $y, HERE
  37 }->('dummy');
  38
  39 sub {
  40  uplevel { is "@_", '4 5', "two const arguments" } 4, 5, HERE
  41 }->('dummy');
  42
  43 sub {
  44  uplevel { is "@_", '1 2 3 4 5 6 7 8 9 10', "ten const arguments" }
  45          1 .. 10 => HERE;
  46 }->('dummy');
  47
  48 # Reification of @_
  49
  50 sub {
  51  my @args = (1 .. 10);
  52  uplevel {
  53   my $r = shift;
  54   is        $r,  1,           'shift: result';
  55   is_deeply \@_, [ 2 .. 10 ], 'shift: @_ inside';
  56  } @args, HERE;
  57  is_deeply \@args, [ 1 .. 10 ], 'shift: args';
  58  is_deeply \@_,    [ 'dummy' ], 'shift: @_ outside';
  59 }->('dummy');
  60
  61 sub {
  62  my @args = (1 .. 10);
  63  uplevel {
  64   my $r = pop;
  65   is        $r,  10,         'pop: result';
  66   is_deeply \@_, [ 1 .. 9 ], 'pop: @_ inside';
  67  } @args, HERE;
  68  is_deeply \@args, [ 1 .. 10 ], 'pop: args';
  69  is_deeply \@_,    [ 'dummy' ], 'pop: @_ outside';
  70 }->('dummy');
  71
  72 sub {
  73  my @args = (1 .. 10);
  74  uplevel {
  75   my $r = unshift @_, 0;
  76   is        $r,  11,          'unshift: result';
  77   is_deeply \@_, [ 0 .. 10 ], 'unshift: @_ inside';
  78  } @args, HERE;
  79  is_deeply \@args, [ 1 .. 10 ], 'unshift: args';
  80  is_deeply \@_,    [ 'dummy' ], 'unshift: @_ outside';
  81 }->('dummy');
  82
  83 sub {
  84  my @args = (1 .. 10);
  85  uplevel {
  86   my $r = push @_, 11;
  87   is        $r,  11,          'push: result';
  88   is_deeply \@_, [ 1 .. 11 ], 'push: @_ inside';
  89  } @args, HERE;
  90  is_deeply \@args, [ 1 .. 10 ], 'push: args';
  91  is_deeply \@_,    [ 'dummy' ], 'push: @_ outside';
  92 }->('dummy');
  93
  94 sub {
  95  my @args = (1 .. 10);
  96  uplevel {
  97   my ($r) = splice @_, 4, 1;
  98   is        $r,  5,                   'splice: result';
  99   is_deeply \@_, [ 1 .. 4, 6 .. 10 ], 'splice: @_ inside';
 100  } @args, HERE;
 101  is_deeply \@args, [ 1 .. 10 ], 'splice: args';
 102  is_deeply \@_,    [ 'dummy' ], 'splice: @_ outside';
 103 }->('dummy');
 104
 105 sub {
 106  my @args = (1 .. 10);
 107  uplevel {
 108   my ($r, $s, $t, @rest) = @_;
 109   is_deeply [ $r, $s, $t, \@rest ], [ 1 .. 3, [ 4 .. 10 ] ], 'unpack 1: result';
 110   is_deeply \@_, [ 1 .. 10 ],                             'unpack 1: @_ inside';
 111  } @args, HERE;
 112  is_deeply \@args, [ 1 .. 10 ], 'unpack 1: args';
 113  is_deeply \@_,    [ 'dummy' ], 'unpack 1: @_ outside';
 114 }->('dummy');
 115
 116 sub {
 117  my @args = (1, 2);
 118  uplevel {
 119   my ($r, $s, $t, @rest) = @_;
 120   is_deeply [ $r, $s, $t, \@rest ], [ 1, 2, undef, [ ] ], 'unpack 2: result';
 121   is_deeply \@_, [ 1, 2 ],                                'unpack 2: @_ inside';
 122  } @args, HERE;
 123  is_deeply \@args, [ 1, 2 ],    'unpack 2: args';
 124  is_deeply \@_,    [ 'dummy' ], 'unpack 2: @_ outside';
 125 }->('dummy');
 126
 127 # Aliasing
 128
 129 sub {
 130  my $s = 'abc';
 131  uplevel {
 132   $_[0] = 'xyz';
 133  } $s, HERE;
 134  is $s, 'xyz', 'aliasing, one layer';
 135 }->('dummy');
 136
 137 sub {
 138  my $s = 'abc';
 139  sub {
 140   uplevel {
 141    $_[0] = 'xyz';
 142   } $_[0], HERE;
 143   is $_[0], 'xyz', 'aliasing, two layers 1';
 144  }->($s);
 145  is $s, 'xyz', 'aliasing, two layers 2';
 146 }->('dummy');
 147
 148 # goto
 149
 150 SKIP: {
 151  if ("$]" < 5.008) {
 152   my $cb = sub { fail "should not be executed" };
 153   local $@;
 154   eval { sub { uplevel { goto $cb } HERE }->() };
 155   like $@, qr/^Can't goto to an uplevel'd stack frame on perl 5\.6/,
 156            "goto croaks";
 157   skip "goto to an uplevel'd stack frame does not work on perl 5\.6"
 158                                                    => ((5 * 4 * 4) * 3 + 1) - 1;
 159  }
 160
 161  my @args = (
 162   [ [ ],          [ 'm' ]      ],
 163   [ [ 'a' ],      [ ]          ],
 164   [ [ 'b' ],      [ 'n' ]      ],
 165   [ [ 'c' ],      [ 'o', 'p' ] ],
 166   [ [ 'd', 'e' ], [ 'q' ]      ],
 167  );
 168
 169  for my $args (@args) {
 170   my ($out, $in) = @$args;
 171
 172   my @out  = @$out;
 173   my @in   = @$in;
 174
 175   for my $reify_out (0, 1) {
 176    for my $reify_in (0, 1) {
 177     my $desc;
 178
 179     my $base_test = sub {
 180      if ($reify_in) {
 181       is_deeply \@_, $in, "$desc: \@_ inside";
 182      } else {
 183       is "@_", "@in", "$desc: \@_ inside";
 184      }
 185     };
 186
 187     my $goto_test         = sub { goto $base_test };
 188     my $uplevel_test      = sub { &uplevel($base_test, @_, HERE) };
 189     my $goto_uplevel_test = sub { &uplevel($goto_test, @_, HERE) };
 190
 191     my @tests = (
 192      [ 'goto'                    => sub { goto $base_test }         ],
 193      [ 'goto in goto'            => sub { goto $goto_test }         ],
 194      [ 'uplevel in goto'         => sub { goto $uplevel_test }      ],
 195      [ 'goto in uplevel in goto' => sub { goto $goto_uplevel_test } ],
 196     );
 197
 198     for my $test (@tests) {
 199      ($desc, my $cb) = @$test;
 200      $desc .= ' (' . @out . ' out, ' . @in . ' in';
 201      $desc .= ', reify out' if $reify_out;
 202      $desc .= ', reify in'  if $reify_in;
 203      $desc .= ')';
 204
 205      local $@;
 206      eval {
 207       sub {
 208        &uplevel($cb, @in, HERE);
 209        if ($reify_out) {
 210         is_deeply \@_, $out, "$desc: \@_ outside";
 211        } else {
 212         is "@_", "@out", "$desc: \@_ outside";
 213        }
 214       }->(@out);
 215      };
 216      is $@, '', "$desc: no error";
 217     }
 218    }
 219   }
 220  }
 221
 222  sub {
 223   my $s  = 'caesar';
 224   my $cb = sub {
 225    $_[0] = 'brutus';
 226   };
 227   sub {
 228    uplevel {
 229     goto $cb;
 230    } $_[0], HERE;
 231   }->($s);
 232   is $s, 'brutus', 'aliasing and goto';
 233  }->('dummy');
 234 }
 235
 236 # uplevel() to uplevel()
 237
 238 {
 239  my $desc = '\&uplevel as the uplevel() callback';
 240  local $@;
 241  eval {
 242   sub {
 243    my $cxt = HERE;
 244    sub {
 245     sub {
 246      # Note that an XS call does not need a context, so after the first uplevel
 247      # call UP will point to the scope above the first target.
 248      uplevel(\&uplevel => (sub {
 249       is "@_", '1 2 3', "$desc: arguments inisde";
 250       is HERE, $cxt,    "$desc: context inside";
 251      } => 1 .. 3 => UP) => UP);
 252     }->(10 .. 19);
 253    }->(sub { die 'wut' } => HERE);
 254   }->('dummy');
 255  };
 256  is $@, '', "$desc: no error";
 257 }
 258
 259 # Magic
 260
 261 {
 262  package Scope::Upper::TestMagic;
 263
 264  sub TIESCALAR {
 265   my ($class, $cb) = @_;
 266   bless { cb => $cb }, $class;
 267  }
 268
 269  sub FETCH { $_[0]->{cb}->(@_) }
 270
 271  sub STORE { die "Read only magic scalar" }
 272 }
 273
 274 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 275 sub {
 276  uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
 277 }->('dummy');
 278
 279 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 280 sub {
 281  uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
 282 }->('dummy');
 283
 284 # Destruction
 285
 286 {
 287  package Scope::Upper::TestTimelyDestruction;
 288
 289  sub new {
 290   my ($class, $flag) = @_;
 291   $$flag = 0;
 292   bless { flag => $flag }, $class;
 293  }
 294
 295  sub DESTROY {
 296   ${$_[0]->{flag}}++;
 297  }
 298 }
 299
 300 SKIP: {
 301  skip 'This fails even with a plain subroutine call on 5.8.0' => 6
 302                                                                if "$]" <= 5.008;
 303
 304  my $destroyed;
 305  {
 306   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 307   is $destroyed, 0, 'destruction: not yet 1';
 308   sub {
 309    is $destroyed, 0, 'destruction: not yet 2';
 310    uplevel {
 311     is $destroyed, 0, 'destruction: not yet 3';
 312    } $z, HERE;
 313    is $destroyed, 0, 'destruction: not yet 4';
 314   }->('dummy');
 315   is $destroyed, 0, 'destruction: not yet 5';
 316  }
 317  is $destroyed, 1, 'destruction: destroyed';
 318 }