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