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