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