Commit | Line | Data |
---|---|---|
0e25c5fd JH |
1 | BEGIN { |
2 | chdir 't' if -d 't'; | |
3 | @INC = '../lib'; | |
ce707141 | 4 | require './test.pl'; |
0e25c5fd JH |
5 | } |
6 | ||
4b09a709 MS |
7 | my $Is_VMS = $^O eq 'VMS'; |
8 | ||
0e25c5fd JH |
9 | use Carp qw(carp cluck croak confess); |
10 | ||
9cb6ed42 | 11 | plan tests => 37; |
0e25c5fd | 12 | |
ce707141 | 13 | ok 1; |
0e25c5fd | 14 | |
ce707141 CB |
15 | { local $SIG{__WARN__} = sub { |
16 | like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' }; | |
0e25c5fd | 17 | |
ce707141 | 18 | carp "ok 2\n"; |
22dc90ad | 19 | |
ce707141 CB |
20 | } |
21 | ||
22 | { local $SIG{__WARN__} = sub { | |
23 | like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' }; | |
0e25c5fd | 24 | |
ce707141 CB |
25 | carp 3; |
26 | ||
27 | } | |
0e25c5fd JH |
28 | |
29 | sub sub_4 { | |
30 | ||
ce707141 CB |
31 | local $SIG{__WARN__} = sub { |
32 | like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/, 'cluck 4' }; | |
0e25c5fd JH |
33 | |
34 | cluck 4; | |
35 | ||
36 | } | |
37 | ||
38 | sub_4; | |
39 | ||
ce707141 CB |
40 | { local $SIG{__DIE__} = sub { |
41 | like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/, 'croak 5' }; | |
0e25c5fd | 42 | |
ce707141 CB |
43 | eval { croak 5 }; |
44 | } | |
0e25c5fd JH |
45 | |
46 | sub sub_6 { | |
ce707141 CB |
47 | local $SIG{__DIE__} = sub { |
48 | like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at.+\b(?i:carp\.t) line \d+$/, 'confess 6' }; | |
0e25c5fd JH |
49 | |
50 | eval { confess 6 }; | |
51 | } | |
52 | ||
53 | sub_6; | |
54 | ||
ce707141 | 55 | ok(1); |
0e25c5fd | 56 | |
976ea96e RS |
57 | # test for caller_info API |
58 | my $eval = "use Carp::Heavy; return Carp::caller_info(0);"; | |
59 | my %info = eval($eval); | |
ce707141 | 60 | is($info{sub_name}, "eval '$eval'", 'caller_info API'); |
b5777b26 RB |
61 | |
62 | # test for '...::CARP_NOT used only once' warning from Carp::Heavy | |
63 | my $warning; | |
64 | eval { | |
65 | BEGIN { | |
66 | $^W = 1; | |
ce707141 | 67 | local $SIG{__WARN__} = |
b5777b26 RB |
68 | sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } } |
69 | } | |
22dc90ad | 70 | package Z; |
b5777b26 RB |
71 | BEGIN { eval { Carp::croak() } } |
72 | }; | |
ce707141 | 73 | ok !$warning, q/'...::CARP_NOT used only once' warning from Carp::Heavy/; |
22dc90ad | 74 | |
d735c2ef BT |
75 | # Test the location of error messages. |
76 | like(A::short(), qr/^Error at C/, "Short messages skip carped package"); | |
77 | ||
78 | { | |
79 | local @C::ISA = "D"; | |
80 | like(A::short(), qr/^Error at B/, "Short messages skip inheritance"); | |
81 | } | |
82 | ||
83 | { | |
84 | local @D::ISA = "C"; | |
85 | like(A::short(), qr/^Error at B/, "Short messages skip inheritance"); | |
86 | } | |
87 | ||
88 | { | |
89 | local @D::ISA = "B"; | |
90 | local @B::ISA = "C"; | |
91 | like(A::short(), qr/^Error at A/, "Inheritance is transitive"); | |
92 | } | |
93 | ||
94 | { | |
95 | local @B::ISA = "D"; | |
96 | local @C::ISA = "B"; | |
97 | like(A::short(), qr/^Error at A/, "Inheritance is transitive"); | |
98 | } | |
99 | ||
100 | { | |
101 | local @C::CARP_NOT = "D"; | |
102 | like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT"); | |
103 | } | |
104 | ||
105 | { | |
106 | local @D::CARP_NOT = "C"; | |
107 | like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT"); | |
108 | } | |
109 | ||
110 | { | |
111 | local @D::CARP_NOT = "B"; | |
112 | local @B::CARP_NOT = "C"; | |
113 | like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive"); | |
114 | } | |
115 | ||
116 | { | |
117 | local @B::CARP_NOT = "D"; | |
118 | local @C::CARP_NOT = "B"; | |
119 | like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive"); | |
120 | } | |
121 | ||
122 | { | |
123 | local @D::ISA = "C"; | |
124 | local @D::CARP_NOT = "B"; | |
125 | like(A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance"); | |
126 | } | |
127 | ||
128 | { | |
129 | local @D::ISA = "B"; | |
130 | local @D::CARP_NOT = "C"; | |
131 | like(A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance"); | |
132 | } | |
133 | ||
134 | # %Carp::Internal | |
135 | { | |
136 | local $Carp::Internal{C} = 1; | |
137 | like(A::short(), qr/^Error at B/, "Short doesn't report Internal"); | |
138 | } | |
139 | ||
140 | { | |
141 | local $Carp::Internal{D} = 1; | |
142 | like(A::long(), qr/^Error at C/, "Long doesn't report Internal"); | |
143 | } | |
144 | ||
145 | # %Carp::CarpInternal | |
146 | { | |
147 | local $Carp::CarpInternal{D} = 1; | |
148 | like(A::short(), qr/^Error at B/ | |
149 | , "Short doesn't report calls to CarpInternal"); | |
150 | } | |
151 | ||
152 | { | |
153 | local $Carp::CarpInternal{D} = 1; | |
154 | like(A::long(), qr/^Error at C/, "Long doesn't report CarpInternal"); | |
155 | } | |
22dc90ad JB |
156 | |
157 | # tests for global variables | |
158 | sub x { carp @_ } | |
159 | sub w { cluck @_ } | |
160 | ||
161 | # $Carp::Verbose; | |
162 | { my $aref = [ | |
ce707141 CB |
163 | qr/t at \S*(?i:carp.t) line \d+/, |
164 | qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/ | |
22dc90ad | 165 | ]; |
ce707141 | 166 | my $i = 0; |
22dc90ad JB |
167 | |
168 | for my $re (@$aref) { | |
169 | local $Carp::Verbose = $i++; | |
170 | local $SIG{__WARN__} = sub { | |
ce707141 | 171 | like $_[0], $re, 'Verbose'; |
22dc90ad JB |
172 | }; |
173 | package Z; | |
174 | main::x('t'); | |
175 | } | |
176 | } | |
177 | ||
178 | # $Carp::MaxEvalLen | |
ce707141 | 179 | { my $test_num = 1; |
22dc90ad JB |
180 | for(0,4) { |
181 | my $txt = "Carp::cluck($test_num)"; | |
182 | local $Carp::MaxEvalLen = $_; | |
183 | local $SIG{__WARN__} = sub { | |
184 | "@_"=~/'(.+?)(?:\n|')/s; | |
ce707141 | 185 | is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen'; |
22dc90ad JB |
186 | }; |
187 | eval "$txt"; $test_num++; | |
188 | } | |
189 | } | |
190 | ||
191 | # $Carp::MaxArgLen | |
ce707141 | 192 | { |
22dc90ad JB |
193 | for(0,4) { |
194 | my $arg = 'testtest'; | |
195 | local $Carp::MaxArgLen = $_; | |
196 | local $SIG{__WARN__} = sub { | |
197 | "@_"=~/'(.+?)'/; | |
ce707141 | 198 | is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen'; |
22dc90ad JB |
199 | }; |
200 | ||
201 | package Z; | |
202 | main::w($arg); | |
203 | } | |
204 | } | |
205 | ||
206 | # $Carp::MaxArgNums | |
ce707141 | 207 | { my $i = 0; |
22dc90ad | 208 | my $aref = [ |
ce707141 CB |
209 | qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, 3, 4\) called at \S*(?i:carp.t) line \d+/, |
210 | qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/, | |
22dc90ad JB |
211 | ]; |
212 | ||
213 | for(@$aref) { | |
214 | local $Carp::MaxArgNums = $i++; | |
215 | local $SIG{__WARN__} = sub { | |
ce707141 | 216 | like "@_", $_, 'MaxArgNums'; |
22dc90ad JB |
217 | }; |
218 | ||
219 | package Z; | |
220 | main::w(1..4); | |
221 | } | |
222 | } | |
223 | ||
224 | # $Carp::CarpLevel | |
ce707141 | 225 | { my $i = 0; |
22dc90ad | 226 | my $aref = [ |
ce707141 CB |
227 | qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/, |
228 | qr/1 at \S*(?i:carp.t) line \d+$/, | |
22dc90ad JB |
229 | ]; |
230 | ||
231 | for (@$aref) { | |
232 | local $Carp::CarpLevel = $i++; | |
233 | local $SIG{__WARN__} = sub { | |
ce707141 | 234 | like "@_", $_, 'CarpLevel'; |
22dc90ad JB |
235 | }; |
236 | ||
237 | package Z; | |
238 | main::w(1); | |
239 | } | |
240 | } | |
62e1ddac | 241 | |
4b09a709 MS |
242 | { |
243 | local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS; | |
244 | ||
245 | # Check that croak() and confess() don't clobber $! | |
246 | runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})', | |
247 | stderr => 1); | |
248 | ||
249 | is($?>>8, 42, 'croak() doesn\'t clobber $!'); | |
250 | ||
251 | runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})', | |
252 | stderr => 1); | |
253 | ||
254 | is($?>>8, 42, 'confess() doesn\'t clobber $!'); | |
255 | } | |
d735c2ef | 256 | |
9cb6ed42 NC |
257 | # undef used to be incorrectly reported as the string "undef" |
258 | sub cluck_undef { | |
259 | ||
260 | local $SIG{__WARN__} = sub { | |
261 | like $_[0], qr/^Bang! at.+\b(?i:carp\.t) line \d+\n\tmain::cluck_undef\(0, 'undef', 2, undef, 4\) called at.+\b(?i:carp\.t) line \d+$/, "cluck doesn't quote undef" }; | |
262 | ||
263 | cluck "Bang!" | |
264 | ||
265 | } | |
266 | ||
267 | cluck_undef (0, "undef", 2, undef, 4); | |
268 | ||
d735c2ef BT |
269 | # line 1 "A" |
270 | package A; | |
271 | sub short { | |
272 | B::short(); | |
273 | } | |
274 | ||
275 | sub long { | |
276 | B::long(); | |
277 | } | |
278 | ||
279 | # line 1 "B" | |
280 | package B; | |
281 | sub short { | |
282 | C::short(); | |
283 | } | |
284 | ||
285 | sub long { | |
286 | C::long(); | |
287 | } | |
288 | ||
289 | # line 1 "C" | |
290 | package C; | |
291 | sub short { | |
292 | D::short(); | |
293 | } | |
294 | ||
295 | sub long { | |
296 | D::long(); | |
297 | } | |
298 | ||
299 | # line 1 "D" | |
300 | package D; | |
301 | sub short { | |
302 | eval{ Carp::croak("Error") }; | |
303 | return $@; | |
304 | } | |
305 | ||
306 | sub long { | |
307 | eval{ Carp::confess("Error") }; | |
308 | return $@; | |
309 | } |