t/10-base.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 92;
   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', __LINE__-1);
  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 # Test hash keys
  84 my $c = 0;
  85 my %h = (
  86  a => 5,
  87  b => 7,
  88 );
  89 sub a { ++$c }
  90 sub b { ++$c }
  91 is($c, 0, "hash keys shouldn't be converted");
  92
  93 my $foo;
  94 our @foo;
  95
  96 eval { foo 1, 2, \%h };
  97 _got_ok('compiling to foo(1,2,\\\%h)');
  98 is($foo, 15, 'foo really was executed');
  99
 100 eval { foo(3, 4, \%h) };
 101 _got_ok('compiling to foo(3,4,\\\%h)');
 102 is($foo, 19, 'foo() really was executed');
 103
 104 eval { local @_ = (5, 6, \%h); &foo };
 105 _got_ok('compiling to foo(5,6,\\\%h)');
 106 is($foo, 23, '&foo really was executed');
 107
 108 eval { &foo(7, 8, \%h) };
 109 _got_ok('compiling to foo(7,8,\\\%h)');
 110 is($foo, 27, '&foo() really was executed');
 111
 112 eval { wut 13, "what" };
 113 _got_ok('compiling to wut(13,"what")');
 114 is($wut, 17, 'wut really was executed');
 115
 116 eval { wut(17, "what") };
 117 _got_ok('compiling to wut(17,"what")');
 118 is($wut, 21, 'wut() really was executed');
 119
 120 eval { local @_ = (21, "what"); &wut };
 121 _got_ok('compiling to wut(21,"what")');
 122 is($wut, 25, '&wut really was executed');
 123
 124 eval { &wut(25, "what") };
 125 _got_ok('compiling to wut(25,"what")');
 126 is($wut, 29, '&wut() really was executed');
 127
 128 eval { qux };
 129 _got_undefined('qux', __LINE__-1);
 130
 131 eval { qux() };
 132 _got_undefined('qux', __LINE__-1);
 133
 134 eval { &qux };
 135 _got_undefined('qux', __LINE__-1);
 136
 137 eval { &qux() };
 138 _got_undefined('qux', __LINE__-1);
 139
 140 {
 141  no strict 'refs';
 142  is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined');
 143  is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined, really');
 144  isnt(*{'::yay'}{CODE}, undef, 'yay is defined');
 145  isnt(*{'::foo'}{CODE}, undef, 'foo is defined');
 146  is(*{'::flip'}{CODE}, undef, 'flip isn\'t defined');
 147  isnt(*{'::flop'}{CODE}, undef, 'flip is defined');
 148  is(*{'::qux'}{CODE}, undef, 'qux isn\'t defined');
 149  isnt(*{'::blech'}{CODE}, undef, 'blech is defined');
 150  isnt(*{'::wut'}{CODE}, undef, 'wut is defined');
 151 }
 152
 153 eval { no warnings; no strict; qux };
 154 _got_undefined('qux', __LINE__-1);
 155
 156 eval { no warnings; no strict; blech };
 157 _got_undefined('blech', __LINE__-1);
 158
 159 sub foo {
 160  if ($_[2]) {
 161   my %h = %{$_[2]};
 162   $foo = $_[0] + $_[1] + (($h{a} || 0 == 5) ? 4 : 0)
 163                        + (($h{b} || 0 == 7) ? 8 : 0);
 164   undef;
 165  } else {
 166   $foo = '::foo'; # for symbol table tests later
 167  }
 168 }
 169
 170 eval { foo 3, 4, { } };
 171 _got_ok('compiling to foo(3,4,{})');
 172 is($foo, 7, 'foo really was executed');
 173
 174 $warn = undef;
 175 eval {
 176  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 177  local *qux = sub { $qux = $_[0] };
 178  qux 5;
 179 };
 180 _got_ok('compiling to qux(5)');
 181 is($qux, 5, 'qux really was executed');
 182 is($warn, undef, 'no redefine warning');
 183
 184 $warn = undef;
 185 eval {
 186  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 187  local *blech = sub { $blech = $_[0] };
 188  blech 7;
 189 };
 190 _got_ok('compiling to blech(7)');
 191 is($blech, 7, 'blech really was executed');
 192 is($warn, undef, 'no redefine warning');
 193
 194 eval { qux };
 195 _got_undefined('qux', __LINE__-1);
 196
 197 eval { blech };
 198 _got_undefined('blech', __LINE__-1);
 199
 200 # === Up to there =============================================================
 201 no subs::auto;
 202
 203 my $b;
 204 my $cb = eval {
 205  sub {
 206   $b = do {
 207    no strict;
 208    no warnings 'reserved';
 209    blech;
 210   }
 211  }
 212 };
 213 _got_ok('compiling to bareword');
 214 $cb->();
 215 is($b, 'blech', 'bareword ok');
 216
 217 eval { foo 13, 1, { } };
 218 _got_ok('compiling to foo(13,1,{})');
 219 is($foo, 14, 'foo really was executed');
 220
 221 $warn = undef;
 222 {
 223  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/; diag $_[0] };
 224  local *qux = sub { $qux = 2 * $_[0] };
 225  qux(3);
 226 }
 227 _got_ok('compiling to qux(3)');
 228 is($qux, 6, 'new qux really was executed');
 229 is($warn, undef, 'no redefine warning');
 230
 231 $warn = undef;
 232 {
 233  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 234  local *blech = sub { $blech = 2 * $_[0] };
 235  blech(9);
 236 }
 237 _got_ok('compiling to blech(9)');
 238 is($blech, 18, 'new blech really was executed');
 239 is($warn, undef, 'no redefine warning');
 240
 241 eval "qux";
 242 _got_bareword('qux', 1, eval => 1);
 243
 244 eval "blech";
 245 _got_undefined('blech', 1, eval => 1);
 246
 247 {
 248  no strict qw/refs subs/;
 249  is(*{::feh}{CODE}, undef, 'feh isn\'t defined');
 250  is(*{::feh}{CODE}, undef, 'feh isn\'t defined, really');
 251  isnt(*{::yay}{CODE}, undef, 'yay is defined');
 252  isnt(*{::foo}{CODE}, undef, 'foo is defined'); # calls foo
 253  is($foo, '::foo', 'foo was called');
 254  is(*{::flip}{CODE}, undef, 'flip isn\'t defined');
 255  isnt(*{::flop}{CODE}, undef, 'flip is defined');
 256  is(*{::qux}{CODE}, undef, 'qux isn\'t defined');
 257  isnt(*{::blech}{CODE}, undef, 'blech is defined');
 258  isnt(*{::wut}{CODE}, undef, 'wut is defined');
 259 }
 260
 261 sub blech;
 262 eval { blech };
 263 _got_undefined('blech', __LINE__-1);
 264
 265 sub flop;
 266
 267 bar();
 268 is($bar, 1, 'bar ok');
 269
 270 sub wut { $wut = ($_[0] || 0) + length($_[1] || ''); '::wut' }
 271
 272 sub yay { @yay = @_; '::yay' }
 273
 274 # === Restarting from there ===================================================
 275 use subs::auto;
 276
 277 eval "no subs::auto; meh";
 278 _got_bareword("meh", 1, eval => 1);
 279 # eval "use subs::auto; meh";
 280 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
 281 # eval "meh";
 282 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
 283
 284 my $buf = '';
 285 {
 286  no subs::auto;
 287  open DONGS, '>', \$buf or die "open-in-memory: $!";
 288 }
 289 print DONGS "hlagh\n";
 290 is($buf, "hlagh\n", 'filehandles should\'t be touched');
 291 close DONGS;
 292
 293 seek DATA, 0, 1;
 294 my @fruits = <DATA>;
 295 chomp @fruits;
 296 is_deeply(\@fruits, [ qw/apple pear banana/ ], 'DATA filehandle ok');
 297
 298 eval { foo 7, 9, { } };
 299 _got_ok('compiling to foo(7,9,{})');
 300 is($foo, 16, 'foo really was executed');
 301
 302 eval { foo(8, 10, { }) };
 303 _got_ok('compiling to foo(8,10,{})');
 304 is($foo, 18, 'foo() really was executed');
 305
 306 eval { local @_ = (9, 11, { }); &foo };
 307 _got_ok('compiling to foo(9,11,{})');
 308 is($foo, 20, '&foo really was executed');
 309
 310 eval { &foo(10, 12, { }) };
 311 _got_ok('compiling to foo(10,12,{})');
 312 is($foo, 22, '&foo() really was executed');
 313
 314 eval { blech };
 315 _got_undefined('blech', __LINE__-1);
 316
 317 eval { blech() };
 318 _got_undefined('blech', __LINE__-1);
 319
 320 eval { &blech };
 321 _got_undefined('blech', __LINE__-1);
 322
 323 eval { &blech() };
 324 _got_undefined('blech', __LINE__-1);
 325
 326 ok(-f $0 && -r _, '-X _');
 327
 328 __DATA__
 329 apple
 330 pear
 331 banana