t/62-uplevel-return.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => (10 + 5 + 4) * 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 = sub {
  20   my @ret = &uplevel($code, HERE);
  21   is_deeply \@ret, $exp_in, "$desc: inside";
  22   @$exp_out;
  23  }->('dummy');
  24
  25  is_deeply \@ret, $exp_out, "$desc: outside";
  26 }
  27
  28 check { return } [ ], 'empty explicit return';
  29
  30 check { () }     [ ], 'empty implicit return';
  31
  32 check { return 1 } [ 1 ], 'one const scalar explicit return';
  33
  34 check { 2 }        [ 2 ], 'one const scalar implicit return';
  35
  36 {
  37  my $x = 3;
  38  check { return $x } [ 3 ], 'one lexical scalar explicit return';
  39 }
  40
  41 {
  42  my $x = 4;
  43  check { $x }        [ 4 ], 'one lexical scalar implicit return';
  44 }
  45
  46 {
  47  our $x = 3;
  48  check { return $x } [ 3 ], 'one global scalar explicit return';
  49 }
  50
  51 {
  52  our $x = 4;
  53  check { $x }        [ 4 ], 'one global scalar implicit return';
  54 }
  55
  56 check { return 1 .. 5 } [ 1 .. 5 ],  'five const scalar explicit return';
  57
  58 check { 6 .. 10 }       [ 6 .. 10 ], 'five const scalar implicit return';
  59
  60 # Mark
  61
  62 {
  63  my $desc = 'one scalar explict return between two others, without args';
  64  my @ret = sub {
  65   my @ret = (1, uplevel(sub { return 2 }), 3);
  66   is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
  67   qw<X Y>;
  68  }->('dummy');
  69  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
  70 }
  71
  72 {
  73  my $desc = 'one scalar implict return between two others, without args';
  74  my @ret = sub {
  75   my @ret = (4, uplevel(sub { 5 }), 6);
  76   is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
  77   qw<X Y>;
  78  }->('dummy');
  79  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
  80 }
  81
  82 {
  83  my $desc = 'one scalar explict return between two others, with args';
  84  my @ret = sub {
  85   my @ret = (1, uplevel(sub { return 2 }, 7 .. 9, HERE), 3);
  86   is_deeply \@ret, [ 1 .. 3 ], "$desc: inside";
  87   qw<X Y>;
  88  }->('dummy');
  89  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
  90 }
  91
  92 {
  93  my $desc = 'one scalar implict return between two others, with args';
  94  my @ret = sub {
  95   my @ret = (4, uplevel(sub { 5 }, 7 .. 9, HERE), 6);
  96   is_deeply \@ret, [ 4 .. 6 ], "$desc: inside";
  97   qw<X Y>;
  98  }->('dummy');
  99  is_deeply \@ret, [ qw<X Y> ], "$desc: outside";
 100 }
 101
 102 {
 103  my $desc = 'complex chain of calls';
 104
 105  sub one   { "<",   two("{", @_, "}"), ">" }
 106  sub two   { "(", three("[", @_, "]"), ")" }
 107  sub three { (uplevel { "A", "B", four(@_) } @_, UP), "Z" }
 108  sub four  {
 109   is_deeply \@_, [ qw|[ { * } ]| ], "$desc: inside";
 110   @_
 111  }
 112
 113  my @ret  = one('*');
 114  is_deeply \@ret, [ qw|< ( A B [ { * } ] Z ) >| ], "$desc: outside";
 115 }
 116
 117 # Magic
 118
 119 {
 120  package Scope::Upper::TestMagic;
 121
 122  sub TIESCALAR {
 123   my ($class, $cb) = @_;
 124   bless { cb => $cb }, $class;
 125  }
 126
 127  sub FETCH { $_[0]->{cb}->(@_) }
 128
 129  sub STORE { die "Read only magic scalar" }
 130 }
 131
 132 {
 133  tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
 134  check { return $mg } [ $$ ], 'one magical scalar explicit return';
 135  check { $mg }        [ $$ ], 'one magical scalar implicit return';
 136
 137  tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
 138  check { return $mg2 } [ $$ ], 'one double magical scalar explicit return';
 139  check { $mg2 }        [ $$ ], 'one double magical scalar implicit return';
 140 }
 141
 142 # Destruction
 143
 144 {
 145  package Scope::Upper::TestTimelyDestruction;
 146
 147  sub new {
 148   my ($class, $flag) = @_;
 149   $$flag = 0;
 150   bless { flag => $flag }, $class;
 151  }
 152
 153  sub DESTROY {
 154   ${$_[0]->{flag}}++;
 155  }
 156 }
 157
 158 {
 159  my $destroyed;
 160  {
 161   sub {
 162    my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 163    is $destroyed, 0, 'destruction 1: not yet 1';
 164    uplevel {
 165     is $destroyed, 0, 'destruction 1: not yet 2';
 166     $z;
 167    }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () }
 168   }->('dummy');
 169   is $destroyed, 1, 'destruction 1: destroyed 1';
 170  }
 171  is $destroyed, 1, 'destruction 1: destroyed 2';
 172 }
 173
 174 SKIP: {
 175  skip 'This fails even with a plain subroutine call on 5.8.x' => 6
 176                                                                 if "$]" < 5.009;
 177
 178  my $destroyed;
 179  {
 180   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
 181   is $destroyed, 0, 'destruction 2: not yet 1';
 182   sub {
 183    is $destroyed, 0, 'destruction 2: not yet 2';
 184    (uplevel {
 185     is $destroyed, 0, 'destruction 2: not yet 3';
 186     return $z;
 187    }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () }
 188   }->('dummy');
 189   is $destroyed, 0, 'destruction 2: not yet 5';
 190  }
 191  is $destroyed, 1, 'destruction 2: destroyed';
 192 }