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) + 5 + 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/^uplevel\(\) can't execute code that calls goto before perl 5\.8/,
 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 # goto XS
 237
 238 SKIP: {
 239  skip "goto to an uplevel'd stack frame does not work on perl 5\.6" => 5
 240                                                                 if "$]" < 5.008;
 241
 242  my $desc = 'uplevel() calling goto &uplevel';
 243  local $@;
 244  eval {
 245   sub {
 246    my $outer_cxt = HERE;
 247    sub {
 248     my $inner_cxt = HERE;
 249     sub {
 250      uplevel {
 251       is HERE, $inner_cxt, "$desc: context inside first uplevel";
 252       is "@_", '1 2 3',    "$desc: arguments inisde first uplevel";
 253       unshift @_, 0;
 254       push    @_, 4;
 255       unshift @_, sub {
 256        is HERE, $outer_cxt,  "$desc: context inside second uplevel";
 257        is "@_", '0 1 2 3 4', "$desc: arguments inisde second uplevel";
 258       };
 259       push @_, UP;
 260       goto \&uplevel;
 261      } 1 .. 3 => UP;
 262     }->();
 263    }->();
 264   }->();
 265  };
 266  is $@, '', "$desc: no error";
 267 }
 268
 269 # uplevel() to uplevel()
 270
 271 {
 272  my $desc = '\&uplevel as the uplevel() callback';
 273  local $@;
 274  eval {
 275   sub {
 276    my $cxt = HERE;
 277    sub {
 278     sub {
 279      # Note that an XS call does not need a context, so after the first uplevel
 280      # call UP will point to the scope above the first target.
 281      uplevel(\&uplevel => (sub {
 282       is "@_", '1 2 3', "$desc: arguments inisde";
 283       is HERE, $cxt,    "$desc: context inside";
 284      } => 1 .. 3 => UP) => UP);
 285     }->(10 .. 19);
 286    }->(sub { die 'wut' } => HERE);
 287   }->('dummy');
 288  };
 289  is $@, '', "$desc: no error";
 290 }
 291
 292 # Magic
 293
 294 {
 295  package Scope::Upper::TestMagic;
 296
 297  sub TIESCALAR {
 298   my ($class, $cb) = @_;
 299   bless { cb => $cb }, $class;
 300  }
 301
 302  sub FETCH { $_[0]->{cb}->(@_) }
 303
 304  sub STORE { die "Read only magic scalar" }
 305 }
 306
 307 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 308 sub {
 309  uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
 310 }->('dummy');
 311
 312 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 313 sub {
 314  uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
 315 }->('dummy');
 316
 317 # Destruction
 318
 319 {
 320  package Scope::Upper::TestTimelyDestruction;
 321
 322  sub new {
 323   my ($class, $flag) = @_;
 324   $$flag = 0;
 325   bless { flag => $flag }, $class;
 326  }
 327
 328  sub DESTROY {
 329   ${$_[0]->{flag}}++;
 330  }
 331 }
 332
 333 SKIP: {
 334  skip 'This fails even with a plain subroutine call on 5.8.0' => 6
 335                                                                if "$]" <= 5.008;
 336
 337  my $destroyed;
 338  {
 339   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 340   is $destroyed, 0, 'destruction: not yet 1';
 341   sub {
 342    is $destroyed, 0, 'destruction: not yet 2';
 343    uplevel {
 344     is $destroyed, 0, 'destruction: not yet 3';
 345    } $z, HERE;
 346    is $destroyed, 0, 'destruction: not yet 4';
 347   }->('dummy');
 348   is $destroyed, 0, 'destruction: not yet 5';
 349  }
 350  is $destroyed, 1, 'destruction: destroyed';
 351 }