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 + 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 # Mark
  82
  83 {
  84  my $desc = 'one scalar explict return between two others, without args';
  85  my @ret = sub {
  86   my @ret = (1, uplevel(sub { return 2 }), 3);
  87   is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
  88   qw<X Y>;
  89  }->('dummy');
  90  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
  91 }
  92
  93 {
  94  my $desc = 'one scalar implict return between two others, without args';
  95  my @ret = sub {
  96   my @ret = (4, uplevel(sub { 5 }), 6);
  97   is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
  98   qw<X Y>;
  99  }->('dummy');
 100  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
 101 }
 102
 103 {
 104  my $desc = 'one scalar explict return between two others, with args';
 105  my @ret = sub {
 106   my @ret = (1, uplevel(sub { return 2 }, 7 .. 9, HERE), 3);
 107   is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
 108   qw<X Y>;
 109  }->('dummy');
 110  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
 111 }
 112
 113 {
 114  my $desc = 'one scalar implict return between two others, with args';
 115  my @ret = sub {
 116   my @ret = (4, uplevel(sub { 5 }, 7 .. 9, HERE), 6);
 117   is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
 118   qw<X Y>;
 119  }->('dummy');
 120  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
 121 }
 122
 123 {
 124  my $desc = 'complex chain of calls';
 125
 126  sub one   { "<",   two("{", @_, "}"), ">" }
 127  sub two   { "(", three("[", @_, "]"), ")" }
 128  sub three { (uplevel { "A", "B", four(@_) } @_, UP), "Z" }
 129  sub four  {
 130   is_deeply \@_, [ qw|[ { * } ]| ], "$desc: inside";
 131   @_
 132  }
 133
 134  my @ret  = one('*');
 135  is_deeply \@ret, [ qw|< ( A B [ { * } ] Z ) >| ], "$desc: outside";
 136 }
 137
 138 # Magic
 139
 140 {
 141  package Scope::Upper::TestMagic;
 142
 143  sub TIESCALAR {
 144   my ($class, $cb) = @_;
 145   bless { cb => $cb }, $class;
 146  }
 147
 148  sub FETCH { $_[0]->{cb}->(@_) }
 149
 150  sub STORE { die "Read only magic scalar" }
 151 }
 152
 153 {
 154  tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 155  check { return $mg } [ $$ ], 'one magical scalar explicit return';
 156  check { $mg }        [ $$ ], 'one magical scalar implicit return';
 157
 158  tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 159  check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
 160  check { $mg2 }        [ $$ ], 'one double magical scalar implicit return';
 161 }
 162
 163 # Destruction
 164
 165 {
 166  package Scope::Upper::TestTimelyDestruction;
 167
 168  sub new {
 169   my ($class, $flag) = @_;
 170   $$flag = 0;
 171   bless { flag => $flag }, $class;
 172  }
 173
 174  sub DESTROY {
 175   ${$_[0]->{flag}}++;
 176  }
 177 }
 178
 179 {
 180  my $destroyed;
 181  {
 182   sub {
 183    my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 184    is $destroyed, 0, 'destruction 1: not yet 1';
 185    uplevel {
 186     is $destroyed, 0, 'destruction 1: not yet 2';
 187     $z;
 188    }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
 189   }->('dummy');
 190   is $destroyed, 1, 'destruction 1: destroyed 1';
 191  }
 192  is $destroyed, 1, 'destruction 1: destroyed 2';
 193 }
 194
 195 SKIP: {
 196  skip 'This fails even with a plain subroutine call on 5.8.x' => 6
 197                                                                 if "$]" < 5.009;
 198
 199  my $destroyed;
 200  {
 201   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 202   is $destroyed, 0, 'destruction 2: not yet 1';
 203   sub {
 204    is $destroyed, 0, 'destruction 2: not yet 2';
 205    (uplevel {
 206     is $destroyed, 0, 'destruction 2: not yet 3';
 207     return $z;
 208    }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
 209   }->('dummy');
 210   is $destroyed, 0, 'destruction 2: not yet 5';
 211  }
 212  is $destroyed, 1, 'destruction 2: destroyed';
 213 }