t/10-base.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 59;
   7
   8 my %_re = (
   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]/ },
  11 );
  12
  13 sub _got_test {
  14  my $sub  = shift;
  15  my $line = shift;
  16  my %args = @_;
  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);
  21  if ($args{todo}) {
  22   TODO: {
  23    local $TODO = $args{todo};
  24    like($@, $re, $msg);
  25   }
  26  } else {
  27   like($@, $re, $msg);
  28  }
  29 }
  30
  31 sub _got_bareword { _got_test(@_, name => 'bareword'); }
  32
  33 sub _got_undefined {
  34  my $sub = shift;
  35  $sub = 'main::' . $sub if $sub !~ /::/;
  36  _got_test($sub, @_, name => 'undefined');
  37 }
  38
  39 sub _got_ok { is($@, '', $_[0]); }
  40
  41 my $warn;
  42
  43 my $bar;
  44 sub bar { $bar = 1 }
  45
  46 eval "yay 11, 13"; # Defined on the other side of the scope
  47 _got_ok('compiling to yay(11,13)');
  48 our @yay;
  49 is_deeply(\@yay, [ 11, 13 ], 'yay really was executed');
  50
  51 eval "flip"; # Not called in sub::auto zone, not declared, not defined
  52 _got_bareword('flip', 1, eval => 1);
  53
  54 eval "flop"; # Not called in sub::auto zone, declared, not defined
  55 _got_undefined('flop', 1, eval => 1);
  56
  57 my $qux;
  58 eval "qux"; # Called in sub::auto zone, not declared, not defined
  59 _got_bareword('qux', 1, eval => 1);
  60
  61 my $blech;
  62 eval "blech"; # Called in sub::auto zone, declared, not defined
  63 _got_undefined('blech', 1, eval => 1);
  64
  65 my $wut;
  66 eval "wut"; # Called in sub::auto zone, declared, defined
  67 _got_ok('compiling to wut()');
  68
  69 # === Starting from here ======================================================
  70 use subs::auto;
  71
  72 eval { onlycalledonce 1, 2 };
  73 _got_undefined('onlycalledonce', 72);
  74
  75 eval { Test::More->import() };
  76 _got_ok('don\'t touch class names');
  77
  78 my $strict;
  79 sub strict { $strict = 1; undef }
  80 eval { strict->import };
  81 is($strict, 1, 'the strict subroutine was called');
  82
  83 my %h = (
  84  a => 5,
  85  b => 7,
  86 );
  87
  88 my $foo;
  89 our @foo;
  90
  91 my $y = eval {
  92  foo 1, 2, \%h;
  93 };
  94 _got_ok('compiling to foo(1,2,\\\%h)');
  95 is($foo, 15, 'foo really was executed');
  96
  97 eval {
  98  wut 13, "what"
  99 };
 100 _got_ok('compiling to wut(13,"what")');
 101 is($wut, 17, 'wut really was executed');
 102
 103 eval { qux };
 104 _got_undefined('qux', 103);
 105
 106 {
 107  no strict 'refs';
 108  is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined');
 109  is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined, really');
 110  isnt(*{'::yay'}{CODE}, undef, 'yay is defined');
 111  isnt(*{'::foo'}{CODE}, undef, 'foo is defined');
 112  is(*{'::flip'}{CODE}, undef, 'flip isn\'t defined');
 113  isnt(*{'::flop'}{CODE}, undef, 'flip is defined');
 114  is(*{'::qux'}{CODE}, undef, 'qux isn\'t defined');
 115  isnt(*{'::blech'}{CODE}, undef, 'blech is defined');
 116  isnt(*{'::wut'}{CODE}, undef, 'wut is defined');
 117 }
 118
 119 eval { no warnings; no strict; qux };
 120 _got_undefined('qux', 119);
 121
 122 eval { no warnings; no strict; blech };
 123 _got_undefined('blech', 122);
 124
 125 sub foo {
 126  if ($_[2]) {
 127   my %h = %{$_[2]};
 128   $foo = $_[0] + $_[1] + (($h{a} || 0 == 5) ? 4 : 0)
 129                        + (($h{b} || 0 == 7) ? 8 : 0);
 130   undef;
 131  } else {
 132   $foo = '::foo'; # for symbol table tests later
 133  }
 134 }
 135
 136 eval {
 137  foo 3, 4, { };
 138 };
 139 _got_ok('compiling to foo(3,4,{})');
 140 is($foo, 7, 'foo really was executed');
 141
 142 $warn = undef;
 143 eval {
 144  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 145  local *qux = sub { $qux = $_[0] };
 146  qux 5;
 147 };
 148 _got_ok('compiling to qux(5)');
 149 is($qux, 5, 'qux really was executed');
 150 is($warn, undef, 'no redefine warning');
 151
 152 $warn = undef;
 153 eval {
 154  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 155  local *blech = sub { $blech = $_[0] };
 156  blech 7;
 157 };
 158 _got_ok('compiling to blech(7)');
 159 is($blech, 7, 'blech really was executed');
 160 is($warn, undef, 'no redefine warning');
 161
 162 eval { qux };
 163 _got_undefined('qux', 162);
 164
 165 eval { blech };
 166 _got_undefined('blech', 165);
 167
 168 # === Up to there =============================================================
 169 no subs::auto;
 170
 171 my $b;
 172 my $cb = eval {
 173  sub {
 174   $b = do {
 175    no strict;
 176    no warnings 'reserved';
 177    blech;
 178   }
 179  }
 180 };
 181 _got_ok('compiling to bareword');
 182 $cb->();
 183 is($b, 'blech', 'bareword ok');
 184
 185 $warn = undef;
 186 {
 187  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/; diag $_[0] };
 188  local *qux = sub { $qux = 2 * $_[0] };
 189  qux(3);
 190 }
 191 _got_ok('compiling to qux(3)');
 192 is($qux, 6, 'new qux really was executed');
 193 is($warn, undef, 'no redefine warning');
 194
 195 $warn = undef;
 196 {
 197  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 198  local *blech = sub { $blech = 2 * $_[0] };
 199  blech(9);
 200 }
 201 _got_ok('compiling to blech(9)');
 202 is($blech, 18, 'new blech really was executed');
 203 is($warn, undef, 'no redefine warning');
 204
 205 eval "qux";
 206 _got_bareword('qux', 1, eval => 1);
 207
 208 eval "blech";
 209 _got_undefined('blech', 1, eval => 1);
 210
 211 {
 212  no strict qw/refs subs/;
 213  is(*{::feh}{CODE}, undef, 'feh isn\'t defined');
 214  is(*{::feh}{CODE}, undef, 'feh isn\'t defined, really');
 215  isnt(*{::yay}{CODE}, undef, 'yay is defined');
 216  isnt(*{::foo}{CODE}, undef, 'foo is defined'); # calls foo
 217  is($foo, '::foo', 'foo was called');
 218  is(*{::flip}{CODE}, undef, 'flip isn\'t defined');
 219  isnt(*{::flop}{CODE}, undef, 'flip is defined');
 220  is(*{::qux}{CODE}, undef, 'qux isn\'t defined');
 221  isnt(*{::blech}{CODE}, undef, 'blech is defined');
 222  isnt(*{::wut}{CODE}, undef, 'wut is defined');
 223 }
 224
 225 sub blech;
 226 eval { blech };
 227 _got_undefined('blech', 226);
 228
 229 sub flop;
 230
 231 bar();
 232 is($bar, 1, 'bar ok');
 233
 234 sub wut { $wut = ($_[0] || 0) + length($_[1] || ''); '::wut' }
 235
 236 sub yay { @yay = @_; '::yay' }
 237
 238 {
 239  use subs::auto;
 240  eval "no subs::auto; meh";
 241  _got_bareword("meh", 1, eval => 1);
 242 # eval "use subs::auto; meh";
 243 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
 244 # eval "meh";
 245 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
 246 }