]> git.vpit.fr Git - perl/modules/Sub-Op.git/blob - t/10-base.t
Test if the name member is not NULL before cloning it
[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 => (1 + 3) * 16 + (1 + 2 * 3) * 2 + 2 * 29;
9
10 our $called;
11
12 {
13  local $/ = "####\n";
14  while (<DATA>) {
15   chomp;
16   s/\s*$//;
17
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::LexicalSub $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   for my $name (@names) {
54    $test .= <<"   CHECK_VIVID"
55     BEGIN {
56      no warnings 'uninitialized'; # Test::Builder can't get the file name
57      ok !exists &main::${name},  '$name: not stubbed';
58      ok !defined &main::${name}, '$name: body not defined';
59      is *main::${name}\{CODE\}, undef, '$name: empty symbol table entry';
60     }
61    CHECK_VIVID
62   }
63   $test .= "}\n";
64
65   local $called = 0;
66   eval $test;
67   if ($@) {
68    fail "@names: unable to evaluate test case: $@";
69    diag $test;
70   }
71
72   is $called, $calls, "@names: the hook was called the right number of times";
73   if ($called < $calls) {
74    fail, fail for $called + 1 .. $calls;
75   }
76  }
77 }
78
79 __DATA__
80 foo();
81 ----
82 foo # () # [ ]
83 ####
84 bar;
85 ----
86 bar # () # [ ]
87 ####
88 baz(1);
89 ----
90 baz # () # [ 1 ]
91 ####
92 zap 2;
93 ----
94 zap # () # [ 2 ]
95 ####
96 package X;
97 main::flap 7, 8;
98 ----
99 flap # () # [ 7, 8 ]
100 ####
101 wut; wut 1; wut 2, 3
102 ----
103 wut # () # [ ], [ 1 ], [ 2, 3 ]
104 ####
105 qux(qux(1));
106 ----
107 qux # @_ # [ 1 ], [ 1 ]
108 ####
109 wat 1, wat, 2, wat(3, 4), 5
110 ----
111 wat # @_ # [ ], [ 3, 4 ], [ 1, 2, 3, 4, 5 ]
112 ####
113 sum sum sum(1, 2), sum(3, 4)
114 ----
115 sum # do { my $s = 0; $s += $_ for @_; $s } # [ 1, 2 ], [ 3, 4 ], [ 3, 7 ], [ 10 ]
116 ####
117 return;
118 my $x = \&func
119 ----
120 func # () # ()
121 ####
122 return;
123 __PACKAGE__->meth
124 ----
125 meth # () # ()
126 ####
127 fetch 1, do { no strict 'refs'; *{__PACKAGE__.'::fetch'}{CODE} }, 2
128 ----
129 fetch # () # [ 1, undef, 2 ]
130 ####
131 my ($cb, $err);
132 BEGIN {
133  $cb = do { no strict 'refs'; \&{__PACKAGE__.'::cvref'} };
134  eval { $cb->() };
135  $err = $@ =~ /^Undefined subroutine &main::cvref/ ? undef : $@;
136 }
137 cvref $err;
138 ----
139 cvref # () # [ undef ]
140 ####
141 our $scalr = 1;
142 scalr $scalr;
143 ----
144 scalr # () # [ 1 ]
145 ####
146 our @array = (2, 3);
147 array @array;
148 ----
149 array # () # [ 2, 3 ]
150 ####
151 our %hash = (x => 4);
152 hash $hash{x};
153 ----
154 hash # () # [ 4 ]
155 ####
156 foo 1;
157 bar 2;
158 ----
159 foo, bar # () # [ 1 ], [ 2 ] # foo, bar
160 ####
161 foo 1, foo(2), 3, bar(4, foo(bar, 5), 6);
162 ----
163 foo, bar # @_ # [ 2 ], [ ], [ 5 ], [ 4, 5, 6 ], [ 1, 2, 3, 4, 5, 6 ] # foo, bar, foo, bar, foo