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