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 + 4 + 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 # uplevel() to uplevel()
 177
 178 {
 179  my $desc = '\&uplevel as the uplevel() callback';
 180  local $@;
 181  eval {
 182   my @ret = sub {
 183    my $cxt = HERE;
 184    my @ret = sub {
 185     my @ret = sub {
 186      # Note that an XS call does not need a context, so after the first uplevel
 187      # call UP will point to the scope above the first target.
 188      'a', uplevel(\&uplevel => (sub {
 189       return qw<x y z>;
 190      } => UP) => UP), 'b';
 191     }->();
 192     is "@ret", 'a x y z b', "$desc: returned from uplevel";
 193     return qw<u v w>;
 194    }->();
 195    is "@ret", 'u v w', "$desc: returned from the first target";
 196    return qw<m n>;
 197   }->();
 198   is "@ret", 'm n', "$desc: returned from the second target";
 199  };
 200  is $@, '', "$desc: no error";
 201 }
 202
 203 # Magic
 204
 205 {
 206  package Scope::Upper::TestMagic;
 207
 208  sub TIESCALAR {
 209   my ($class, $cb) = @_;
 210   bless { cb => $cb }, $class;
 211  }
 212
 213  sub FETCH { $_[0]->{cb}->(@_) }
 214
 215  sub STORE { die "Read only magic scalar" }
 216 }
 217
 218 {
 219  tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 220  check { return $mg } [ $$ ], 'one magical scalar explicit return';
 221  check { $mg }        [ $$ ], 'one magical scalar implicit return';
 222
 223  tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 224  check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
 225  check { $mg2 }        [ $$ ], 'one double magical scalar implicit return';
 226 }
 227
 228 # Destruction
 229
 230 {
 231  package Scope::Upper::TestTimelyDestruction;
 232
 233  sub new {
 234   my ($class, $flag) = @_;
 235   $$flag = 0;
 236   bless { flag => $flag }, $class;
 237  }
 238
 239  sub DESTROY {
 240   ${$_[0]->{flag}}++;
 241  }
 242 }
 243
 244 {
 245  my $destroyed;
 246  {
 247   sub {
 248    my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 249    is $destroyed, 0, 'destruction 1: not yet 1';
 250    uplevel {
 251     is $destroyed, 0, 'destruction 1: not yet 2';
 252     $z;
 253    }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
 254   }->('dummy');
 255   is $destroyed, 1, 'destruction 1: destroyed 1';
 256  }
 257  is $destroyed, 1, 'destruction 1: destroyed 2';
 258 }
 259
 260 SKIP: {
 261  skip 'This fails even with a plain subroutine call on 5.8.x' => 6
 262                                                                 if "$]" < 5.009;
 263
 264  my $destroyed;
 265  {
 266   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 267   is $destroyed, 0, 'destruction 2: not yet 1';
 268   sub {
 269    is $destroyed, 0, 'destruction 2: not yet 2';
 270    (uplevel {
 271     is $destroyed, 0, 'destruction 2: not yet 3';
 272     return $z;
 273    }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
 274   }->('dummy');
 275   is $destroyed, 0, 'destruction 2: not yet 5';
 276  }
 277  is $destroyed, 1, 'destruction 2: destroyed';
 278 }