t/21-bad.t

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