t/10-base.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use blib 't/Sub-Op-LexicalSub';
   7
   8 use Test::More tests => 2 * 15 + 3 * 2 + 2 * 28;
   9
  10 our $called;
  11
  12 {
  13  local $/ = "####\n";
  14  while (<DATA>) {
  15   chomp;
  16   s/\s*$//;
  17
  18   my ($code, $params)           = split /----\s*/, $_;
  19   my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params;
  20
  21   my @names = split /\s*,\s*/, $names;
  22
  23   my @exp = eval $exp;
  24   if ($@) {
  25    fail "@names: unable to get expected values: $@";
  26    next;
  27   }
  28   my $calls = @exp;
  29
  30   my @seq;
  31   if ($seq) {
  32    s/^\s*//, s/\s*$//  for $seq;
  33    @seq = split /\s*,\s*/, $seq;
  34    die "calls and seq length mismatch" unless @seq == $calls;
  35   } else {
  36    @seq = ($names[0]) x $calls;
  37   }
  38
  39   my $test = "{\n";
  40   for my $name (@names) {
  41    $test .= <<"   INIT"
  42     use Sub::Op::LexicalSub $name => sub {
  43      ++\$called;
  44      my \$exp = shift \@exp;
  45      is_deeply \\\@_, \$exp,   '$name: arguments are correct';
  46      my \$seq = shift \@seq;
  47      is        \$seq, '$name', '$name: sequence is correct';
  48      $ret;
  49     };
  50    INIT
  51   }
  52   $test .= "{\n$code\n}\n";
  53   for my $name (@names) {
  54    $test .= <<"   CHECK_VIVID"
  55     BEGIN {
  56      no warnings 'uninitialized'; # Test::Builder can't get the file name
  57      is *main::${name}\{CODE\}, undef, '$name: no symbol table vivification';
  58     }
  59    CHECK_VIVID
  60   }
  61   $test .= "}\n";
  62
  63   local $called = 0;
  64   eval $test;
  65   if ($@) {
  66    fail "@names: unable to evaluate test case: $@";
  67    diag $test;
  68   }
  69
  70   is $called, $calls, "@names: the hook was called the right number of times";
  71   if ($called < $calls) {
  72    fail for $called + 1 .. $calls;
  73   }
  74  }
  75 }
  76
  77 __DATA__
  78 foo();
  79 ----
  80 foo # () # [ ]
  81 ####
  82 bar;
  83 ----
  84 bar # () # [ ]
  85 ####
  86 baz(1);
  87 ----
  88 baz # () # [ 1 ]
  89 ####
  90 zap 2;
  91 ----
  92 zap # () # [ 2 ]
  93 ####
  94 package X;
  95 main::flap 7, 8;
  96 ----
  97 flap # () # [ 7, 8 ]
  98 ####
  99 wut; wut 1; wut 2, 3
 100 ----
 101 wut # () # [ ], [ 1 ], [ 2, 3 ]
 102 ####
 103 qux(qux(1));
 104 ----
 105 qux # @_ # [ 1 ], [ 1 ]
 106 ####
 107 wat 1, wat, 2, wat(3, 4), 5
 108 ----
 109 wat # @_ # [ ], [ 3, 4 ], [ 1, 2, 3, 4, 5 ]
 110 ####
 111 sum sum sum(1, 2), sum(3, 4)
 112 ----
 113 sum # do { my $s = 0; $s += $_ for @_; $s } # [ 1, 2 ], [ 3, 4 ], [ 3, 7 ], [ 10 ]
 114 ####
 115 return;
 116 my $x = \&func
 117 ----
 118 func # () # ()
 119 ####
 120 return;
 121 __PACKAGE__->meth
 122 ----
 123 meth # () # ()
 124 ####
 125 fetch 1, do { no strict 'refs'; *{__PACKAGE__.'::fetch'}{CODE} }, 2
 126 ----
 127 fetch # () # [ 1, undef, 2 ]
 128 ####
 129 our $scalr = 1;
 130 scalr $scalr;
 131 ----
 132 scalr # () # [ 1 ]
 133 ####
 134 our @array = (2, 3);
 135 array @array;
 136 ----
 137 array # () # [ 2, 3 ]
 138 ####
 139 our %hash = (x => 4);
 140 hash $hash{x};
 141 ----
 142 hash # () # [ 4 ]
 143 ####
 144 foo 1;
 145 bar 2;
 146 ----
 147 foo, bar # () # [ 1 ], [ 2 ] # foo, bar
 148 ####
 149 foo 1, foo(2), 3, bar(4, foo(bar, 5), 6);
 150 ----
 151 foo, bar # @_ # [ 2 ], [ ], [ 5 ], [ 4, 5, 6 ], [ 1, 2, 3, 4, 5, 6 ] # foo, bar, foo, bar, foo