t/62-uplevel-return.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => (13 + 5 + 4) * 2 + 1 + (3 + 3 + 1) + 2 + 11;
   7
   8 use Scope::Upper qw<uplevel HERE UP>;
   9
  10 # Basic
  11
  12 sub check (&$$) {
  13  my ($code, $exp_in, $desc) = @_;
  14
  15  local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
  16
  17  my $exp_out = [ 'A', map("X$_", @$exp_in), 'Z' ];
  18
  19  my @ret_in;
  20  my @ret_out = sub {
  21   @ret_in = &uplevel($code, HERE);
  22   is_deeply \@ret_in, $exp_in, "$desc: inside";
  23   @$exp_out;
  24  }->('dummy');
  25
  26  is_deeply \@ret_out, $exp_out, "$desc: outside";
  27
  28  @ret_in;
  29 }
  30
  31 check { return } [ ], 'empty explicit return';
  32
  33 check { () }     [ ], 'empty implicit return';
  34
  35 check { return 1 } [ 1 ], 'one const scalar explicit return';
  36
  37 check { 2 }        [ 2 ], 'one const scalar implicit return';
  38
  39 {
  40  my $x = 3;
  41  check { return $x } [ 3 ], 'one lexical scalar explicit return';
  42 }
  43
  44 {
  45  my $x = 4;
  46  check { $x }        [ 4 ], 'one lexical scalar implicit return';
  47 }
  48
  49 {
  50  our $x = 3;
  51  check { return $x } [ 3 ], 'one global scalar explicit return';
  52 }
  53
  54 {
  55  our $x = 4;
  56  check { $x }        [ 4 ], 'one global scalar implicit return';
  57 }
  58
  59 check { return 1 .. 5 } [ 1 .. 5 ],  'five const scalar explicit return';
  60
  61 check { 6 .. 10 }       [ 6 .. 10 ], 'five const scalar implicit return';
  62
  63 check { 'a' .. 'z' }    [ 'a' .. 'z' ], '26 const scalar implicit return';
  64
  65 check { [ qw<A B C> ] } [ [ qw<A B C> ] ],'one array reference implicit return';
  66
  67 my $cb = sub { 123 };
  68 my ($ret) = check { $cb } [ $cb ], 'one anonymous sub implicit return';
  69 is $ret->(), $cb->(), 'anonymous sub returned by uplevel still works';
  70
  71 for my $run (1 .. 3) {
  72  my ($cb) = sub {
  73   uplevel {
  74    my $id = 123;
  75    sub { ++$id };
  76   };
  77  }->('dummy');
  78  is $cb->(), 124, "near closure returned by uplevel still works";
  79 }
  80
  81 {
  82  my $id = 456;
  83  for my $run (1 .. 3) {
  84   my ($cb) = sub {
  85    uplevel {
  86     my $step = 2;
  87     sub { $id += $step };
  88    };
  89   }->('dummy');
  90   is $cb->(), 456 + 2 * $run, "far closure returned by uplevel still works";
  91  }
  92  is $id, 456 + 2 * 3, 'captured lexical has the right value at the end';
  93 }
  94
  95 # Mark
  96
  97 {
  98  my $desc = 'one scalar explict return between two others, without args';
  99  my @ret = sub {
 100   my @ret = (1, uplevel(sub { return 2 }), 3);
 101   is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
 102   qw<X Y>;
 103  }->('dummy');
 104  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
 105 }
 106
 107 {
 108  my $desc = 'one scalar implict return between two others, without args';
 109  my @ret = sub {
 110   my @ret = (4, uplevel(sub { 5 }), 6);
 111   is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
 112   qw<X Y>;
 113  }->('dummy');
 114  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
 115 }
 116
 117 {
 118  my $desc = 'one scalar explict return between two others, with args';
 119  my @ret = sub {
 120   my @ret = (1, uplevel(sub { return 2 }, 7 .. 9, HERE), 3);
 121   is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
 122   qw<X Y>;
 123  }->('dummy');
 124  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
 125 }
 126
 127 {
 128  my $desc = 'one scalar implict return between two others, with args';
 129  my @ret = sub {
 130   my @ret = (4, uplevel(sub { 5 }, 7 .. 9, HERE), 6);
 131   is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
 132   qw<X Y>;
 133  }->('dummy');
 134  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
 135 }
 136
 137 {
 138  my $desc = 'complex chain of calls';
 139
 140  sub one   { "<",   two("{", @_, "}"), ">" }
 141  sub two   { "(", three("[", @_, "]"), ")" }
 142  sub three { (uplevel { "A", "B", four(@_) } @_, UP), "Z" }
 143  sub four  {
 144   is_deeply \@_, [ qw|[ { * } ]| ], "$desc: inside";
 145   @_
 146  }
 147
 148  my @ret  = one('*');
 149  is_deeply \@ret, [ qw|< ( A B [ { * } ] Z ) >| ], "$desc: outside";
 150 }
 151
 152 # goto
 153
 154 SKIP: {
 155  skip "goto to an uplevel'd stack frame does not work on perl 5\.6"
 156                                                            => 2 if "$]" < 5.008;
 157
 158  {
 159   my $desc = 'values returned from goto';
 160   local $@;
 161   my $cb  = sub { 'hello' };
 162   my @ret = eval {
 163    'a', sub {
 164     'b', sub {
 165      'c', &uplevel(sub {
 166        'd', (goto $cb), 'w'
 167      } => UP), 'x'
 168     }->(), 'y'
 169    }->(), 'z'
 170   };
 171   is        $@,    '',                        "$desc: did not croak";
 172   is_deeply \@ret, [ qw<a b c hello x y z> ], "$desc: returned values";
 173  }
 174 }
 175
 176 # Magic
 177
 178 {
 179  package Scope::Upper::TestMagic;
 180
 181  sub TIESCALAR {
 182   my ($class, $cb) = @_;
 183   bless { cb => $cb }, $class;
 184  }
 185
 186  sub FETCH { $_[0]->{cb}->(@_) }
 187
 188  sub STORE { die "Read only magic scalar" }
 189 }
 190
 191 {
 192  tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 193  check { return $mg } [ $$ ], 'one magical scalar explicit return';
 194  check { $mg }        [ $$ ], 'one magical scalar implicit return';
 195
 196  tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 197  check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
 198  check { $mg2 }        [ $$ ], 'one double magical scalar implicit return';
 199 }
 200
 201 # Destruction
 202
 203 {
 204  package Scope::Upper::TestTimelyDestruction;
 205
 206  sub new {
 207   my ($class, $flag) = @_;
 208   $$flag = 0;
 209   bless { flag => $flag }, $class;
 210  }
 211
 212  sub DESTROY {
 213   ${$_[0]->{flag}}++;
 214  }
 215 }
 216
 217 {
 218  my $destroyed;
 219  {
 220   sub {
 221    my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 222    is $destroyed, 0, 'destruction 1: not yet 1';
 223    uplevel {
 224     is $destroyed, 0, 'destruction 1: not yet 2';
 225     $z;
 226    }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
 227   }->('dummy');
 228   is $destroyed, 1, 'destruction 1: destroyed 1';
 229  }
 230  is $destroyed, 1, 'destruction 1: destroyed 2';
 231 }
 232
 233 SKIP: {
 234  skip 'This fails even with a plain subroutine call on 5.8.x' => 6
 235                                                                 if "$]" < 5.009;
 236
 237  my $destroyed;
 238  {
 239   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 240   is $destroyed, 0, 'destruction 2: not yet 1';
 241   sub {
 242    is $destroyed, 0, 'destruction 2: not yet 2';
 243    (uplevel {
 244     is $destroyed, 0, 'destruction 2: not yet 3';
 245     return $z;
 246    }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
 247   }->('dummy');
 248   is $destroyed, 0, 'destruction 2: not yet 5';
 249  }
 250  is $destroyed, 1, 'destruction 2: destroyed';
 251 }