t/10-base.t

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