t/20-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 use Test::More tests => 46 * 6 + 2;
  13
  14 my ($obj, $x);
  15 our ($y, $bloop);
  16
  17 sub expect {
  18  my ($pkg) = @_;
  19  return qr/^warn:Indirect call of method "(?:new|meh|$pkg$pkg)" on object "(?:$pkg|newnew|\$(?:[xy_\$]|(?:sploosh::)?sploosh|(?:main::)?bloop))"/
  20 }
  21
  22 {
  23  local $/ = "####\n";
  24  while (<DATA>) {
  25   chomp;
  26   s/\s*$//;
  27   local $SIG{__WARN__} = sub { die 'warn:' . join(' ', @_) };
  28   {
  29    use indirect;
  30    eval "die qq{ok\\n}; $_";
  31   }
  32   is($@, "ok\n", "use indirect: $_");
  33   {
  34    no indirect;
  35    eval "die qq{the code compiled but it shouldn't have\n}; $_";
  36   }
  37   like($@, expect('Hlagh'), "no indirect: $_");
  38   s/Hlagh/Dongs/g;
  39   {
  40    use indirect;
  41    eval "die qq{ok\\n}; $_";
  42   }
  43   is($@, "ok\n", "use indirect, defined: $_");
  44   {
  45    no indirect;
  46    eval "die qq{the code compiled but it shouldn't have\n}; $_";
  47   }
  48   like($@, expect('Dongs'), "no indirect, defined: $_");
  49   s/\$/\$ \n\t /g;
  50   s/Dongs/Hlagh/g;
  51   {
  52    use indirect;
  53    eval "die qq{ok\\n}; $_";
  54   }
  55   is($@, "ok\n", "use indirect, spaces: $_");
  56   {
  57    no indirect;
  58    eval "die qq{the code compiled but it shouldn't have\n}; $_";
  59   }
  60   like($@, expect('Hlagh'), "no indirect, spaces: $_");
  61  }
  62 }
  63
  64 eval {
  65  no indirect 'hlagh';
  66  my $warn;
  67  local $SIG{__WARN__} = sub { $warn = join ' ', @_ };
  68  eval "die qq{the code compiled but it shouldn't have\n}; \$obj = new Hlagh1;";
  69  like($warn, qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"Hlagh1"/, 'no indirect "hlagh" enables the pragma');
  70  eval "die qq{the code compiled but it shouldn't have\n}; \$obj = new Hlagh2;";
  71  like($warn, qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"Hlagh2"/, 'no indirect "hlagh" doesn\'t croak');
  72 }
  73
  74 __DATA__
  75 $obj = new Hlagh;
  76 ####
  77 $obj = new Hlagh();
  78 ####
  79 $obj = new Hlagh(1);
  80 ####
  81 $obj = new Hlagh(1, 2);
  82 ####
  83 $obj = new        Hlagh            ;
  84 ####
  85 $obj = new        Hlagh     (      )      ;
  86 ####
  87 $obj = new        Hlagh     (      1        )     ;
  88 ####
  89 $obj = new        Hlagh     (      1        ,       2        )     ;
  90 ####
  91 $obj = new
  92                       Hlagh
  93         ;
  94 ####
  95 $obj = new
  96                                        Hlagh     (
  97                   )      ;
  98 ####
  99 $obj =
 100               new
 101     Hlagh     (      1
 102             )     ;
 103 ####
 104 $obj =
 105 new
 106 Hlagh
 107                    (      1        ,
 108                 2        )     ;
 109 ####
 110 $obj = new $x;
 111 ####
 112 $obj = new $x();
 113 ####
 114 $obj = new $x('foo');
 115 ####
 116 $obj = new $x qq{foo}, 1;
 117 ####
 118 $obj = new $x qr{foo\s+bar}, 1 .. 1;
 119 ####
 120 $obj = new $x(qw/bar baz/);
 121 ####
 122 $obj = new
 123           $_;
 124 ####
 125 $obj = new
 126              $_     (        );
 127 ####
 128 $obj = new $_      qr/foo/  ;
 129 ####
 130 $obj = new $_     qq(bar baz);
 131 ####
 132 meh $_;
 133 ####
 134 meh $_ 1, 2;
 135 ####
 136 meh $$;
 137 ####
 138 meh $$ 1, 2;
 139 ####
 140 meh $x;
 141 ####
 142 meh $x 1, 2;
 143 ####
 144 meh $x, 1, 2;
 145 ####
 146 meh $y;
 147 ####
 148 meh $y 1, 2;
 149 ####
 150 meh $y, 1, 2;
 151 ####
 152 package sploosh;
 153 our $sploosh;
 154 meh $sploosh::sploosh;
 155 ####
 156 package sploosh;
 157 our $sploosh;
 158 meh $sploosh;
 159 ####
 160 package sploosh;
 161 meh $main::bloop;
 162 ####
 163 package sploosh;
 164 meh $bloop;
 165 ####
 166 package sploosh;
 167 our $sploosh;
 168 package main;
 169 meh $sploosh::sploosh;
 170 ####
 171 new Hlagh->wut;
 172 ####
 173 new Hlagh->wut();
 174 ####
 175 new Hlagh->wut, "Wut";
 176 ####
 177 $obj = HlaghHlagh Hlagh;
 178 ####
 179 $obj = HlaghHlagh Hlagh; # HlaghHlagh Hlagh
 180 ####
 181 $obj = new newnew;
 182 ####
 183 $obj = new newnew; # new newnew
 184 ####
 185 new Hlagh (meh $x)
 186 ####
 187 Hlagh->new(meh $x)