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