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
   8 use lib 't/lib';
   9 use VPIT::TestHelpers;
  10
  11 use Scope::Upper qw<yield leave HERE>;
  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 }