]> git.vpit.fr Git - perl/modules/Sub-Op.git/blob - t/10-base.t
Fix deparsing of sub deref
[perl/modules/Sub-Op.git] / t / 10-base.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 * 15 + 3 * 2 + 2 * 28;
9
10 our $called;
11
12 {
13  local $/ = "####\n";
14  while (<DATA>) {
15   my ($code, $params)           = split /----\s*/, $_;
16   my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params;
17
18   my @names = split /\s*,\s*/, $names;
19
20   my @exp = eval $exp;
21   if ($@) {
22    fail "@names: unable to get expected values: $@";
23    next;
24   }
25   my $calls = @exp;
26
27   my @seq;
28   if ($seq) {
29    s/^\s*//, s/\s*$//  for $seq;
30    @seq = split /\s*,\s*/, $seq;
31    die "calls and seq length mismatch" unless @seq == $calls;
32   } else {
33    @seq = ($names[0]) x $calls;
34   }
35
36   my $test = "{\n";
37   for my $name (@names) {
38    $test .= <<"   INIT"
39     use Sub::Op::LexicalSub $name => sub {
40      ++\$called;
41      my \$exp = shift \@exp;
42      is_deeply \\\@_, \$exp,   '$name: arguments are correct';
43      my \$seq = shift \@seq;
44      is        \$seq, '$name', '$name: sequence is correct';
45      $ret;
46     };
47    INIT
48   }
49   $test .= "{\n$code\n}\n";
50   for my $name (@names) {
51    $test .= <<"   CHECK_VIVID"
52     BEGIN {
53      no warnings 'uninitialized'; # Test::Builder can't get the file name
54      is *main::${name}\{CODE\}, undef, '$name: no symbol table vivification';
55     }
56    CHECK_VIVID
57   }
58   $test .= "}\n";
59
60   local $called = 0;
61   eval $test;
62   if ($@) {
63    fail "@names: unable to evaluate test case: $@";
64    diag $test;
65   }
66
67   is $called, $calls, "@names: the hook was called the right number of times";
68   if ($called < $calls) {
69    fail for $called + 1 .. $calls;
70   }
71  }
72 }
73
74 __DATA__
75 foo();
76 ----
77 foo # () # [ ]
78 ####
79 bar;
80 ----
81 bar # () # [ ]
82 ####
83 baz(1);
84 ----
85 baz # () # [ 1 ]
86 ####
87 zap 2;
88 ----
89 zap # () # [ 2 ]
90 ####
91 package X;
92 main::flap 7, 8;
93 ----
94 flap # () # [ 7, 8 ]
95 ####
96 wut; wut 1; wut 2, 3
97 ----
98 wut # () # [ ], [ 1 ], [ 2, 3 ]
99 ####
100 qux(qux(1));
101 ----
102 qux # @_ # [ 1 ], [ 1 ]
103 ####
104 wat 1, wat, 2, wat(3, 4), 5
105 ----
106 wat # @_ # [ ], [ 3, 4 ], [ 1, 2, 3, 4, 5 ]
107 ####
108 sum sum sum(1, 2), sum(3, 4)
109 ----
110 sum # do { my $s = 0; $s += $_ for @_; $s } # [ 1, 2 ], [ 3, 4 ], [ 3, 7 ], [ 10 ]
111 ####
112 return;
113 my $x = \&func
114 ----
115 func # () # ()
116 ####
117 return;
118 __PACKAGE__->meth
119 ----
120 meth # () # ()
121 ####
122 fetch 1, do { no strict 'refs'; *{__PACKAGE__.'::fetch'}{CODE} }, 2
123 ----
124 fetch # () # [ 1, undef, 2 ]
125 ####
126 our $scalr = 1;
127 scalr $scalr;
128 ----
129 scalr # () # [ 1 ]
130 ####
131 our @array = (2, 3);
132 array @array;
133 ----
134 array # () # [ 2, 3 ]
135 ####
136 our %hash = (x => 4);
137 hash $hash{x};
138 ----
139 hash # () # [ 4 ]
140 ####
141 foo 1;
142 bar 2;
143 ----
144 foo, bar # () # [ 1 ], [ 2 ] # foo, bar
145 ####
146 foo 1, foo(2), 3, bar(4, foo(bar, 5), 6);
147 ----
148 foo, bar # @_ # [ 2 ], [ ], [ 5 ], [ 4, 5, 6 ], [ 1, 2, 3, 4, 5, 6 ] # foo, bar, foo, bar, foo