t/20-good.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 use Test::More tests => 109 * 8 + 10;
  13
  14 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
  15
  16 my ($obj, $pkg, $cb, $x, @a);
  17 our ($y, $meth);
  18 sub meh;
  19 sub zap (&);
  20
  21 my @warns;
  22
  23 sub try {
  24  my ($code) = @_;
  25
  26  @warns = ();
  27  {
  28   local $SIG{__WARN__} = sub { push @warns, @_ };
  29   eval $code;
  30  }
  31 }
  32
  33 {
  34  local $/ = "####";
  35  while (<DATA>) {
  36   chomp;
  37   s/\s*$//;
  38   s/(.*?)$//m;
  39   my ($skip, $prefix) = split /#+/, $1;
  40   $skip   = 0  unless defined $skip;
  41   $prefix = '' unless defined $prefix;
  42   s/\s*//;
  43
  44 SKIP:
  45   {
  46    skip "$_: $skip" => 8 if eval $skip;
  47
  48    {
  49     try "return; $prefix; use indirect; $_";
  50     is $@,     '', "use indirect: $_";
  51     is @warns, 0,  'no reports';
  52
  53     try "return; $prefix; no indirect; $_";
  54     is $@,     '', "no indirect: $_";
  55     is @warns, 0,  'no reports';
  56    }
  57
  58    {
  59     local $_ = $_;
  60     s/Hlagh/Dongs/g;
  61
  62     try "return; $prefix; use indirect; $_";
  63     is $@,     '', "use indirect, defined: $_";
  64     is @warns, 0,  'no reports';
  65
  66     try "return; $prefix; no indirect; $_";
  67     is $@,     '', "no indirect, defined: $_";
  68     is @warns, 0,  'no reports';
  69    }
  70   }
  71  }
  72 }
  73
  74 # These tests must be run outside of eval to be meaningful.
  75 {
  76  sub Zlott::Owww::new { }
  77
  78  my (@warns, $hook, $desc, $id);
  79  BEGIN {
  80   $hook = sub { push @warns, indirect::msg(@_) };
  81   $desc = "test sort and line endings %d: no indirect construct";
  82   $id   = 1;
  83  }
  84
  85  BEGIN { @warns = () }
  86  {
  87   no indirect hook => $hook;
  88   my @stuff = sort Zlott::Owww
  89           ->new;
  90  }
  91  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
  92
  93  BEGIN { @warns = () }
  94  {
  95   no indirect hook => $hook;
  96   my @stuff = sort Zlott::Owww
  97                ->new;
  98  };
  99  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 100
 101  BEGIN { @warns = () }
 102  {
 103   no indirect hook => $hook;
 104   my @stuff = sort Zlott::Owww
 105                  ->new;
 106  }
 107  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 108
 109  BEGIN { @warns = () }
 110  {
 111   no indirect hook => $hook;
 112   my @stuff = sort Zlott::Owww
 113                   ->new;
 114  }
 115  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 116
 117  BEGIN { @warns = () }
 118  {
 119   no indirect hook => $hook;
 120   my @stuff = sort Zlott::Owww
 121                    ->new;
 122  }
 123  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 124
 125  BEGIN { @warns = () }
 126  {
 127   no indirect hook => $hook;
 128   my @stuff = sort Zlott::Owww
 129                      ->new;
 130  }
 131  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 132
 133  BEGIN { @warns = () }
 134  {
 135   no indirect hook => $hook;
 136   my @stuff = sort Zlott::Owww
 137                        ->new;
 138  }
 139  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 140
 141  BEGIN { @warns = () }
 142  {
 143   no indirect hook => $hook;
 144   my @stuff = sort Zlott::Owww
 145                           ->new;
 146  }
 147  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 148
 149  BEGIN { @warns = () }
 150  {
 151   no indirect hook => $hook;
 152   my @stuff = sort Zlott::Owww
 153                             ->new;
 154  }
 155  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 156
 157  BEGIN { @warns = () }
 158  {
 159   no indirect hook => $hook;
 160   my @stuff = sort Zlott::Owww
 161                              ->new;
 162  }
 163  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
 164 }
 165
 166 __DATA__
 167
 168 $obj = Hlagh->new;
 169 ####
 170 $obj = Hlagh->new();
 171 ####
 172 $obj = Hlagh->new(1);
 173 ####
 174 $obj = Hlagh->new(q{foo}, bar => $obj);
 175 ####
 176 $obj = Hlagh   ->   new   ;
 177 ####
 178 $obj = Hlagh   ->   new   (   )   ;
 179 ####
 180 $obj = Hlagh   ->   new   (   1   )   ;
 181 ####
 182 $obj = Hlagh   ->   new   (   'foo'   ,   bar =>   $obj   );
 183 ####
 184 $obj = Hlagh
 185             ->
 186                           new   ;
 187 ####
 188 $obj = Hlagh
 189
 190       ->
 191 new   (
 192  )   ;
 193 ####
 194 $obj = Hlagh
 195                                        ->   new   (
 196                1   )   ;
 197 ####
 198 $obj = Hlagh   ->
 199                               new   (   "foo"
 200   ,    bar
 201                =>        $obj       );
 202 ####
 203 $obj = new->new;
 204 ####
 205 $obj = new->new; # new new
 206 ####
 207 $obj = new->newnew;
 208 ####
 209 $obj = newnew->new;
 210 ####
 211 $obj = Hlagh->$cb;
 212 ####
 213 $obj = Hlagh->$cb();
 214 ####
 215 $obj = Hlagh->$cb($pkg);
 216 ####
 217 $obj = Hlagh->$cb(sub { 'foo' },  bar => $obj);
 218 ####
 219 $obj = Hlagh->$meth;
 220 ####
 221 $obj =   Hlagh
 222    ->
 223           $meth   ( 1,   2   );
 224 ####
 225 $obj = $pkg->new   ;
 226 ####
 227 $obj = $pkg  ->   new  (   );
 228 ####
 229 $obj = $pkg
 230            ->
 231         new ( $pkg );
 232 ####
 233 $obj =
 234          $pkg
 235 ->
 236 new        (     qr/foo/,
 237       foo => qr/bar/   );
 238 ####
 239 $obj
 240   =
 241 $pkg
 242 ->
 243 $cb
 244 ;
 245 ####
 246 $obj = $pkg    ->   ($cb)   ();
 247 ####
 248 $obj = $pkg->$cb( $obj  );
 249 ####
 250 $obj = $pkg->$cb(qw<foo bar baz>);
 251 ####
 252 $obj = $pkg->$meth;
 253 ####
 254 $obj
 255  =
 256     $pkg
 257           ->
 258               $meth
 259   ( 1 .. 10 );
 260 ####
 261 $obj = $y->$cb;
 262 ####
 263 $obj =  $y
 264   ->          $cb   (
 265   'foo', 1, 2, 'bar'
 266 );
 267 ####
 268 $obj = $y->$meth;
 269 ####
 270 $obj =
 271   $y->
 272       $meth   (
 273  qr(hello),
 274 );
 275 ####
 276 meh;
 277 ####
 278 meh $_;
 279 ####
 280 meh $x;
 281 ####
 282 meh $x, 1, 2;
 283 ####
 284 meh $y;
 285 ####
 286 meh $y, 1, 2;
 287 #### "$]" < 5.010 # use feature 'state'; state $z
 288 meh $z;
 289 #### "$]" < 5.010 # use feature 'state'; state $z
 290 meh $z, 1, 2;
 291 ####
 292 print;
 293 ####
 294 print $_;
 295 ####
 296 print $x;
 297 ####
 298 print $x "oh hai\n";
 299 ####
 300 print $y;
 301 ####
 302 print $y "dongs\n";
 303 #### "$]" < 5.010 # use feature 'state'; state $z
 304 print $z;
 305 #### "$]" < 5.010 # use feature 'state'; state $z
 306 print $z "hlagh\n";
 307 ####
 308 print STDOUT "bananananananana\n";
 309 ####
 310 $x->foo($pkg->$cb)
 311 ####
 312 $obj = "apple ${\($x->new)} pear"
 313 ####
 314 $obj = "apple @{[$x->new]} pear"
 315 ####
 316 $obj = "apple ${\($y->new)} pear"
 317 ####
 318 $obj = "apple @{[$y->new]} pear"
 319 ####
 320 $obj = "apple ${\($x->$cb)} pear"
 321 ####
 322 $obj = "apple @{[$x->$cb]} pear"
 323 ####
 324 $obj = "apple ${\($y->$cb)} pear"
 325 ####
 326 $obj = "apple @{[$y->$cb]} pear"
 327 ####
 328 $obj = "apple ${\($x->$meth)} pear"
 329 ####
 330 $obj = "apple @{[$x->$meth]} pear"
 331 ####
 332 $obj = "apple ${\($y->$meth)} pear"
 333 ####
 334 $obj = "apple @{[$y->$meth]} pear"
 335 #### # local $_ = "foo";
 336 s/foo/return; Hlagh->new/e;
 337 #### # local $_ = "bar";
 338 s/foo/return; Hlagh->new/e;
 339 #### # local $_ = "foo";
 340 s/foo/return; Hlagh->$cb/e;
 341 #### # local $_ = "bar";
 342 s/foo/return; Hlagh->$cb/e;
 343 #### # local $_ = "foo";
 344 s/foo/return; Hlagh->$meth/e;
 345 #### # local $_ = "bar";
 346 s/foo/return; Hlagh->$meth/e;
 347 #### # local $_ = "foo";
 348 s/foo/return; $x->new/e;
 349 #### # local $_ = "bar";
 350 s/foo/return; $x->new/e;
 351 #### # local $_ = "foo";
 352 s/foo/return; $x->$cb/e;
 353 #### # local $_ = "bar";
 354 s/foo/return; $x->$cb/e;
 355 #### # local $_ = "foo";
 356 s/foo/return; $x->$meth/e;
 357 #### # local $_ = "bar";
 358 s/foo/return; $x->$meth/e;
 359 #### # local $_ = "foo";
 360 s/foo/return; $y->new/e;
 361 #### # local $_ = "bar";
 362 s/foo/return; $y->new/e;
 363 #### # local $_ = "foo";
 364 s/foo/return; $y->$cb/e;
 365 #### # local $_ = "bar";
 366 s/foo/return; $y->$cb/e;
 367 #### # local $_ = "foo";
 368 s/foo/return; $y->$meth/e;
 369 #### # local $_ = "bar";
 370 s/foo/return; $y->$meth/e;
 371 ####
 372 "foo" =~ /(?{Hlagh->new})/;
 373 ####
 374 "foo" =~ /(?{Hlagh->$cb})/;
 375 ####
 376 "foo" =~ /(?{Hlagh->$meth})/;
 377 ####
 378 "foo" =~ /(?{$x->new})/;
 379 ####
 380 "foo" =~ /(?{$x->$cb})/;
 381 ####
 382 "foo" =~ /(?{$x->$meth})/;
 383 ####
 384 "foo" =~ /(?{$y->new})/;
 385 ####
 386 "foo" =~ /(?{$y->$cb})/;
 387 ####
 388 "foo" =~ /(?{$y->$meth})/;
 389 ####
 390 exec $x $x, @a;
 391 ####
 392 exec { $a[0] } @a;
 393 ####
 394 system $x $x, @a;
 395 ####
 396 system { $a[0] } @a;
 397 ####
 398 zap { };
 399 ####
 400 zap { 1; };
 401 ####
 402 zap { 1; 1; };
 403 ####
 404 zap { zap { }; 1; };
 405 ####
 406 my @stuff = sort Hlagh
 407      ->new;
 408 ####
 409 my @stuff = sort Hlagh
 410               ->new;
 411 ####
 412 my @stuff = sort Hlagh
 413                ->new;
 414 ####
 415 my @stuff = sort Hlagh
 416                 ->new;
 417 ####
 418 my @stuff = sort Hlagh
 419                  ->new;
 420 ####
 421 my @stuff = sort Hlagh
 422                    ->new;
 423 ####
 424 my @stuff = sort Hlagh
 425                      ->new;
 426 ####
 427 my @stuff = sort Hlagh
 428                         ->new;