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 + 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 # Magic
 148
 149 {
 150  package Scope::Upper::TestMagic;
 151
 152  sub TIESCALAR {
 153   my ($class, $cb) = @_;
 154   bless { cb => $cb }, $class;
 155  }
 156
 157  sub FETCH { $_[0]->{cb}->(@_) }
 158
 159  sub STORE { die "Read only magic scalar" }
 160 }
 161
 162 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 163 sub {
 164  uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
 165 }->('dummy');
 166
 167 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 168 sub {
 169  uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
 170 }->('dummy');
 171
 172 # Destruction
 173
 174 {
 175  package Scope::Upper::TestTimelyDestruction;
 176
 177  sub new {
 178   my ($class, $flag) = @_;
 179   $$flag = 0;
 180   bless { flag => $flag }, $class;
 181  }
 182
 183  sub DESTROY {
 184   ${$_[0]->{flag}}++;
 185  }
 186 }
 187
 188 SKIP: {
 189  skip 'This fails even with a plain subroutine call on 5.8.0' => 6
 190                                                                if "$]" <= 5.008;
 191
 192  my $destroyed;
 193  {
 194   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 195   is $destroyed, 0, 'destruction: not yet 1';
 196   sub {
 197    is $destroyed, 0, 'destruction: not yet 2';
 198    uplevel {
 199     is $destroyed, 0, 'destruction: not yet 3';
 200    } $z, HERE;
 201    is $destroyed, 0, 'destruction: not yet 4';
 202   }->('dummy');
 203   is $destroyed, 0, 'destruction: not yet 5';
 204  }
 205  is $destroyed, 1, 'destruction: destroyed';
 206 }