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) + 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 # Magic
 153
 154 {
 155  package Scope::Upper::TestMagic;
 156
 157  sub TIESCALAR {
 158   my ($class, $cb) = @_;
 159   bless { cb => $cb }, $class;
 160  }
 161
 162  sub FETCH { $_[0]->{cb}->(@_) }
 163
 164  sub STORE { die "Read only magic scalar" }
 165 }
 166
 167 {
 168  tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 169  check { return $mg } [ $$ ], 'one magical scalar explicit return';
 170  check { $mg }        [ $$ ], 'one magical scalar implicit return';
 171
 172  tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 173  check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
 174  check { $mg2 }        [ $$ ], 'one double magical scalar implicit return';
 175 }
 176
 177 # Destruction
 178
 179 {
 180  package Scope::Upper::TestTimelyDestruction;
 181
 182  sub new {
 183   my ($class, $flag) = @_;
 184   $$flag = 0;
 185   bless { flag => $flag }, $class;
 186  }
 187
 188  sub DESTROY {
 189   ${$_[0]->{flag}}++;
 190  }
 191 }
 192
 193 {
 194  my $destroyed;
 195  {
 196   sub {
 197    my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 198    is $destroyed, 0, 'destruction 1: not yet 1';
 199    uplevel {
 200     is $destroyed, 0, 'destruction 1: not yet 2';
 201     $z;
 202    }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
 203   }->('dummy');
 204   is $destroyed, 1, 'destruction 1: destroyed 1';
 205  }
 206  is $destroyed, 1, 'destruction 1: destroyed 2';
 207 }
 208
 209 SKIP: {
 210  skip 'This fails even with a plain subroutine call on 5.8.x' => 6
 211                                                                 if "$]" < 5.009;
 212
 213  my $destroyed;
 214  {
 215   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 216   is $destroyed, 0, 'destruction 2: not yet 1';
 217   sub {
 218    is $destroyed, 0, 'destruction 2: not yet 2';
 219    (uplevel {
 220     is $destroyed, 0, 'destruction 2: not yet 3';
 221     return $z;
 222    }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
 223   }->('dummy');
 224   is $destroyed, 0, 'destruction 2: not yet 5';
 225  }
 226  is $destroyed, 1, 'destruction 2: destroyed';
 227 }