t/11-existing.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 *((4 + 2 * 4) + (2 * 5) + 1);
   9
  10 our $call_foo;
  11 sub foo { ok $call_foo, 'the preexistent foo was called' }
  12
  13 our $call_bar;
  14 sub bar () { ok $call_bar, 'the preexistent bar was called' }
  15
  16 our $called;
  17
  18 {
  19  local $/ = "####\n";
  20  while (<DATA>) {
  21   chomp;
  22   s/\s*$//;
  23
  24   my ($code, $params)           = split /----\s*/, $_;
  25   my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params;
  26
  27   my @names = split /\s*,\s*/, $names;
  28
  29   my @exp = eval $exp;
  30   if ($@) {
  31    fail "@names: unable to get expected values: $@";
  32    next;
  33   }
  34   my $calls = @exp;
  35
  36   my @seq;
  37   if ($seq) {
  38    s/^\s*//, s/\s*$//  for $seq;
  39    @seq = split /\s*,\s*/, $seq;
  40    die "calls and seq length mismatch" unless @seq == $calls;
  41   } else {
  42    @seq = ($names[0]) x $calls;
  43   }
  44
  45   my $test = "{\n";
  46   for my $name (@names) {
  47    $test .= <<"   INIT"
  48     use Sub::Op::LexicalSub $name => sub {
  49      ++\$called;
  50      my \$exp = shift \@exp;
  51      is_deeply \\\@_, \$exp,   '$name: arguments are correct';
  52      my \$seq = shift \@seq;
  53      is        \$seq, '$name', '$name: sequence is correct';
  54      $ret;
  55     };
  56    INIT
  57   }
  58   $test .= "{\n$code\n}\n";
  59   $test .= "}\n";
  60
  61   local $called = 0;
  62   eval $test;
  63   if ($@) {
  64    fail "@names: unable to evaluate test case: $@";
  65    diag $test;
  66   }
  67
  68   is $called, $calls, "@names: the hook was called the right number of times";
  69   if ($called < $calls) {
  70    fail for $called + 1 .. $calls;
  71   }
  72  }
  73 }
  74
  75 is prototype('main::foo'), undef, "foo's prototype was preserved";
  76 is prototype('main::bar'), '',    "bar's prototype was preserved";
  77
  78 __DATA__
  79 foo();
  80 ----
  81 foo # () # [ ]
  82 ####
  83 foo;
  84 ----
  85 foo # () # [ ]
  86 ####
  87 foo(1);
  88 ----
  89 foo # () # [ 1 ]
  90 ####
  91 foo 2;
  92 ----
  93 foo # () # [ 2 ]
  94 ####
  95 local $call_foo = 1;
  96 &foo();
  97 ----
  98 foo # () #
  99 ####
 100 local $call_foo = 1;
 101 &foo;
 102 ----
 103 foo # () #
 104 ####
 105 local $call_foo = 1;
 106 &foo(3);
 107 ----
 108 foo # () #
 109 ####
 110 local $call_foo = 1;
 111 my $foo = \&foo;
 112 $foo->();
 113 ----
 114 foo # () #
 115 ####
 116 local $call_foo = 1;
 117 my $foo = \&foo;
 118 &$foo;
 119 ----
 120 foo # () #
 121 ####
 122 bar();
 123 ----
 124 bar # () # [ ]
 125 ####
 126 bar;
 127 ----
 128 bar # () # [ ]
 129 ####
 130 bar(1);
 131 ----
 132 bar # () # [ 1 ]
 133 ####
 134 bar 2;
 135 ----
 136 bar # () # [ 2 ]
 137 ####
 138 local $call_bar = 1;
 139 &bar();
 140 ----
 141 bar # () #
 142 ####
 143 local $call_bar = 1;
 144 &bar;
 145 ----
 146 bar # () #
 147 ####
 148 local $call_bar = 1;
 149 &bar(3);
 150 ----
 151 bar # () #
 152 ####
 153 local $call_bar = 1;
 154 my $bar = \&bar;
 155 $bar->();
 156 ----
 157 bar # () #
 158 ####
 159 local $call_bar = 1;
 160 my $bar = \&bar;
 161 &$bar;
 162 ----
 163 bar # () #