t/58-yield-misc.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 4 * 3 + 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 leave
  79
  80 {
  81  my @res = (1, do {
  82   leave;
  83   'XXX';
  84  }, 2);
  85  is "@res", '1 2', 'leave without arguments';
  86 }
  87
  88 {
  89  my @res = (1, do {
  90   leave 2, 3;
  91   'XXX';
  92  }, 4);
  93  is "@res", '1 2 3 4', 'leave with arguments';
  94 }
  95
  96 {
  97  my $s = 'a';
  98  local $@;
  99  eval {
 100   $s =~ s/./leave; die 'not reached'/e;
 101  };
 102  my $err  = $@;
 103  my $line = __LINE__-3;
 104  like $err,
 105       qr/^leave\(\) can't target a substitution context at \Q$0\E line $line/,
 106       'leave() cannot exit subst';
 107 }