t/10-base.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 92;
   7
   8 # ... Helpers .................................................................
   9
  10 my %_re = (
  11  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]/ },
  12  undefined => sub { qr/^Undefined\s+subroutine\s+\&$_[0]\s+called\s+at\s+$_[1]\s+line\s+$_[2]/ },
  13 );
  14
  15 sub _got_test {
  16  my $sub  = shift;
  17  my $line = shift;
  18  my %args = @_;
  19  my $msg  = delete $args{msg};
  20  $msg     = join ' ', $args{name}, $sub, 'line', $line unless $msg;
  21  my $file = $args{eval} ? '\\(eval\\s+\\d+\\)' : quotemeta $0;
  22  my $re   = $_re{$args{name}}->($sub, $file, $line);
  23  if ($args{todo}) {
  24   TODO: {
  25    local $TODO = $args{todo};
  26    like($@, $re, $msg);
  27   }
  28  } else {
  29   like($@, $re, $msg);
  30  }
  31 }
  32
  33 sub _got_bareword { _got_test(@_, name => 'bareword'); }
  34
  35 sub _got_undefined {
  36  my $sub = shift;
  37  $sub = 'main::' . $sub if $sub !~ /::/;
  38  _got_test($sub, @_, name => 'undefined');
  39 }
  40
  41 sub _got_ok { is($@, '', $_[0]); }
  42
  43 my $warn;
  44
  45 # ... First test that the default behaviour apply to all the subs .............
  46
  47 my $bar;
  48 sub bar { $bar = 1 }
  49
  50 eval "yay 11, 13"; # Defined on the other side of the scope
  51 _got_ok('compiling to yay(11,13)');
  52 our @yay;
  53 is_deeply(\@yay, [ 11, 13 ], 'yay really was executed');
  54
  55 eval "flip"; # Not called in sub::auto zone, not declared, not defined
  56 _got_bareword('flip', 1, eval => 1);
  57
  58 eval "flop"; # Not called in sub::auto zone, declared outside, not defined
  59 _got_undefined('flop', 1, eval => 1);
  60
  61 my $qux;
  62 eval "qux"; # Called in sub::auto zone, not declared, not defined
  63 _got_bareword('qux', 1, eval => 1);
  64
  65 my $blech;
  66 eval "blech"; # Called in sub::auto zone, declared outside, not defined
  67 _got_undefined('blech', 1, eval => 1);
  68
  69 my $wut;
  70 eval "wut"; # Called in sub::auto zone, declared and defined outside
  71 _got_ok('compiling to wut()');
  72
  73 # === Starting from here ======================================================
  74 use subs::auto;
  75
  76 # ... Called in sub::auto zone only, not declared, not defined ................
  77
  78 eval { onlycalledonce 1, 2 };
  79 _got_undefined('onlycalledonce', __LINE__-1);
  80
  81 # ... Method calls, anyone? ...................................................
  82
  83 eval { Test::More->import() };
  84 _got_ok('don\'t touch class names');
  85
  86 my $strict;
  87 sub strict { $strict = 1; undef }
  88 eval { strict->import };
  89 is($strict, 1, 'the strict subroutine was called');
  90
  91 # ... Test hash keys ..........................................................
  92
  93 my $c = 0;
  94 my %h = (
  95  a => 5,
  96  b => 7,
  97 );
  98 sub a { ++$c }
  99 sub b { ++$c }
 100 is($c, 0, "hash keys shouldn't be converted");
 101
 102 my $foo;
 103 our @foo;
 104
 105 # ... Called in sub::auto zone, declared and defined inside ...................
 106
 107 eval { foo 1, 2, \%h };
 108 _got_ok('compiling to foo(1,2,\\\%h)');
 109 is($foo, 15, 'foo really was executed');
 110
 111 eval { foo(3, 4, \%h) };
 112 _got_ok('compiling to foo(3,4,\\\%h)');
 113 is($foo, 19, 'foo() really was executed');
 114
 115 eval { local @_ = (5, 6, \%h); &foo };
 116 _got_ok('compiling to foo(5,6,\\\%h)');
 117 is($foo, 23, '&foo really was executed');
 118
 119 eval { &foo(7, 8, \%h) };
 120 _got_ok('compiling to foo(7,8,\\\%h)');
 121 is($foo, 27, '&foo() really was executed');
 122
 123 # ... Called in sub::auto zone, declared and defined outside ..................
 124
 125 eval { wut 13, "what" };
 126 _got_ok('compiling to wut(13,"what")');
 127 is($wut, 17, 'wut really was executed');
 128
 129 eval { wut(17, "what") };
 130 _got_ok('compiling to wut(17,"what")');
 131 is($wut, 21, 'wut() really was executed');
 132
 133 eval { local @_ = (21, "what"); &wut };
 134 _got_ok('compiling to wut(21,"what")');
 135 is($wut, 25, '&wut really was executed');
 136
 137 eval { &wut(25, "what") };
 138 _got_ok('compiling to wut(25,"what")');
 139 is($wut, 29, '&wut() really was executed');
 140
 141 # ... Called in sub::auto zone, not declared, not defined .....................
 142
 143 eval { qux };
 144 _got_undefined('qux', __LINE__-1);
 145
 146 eval { qux() };
 147 _got_undefined('qux', __LINE__-1);
 148
 149 eval { &qux };
 150 _got_undefined('qux', __LINE__-1);
 151
 152 eval { &qux() };
 153 _got_undefined('qux', __LINE__-1);
 154
 155 # ... Are our subs visible in the symbol table entry or what? .................
 156
 157 {
 158  no strict 'refs';
 159  is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined');
 160  is(*{'::feh'}{CODE}, undef, 'feh isn\'t defined, really');
 161  isnt(*{'::yay'}{CODE}, undef, 'yay is defined');
 162  isnt(*{'::foo'}{CODE}, undef, 'foo is defined');
 163  is(*{'::flip'}{CODE}, undef, 'flip isn\'t defined');
 164  isnt(*{'::flop'}{CODE}, undef, 'flop is defined');
 165  is(*{'::qux'}{CODE}, undef, 'qux isn\'t defined');
 166  isnt(*{'::blech'}{CODE}, undef, 'blech is defined');
 167  isnt(*{'::wut'}{CODE}, undef, 'wut is defined');
 168 }
 169
 170 # ... Let's check that this didn't induce any quantic effect ..................
 171
 172 eval { no warnings; no strict; qux };
 173 _got_undefined('qux', __LINE__-1);
 174
 175 eval { no warnings; no strict; blech };
 176 _got_undefined('blech', __LINE__-1);
 177
 178 # ... Define foo ..............................................................
 179
 180 sub foo {
 181  if ($_[2]) {
 182   my %h = %{$_[2]};
 183   $foo = $_[0] + $_[1] + (($h{a} || 0 == 5) ? 4 : 0)
 184                        + (($h{b} || 0 == 7) ? 8 : 0);
 185   undef;
 186  } else {
 187   $foo = '::foo'; # for symbol table tests later
 188  }
 189 }
 190
 191 eval { foo 3, 4, { } };
 192 _got_ok('compiling to foo(3,4,{})');
 193 is($foo, 7, 'foo really was executed');
 194
 195 # ... Locally define qux (declared outside, not defined) ......................
 196
 197 $warn = undef;
 198 eval {
 199  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 200  local *qux = sub { $qux = $_[0] };
 201  qux 5;
 202 };
 203 _got_ok('compiling to qux(5)');
 204 is($qux, 5, 'qux really was executed');
 205 is($warn, undef, 'no redefine warning');
 206
 207 # ... Locally define blech (declared and defined outside) .....................
 208
 209 $warn = undef;
 210 eval {
 211  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 212  local *blech = sub { $blech = $_[0] };
 213  blech 7;
 214 };
 215 _got_ok('compiling to blech(7)');
 216 is($blech, 7, 'blech really was executed');
 217 is($warn, undef, 'no redefine warning');
 218
 219 # ... But now they aren't anymore .............................................
 220
 221 eval { qux };
 222 _got_undefined('qux', __LINE__-1);
 223
 224 eval { blech };
 225 _got_undefined('blech', __LINE__-1);
 226
 227 # === Up to there =============================================================
 228 no subs::auto;
 229
 230 # ... Barewords are strings when the pragma isn't in effect ...................
 231
 232 my $b;
 233 my $cb = eval {
 234  sub {
 235   $b = do {
 236    no strict;
 237    no warnings 'reserved';
 238    blech;
 239   }
 240  }
 241 };
 242 _got_ok('compiling to bareword');
 243 $cb->();
 244 is($b, 'blech', 'bareword ok');
 245
 246 # ... Does foo's definition still valid outside of the pragma scope? ..........
 247
 248 eval { foo 13, 1, { } };
 249 _got_ok('compiling to foo(13,1,{})');
 250 is($foo, 14, 'foo really was executed');
 251
 252 # ... Locally define qux ......................................................
 253
 254 $warn = undef;
 255 {
 256  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/; diag $_[0] };
 257  local *qux = sub { $qux = 2 * $_[0] };
 258  qux(3);
 259 }
 260 _got_ok('compiling to qux(3)');
 261 is($qux, 6, 'new qux really was executed');
 262 is($warn, undef, 'no redefine warning');
 263
 264 # ... Locally define blech ....................................................
 265
 266 $warn = undef;
 267 {
 268  local $SIG{__WARN__} = sub { $warn = $_[0] =~ /Subroutine\s+\S+redefined/ };
 269  local *blech = sub { $blech = 2 * $_[0] };
 270  blech(9);
 271 }
 272 _got_ok('compiling to blech(9)');
 273 is($blech, 18, 'new blech really was executed');
 274 is($warn, undef, 'no redefine warning');
 275
 276 # ... But now they aren't anymore .............................................
 277
 278 eval "qux";
 279 _got_bareword('qux', 1, eval => 1);
 280
 281 eval "blech";
 282 _got_undefined('blech', 1, eval => 1);
 283
 284 # ... How's my symbol table, Doug Hastings? ...................................
 285
 286 {
 287  no strict qw<refs subs>;
 288  is(*{::feh}{CODE}, undef, 'feh isn\'t defined');
 289  is(*{::feh}{CODE}, undef, 'feh isn\'t defined, really');
 290  isnt(*{::yay}{CODE}, undef, 'yay is defined');
 291  isnt(*{::foo}{CODE}, undef, 'foo is defined'); # calls foo
 292  is($foo, '::foo', 'foo was called');
 293  is(*{::flip}{CODE}, undef, 'flip isn\'t defined');
 294  isnt(*{::flop}{CODE}, undef, 'flop is defined');
 295  is(*{::qux}{CODE}, undef, 'qux isn\'t defined');
 296  isnt(*{::blech}{CODE}, undef, 'blech is defined');
 297  isnt(*{::wut}{CODE}, undef, 'wut is defined');
 298 }
 299
 300 # ... Declareth thy oneth thad shalt be .......................................
 301
 302 sub blech;
 303 eval { blech };
 304 _got_undefined('blech', __LINE__-1);
 305
 306 sub flop;
 307
 308 bar();
 309 is($bar, 1, 'bar ok');
 310
 311 sub wut { $wut = ($_[0] || 0) + length($_[1] || ''); '::wut' }
 312
 313 sub yay { @yay = @_; '::yay' }
 314
 315 # === Restarting from there ===================================================
 316 use subs::auto;
 317
 318 # ... How does the pragma propagates through eval STRING? .....................
 319
 320 eval "no subs::auto; meh";
 321 _got_bareword("meh", 1, eval => 1);
 322 # eval "use subs::auto; meh";
 323 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
 324 # eval "meh";
 325 # _got_undefined('meh', 1, eval => 1, todo => 'Fails because of some bug in perl or Variable::Magic');
 326
 327 # ... Try filehandles .........................................................
 328
 329 my $buf = '';
 330 {
 331  no subs::auto;
 332  open DONGS, '>', \$buf or die "open-in-memory: $!";
 333 }
 334 print DONGS "hlagh\n";
 335 is($buf, "hlagh\n", 'filehandles should\'t be touched');
 336 close DONGS;
 337
 338 # ... Try default filehandles .................................................
 339
 340 seek DATA, 0, 1;
 341 my @fruits = <DATA>;
 342 chomp @fruits;
 343 is_deeply(\@fruits, [ qw<apple pear banana> ], 'DATA filehandle ok');
 344
 345 # ... Retest foo (declared and defined inside) ................................
 346
 347 eval { foo 7, 9, { } };
 348 _got_ok('compiling to foo(7,9,{})');
 349 is($foo, 16, 'foo really was executed');
 350
 351 eval { foo(8, 10, { }) };
 352 _got_ok('compiling to foo(8,10,{})');
 353 is($foo, 18, 'foo() really was executed');
 354
 355 eval { local @_ = (9, 11, { }); &foo };
 356 _got_ok('compiling to foo(9,11,{})');
 357 is($foo, 20, '&foo really was executed');
 358
 359 eval { &foo(10, 12, { }) };
 360 _got_ok('compiling to foo(10,12,{})');
 361 is($foo, 22, '&foo() really was executed');
 362
 363 # ... Retest blech (declared outside, not defined) ............................
 364
 365 eval { blech };
 366 _got_undefined('blech', __LINE__-1);
 367
 368 eval { blech() };
 369 _got_undefined('blech', __LINE__-1);
 370
 371 eval { &blech };
 372 _got_undefined('blech', __LINE__-1);
 373
 374 eval { &blech() };
 375 _got_undefined('blech', __LINE__-1);
 376
 377 # ... Try _ in a filetest .....................................................
 378
 379 ok(-f $0 && -r _, '-X _');
 380
 381 __DATA__
 382 apple
 383 pear
 384 banana