6 use Test::More tests => 67;
9 bareword => sub { qr/^Bareword\s+['"]?\s*$_[0]\s*['"]?\s+not\s+allowed\s+while\s+["']?\s*strict\s+subs\s*['"]?\s+in\s+use\s+at\s+$_[1]\s+line\s+$_[2]/ },
10 undefined => sub { qr/^Undefined\s+subroutine\s+\&$_[0]\s+called\s+at\s+$_[1]\s+line\s+$_[2]/ },
17 my $msg = delete $args{msg};
18 $msg = join ' ', $args{name}, $sub, 'line', $line unless $msg;
19 my $file = $args{eval} ? '\\(eval\\s+\\d+\\)' : quotemeta $0;
20 my $re = $_re{$args{name}}->($sub, $file, $line);
23 local $TODO = $args{todo};
31 sub _got_bareword { _got_test(@_, name => 'bareword'); }
35 $sub = 'main::' . $sub if $sub !~ /::/;
36 _got_test($sub, @_, name => 'undefined');
39 sub _got_ok { is($@, '', $_[0]); }
46 eval "yay 11, 13"; # Defined on the other side of the scope
47 _got_ok('compiling to yay(11,13)');
49 is_deeply(\@yay, [ 11, 13 ], 'yay really was executed');
51 eval "flip"; # Not called in sub::auto zone, not declared, not defined
52 _got_bareword('flip', 1, eval => 1);
54 eval "flop"; # Not called in sub::auto zone, declared, not defined
55 _got_undefined('flop', 1, eval => 1);
58 eval "qux"; # Called in sub::auto zone, not declared, not defined
59 _got_bareword('qux', 1, eval => 1);
62 eval "blech"; # Called in sub::auto zone, declared, not defined
63 _got_undefined('blech', 1, eval => 1);
66 eval "wut"; # Called in sub::auto zone, declared, defined
67 _got_ok('compiling to wut()');
69 # === Starting from here ======================================================
72 eval { onlycalledonce 1, 2 };
73 _got_undefined('onlycalledonce', __LINE__-1);
75 eval { Test::More->import() };
76 _got_ok('don\'t touch class names');
79 sub strict { $strict = 1; undef }
80 eval { strict->import };
81 is($strict, 1, 'the strict subroutine was called');
91 my $y = eval { foo 1, 2, \%h };
92 _got_ok('compiling to foo(1,2,\\\%h)');
93 is($foo, 15, 'foo really was executed');
95 eval { wut 13, "what" };
96 _got_ok('compiling to wut(13,"what")');
97 is($wut, 17, 'wut really was executed');
100 _got_undefined('qux', __LINE__-1);
104 is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined');
105 is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined, really');
106 isnt(*{'::yay'}{CODE}, undef, 'yay is defined');
107 isnt(*{'::foo'}{CODE}, undef, 'foo is defined');
108 is(*{'::flip'}{CODE}, undef, 'flip isn\'t defined');
109 isnt(*{'::flop'}{CODE}, undef, 'flip is defined');
110 is(*{'::qux'}{CODE}, undef, 'qux isn\'t defined');
111 isnt(*{'::blech'}{CODE}, undef, 'blech is defined');
112 isnt(*{'::wut'}{CODE}, undef, 'wut is defined');
115 eval { no warnings; no strict; qux };
116 _got_undefined('qux', __LINE__-1);
118 eval { no warnings; no strict; blech };
119 _got_undefined('blech', __LINE__-1);
124 $foo = $_[0] + $_[1] + (($h{a} || 0 == 5) ? 4 : 0)
125 + (($h{b} || 0 == 7) ? 8 : 0);
128 $foo = '::foo'; # for symbol table tests later
132 eval { foo 3, 4, { } };
133 _got_ok('compiling to foo(3,4,{})');
134 is($foo, 7, 'foo really was executed');
138 local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
139 local *qux = sub { $qux = $_[0] };
142 _got_ok('compiling to qux(5)');
143 is($qux, 5, 'qux really was executed');
144 is($warn, undef, 'no redefine warning');
148 local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
149 local *blech = sub { $blech = $_[0] };
152 _got_ok('compiling to blech(7)');
153 is($blech, 7, 'blech really was executed');
154 is($warn, undef, 'no redefine warning');
157 _got_undefined('qux', __LINE__-1);
160 _got_undefined('blech', __LINE__-1);
162 # === Up to there =============================================================
170 no warnings 'reserved';
175 _got_ok('compiling to bareword');
177 is($b, 'blech', 'bareword ok');
179 eval { foo 13, 1, { } };
180 _got_ok('compiling to foo(13,1,{})');
181 is($foo, 14, 'foo really was executed');
185 local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/; diag $_[0] };
186 local *qux = sub { $qux = 2 * $_[0] };
189 _got_ok('compiling to qux(3)');
190 is($qux, 6, 'new qux really was executed');
191 is($warn, undef, 'no redefine warning');
195 local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
196 local *blech = sub { $blech = 2 * $_[0] };
199 _got_ok('compiling to blech(9)');
200 is($blech, 18, 'new blech really was executed');
201 is($warn, undef, 'no redefine warning');
204 _got_bareword('qux', 1, eval => 1);
207 _got_undefined('blech', 1, eval => 1);
210 no strict qw/refs subs/;
211 is(*{::feh}{CODE}, undef, 'feh isn\'t defined');
212 is(*{::feh}{CODE}, undef, 'feh isn\'t defined, really');
213 isnt(*{::yay}{CODE}, undef, 'yay is defined');
214 isnt(*{::foo}{CODE}, undef, 'foo is defined'); # calls foo
215 is($foo, '::foo', 'foo was called');
216 is(*{::flip}{CODE}, undef, 'flip isn\'t defined');
217 isnt(*{::flop}{CODE}, undef, 'flip is defined');
218 is(*{::qux}{CODE}, undef, 'qux isn\'t defined');
219 isnt(*{::blech}{CODE}, undef, 'blech is defined');
220 isnt(*{::wut}{CODE}, undef, 'wut is defined');
225 _got_undefined('blech', __LINE__-1);
230 is($bar, 1, 'bar ok');
232 sub wut { $wut = ($_[0] || 0) + length($_[1] || ''); '::wut' }
234 sub yay { @yay = @_; '::yay' }
236 # === Restarting from there ===================================================
239 eval "no subs::auto; meh";
240 _got_bareword("meh", 1, eval => 1);
241 # eval "use subs::auto; meh";
242 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
244 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
249 open DONGS, '>', \$buf or die "open-in-memory: $!";
251 print DONGS "hlagh\n";
252 is($buf, "hlagh\n", 'filehandles should\'t be touched');
258 is_deeply(\@fruits, [ qw/apple pear banana/ ], 'DATA filehandle ok');
260 eval { foo 7, 9, { } };
261 _got_ok('compiling to foo(7,9,{})');
262 is($foo, 16, 'foo really was executed');
265 _got_undefined('blech', __LINE__-1);
267 ok(-f $0 && -r _, '-X _');