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 => (1 + 3) * 17 + (1 + 2 * 3) * 2 + 2 * 31;
   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      ok !exists &main::${name},  '$name: not stubbed';
  58      ok !defined &main::${name}, '$name: body not defined';
  59      is *main::${name}\{CODE\}, undef, '$name: empty symbol table entry';
  60     }
  61    CHECK_VIVID
  62   }
  63   $test .= "}\n";
  64
  65   local $called = 0;
  66   eval $test;
  67   if ($@) {
  68    fail "@names: unable to evaluate test case: $@";
  69    diag $test;
  70   }
  71
  72   is $called, $calls, "@names: the hook was called the right number of times";
  73   if ($called < $calls) {
  74    fail, fail for $called + 1 .. $calls;
  75   }
  76  }
  77 }
  78
  79 __DATA__
  80 foo();
  81 ----
  82 foo # () # [ ]
  83 ####
  84 bar;
  85 ----
  86 bar # () # [ ]
  87 ####
  88 baz(1);
  89 ----
  90 baz # () # [ 1 ]
  91 ####
  92 zap 2;
  93 ----
  94 zap # () # [ 2 ]
  95 ####
  96 package X;
  97 main::flap 7, 8;
  98 ----
  99 flap # () # [ 7, 8 ]
 100 ####
 101 wut; wut 1; wut 2, 3
 102 ----
 103 wut # () # [ ], [ 1 ], [ 2, 3 ]
 104 ####
 105 qux(qux(1));
 106 ----
 107 qux # @_ # [ 1 ], [ 1 ]
 108 ####
 109 wat 1, wat, 2, wat(3, 4), 5
 110 ----
 111 wat # @_ # [ ], [ 3, 4 ], [ 1, 2, 3, 4, 5 ]
 112 ####
 113 sum sum sum(1, 2), sum(3, 4)
 114 ----
 115 sum # do { my $s = 0; $s += $_ for @_; $s } # [ 1, 2 ], [ 3, 4 ], [ 3, 7 ], [ 10 ]
 116 ####
 117 return;
 118 my $x = \&func
 119 ----
 120 func # () # ()
 121 ####
 122 return;
 123 __PACKAGE__->meth
 124 ----
 125 meth # () # ()
 126 ####
 127 fetch 1, do { no strict 'refs'; *{__PACKAGE__.'::fetch'}{CODE} }, 2
 128 ----
 129 fetch # () # [ 1, undef, 2 ]
 130 ####
 131 my ($cb, $err);
 132 BEGIN {
 133  $cb = do { no strict 'refs'; \&{__PACKAGE__.'::cvref'} };
 134  eval { $cb->() };
 135  $err = $@ =~ /^Undefined subroutine &main::cvref/ ? undef : $@;
 136 }
 137 cvref $err;
 138 ----
 139 cvref # () # [ undef ]
 140 ####
 141 our $scalr = 1;
 142 scalr $scalr;
 143 ----
 144 scalr # () # [ 1 ]
 145 ####
 146 our @array = (2, 3);
 147 array @array;
 148 ----
 149 array # () # [ 2, 3 ]
 150 ####
 151 our %hash = (x => 4);
 152 hash $hash{x};
 153 ----
 154 hash # () # [ 4 ]
 155 ####
 156 foo 1;
 157 bar 2;
 158 ----
 159 foo, bar # () # [ 1 ], [ 2 ] # foo, bar
 160 ####
 161 foo 1, foo(2), 3, bar(4, foo(bar, 5), 6);
 162 ----
 163 foo, bar # @_ # [ 2 ], [ ], [ 5 ], [ 4, 5, 6 ], [ 1, 2, 3, 4, 5, 6 ] # foo, bar, foo, bar, foo
 164 ####
 165 foo 0, sub {
 166  foo $_[0], 2, $_[1]
 167 }->(1, 3), 4;
 168 ----
 169 foo # @_ # [ 1, 2, 3 ], [ 0, 1, 2, 3, 4 ]