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