t/10-args.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 4 + 3 + 1;
   7
   8 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
   9
  10 sub expect {
  11  my ($pkg) = @_;
  12  qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/;
  13 }
  14
  15 {
  16  my @warns;
  17  {
  18   local $SIG{__WARN__} = sub { push @warns, "@_" };
  19   eval <<'  HERE';
  20    return;
  21    no indirect;
  22    my $x = new Warn1;
  23    $x = new Warn2;
  24   HERE
  25  }
  26  my $w1 = shift @warns;
  27  my $w2 = shift @warns;
  28  is             $@, '',              'didn\'t croak without arguments';
  29  like          $w1, expect('Warn1'), 'first warning caught without arguments';
  30  like          $w2, expect('Warn2'), 'second warning caught without arguments';
  31  is_deeply \@warns, [ ],             'no more warnings without arguments';
  32 }
  33
  34 for my $fatal (':fatal', 'FATAL', ':Fatal') {
  35  {
  36   local $SIG{__WARN__} = sub { die "warn:@_" };
  37   eval <<"  HERE";
  38    die qq{shouldn't even compile\n};
  39    no indirect '$fatal', hook => sub { die 'should not be called' };
  40    my \$x = new Croaked;
  41    \$x = new NotReached;
  42   HERE
  43  }
  44  like $@, expect('Croaked'), "croaks when $fatal is specified";
  45 }
  46
  47 {
  48  {
  49   local $SIG{__WARN__} = sub { "warn:@_" };
  50   eval <<'  HERE';
  51    die qq{shouldn't even compile\n};
  52    no indirect 'whatever', hook => sub { die 'hook:' . join(':', @_) . "\n" }, ':fatal';
  53    my $x = new Hooked;
  54    $x = new AlsoNotReached;
  55   HERE
  56  }
  57  like $@, qr/^hook:Hooked:new:\(eval\s+\d+\):\d+$/, 'calls the specified hook';
  58 }