Add support for prototypes

[perl/modules/Sub-Op.git] / t / 12-prototype.t

diff --git a/t/12-prototype.t b/t/12-prototype.t
new file mode 100644 (file)
index 0000000..d4f1c82
--- /dev/null
+++ b/t/12-prototype.t
@@ -0,0 +1,162 @@
+#!perl
+
+use 5.010;
+
+use strict;
+use warnings;
+
+use blib 't/Sub-Op-LexicalSub';
+
+use Test::More tests => 1 * 11 + 3 * 12 + 2 * 18 + 4;
+
+my @array = (1 .. 4);
+my %hash  = (a => 'b');
+
+our $called;
+
+{
+ local $/ = "####\n";
+ while (<DATA>) {
+  chomp;
+  s/\s*$//;
+
+  my ($code, $params)           = split /----\s*/, $_;
+  my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params;
+
+  my @names = split /\s*,\s*/, $names;
+  my @protos;
+  for my $i (0 .. $#names) {
+   my $name = $names[$i];
+   if ($name =~ /^\s*([^\s\(]+)\s*(\([^\)]*\))\s*$/) {
+    $names[$i]  = $1;
+    $protos[$i] = $2;
+   }
+  }
+
+  my @exp = eval $exp;
+  if ($@) {
+   fail "@names: unable to get expected values: $@";
+   next;
+  }
+  my $calls = @exp;
+
+  my @seq;
+  if ($seq) {
+   s/^\s*//, s/\s*$//  for $seq;
+   @seq = split /\s*,\s*/, $seq;
+   die "calls and seq length mismatch" unless @seq == $calls;
+  } else {
+   @seq = ($names[0]) x $calls;
+  }
+
+  my $test = "{\n";
+  for my $i (0 .. $#names) {
+   my $name  = $names[$i];
+   my $proto = $protos[$i] // '';
+   $test .= <<"   INIT"
+    use Sub::Op::LexicalSub $name => sub $proto {
+     ++\$called;
+     my \$exp = shift \@exp;
+     is_deeply \\\@_, \$exp,   '$name: arguments are correct';
+     my \$seq = shift \@seq;
+     is        \$seq, '$name', '$name: sequence is correct';
+     $ret;
+    };
+   INIT
+  }
+  $test .= "{\n$code\n}\n";
+  for my $name (@names) {
+   $test .= <<"   CHECK_VIVID"
+    BEGIN {
+     no warnings 'uninitialized'; # Test::Builder can't get the file name
+     ok !exists &main::${name},  '$name: not stubbed';
+     ok !defined &main::${name}, '$name: body not defined';
+     is *main::${name}\{CODE\}, undef, '$name: empty symbol table entry';
+    }
+   CHECK_VIVID
+  }
+  $test .= "}\n";
+
+  local $called = 0;
+  eval $test;
+  if ($@) {
+   fail "@names: unable to evaluate test case: $@";
+   diag $test;
+  }
+
+  is $called, $calls, "@names: the hook was called the right number of times";
+  if ($called < $calls) {
+   fail, fail for $called + 1 .. $calls;
+  }
+ }
+}
+
+{
+ eval <<' TEST';
+  use Sub::Op::LexicalSub foo => sub (&) { $_[0]->() };
+  foo { pass 'block called'; };
+ TEST
+ fail $@ if $@;
+}
+
+{
+ eval <<' TEST';
+  use Sub::Op::LexicalSub foo => sub (&@) { my $cb = shift; goto &$cb };
+  foo { is_deeply \@_, [ ],      'block called without arguments' };
+  foo { is_deeply \@_, [ 1 ],    'block called without 1 argument' } 1;
+  foo { is_deeply \@_, [ 2, 3 ], 'block called without 2 argument' } 2, 3;
+ TEST
+ fail $@ if $@;
+}
+
+__DATA__
+foo();
+----
+foo() # () # [ ]
+####
+foo;
+----
+foo() # () # [ ]
+####
+foo(1);
+----
+foo($) # () # [ 1 ]
+####
+foo 2;
+----
+foo($) # () # [ 2 ]
+####
+my @stuff = (foo 3, 4);
+----
+foo($) # () # [ 3 ]
+####
+foo @array;
+----
+foo($) # () # [ scalar @array ]
+####
+my @stuff = (foo 5, 6);
+bar 7, 8;
+@stuff    = (foo 9, 10);
+----
+foo($), bar($$) # () # [ 5 ], [ 7, 8 ], [ 9 ] # foo, bar, foo
+####
+foo @array;
+----
+foo(\@) # () # [ \@array ]
+####
+foo @array;
+foo %hash;
+----
+foo(\[@%]) # () # [ \@array ], [ \%hash ]
+####
+foo @array, 13;
+foo %hash,  14;
+----
+foo(\[@%]$) # () # [ \@array, 13 ], [ \%hash, 14 ]
+####
+foo @array;
+foo @array, 15;
+foo %hash;
+foo %hash, 16;
+----
+foo(\[@%];$) # () # [ \@array ], [ \@array, 15 ], [ \%hash ], [ \%hash, 16 ]