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