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