]> git.vpit.fr Git - perl/modules/indirect.git/blob - t/20-bad.t
Fix a possible collisions by hashing pointers with the format %u
[perl/modules/indirect.git] / 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)