t/11-existing.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use blib 't/Sub-Op-Test';
   7
   8 use Test::More tests => (4 + 2 * 4) + (2 * 5);
   9
  10 our $call_foo;
  11 sub foo { ok $call_foo, 'the preexistent foo was called' }
  12
  13 our $called;
  14
  15 {
  16  local $/ = "####\n";
  17  while (<DATA>) {
  18   my ($code, $params)           = split /----\s*/, $_;
  19   my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params;
  20
  21   my @names = split /\s*,\s*/, $names;
  22
  23   my @exp = eval $exp;
  24   if ($@) {
  25    fail "@names: unable to get expected values: $@";
  26    next;
  27   }
  28   my $calls = @exp;
  29
  30   my @seq;
  31   if ($seq) {
  32    s/^\s*//, s/\s*$//  for $seq;
  33    @seq = split /\s*,\s*/, $seq;
  34    die "calls and seq length mismatch" unless @seq == $calls;
  35   } else {
  36    @seq = ($names[0]) x $calls;
  37   }
  38
  39   my $test = "{\n";
  40   for my $name (@names) {
  41    $test .= <<"   INIT"
  42     use Sub::Op::Test $name => sub {
  43      ++\$called;
  44      my \$exp = shift \@exp;
  45      is_deeply \\\@_, \$exp,   '$name: arguments are correct';
  46      my \$seq = shift \@seq;
  47      is        \$seq, '$name', '$name: sequence is correct';
  48      $ret;
  49     };
  50    INIT
  51   }
  52   $test .= "{\n$code\n}\n";
  53   $test .= "}\n";
  54
  55   local $called = 0;
  56   eval $test;
  57   if ($@) {
  58    fail "@names: unable to evaluate test case: $@";
  59    diag $test;
  60   }
  61
  62   is $called, $calls, "@names: the hook was called the right number of times";
  63   if ($called < $calls) {
  64    fail for $called + 1 .. $calls;
  65   }
  66  }
  67 }
  68
  69 __DATA__
  70 foo();
  71 ----
  72 foo # () # [ ]
  73 ####
  74 foo;
  75 ----
  76 foo # () # [ ]
  77 ####
  78 foo(1);
  79 ----
  80 foo # () # [ 1 ]
  81 ####
  82 foo 2;
  83 ----
  84 foo # () # [ 2 ]
  85 ####
  86 local $call_foo = 1;
  87 &foo();
  88 ----
  89 foo # () #
  90 ####
  91 local $call_foo = 1;
  92 &foo;
  93 ----
  94 foo # () #
  95 ####
  96 local $call_foo = 1;
  97 &foo(3);
  98 ----
  99 foo # () #
 100 ####
 101 local $call_foo = 1;
 102 my $foo = \&foo;
 103 $foo->();
 104 ----
 105 foo # () #
 106 ####
 107 local $call_foo = 1;
 108 my $foo = \&foo;
 109 &$foo;
 110 ----
 111 foo # () #