t/21-bad.t

   1 #!perl -T
   2
   3 package NotEmpty;
   4
   5 sub new;
   6
   7 package main;
   8
   9 use strict;
  10 use warnings;
  11
  12 my ($tests, $reports);
  13 BEGIN {
  14  $tests   = 84;
  15  $reports = 96;
  16 }
  17
  18 use Test::More tests => 3 * (4 * $tests + $reports) + 4;
  19
  20 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
  21
  22 my ($obj, $x);
  23 our ($y, $bloop);
  24
  25 sub expect {
  26  my ($expected) = @_;
  27
  28  die unless $expected;
  29
  30  map {
  31   my ($meth, $obj, $file, $line) = @$_;
  32   $meth = quotemeta $meth;
  33   $obj  = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\"";
  34   $file = '\((?:re_)?eval \d+\)' unless defined $file;
  35   $line = '\d+'                  unless defined $line;
  36   qr/^Indirect call of method "$meth" on $obj at $file line $line/
  37  } eval $expected;
  38 }
  39
  40 my @warns;
  41
  42 sub try {
  43  my ($code) = @_;
  44
  45  @warns = ();
  46  {
  47   local $SIG{__WARN__} = sub { push @warns, @_ };
  48   eval $code;
  49  }
  50 }
  51
  52 {
  53  local $/ = "####";
  54  while (<DATA>) {
  55   chomp;
  56   s/\s*$//;
  57   s/(.*?)$//m;
  58   my ($skip, $prefix) = split /#+/, $1;
  59   $skip   = 0  unless defined $skip;
  60   $prefix = '' unless defined $prefix;
  61   s/\s*//;
  62
  63 SKIP:
  64   {
  65    if (do { local $@; eval $skip }) {
  66     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
  67     my @expected = expect($expected);
  68     skip "$_: $skip" => 3 * (4 + @expected);
  69    }
  70
  71    {
  72     local $_ = $_;
  73     s/Pkg/Empty/g;
  74     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
  75     my @expected = expect($expected);
  76
  77     try "return; $prefix; use indirect; $code";
  78     is $@,     '', "use indirect: $code";
  79     is @warns, 0,  'correct number of reports';
  80
  81     try "return; $prefix; no indirect; $code";
  82     is $@,     '',        "no indirect: $code";
  83     is @warns, @expected, 'correct number of reports';
  84     for my $i (0 .. $#expected) {
  85      like $warns[$i], $expected[$i], "report $i is correct";
  86     }
  87    }
  88
  89    {
  90     local $_ = $_;
  91     s/Pkg/NotEmpty/g;
  92     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
  93     my @expected = expect($expected);
  94
  95     try "return; $prefix; use indirect; $code";
  96     is $@,     '', "use indirect, defined: $code";
  97     is @warns, 0,  'correct number of reports';
  98
  99     try "return; $prefix; no indirect; $code";
 100     is $@,     '',        "no indirect, defined: $code";
 101     is @warns, @expected, 'correct number of reports';
 102     for my $i (0 .. $#expected) {
 103      like $warns[$i], $expected[$i], "report $i is correct";
 104     }
 105    }
 106
 107 SKIP:
 108    {
 109     local $_ = $_;
 110     s/Pkg/Empty/g;
 111     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
 112     my @expected = expect($expected);
 113     skip 'No space tests on perl 5.11' => 4 + @expected
 114                                               if "$]" >= 5.011 and "$]" < 5.012;
 115     $code =~ s/\$/\$ \n\t /g;
 116
 117     try "return; $prefix; use indirect; $code";
 118     is $@,     '', "use indirect, spaces: $code";
 119     is @warns, 0,  'correct number of reports';
 120
 121     try "return; $prefix; no indirect; $code";
 122     is $@,     '',        "no indirect, spaces: $code";
 123     is @warns, @expected, 'correct number of reports';
 124     for my $i (0 .. $#expected) {
 125      like $warns[$i], $expected[$i], "report $i is correct";
 126     }
 127    }
 128   }
 129  }
 130 }
 131
 132 eval {
 133  my @warns;
 134  {
 135   local $SIG{__WARN__} = sub { push @warns, @_ };
 136   eval "return; no indirect 'whatever'; \$obj = new Pkg1;";
 137  }
 138  is        $@,      '',  'no indirect "whatever" didn\'t croak';
 139  is        @warns,  1,   'only one warning';
 140  my $warn = shift @warns;
 141  like      $warn,   qr/^Indirect call of method "new" on object "Pkg1"/,
 142                          'no indirect "whatever" enables the pragma';
 143  is_deeply \@warns, [ ], 'nothing more';
 144 }
 145
 146 __DATA__
 147
 148 $obj = new Pkg;
 149 ----
 150 [ 'new', 'Pkg' ]
 151 ####
 152 $obj = new Pkg if 0;
 153 ----
 154 [ 'new', 'Pkg' ]
 155 ####
 156 $obj = new Pkg();
 157 ----
 158 [ 'new', 'Pkg' ]
 159 ####
 160 $obj = new Pkg(1);
 161 ----
 162 [ 'new', 'Pkg' ]
 163 ####
 164 $obj = new Pkg(1, 2);
 165 ----
 166 [ 'new', 'Pkg' ]
 167 ####
 168 $obj = new        Pkg            ;
 169 ----
 170 [ 'new', 'Pkg' ]
 171 ####
 172 $obj = new        Pkg     (      )      ;
 173 ----
 174 [ 'new', 'Pkg' ]
 175 ####
 176 $obj = new        Pkg     (      1        )     ;
 177 ----
 178 [ 'new', 'Pkg' ]
 179 ####
 180 $obj = new        Pkg     (      1        ,       2        )     ;
 181 ----
 182 [ 'new', 'Pkg' ]
 183 ####
 184 $obj = new
 185                       Pkg
 186         ;
 187 ----
 188 [ 'new', 'Pkg' ]
 189 ####
 190 $obj = new
 191                                        Pkg     (
 192                   )      ;
 193 ----
 194 [ 'new', 'Pkg' ]
 195 ####
 196 $obj =
 197               new
 198     Pkg     (      1
 199             )     ;
 200 ----
 201 [ 'new', 'Pkg' ]
 202 ####
 203 $obj =
 204 new
 205 Pkg
 206                    (      1        ,
 207                 2        )     ;
 208 ----
 209 [ 'new', 'Pkg' ]
 210 ####
 211 $obj = new $x;
 212 ----
 213 [ 'new', '$x' ]
 214 ####
 215 $obj = new $x();
 216 ----
 217 [ 'new', '$x' ]
 218 ####
 219 $obj = new $x('foo');
 220 ----
 221 [ 'new', '$x' ]
 222 ####
 223 $obj = new $x qq{foo}, 1;
 224 ----
 225 [ 'new', '$x' ]
 226 ####
 227 $obj = new $x qr{foo\s+bar}, 1 .. 1;
 228 ----
 229 [ 'new', '$x' ]
 230 ####
 231 $obj = new $x(qw<bar baz>);
 232 ----
 233 [ 'new', '$x' ]
 234 ####
 235 $obj = new
 236           $_;
 237 ----
 238 [ 'new', '$_' ]
 239 ####
 240 $obj = new
 241              $_     (        );
 242 ----
 243 [ 'new', '$_' ]
 244 ####
 245 $obj = new $_      qr/foo/  ;
 246 ----
 247 [ 'new', '$_' ]
 248 ####
 249 $obj = new $_     qq(bar baz);
 250 ----
 251 [ 'new', '$_' ]
 252 ####
 253 meh $_;
 254 ----
 255 [ 'meh', '$_' ]
 256 ####
 257 meh $_ 1, 2;
 258 ----
 259 [ 'meh', '$_' ]
 260 ####
 261 meh $$;
 262 ----
 263 [ 'meh', '$$' ]
 264 ####
 265 meh $$ 1, 2;
 266 ----
 267 [ 'meh', '$$' ]
 268 ####
 269 meh $x;
 270 ----
 271 [ 'meh', '$x' ]
 272 ####
 273 meh $x 1, 2;
 274 ----
 275 [ 'meh', '$x' ]
 276 ####
 277 meh $x, 1, 2;
 278 ----
 279 [ 'meh', '$x' ]
 280 ####
 281 meh $y;
 282 ----
 283 [ 'meh', '$y' ]
 284 ####
 285 meh $y 1, 2;
 286 ----
 287 [ 'meh', '$y' ]
 288 ####
 289 meh $y, 1, 2;
 290 ----
 291 [ 'meh', '$y' ]
 292 #### "$]" < 5.010 # use feature 'state'; state $z
 293 meh $z;
 294 ----
 295 [ 'meh', '$z' ]
 296 #### "$]" < 5.010 # use feature 'state'; state $z
 297 meh $z 1, 2;
 298 ----
 299 [ 'meh', '$z' ]
 300 #### "$]" < 5.010 # use feature 'state'; state $z
 301 meh $z, 1, 2;
 302 ----
 303 [ 'meh', '$z' ]
 304 ####
 305 package sploosh;
 306 our $sploosh;
 307 meh $sploosh::sploosh;
 308 ----
 309 [ 'meh', '$sploosh::sploosh' ]
 310 ####
 311 package sploosh;
 312 our $sploosh;
 313 meh $sploosh;
 314 ----
 315 [ 'meh', '$sploosh' ]
 316 ####
 317 package sploosh;
 318 meh $main::bloop;
 319 ----
 320 [ 'meh', '$main::bloop' ]
 321 ####
 322 package sploosh;
 323 meh $bloop;
 324 ----
 325 [ 'meh', '$bloop' ]
 326 ####
 327 package ma;
 328 meh $bloop;
 329 ----
 330 [ 'meh', '$bloop' ]
 331 ####
 332 package sploosh;
 333 our $sploosh;
 334 package main;
 335 meh $sploosh::sploosh;
 336 ----
 337 [ 'meh', '$sploosh::sploosh' ]
 338 ####
 339 new Pkg->wut;
 340 ----
 341 [ 'new', 'Pkg' ]
 342 ####
 343 new Pkg->wut();
 344 ----
 345 [ 'new', 'Pkg' ]
 346 ####
 347 new Pkg->wut, "Wut";
 348 ----
 349 [ 'new', 'Pkg' ]
 350 ####
 351 $obj = PkgPkg Pkg;
 352 ----
 353 [ 'PkgPkg', 'Pkg' ]
 354 ####
 355 $obj = PkgPkg Pkg; # PkgPkg Pkg
 356 ----
 357 [ 'PkgPkg', 'Pkg' ]
 358 ####
 359 $obj = new newnew;
 360 ----
 361 [ 'new', 'newnew' ]
 362 ####
 363 $obj = new newnew; # new newnew
 364 ----
 365 [ 'new', 'newnew' ]
 366 ####
 367 $obj = feh feh;
 368 ----
 369 [ 'feh', 'feh' ]
 370 ####
 371 $obj = feh feh; # feh feh
 372 ----
 373 [ 'feh', 'feh' ]
 374 ####
 375 new Pkg (meh $x)
 376 ----
 377 [ 'meh', '$x' ], [ 'new', 'Pkg' ]
 378 ####
 379 Pkg->new(meh $x)
 380 ----
 381 [ 'meh', '$x' ]
 382 ####
 383 $obj = "apple ${\(new Pkg)} pear"
 384 ----
 385 [ 'new', 'Pkg' ]
 386 ####
 387 $obj = "apple @{[new Pkg]} pear"
 388 ----
 389 [ 'new', 'Pkg' ]
 390 ####
 391 $obj = "apple ${\(new $x)} pear"
 392 ----
 393 [ 'new', '$x' ]
 394 ####
 395 $obj = "apple @{[new $x]} pear"
 396 ----
 397 [ 'new', '$x' ]
 398 ####
 399 $obj = "apple ${\(new $y)} pear"
 400 ----
 401 [ 'new', '$y' ]
 402 ####
 403 $obj = "apple @{[new $y]} pear"
 404 ----
 405 [ 'new', '$y' ]
 406 ####
 407 $obj = "apple ${\(new $x qq|${\(stuff $y)}|)} pear"
 408 ----
 409 [ 'stuff', '$y' ], [ 'new', '$x' ]
 410 ####
 411 $obj = "apple @{[new $x qq|@{[stuff $y]}|]} pear"
 412 ----
 413 [ 'stuff', '$y' ], [ 'new', '$x' ]
 414 #### # local $_ = "foo";
 415 s/foo/return; new Pkg/e;
 416 ----
 417 [ 'new', 'Pkg' ]
 418 #### # local $_ = "bar";
 419 s/foo/return; new Pkg/e;
 420 ----
 421 [ 'new', 'Pkg' ]
 422 #### # local $_ = "foo";
 423 s/foo/return; new $x/e;
 424 ----
 425 [ 'new', '$x' ]
 426 #### # local $_ = "bar";
 427 s/foo/return; new $x/e;
 428 ----
 429 [ 'new', '$x' ]
 430 #### # local $_ = "foo";
 431 s/foo/return; new $y/e;
 432 ----
 433 [ 'new', '$y' ]
 434 #### # local $_ = "bar";
 435 s/foo/return; new $y/e;
 436 ----
 437 [ 'new', '$y' ]
 438 ####
 439 "foo" =~ /(?{new Pkg})/;
 440 ----
 441 [ 'new', 'Pkg' ]
 442 ####
 443 "foo" =~ /(?{new $x})/;
 444 ----
 445 [ 'new', '$x' ]
 446 ####
 447 "foo" =~ /(?{new $y})/;
 448 ----
 449 [ 'new', '$y' ]
 450 ####
 451 "foo" =~ /(??{new Pkg})/;
 452 ----
 453 [ 'new', 'Pkg' ]
 454 ####
 455 "foo" =~ /(??{new $x})/;
 456 ----
 457 [ 'new', '$x' ]
 458 ####
 459 "foo" =~ /(??{new $y})/;
 460 ----
 461 [ 'new', '$y' ]
 462 ####
 463 meh { };
 464 ----
 465 [ 'meh', '{' ]
 466 ####
 467 meh {
 468  1;
 469 };
 470 ----
 471 [ 'meh', '{' ]
 472 ####
 473 meh {
 474  1;
 475  1;
 476 };
 477 ----
 478 [ 'meh', '{' ]
 479 ####
 480 meh { new Pkg; 1; };
 481 ----
 482 [ 'new', 'Pkg' ], [ 'meh', '{' ]
 483 ####
 484 meh { feh $x; 1; };
 485 ----
 486 [ 'feh', '$x' ], [ 'meh', '{' ]
 487 ####
 488 meh { feh $x; use indirect; new Pkg; 1; };
 489 ----
 490 [ 'feh', '$x' ], [ 'meh', '{' ]
 491 ####
 492 meh { feh $y; 1; };
 493 ----
 494 [ 'feh', '$y' ], [ 'meh', '{' ]
 495 ####
 496 meh { feh $x; 1; } new Pkg, feh $y;
 497 ----
 498 [ 'feh', '$x' ], [ 'new', 'Pkg' ], [ 'feh', '$y' ], [ 'meh', '{' ]
 499 ####
 500 $obj = "apple @{[new { feh $x; meh $y; 1 }]} pear"
 501 ----
 502 [ 'feh', '$x' ], [ 'meh', '$y' ], [ 'new', '{' ]
 503 ####
 504 package __PACKAGE_;
 505 new __PACKAGE_;
 506 ----
 507 [ 'new', '__PACKAGE_' ]
 508 ####
 509 package __PACKAGE___;
 510 new __PACKAGE___;
 511 ----
 512 [ 'new', '__PACKAGE___' ]