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 => 50 * 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|\$(?:[xyz_\$]|(?:sploosh::)?sploosh|(?:main::)?bloop))"/
  20 }
  21
  22 {
  23  local $/ = "####";
  24  while (<DATA>) {
  25   chomp;
  26   s/\s*$//;
  27   s/(.*?)$//m;
  28   my ($skip, $prefix) = split /#+/, $1;
  29   $skip   = 0  unless defined $skip;
  30   $prefix = '' unless defined $prefix;
  31   s/\s*//;
  32
  33 SKIP:
  34   {
  35    skip "$_: $skip" => 6 if eval $skip;
  36
  37    local $SIG{__WARN__} = sub { die 'warn:' . join(' ', @_) };
  38
  39    eval "die qq{ok\\n}; $prefix; use indirect; $_";
  40    is($@, "ok\n", "use indirect: $_");
  41
  42    eval "die qq{the code compiled but it shouldn't have\n}; $prefix; no indirect; $_";
  43    like($@, expect('Hlagh'), "no indirect: $_");
  44
  45    s/Hlagh/Dongs/g;
  46
  47    eval "die qq{ok\\n}; $prefix; use indirect; $_";
  48    is($@, "ok\n", "use indirect, defined: $_");
  49
  50    eval "die qq{the code compiled but it shouldn't have\n}; $prefix; no indirect; $_";
  51    like($@, expect('Dongs'), "no indirect, defined: $_");
  52
  53    s/\$/\$ \n\t /g;
  54    s/Dongs/Hlagh/g;
  55
  56    eval "die qq{ok\\n}; $prefix; use indirect; $_";
  57    is($@, "ok\n", "use indirect, spaces: $_");
  58
  59    eval "die qq{the code compiled but it shouldn't have\n}; $prefix; no indirect; $_";
  60    like($@, expect('Hlagh'), "no indirect, spaces: $_");
  61   }
  62  }
  63 }
  64
  65 eval {
  66  my $warn;
  67  local $SIG{__WARN__} = sub { $warn = join ' ', @_ };
  68  eval "die qq{ok\n}; no indirect 'hlagh'; \$obj = new Hlagh1;";
  69  is($@, "ok\n", 'no indirect "hlagh" didn\'t croak');
  70  like($warn, qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"Hlagh1"/, 'no indirect "hlagh" enables the pragma');
  71 }
  72
  73 __DATA__
  74
  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 #### $] < 5.010 # use feature 'state'; state $z
 152 meh $z;
 153 #### $] < 5.010 # use feature 'state'; state $z
 154 meh $z 1, 2;
 155 #### $] < 5.010 # use feature 'state'; state $z
 156 meh $z, 1, 2;
 157 ####
 158 package sploosh;
 159 our $sploosh;
 160 meh $sploosh::sploosh;
 161 ####
 162 package sploosh;
 163 our $sploosh;
 164 meh $sploosh;
 165 ####
 166 package sploosh;
 167 meh $main::bloop;
 168 ####
 169 package sploosh;
 170 meh $bloop;
 171 ####
 172 package ma;
 173 meh $bloop;
 174 ####
 175 package sploosh;
 176 our $sploosh;
 177 package main;
 178 meh $sploosh::sploosh;
 179 ####
 180 new Hlagh->wut;
 181 ####
 182 new Hlagh->wut();
 183 ####
 184 new Hlagh->wut, "Wut";
 185 ####
 186 $obj = HlaghHlagh Hlagh;
 187 ####
 188 $obj = HlaghHlagh Hlagh; # HlaghHlagh Hlagh
 189 ####
 190 $obj = new newnew;
 191 ####
 192 $obj = new newnew; # new newnew
 193 ####
 194 new Hlagh (meh $x)
 195 ####
 196 Hlagh->new(meh $x)