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) + 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{\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   for my $name (grep +{ map +($_, 1), qw/foo bar/ }->{ $_ }, @names) {
  63    $test .= <<"   CHECK_SUB"
  64     {
  65      local \$call_$name = 1;
  66      $name();
  67     }
  68    CHECK_SUB
  69   }
  70   $test .= "}\n";
  71
  72   local $called = 0;
  73   eval $test;
  74   if ($@) {
  75    fail "@names: unable to evaluate test case: $@";
  76    diag $test;
  77   }
  78
  79   is $called, $calls, "@names: the hook was called the right number of times";
  80   if ($called < $calls) {
  81    fail, fail for $called + 1 .. $calls;
  82   }
  83  }
  84 }
  85
  86 is prototype('main::foo'), undef, "foo's prototype was preserved";
  87 is prototype('main::bar'), '',    "bar's prototype was preserved";
  88 is prototype('main::X'),   '',    "X's prototype was preserved";
  89 ok Sub::Op::_constant_sub(do { no strict "refs"; \&{"main::X"} }),
  90                                   'X is still a constant';
  91
  92 __DATA__
  93 foo();
  94 ----
  95 foo # () # [ ]
  96 ####
  97 foo;
  98 ----
  99 foo # () # [ ]
 100 ####
 101 foo(1);
 102 ----
 103 foo # () # [ 1 ]
 104 ####
 105 foo 2;
 106 ----
 107 foo # () # [ 2 ]
 108 ####
 109 local $call_foo = 1;
 110 &foo();
 111 ----
 112 foo # () #
 113 ####
 114 local $call_foo = 1;
 115 &foo;
 116 ----
 117 foo # () #
 118 ####
 119 local $call_foo = 1;
 120 &foo(3);
 121 ----
 122 foo # () #
 123 ####
 124 local $call_foo = 1;
 125 my $foo = \&foo;
 126 $foo->();
 127 ----
 128 foo # () #
 129 ####
 130 local $call_foo = 1;
 131 my $foo = \&foo;
 132 &$foo;
 133 ----
 134 foo # () #
 135 ####
 136 bar();
 137 ----
 138 bar # () # [ ]
 139 ####
 140 bar;
 141 ----
 142 bar # () # [ ]
 143 ####
 144 bar(1);
 145 ----
 146 bar # () # [ 1 ]
 147 ####
 148 bar 2;
 149 ----
 150 bar # () # [ 2 ]
 151 ####
 152 local $call_bar = 1;
 153 &bar();
 154 ----
 155 bar # () #
 156 ####
 157 local $call_bar = 1;
 158 &bar;
 159 ----
 160 bar # () #
 161 ####
 162 local $call_bar = 1;
 163 &bar(3);
 164 ----
 165 bar # () #
 166 ####
 167 local $call_bar = 1;
 168 my $bar = \&bar;
 169 $bar->();
 170 ----
 171 bar # () #
 172 ####
 173 local $call_bar = 1;
 174 my $bar = \&bar;
 175 &$bar;
 176 ----
 177 bar # () #
 178 ####
 179 is X, 2, 'constant overriding';
 180 ----
 181 X # 2 # [ ]