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