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) + 4;
  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 @warns;
 120  {
 121   local $SIG{__WARN__} = sub { push @warns, @_ };
 122   eval "return; no indirect 'hlagh'; \$obj = new Hlagh1;";
 123  }
 124  is        $@,      '',  'no indirect "hlagh" didn\'t croak';
 125  is        @warns,  1,   'only one warning';
 126  my $warn = shift @warns;
 127  like      $warn,   qr/^Indirect call of method "new" on object "Hlagh1"/,
 128                          'no indirect "hlagh" enables the pragma';
 129  is_deeply \@warns, [ ], 'nothing more';
 130 }
 131
 132 __DATA__
 133
 134 $obj = new Hlagh;
 135 ----
 136 [ 'new', 'Hlagh' ]
 137 ####
 138 $obj = new Hlagh if 0;
 139 ----
 140 [ 'new', 'Hlagh' ]
 141 ####
 142 $obj = new Hlagh();
 143 ----
 144 [ 'new', 'Hlagh' ]
 145 ####
 146 $obj = new Hlagh(1);
 147 ----
 148 [ 'new', 'Hlagh' ]
 149 ####
 150 $obj = new Hlagh(1, 2);
 151 ----
 152 [ 'new', 'Hlagh' ]
 153 ####
 154 $obj = new        Hlagh            ;
 155 ----
 156 [ 'new', 'Hlagh' ]
 157 ####
 158 $obj = new        Hlagh     (      )      ;
 159 ----
 160 [ 'new', 'Hlagh' ]
 161 ####
 162 $obj = new        Hlagh     (      1        )     ;
 163 ----
 164 [ 'new', 'Hlagh' ]
 165 ####
 166 $obj = new        Hlagh     (      1        ,       2        )     ;
 167 ----
 168 [ 'new', 'Hlagh' ]
 169 ####
 170 $obj = new
 171                       Hlagh
 172         ;
 173 ----
 174 [ 'new', 'Hlagh' ]
 175 ####
 176 $obj = new
 177                                        Hlagh     (
 178                   )      ;
 179 ----
 180 [ 'new', 'Hlagh' ]
 181 ####
 182 $obj =
 183               new
 184     Hlagh     (      1
 185             )     ;
 186 ----
 187 [ 'new', 'Hlagh' ]
 188 ####
 189 $obj =
 190 new
 191 Hlagh
 192                    (      1        ,
 193                 2        )     ;
 194 ----
 195 [ 'new', 'Hlagh' ]
 196 ####
 197 $obj = new $x;
 198 ----
 199 [ 'new', '$x' ]
 200 ####
 201 $obj = new $x();
 202 ----
 203 [ 'new', '$x' ]
 204 ####
 205 $obj = new $x('foo');
 206 ----
 207 [ 'new', '$x' ]
 208 ####
 209 $obj = new $x qq{foo}, 1;
 210 ----
 211 [ 'new', '$x' ]
 212 ####
 213 $obj = new $x qr{foo\s+bar}, 1 .. 1;
 214 ----
 215 [ 'new', '$x' ]
 216 ####
 217 $obj = new $x(qw/bar baz/);
 218 ----
 219 [ 'new', '$x' ]
 220 ####
 221 $obj = new
 222           $_;
 223 ----
 224 [ 'new', '$_' ]
 225 ####
 226 $obj = new
 227              $_     (        );
 228 ----
 229 [ 'new', '$_' ]
 230 ####
 231 $obj = new $_      qr/foo/  ;
 232 ----
 233 [ 'new', '$_' ]
 234 ####
 235 $obj = new $_     qq(bar baz);
 236 ----
 237 [ 'new', '$_' ]
 238 ####
 239 meh $_;
 240 ----
 241 [ 'meh', '$_' ]
 242 ####
 243 meh $_ 1, 2;
 244 ----
 245 [ 'meh', '$_' ]
 246 ####
 247 meh $$;
 248 ----
 249 [ 'meh', '$$' ]
 250 ####
 251 meh $$ 1, 2;
 252 ----
 253 [ 'meh', '$$' ]
 254 ####
 255 meh $x;
 256 ----
 257 [ 'meh', '$x' ]
 258 ####
 259 meh $x 1, 2;
 260 ----
 261 [ 'meh', '$x' ]
 262 ####
 263 meh $x, 1, 2;
 264 ----
 265 [ 'meh', '$x' ]
 266 ####
 267 meh $y;
 268 ----
 269 [ 'meh', '$y' ]
 270 ####
 271 meh $y 1, 2;
 272 ----
 273 [ 'meh', '$y' ]
 274 ####
 275 meh $y, 1, 2;
 276 ----
 277 [ 'meh', '$y' ]
 278 #### $] < 5.010 # use feature 'state'; state $z
 279 meh $z;
 280 ----
 281 [ 'meh', '$z' ]
 282 #### $] < 5.010 # use feature 'state'; state $z
 283 meh $z 1, 2;
 284 ----
 285 [ 'meh', '$z' ]
 286 #### $] < 5.010 # use feature 'state'; state $z
 287 meh $z, 1, 2;
 288 ----
 289 [ 'meh', '$z' ]
 290 ####
 291 package sploosh;
 292 our $sploosh;
 293 meh $sploosh::sploosh;
 294 ----
 295 [ 'meh', '$sploosh::sploosh' ]
 296 ####
 297 package sploosh;
 298 our $sploosh;
 299 meh $sploosh;
 300 ----
 301 [ 'meh', '$sploosh' ]
 302 ####
 303 package sploosh;
 304 meh $main::bloop;
 305 ----
 306 [ 'meh', '$main::bloop' ]
 307 ####
 308 package sploosh;
 309 meh $bloop;
 310 ----
 311 [ 'meh', '$bloop' ]
 312 ####
 313 package ma;
 314 meh $bloop;
 315 ----
 316 [ 'meh', '$bloop' ]
 317 ####
 318 package sploosh;
 319 our $sploosh;
 320 package main;
 321 meh $sploosh::sploosh;
 322 ----
 323 [ 'meh', '$sploosh::sploosh' ]
 324 ####
 325 new Hlagh->wut;
 326 ----
 327 [ 'new', 'Hlagh' ]
 328 ####
 329 new Hlagh->wut();
 330 ----
 331 [ 'new', 'Hlagh' ]
 332 ####
 333 new Hlagh->wut, "Wut";
 334 ----
 335 [ 'new', 'Hlagh' ]
 336 ####
 337 $obj = HlaghHlagh Hlagh;
 338 ----
 339 [ 'HlaghHlagh', 'Hlagh' ]
 340 ####
 341 $obj = HlaghHlagh Hlagh; # HlaghHlagh Hlagh
 342 ----
 343 [ 'HlaghHlagh', 'Hlagh' ]
 344 ####
 345 $obj = new newnew;
 346 ----
 347 [ 'new', 'newnew' ]
 348 ####
 349 $obj = new newnew; # new newnew
 350 ----
 351 [ 'new', 'newnew' ]
 352 ####
 353 $obj = feh feh;
 354 ----
 355 [ 'feh', 'feh' ]
 356 ####
 357 $obj = feh feh; # feh feh
 358 ----
 359 [ 'feh', 'feh' ]
 360 ####
 361 new Hlagh (meh $x)
 362 ----
 363 [ 'meh', '$x' ], [ 'new', 'Hlagh' ]
 364 ####
 365 Hlagh->new(meh $x)
 366 ----
 367 [ 'meh', '$x' ]
 368 ####
 369 meh { };
 370 ----
 371 [ 'meh', '{' ]
 372 ####
 373 meh {
 374  1;
 375 };
 376 ----
 377 [ 'meh', '{' ]
 378 ####
 379 meh {
 380  1;
 381  1;
 382 };
 383 ----
 384 [ 'meh', '{' ]
 385 ####
 386 meh { new Hlagh; 1; };
 387 ----
 388 [ 'new', 'Hlagh' ], [ 'meh', '{' ]
 389 ####
 390 meh { feh $x; 1; };
 391 ----
 392 [ 'feh', '$x' ], [ 'meh', '{' ]
 393 ####
 394 meh { feh $x; use indirect; new Hlagh; 1; };
 395 ----
 396 [ 'feh', '$x' ], [ 'meh', '{' ]
 397 ####
 398 meh { feh $y; 1; };
 399 ----
 400 [ 'feh', '$y' ], [ 'meh', '{' ]
 401 ####
 402 meh { feh $x; 1; } new Hlagh, feh $y;
 403 ----
 404 [ 'feh', '$x' ], [ 'new', 'Hlagh' ], [ 'feh', '$y' ], [ 'meh', '{' ]