t/12-prototype.t

   1 #!perl
   2
   3 use 5.010;
   4
   5 use strict;
   6 use warnings;
   7
   8 use blib 't/Sub-Op-LexicalSub';
   9
  10 use Test::More tests => 1 * 11 + 3 * 12 + 2 * 18 + 4;
  11
  12 my @array = (1 .. 4);
  13 my %hash  = (a => 'b');
  14
  15 our $called;
  16
  17 {
  18  local $/ = "####\n";
  19  while (<DATA>) {
  20   chomp;
  21   s/\s*$//;
  22
  23   my ($code, $params)           = split /----\s*/, $_;
  24   my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params;
  25
  26   my @names = split /\s*,\s*/, $names;
  27   my @protos;
  28   for my $i (0 .. $#names) {
  29    my $name = $names[$i];
  30    if ($name =~ /^\s*([^\s\(]+)\s*(\([^\)]*\))\s*$/) {
  31     $names[$i]  = $1;
  32     $protos[$i] = $2;
  33    }
  34   }
  35
  36   my @exp = eval $exp;
  37   if ($@) {
  38    fail "@names: unable to get expected values: $@";
  39    next;
  40   }
  41   my $calls = @exp;
  42
  43   my @seq;
  44   if ($seq) {
  45    s/^\s*//, s/\s*$//  for $seq;
  46    @seq = split /\s*,\s*/, $seq;
  47    die "calls and seq length mismatch" unless @seq == $calls;
  48   } else {
  49    @seq = ($names[0]) x $calls;
  50   }
  51
  52   my $test = "{\n";
  53   for my $i (0 .. $#names) {
  54    my $name  = $names[$i];
  55    my $proto = $protos[$i] // '';
  56    $test .= <<"   INIT"
  57     use Sub::Op::LexicalSub $name => sub $proto {
  58      ++\$called;
  59      my \$exp = shift \@exp;
  60      is_deeply \\\@_, \$exp,   '$name: arguments are correct';
  61      my \$seq = shift \@seq;
  62      is        \$seq, '$name', '$name: sequence is correct';
  63      $ret;
  64     };
  65    INIT
  66   }
  67   $test .= "{\n$code\n}\n";
  68   for my $name (@names) {
  69    $test .= <<"   CHECK_VIVID"
  70     BEGIN {
  71      no warnings 'uninitialized'; # Test::Builder can't get the file name
  72      ok !exists &main::${name},  '$name: not stubbed';
  73      ok !defined &main::${name}, '$name: body not defined';
  74      is *main::${name}\{CODE\}, undef, '$name: empty symbol table entry';
  75     }
  76    CHECK_VIVID
  77   }
  78   $test .= "}\n";
  79
  80   local $called = 0;
  81   eval $test;
  82   if ($@) {
  83    fail "@names: unable to evaluate test case: $@";
  84    diag $test;
  85   }
  86
  87   is $called, $calls, "@names: the hook was called the right number of times";
  88   if ($called < $calls) {
  89    fail, fail for $called + 1 .. $calls;
  90   }
  91  }
  92 }
  93
  94 {
  95  eval <<' TEST';
  96   use Sub::Op::LexicalSub foo => sub (&) { $_[0]->() };
  97   foo { pass 'block called'; };
  98  TEST
  99  fail $@ if $@;
 100 }
 101
 102 {
 103  eval <<' TEST';
 104   use Sub::Op::LexicalSub foo => sub (&@) { my $cb = shift; goto &$cb };
 105   foo { is_deeply \@_, [ ],      'block called without arguments' };
 106   foo { is_deeply \@_, [ 1 ],    'block called without 1 argument' } 1;
 107   foo { is_deeply \@_, [ 2, 3 ], 'block called without 2 argument' } 2, 3;
 108  TEST
 109  fail $@ if $@;
 110 }
 111
 112 __DATA__
 113 foo();
 114 ----
 115 foo() # () # [ ]
 116 ####
 117 foo;
 118 ----
 119 foo() # () # [ ]
 120 ####
 121 foo(1);
 122 ----
 123 foo($) # () # [ 1 ]
 124 ####
 125 foo 2;
 126 ----
 127 foo($) # () # [ 2 ]
 128 ####
 129 my @stuff = (foo 3, 4);
 130 ----
 131 foo($) # () # [ 3 ]
 132 ####
 133 foo @array;
 134 ----
 135 foo($) # () # [ scalar @array ]
 136 ####
 137 my @stuff = (foo 5, 6);
 138 bar 7, 8;
 139 @stuff    = (foo 9, 10);
 140 ----
 141 foo($), bar($$) # () # [ 5 ], [ 7, 8 ], [ 9 ] # foo, bar, foo
 142 ####
 143 foo @array;
 144 ----
 145 foo(\@) # () # [ \@array ]
 146 ####
 147 foo @array;
 148 foo %hash;
 149 ----
 150 foo(\[@%]) # () # [ \@array ], [ \%hash ]
 151 ####
 152 foo @array, 13;
 153 foo %hash,  14;
 154 ----
 155 foo(\[@%]$) # () # [ \@array, 13 ], [ \%hash, 14 ]
 156 ####
 157 foo @array;
 158 foo @array, 15;
 159 foo %hash;
 160 foo %hash, 16;
 161 ----
 162 foo(\[@%];$) # () # [ \@array ], [ \@array, 15 ], [ \%hash ], [ \%hash, 16 ]