t/58-yield-misc.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 4 * 3 + 1 + 3 + 7;
   7
   8 use lib 't/lib';
   9 use VPIT::TestHelpers;
  10
  11 use Scope::Upper qw<yield leave HERE UP SUB>;
  12
  13 # Test timely destruction of values returned from yield()
  14
  15 our $destroyed;
  16 sub guard { VPIT::TestHelpers::Guard->new(sub { ++$destroyed }) }
  17
  18 {
  19  my $desc = 'scalar context, above';
  20  local $destroyed;
  21  {
  22   my $obj = guard();
  23   my $res = do {
  24    is $destroyed, undef, "$desc: not yet destroyed 1";
  25    yield $obj => HERE;
  26    fail 'not reached 1';
  27   };
  28   is $destroyed, undef, "$desc: not yet destroyed 2";
  29  }
  30  is $destroyed, 1, "$desc: destroyed 1";
  31 }
  32
  33 {
  34  my $desc = 'scalar context, below';
  35  local $destroyed;
  36  {
  37   my $res = do {
  38    my $obj = guard();
  39    is $destroyed, undef, "$desc: not yet destroyed 1";
  40    yield $obj => HERE;
  41    fail 'not reached 1';
  42   };
  43   is $destroyed, undef, "$desc: not yet destroyed 2";
  44  }
  45  is $destroyed, 1, "$desc: destroyed 1";
  46 }
  47
  48 {
  49  my $desc = 'void context, above';
  50  local $destroyed;
  51  {
  52   my $obj = guard();
  53   {
  54    is $destroyed, undef, "$desc: not yet destroyed 1";
  55    yield $obj => HERE;
  56    fail 'not reached 1';
  57   }
  58   is $destroyed, undef, "$desc: not yet destroyed 2";
  59  }
  60  is $destroyed, 1, "$desc: destroyed 1";
  61 }
  62
  63 {
  64  my $desc = 'void context, below';
  65  local $destroyed;
  66  {
  67   {
  68    is $destroyed, undef, "$desc: not yet destroyed 1";
  69    my $obj = guard();
  70    yield $obj => HERE;
  71    fail 'not reached 2';
  72   }
  73   is $destroyed, 1, "$desc: destroyed 1";
  74  }
  75  is $destroyed, 1, "$desc: destroyed 2";
  76 }
  77
  78 # Test 'return from do' in special cases
  79
  80 {
  81  no warnings 'void';
  82  my @res = (1, do {
  83   my $cxt = HERE;
  84   my $thing = (777, do {
  85    my @stuff = (888, do {
  86     yield 2, 3 => $cxt;
  87     map { my $x; $_ x 3 } qw<x y z>
  88    }, 999);
  89    if (@stuff) {
  90     my $y;
  91     ++$y;
  92     'YYY';
  93    } else {
  94     die 'not reached';
  95    }
  96   });
  97   if (1) {
  98    my $z;
  99    'ZZZ';
 100   }
 101   'VVV'
 102  }, 4);
 103  is "@res", '1 2 3 4', 'yield() found the op to return to';
 104 }
 105
 106 # Test leave
 107
 108 {
 109  my @res = (1, do {
 110   leave;
 111   'XXX';
 112  }, 2);
 113  is "@res", '1 2', 'leave without arguments';
 114 }
 115
 116 {
 117  my @res = (1, do {
 118   leave 2, 3;
 119   'XXX';
 120  }, 4);
 121  is "@res", '1 2 3 4', 'leave with arguments';
 122 }
 123
 124 SKIP: {
 125  skip '"eval { $str =~ s/./die q[foo]/e }" breaks havoc on perl 5.8 and below'
 126                                                            => 1 if "$]" < 5.010;
 127  my $s = 'a';
 128  local $@;
 129  eval {
 130   $s =~ s/./leave; die 'not reached'/e;
 131  };
 132  my $err  = $@;
 133  my $line = __LINE__-3;
 134  like $err,
 135       qr/^leave\(\) can't target a substitution context at \Q$0\E line $line/,
 136       'leave() cannot exit subst';
 137 }
 138
 139 {
 140  my @destroyed;
 141
 142  {
 143   package Scope::Upper::TestTimelyDestruction;
 144
 145   sub new {
 146    my ($class, $label) = @_;
 147    bless { label => $label }, $class;
 148   }
 149
 150   sub label { $_[0]->{label} }
 151
 152   sub DESTROY {
 153    push @destroyed, $_[0]->label;
 154   }
 155  }
 156
 157  sub SU_TTD () { 'Scope::Upper::TestTimelyDestruction' }
 158
 159  sub foo {
 160   my $r = SU_TTD->new('a');
 161   my @x = (SU_TTD->new('c'), SU_TTD->new('d'));
 162   yield 123, $r, SU_TTD->new('b'), @x, sub { SU_TTD->new('e') }->() => UP SUB;
 163  }
 164
 165  sub bar {
 166   foo();
 167   die 'not reached';
 168  }
 169
 170  {
 171   my $desc = sub { "yielding @_ across a sub" };
 172   my @res = bar();
 173   is $res[0],        123, $desc->('a constant literal');
 174   is $res[1]->label, 'a', $desc->('a lexical');
 175   is $res[2]->label, 'b', $desc->('a temporary object');
 176   is $res[3]->label, 'c', $desc->('the contents of a lexical array (1)');
 177   is $res[4]->label, 'd', $desc->('the contents of a lexical array (2)');
 178   is $res[5]->label, 'e', $desc->('a temporary object returned by a sub');
 179  }
 180
 181  is_deeply \@destroyed, [ qw<e d c b a> ],
 182                                     'all these objects were properly destroyed';
 183 }