use strict;
use warnings;
-use Test::More tests => 65;
+use Test::More tests => 92;
+
+# ... Helpers .................................................................
my %_re = (
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]/ },
my $warn;
+# ... First test that the default behaviour apply to all the subs .............
+
my $bar;
sub bar { $bar = 1 }
our @yay;
is_deeply(\@yay, [ 11, 13 ], 'yay really was executed');
-eval "flip"; # Not called in sub::auto zone, not declared, not defined
+eval "flip"; # Not called in subs::auto zone, not declared, not defined
_got_bareword('flip', 1, eval => 1);
-eval "flop"; # Not called in sub::auto zone, declared, not defined
+eval "flop"; # Not called in subs::auto zone, declared outside, not defined
_got_undefined('flop', 1, eval => 1);
my $qux;
-eval "qux"; # Called in sub::auto zone, not declared, not defined
+eval "qux"; # Called in subs::auto zone, not declared, not defined
_got_bareword('qux', 1, eval => 1);
my $blech;
-eval "blech"; # Called in sub::auto zone, declared, not defined
+eval "blech"; # Called in subs::auto zone, declared outside, not defined
_got_undefined('blech', 1, eval => 1);
my $wut;
-eval "wut"; # Called in sub::auto zone, declared, defined
+eval "wut"; # Called in subs::auto zone, declared and defined outside
_got_ok('compiling to wut()');
# === Starting from here ======================================================
use subs::auto;
+# ... Called in subs::auto zone only, not declared, not defined ...............
+
eval { onlycalledonce 1, 2 };
_got_undefined('onlycalledonce', __LINE__-1);
+# ... Method calls, anyone? ...................................................
+
eval { Test::More->import() };
_got_ok('don\'t touch class names');
eval { strict->import };
is($strict, 1, 'the strict subroutine was called');
+# ... Test hash keys ..........................................................
+
+my $c = 0;
my %h = (
a => 5,
b => 7,
);
+sub a { ++$c }
+sub b { ++$c }
+is($c, 0, "hash keys shouldn't be converted");
my $foo;
our @foo;
-my $y = eval { foo 1, 2, \%h };
+# ... Called in subs::auto zone, declared and defined inside ..................
+
+eval { foo 1, 2, \%h };
_got_ok('compiling to foo(1,2,\\\%h)');
is($foo, 15, 'foo really was executed');
+eval { foo(3, 4, \%h) };
+_got_ok('compiling to foo(3,4,\\\%h)');
+is($foo, 19, 'foo() really was executed');
+
+eval { local @_ = (5, 6, \%h); &foo };
+_got_ok('compiling to foo(5,6,\\\%h)');
+is($foo, 23, '&foo really was executed');
+
+eval { &foo(7, 8, \%h) };
+_got_ok('compiling to foo(7,8,\\\%h)');
+is($foo, 27, '&foo() really was executed');
+
+# ... Called in subs::auto zone, declared and defined outside .................
+
eval { wut 13, "what" };
_got_ok('compiling to wut(13,"what")');
is($wut, 17, 'wut really was executed');
+eval { wut(17, "what") };
+_got_ok('compiling to wut(17,"what")');
+is($wut, 21, 'wut() really was executed');
+
+eval { local @_ = (21, "what"); &wut };
+_got_ok('compiling to wut(21,"what")');
+is($wut, 25, '&wut really was executed');
+
+eval { &wut(25, "what") };
+_got_ok('compiling to wut(25,"what")');
+is($wut, 29, '&wut() really was executed');
+
+# ... Called in subs::auto zone, not declared, not defined ....................
+
eval { qux };
_got_undefined('qux', __LINE__-1);
+eval { qux() };
+_got_undefined('qux', __LINE__-1);
+
+eval { &qux };
+_got_undefined('qux', __LINE__-1);
+
+eval { &qux() };
+_got_undefined('qux', __LINE__-1);
+
+# ... Are our subs visible in the symbol table entry or what? .................
+
{
no strict 'refs';
is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined');
isnt(*{'::yay'}{CODE}, undef, 'yay is defined');
isnt(*{'::foo'}{CODE}, undef, 'foo is defined');
is(*{'::flip'}{CODE}, undef, 'flip isn\'t defined');
- isnt(*{'::flop'}{CODE}, undef, 'flip is defined');
+ isnt(*{'::flop'}{CODE}, undef, 'flop is defined');
is(*{'::qux'}{CODE}, undef, 'qux isn\'t defined');
isnt(*{'::blech'}{CODE}, undef, 'blech is defined');
isnt(*{'::wut'}{CODE}, undef, 'wut is defined');
}
+# ... Let's check that this didn't induce any quantic effect ..................
+
eval { no warnings; no strict; qux };
_got_undefined('qux', __LINE__-1);
eval { no warnings; no strict; blech };
_got_undefined('blech', __LINE__-1);
+# ... Define foo ..............................................................
+
sub foo {
if ($_[2]) {
my %h = %{$_[2]};
_got_ok('compiling to foo(3,4,{})');
is($foo, 7, 'foo really was executed');
+# ... Locally define qux (declared outside, not defined) ......................
+
$warn = undef;
eval {
- local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
+ local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
local *qux = sub { $qux = $_[0] };
qux 5;
};
is($qux, 5, 'qux really was executed');
is($warn, undef, 'no redefine warning');
+# ... Locally define blech (declared and defined outside) .....................
+
$warn = undef;
eval {
local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
is($blech, 7, 'blech really was executed');
is($warn, undef, 'no redefine warning');
+# ... But now they aren't anymore .............................................
+
eval { qux };
_got_undefined('qux', __LINE__-1);
# === Up to there =============================================================
no subs::auto;
+# ... Barewords are strings when the pragma isn't in effect ...................
+
my $b;
my $cb = eval {
sub {
no strict;
no warnings 'reserved';
blech;
- }
+ }
}
};
_got_ok('compiling to bareword');
$cb->();
is($b, 'blech', 'bareword ok');
+# ... Does foo's definition still valid outside of the pragma scope? ..........
+
eval { foo 13, 1, { } };
_got_ok('compiling to foo(13,1,{})');
is($foo, 14, 'foo really was executed');
+# ... Locally define qux ......................................................
+
$warn = undef;
{
local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/; diag $_[0] };
is($qux, 6, 'new qux really was executed');
is($warn, undef, 'no redefine warning');
+# ... Locally define blech ....................................................
+
$warn = undef;
{
local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
is($blech, 18, 'new blech really was executed');
is($warn, undef, 'no redefine warning');
+# ... But now they aren't anymore .............................................
+
eval "qux";
_got_bareword('qux', 1, eval => 1);
eval "blech";
_got_undefined('blech', 1, eval => 1);
+# ... How's my symbol table, Doug Hastings? ...................................
+
{
- no strict qw/refs subs/;
+ no strict qw<refs subs>;
is(*{::feh}{CODE}, undef, 'feh isn\'t defined');
is(*{::feh}{CODE}, undef, 'feh isn\'t defined, really');
isnt(*{::yay}{CODE}, undef, 'yay is defined');
isnt(*{::foo}{CODE}, undef, 'foo is defined'); # calls foo
is($foo, '::foo', 'foo was called');
is(*{::flip}{CODE}, undef, 'flip isn\'t defined');
- isnt(*{::flop}{CODE}, undef, 'flip is defined');
+ isnt(*{::flop}{CODE}, undef, 'flop is defined');
is(*{::qux}{CODE}, undef, 'qux isn\'t defined');
isnt(*{::blech}{CODE}, undef, 'blech is defined');
isnt(*{::wut}{CODE}, undef, 'wut is defined');
}
+# ... Declareth thy oneth thad shalt be .......................................
+
sub blech;
eval { blech };
_got_undefined('blech', __LINE__-1);
# === Restarting from there ===================================================
use subs::auto;
+# ... How does the pragma propagates through eval STRING? .....................
+
eval "no subs::auto; meh";
_got_bareword("meh", 1, eval => 1);
# eval "use subs::auto; meh";
# eval "meh";
# _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
+# ... Try filehandles .........................................................
+
my $buf = '';
{
no subs::auto;
is($buf, "hlagh\n", 'filehandles should\'t be touched');
close DONGS;
+# ... Try default filehandles .................................................
+
+seek DATA, 0, 1;
+my @fruits = <DATA>;
+chomp @fruits;
+is_deeply(\@fruits, [ qw<apple pear banana> ], 'DATA filehandle ok');
+
+# ... Retest foo (declared and defined inside) ................................
+
eval { foo 7, 9, { } };
_got_ok('compiling to foo(7,9,{})');
is($foo, 16, 'foo really was executed');
+eval { foo(8, 10, { }) };
+_got_ok('compiling to foo(8,10,{})');
+is($foo, 18, 'foo() really was executed');
+
+eval { local @_ = (9, 11, { }); &foo };
+_got_ok('compiling to foo(9,11,{})');
+is($foo, 20, '&foo really was executed');
+
+eval { &foo(10, 12, { }) };
+_got_ok('compiling to foo(10,12,{})');
+is($foo, 22, '&foo() really was executed');
+
+# ... Retest blech (declared outside, not defined) ............................
+
eval { blech };
_got_undefined('blech', __LINE__-1);
+
+eval { blech() };
+_got_undefined('blech', __LINE__-1);
+
+eval { &blech };
+_got_undefined('blech', __LINE__-1);
+
+eval { &blech() };
+_got_undefined('blech', __LINE__-1);
+
+# ... Try _ in a filetest .....................................................
+
+ok(-f $0 && -r _, '-X _');
+
+__DATA__
+apple
+pear
+banana
projects / perl / modules / subs-auto.git / blobdiff