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   = 61;
  15  $reports = 69;
  16 }
  17
  18 use Test::More tests => 3 * (4 * $tests + $reports) + 2;
  19
  20 my ($obj, $x);
  21 our ($y, $bloop);
  22
  23 sub expect {
  24  my ($expected) = @_;
  25
  26  die unless $expected;
  27
  28  map {
  29   my ($meth, $obj, $file, $line) = @$_;
  30   $meth = quotemeta $meth;
  31   $obj  = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\"";
  32   $file = '\(eval \d+\)' unless defined $file;
  33   $line = '\d+'          unless defined $line;
  34   qr/^Indirect call of method "$meth" on $obj at $file line $line/
  35  } eval $expected;
  36 }
  37
  38 my @warns;
  39
  40 sub try {
  41  my ($code) = @_;
  42
  43  @warns = ();
  44  {
  45   local $SIG{__WARN__} = sub { push @warns, @_ };
  46   eval $code;
  47  }
  48 }
  49
  50 {
  51  local $/ = "####";
  52  while (<DATA>) {
  53   chomp;
  54   s/\s*$//;
  55   s/(.*?)$//m;
  56   my ($skip, $prefix) = split /#+/, $1;
  57   $skip   = 0  unless defined $skip;
  58   $prefix = '' unless defined $prefix;
  59   s/\s*//;
  60
  61 SKIP:
  62   {
  63    my ($code, $expected) = split /^-{4,}$/m, $_, 2;
  64    my @expected = expect($expected);
  65
  66    skip "$_: $skip" => 3 * (4 + @expected) if eval $skip;
  67
  68    {
  69     try "return; $prefix; use indirect; $code";
  70     is $@,     '', "use indirect: $code";
  71     is @warns, 0,  'correct number of reports';
  72
  73     try "return; $prefix; no indirect; $code";
  74     is $@,     '',        "no indirect: $code";
  75     is @warns, @expected, 'correct number of reports';
  76     for my $i (0 .. $#expected) {
  77      like $warns[$i], $expected[$i], "report $i is correct";
  78     }
  79    }
  80
  81    {
  82     local $_ = $_;
  83     s/Hlagh/Dongs/g;
  84     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
  85     my @expected = expect($expected);
  86
  87     try "return; $prefix; use indirect; $code";
  88     is $@,     '', "use indirect, defined: $code";
  89     is @warns, 0,  'correct number of reports';
  90
  91     try "return; $prefix; no indirect; $code";
  92     is $@,     '',        "no indirect, defined: $code";
  93     is @warns, @expected, 'correct number of reports';
  94     for my $i (0 .. $#expected) {
  95      like $warns[$i], $expected[$i], "report $i is correct";
  96     }
  97    }
  98
  99    {
 100     my $code = $code;
 101     $code =~ s/\$/\$ \n\t /g;
 102
 103     try "return; $prefix; use indirect; $code";
 104     is $@,     '', "use indirect, spaces: $code";
 105     is @warns, 0,  'correct number of reports';
 106
 107     try "return; $prefix; no indirect; $code";
 108     is $@,     '',        "no indirect, spaces: $code";
 109     is @warns, @expected, 'correct number of reports';
 110     for my $i (0 .. $#expected) {
 111      like $warns[$i], $expected[$i], "report $i is correct";
 112     }
 113    }
 114   }
 115  }
 116 }
 117
 118 eval {
 119  my $warn;
 120  local $SIG{__WARN__} = sub { $warn = join ' ', @_ };
 121  eval "die qq{ok\n}; no indirect 'hlagh'; \$obj = new Hlagh1;";
 122  is($@, "ok\n", 'no indirect "hlagh" didn\'t croak');
 123  like($warn, qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"Hlagh1"/, 'no indirect "hlagh" enables the pragma');
 124 }
 125
 126 __DATA__
 127
 128 $obj = new Hlagh;
 129 ----
 130 [ 'new', 'Hlagh' ]
 131 ####
 132 $obj = new Hlagh if 0;
 133 ----
 134 [ 'new', 'Hlagh' ]
 135 ####
 136 $obj = new Hlagh();
 137 ----
 138 [ 'new', 'Hlagh' ]
 139 ####
 140 $obj = new Hlagh(1);
 141 ----
 142 [ 'new', 'Hlagh' ]
 143 ####
 144 $obj = new Hlagh(1, 2);
 145 ----
 146 [ 'new', 'Hlagh' ]
 147 ####
 148 $obj = new        Hlagh            ;
 149 ----
 150 [ 'new', 'Hlagh' ]
 151 ####
 152 $obj = new        Hlagh     (      )      ;
 153 ----
 154 [ 'new', 'Hlagh' ]
 155 ####
 156 $obj = new        Hlagh     (      1        )     ;
 157 ----
 158 [ 'new', 'Hlagh' ]
 159 ####
 160 $obj = new        Hlagh     (      1        ,       2        )     ;
 161 ----
 162 [ 'new', 'Hlagh' ]
 163 ####
 164 $obj = new
 165                       Hlagh
 166         ;
 167 ----
 168 [ 'new', 'Hlagh' ]
 169 ####
 170 $obj = new
 171                                        Hlagh     (
 172                   )      ;
 173 ----
 174 [ 'new', 'Hlagh' ]
 175 ####
 176 $obj =
 177               new
 178     Hlagh     (      1
 179             )     ;
 180 ----
 181 [ 'new', 'Hlagh' ]
 182 ####
 183 $obj =
 184 new
 185 Hlagh
 186                    (      1        ,
 187                 2        )     ;
 188 ----
 189 [ 'new', 'Hlagh' ]
 190 ####
 191 $obj = new $x;
 192 ----
 193 [ 'new', '$x' ]
 194 ####
 195 $obj = new $x();
 196 ----
 197 [ 'new', '$x' ]
 198 ####
 199 $obj = new $x('foo');
 200 ----
 201 [ 'new', '$x' ]
 202 ####
 203 $obj = new $x qq{foo}, 1;
 204 ----
 205 [ 'new', '$x' ]
 206 ####
 207 $obj = new $x qr{foo\s+bar}, 1 .. 1;
 208 ----
 209 [ 'new', '$x' ]
 210 ####
 211 $obj = new $x(qw/bar baz/);
 212 ----
 213 [ 'new', '$x' ]
 214 ####
 215 $obj = new
 216           $_;
 217 ----
 218 [ 'new', '$_' ]
 219 ####
 220 $obj = new
 221              $_     (        );
 222 ----
 223 [ 'new', '$_' ]
 224 ####
 225 $obj = new $_      qr/foo/  ;
 226 ----
 227 [ 'new', '$_' ]
 228 ####
 229 $obj = new $_     qq(bar baz);
 230 ----
 231 [ 'new', '$_' ]
 232 ####
 233 meh $_;
 234 ----
 235 [ 'meh', '$_' ]
 236 ####
 237 meh $_ 1, 2;
 238 ----
 239 [ 'meh', '$_' ]
 240 ####
 241 meh $$;
 242 ----
 243 [ 'meh', '$$' ]
 244 ####
 245 meh $$ 1, 2;
 246 ----
 247 [ 'meh', '$$' ]
 248 ####
 249 meh $x;
 250 ----
 251 [ 'meh', '$x' ]
 252 ####
 253 meh $x 1, 2;
 254 ----
 255 [ 'meh', '$x' ]
 256 ####
 257 meh $x, 1, 2;
 258 ----
 259 [ 'meh', '$x' ]
 260 ####
 261 meh $y;
 262 ----
 263 [ 'meh', '$y' ]
 264 ####
 265 meh $y 1, 2;
 266 ----
 267 [ 'meh', '$y' ]
 268 ####
 269 meh $y, 1, 2;
 270 ----
 271 [ 'meh', '$y' ]
 272 #### $] < 5.010 # use feature 'state'; state $z
 273 meh $z;
 274 ----
 275 [ 'meh', '$z' ]
 276 #### $] < 5.010 # use feature 'state'; state $z
 277 meh $z 1, 2;
 278 ----
 279 [ 'meh', '$z' ]
 280 #### $] < 5.010 # use feature 'state'; state $z
 281 meh $z, 1, 2;
 282 ----
 283 [ 'meh', '$z' ]
 284 ####
 285 package sploosh;
 286 our $sploosh;
 287 meh $sploosh::sploosh;
 288 ----
 289 [ 'meh', '$sploosh::sploosh' ]
 290 ####
 291 package sploosh;
 292 our $sploosh;
 293 meh $sploosh;
 294 ----
 295 [ 'meh', '$sploosh' ]
 296 ####
 297 package sploosh;
 298 meh $main::bloop;
 299 ----
 300 [ 'meh', '$main::bloop' ]
 301 ####
 302 package sploosh;
 303 meh $bloop;
 304 ----
 305 [ 'meh', '$bloop' ]
 306 ####
 307 package ma;
 308 meh $bloop;
 309 ----
 310 [ 'meh', '$bloop' ]
 311 ####
 312 package sploosh;
 313 our $sploosh;
 314 package main;
 315 meh $sploosh::sploosh;
 316 ----
 317 [ 'meh', '$sploosh::sploosh' ]
 318 ####
 319 new Hlagh->wut;
 320 ----
 321 [ 'new', 'Hlagh' ]
 322 ####
 323 new Hlagh->wut();
 324 ----
 325 [ 'new', 'Hlagh' ]
 326 ####
 327 new Hlagh->wut, "Wut";
 328 ----
 329 [ 'new', 'Hlagh' ]
 330 ####
 331 $obj = HlaghHlagh Hlagh;
 332 ----
 333 [ 'HlaghHlagh', 'Hlagh' ]
 334 ####
 335 $obj = HlaghHlagh Hlagh; # HlaghHlagh Hlagh
 336 ----
 337 [ 'HlaghHlagh', 'Hlagh' ]
 338 ####
 339 $obj = new newnew;
 340 ----
 341 [ 'new', 'newnew' ]
 342 ####
 343 $obj = new newnew; # new newnew
 344 ----
 345 [ 'new', 'newnew' ]
 346 ####
 347 $obj = feh feh;
 348 ----
 349 [ 'feh', 'feh' ]
 350 ####
 351 $obj = feh feh; # feh feh
 352 ----
 353 [ 'feh', 'feh' ]
 354 ####
 355 new Hlagh (meh $x)
 356 ----
 357 [ 'meh', '$x' ], [ 'new', 'Hlagh' ]
 358 ####
 359 Hlagh->new(meh $x)
 360 ----
 361 [ 'meh', '$x' ]
 362 ####
 363 meh { };
 364 ----
 365 [ 'meh', '{' ]
 366 ####
 367 meh {
 368  1;
 369 };
 370 ----
 371 [ 'meh', '{' ]
 372 ####
 373 meh {
 374  1;
 375  1;
 376 };
 377 ----
 378 [ 'meh', '{' ]
 379 ####
 380 meh { new Hlagh; 1; };
 381 ----
 382 [ 'new', 'Hlagh' ], [ 'meh', '{' ]
 383 ####
 384 meh { feh $x; 1; };
 385 ----
 386 [ 'feh', '$x' ], [ 'meh', '{' ]
 387 ####
 388 meh { feh $x; use indirect; new Hlagh; 1; };
 389 ----
 390 [ 'feh', '$x' ], [ 'meh', '{' ]
 391 ####
 392 meh { feh $y; 1; };
 393 ----
 394 [ 'feh', '$y' ], [ 'meh', '{' ]
 395 ####
 396 meh { feh $x; 1; } new Hlagh, feh $y;
 397 ----
 398 [ 'feh', '$x' ], [ 'new', 'Hlagh' ], [ 'feh', '$y' ], [ 'meh', '{' ]