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 {
 151  my @args = (
 152   [ [ ],          [ 'm' ]      ],
 153   [ [ 'a' ],      [ ]          ],
 154   [ [ 'b' ],      [ 'n' ]      ],
 155   [ [ 'c' ],      [ 'o', 'p' ] ],
 156   [ [ 'd', 'e' ], [ 'q' ]      ],
 157  );
 158
 159  for my $args (@args) {
 160   my ($out, $in) = @$args;
 161
 162   my @out  = @$out;
 163   my @in   = @$in;
 164
 165   for my $reify_out (0, 1) {
 166    for my $reify_in (0, 1) {
 167     my $desc;
 168
 169     my $base_test = sub {
 170      if ($reify_in) {
 171       is_deeply \@_, $in, "$desc: \@_ inside";
 172      } else {
 173       is "@_", "@in", "$desc: \@_ inside";
 174      }
 175     };
 176
 177     my $goto_test         = sub { goto $base_test };
 178     my $uplevel_test      = sub { &uplevel($base_test, @_, HERE) };
 179     my $goto_uplevel_test = sub { &uplevel($goto_test, @_, HERE) };
 180
 181     my @tests = (
 182      [ 'goto'                    => sub { goto $base_test }         ],
 183      [ 'goto in goto'            => sub { goto $goto_test }         ],
 184      [ 'uplevel in goto'         => sub { goto $uplevel_test }      ],
 185      [ 'goto in uplevel in goto' => sub { goto $goto_uplevel_test } ],
 186     );
 187
 188     for my $test (@tests) {
 189      ($desc, my $cb) = @$test;
 190      $desc .= ' (' . @out . ' out, ' . @in . ' in';
 191      $desc .= ', reify out' if $reify_out;
 192      $desc .= ', reify in'  if $reify_in;
 193      $desc .= ')';
 194
 195      local $@;
 196      eval {
 197       sub {
 198        &uplevel($cb, @in, HERE);
 199        if ($reify_out) {
 200         is_deeply \@_, $out, "$desc: \@_ outside";
 201        } else {
 202         is "@_", "@out", "$desc: \@_ outside";
 203        }
 204       }->(@out);
 205      };
 206      is $@, '', "$desc: no error";
 207     }
 208    }
 209   }
 210  }
 211
 212  sub {
 213   my $s  = 'caesar';
 214   my $cb = sub {
 215    $_[0] = 'brutus';
 216   };
 217   sub {
 218    uplevel {
 219     goto $cb;
 220    } $_[0], HERE;
 221   }->($s);
 222   is $s, 'brutus', 'aliasing and goto';
 223  }->('dummy');
 224 }
 225
 226 # goto XS
 227
 228 {
 229  my $desc = 'uplevel() calling goto &uplevel';
 230  local $@;
 231  eval {
 232   sub {
 233    my $outer_cxt = HERE;
 234    sub {
 235     my $inner_cxt = HERE;
 236     sub {
 237      uplevel {
 238       is HERE, $inner_cxt, "$desc: context inside first uplevel";
 239       is "@_", '1 2 3',    "$desc: arguments inisde first uplevel";
 240       unshift @_, 0;
 241       push    @_, 4;
 242       unshift @_, sub {
 243        is HERE, $outer_cxt,  "$desc: context inside second uplevel";
 244        is "@_", '0 1 2 3 4', "$desc: arguments inisde second uplevel";
 245       };
 246       push @_, UP;
 247       goto \&uplevel;
 248      } 1 .. 3 => UP;
 249     }->();
 250    }->();
 251   }->();
 252  };
 253  is $@, '', "$desc: no error";
 254 }
 255
 256 # uplevel() to uplevel()
 257
 258 {
 259  my $desc = '\&uplevel as the uplevel() callback';
 260  local $@;
 261  eval {
 262   sub {
 263    my $cxt = HERE;
 264    sub {
 265     sub {
 266      # Note that an XS call does not need a context, so after the first uplevel
 267      # call UP will point to the scope above the first target.
 268      uplevel(\&uplevel => (sub {
 269       is "@_", '1 2 3', "$desc: arguments inisde";
 270       is HERE, $cxt,    "$desc: context inside";
 271      } => 1 .. 3 => UP) => UP);
 272     }->(10 .. 19);
 273    }->(sub { die 'wut' } => HERE);
 274   }->('dummy');
 275  };
 276  is $@, '', "$desc: no error";
 277 }
 278
 279 # Magic
 280
 281 {
 282  package Scope::Upper::TestMagic;
 283
 284  sub TIESCALAR {
 285   my ($class, $cb) = @_;
 286   bless { cb => $cb }, $class;
 287  }
 288
 289  sub FETCH { $_[0]->{cb}->(@_) }
 290
 291  sub STORE { die "Read only magic scalar" }
 292 }
 293
 294 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 295 sub {
 296  uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
 297 }->('dummy');
 298
 299 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 300 sub {
 301  uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
 302 }->('dummy');
 303
 304 # Destruction
 305
 306 {
 307  package Scope::Upper::TestTimelyDestruction;
 308
 309  sub new {
 310   my ($class, $flag) = @_;
 311   $$flag = 0;
 312   bless { flag => $flag }, $class;
 313  }
 314
 315  sub DESTROY {
 316   ${$_[0]->{flag}}++;
 317  }
 318 }
 319
 320 SKIP: {
 321  skip 'This fails even with a plain subroutine call on 5.8.0' => 6
 322                                                                if "$]" <= 5.008;
 323
 324  my $destroyed;
 325  {
 326   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 327   is $destroyed, 0, 'destruction: not yet 1';
 328   sub {
 329    is $destroyed, 0, 'destruction: not yet 2';
 330    uplevel {
 331     is $destroyed, 0, 'destruction: not yet 3';
 332    } $z, HERE;
 333    is $destroyed, 0, 'destruction: not yet 4';
 334   }->('dummy');
 335   is $destroyed, 0, 'destruction: not yet 5';
 336  }
 337  is $destroyed, 1, 'destruction: destroyed';
 338 }