Upgrade to Pod-Simple-3.08
[perl.git] / lib / Carp.t
1 BEGIN {
2         chdir 't' if -d 't';
3         @INC = '../lib';
4         require './test.pl';
5 }
6
7 my $Is_VMS = $^O eq 'VMS';
8
9 use Carp qw(carp cluck croak confess);
10
11 plan tests => 37;
12
13 ok 1;
14
15 { local $SIG{__WARN__} = sub {
16     like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' };
17
18   carp  "ok 2\n";
19
20 }
21
22 { local $SIG{__WARN__} = sub {
23     like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' };
24
25   carp 3;
26
27 }
28
29 sub sub_4 {
30
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' };
33
34 cluck 4;
35
36 }
37
38 sub_4;
39
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' };
42
43   eval { croak 5 };
44 }
45
46 sub sub_6 {
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' };
49
50     eval { confess 6 };
51 }
52
53 sub_6;
54
55 ok(1);
56
57 # test for caller_info API
58 my $eval = "use Carp; return Carp::caller_info(0);";
59 my %info = eval($eval);
60 is($info{sub_name}, "eval '$eval'", 'caller_info API');
61
62 # test for '...::CARP_NOT used only once' warning from Carp
63 my $warning;
64 eval {
65     BEGIN {
66         $^W = 1;
67         local $SIG{__WARN__} =
68             sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } }
69     }
70     package Z;
71     BEGIN { eval { Carp::croak() } }
72 };
73 ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
74
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 }
156
157 # tests for global variables
158 sub x { carp @_ }
159 sub w { cluck @_ }
160
161 # $Carp::Verbose;
162 {   my $aref = [
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+/
165     ];
166     my $i = 0;
167
168     for my $re (@$aref) {
169         local $Carp::Verbose = $i++;
170         local $SIG{__WARN__} = sub {
171             like $_[0], $re, 'Verbose';
172         };
173         package Z;
174         main::x('t');
175     }
176 }
177
178 # $Carp::MaxEvalLen
179 {   my $test_num = 1;
180     for(0,4) {
181         my $txt = "Carp::cluck($test_num)";
182         local $Carp::MaxEvalLen = $_;
183         local $SIG{__WARN__} = sub {
184             "@_"=~/'(.+?)(?:\n|')/s;
185             is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen';
186         };
187         eval "$txt"; $test_num++;
188     }
189 }
190
191 # $Carp::MaxArgLen
192 {
193     for(0,4) {
194         my $arg = 'testtest';
195         local $Carp::MaxArgLen = $_;
196         local $SIG{__WARN__} = sub {
197             "@_"=~/'(.+?)'/;
198             is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
199         };
200
201         package Z;
202         main::w($arg);
203     }
204 }
205
206 # $Carp::MaxArgNums
207 {   my $i = 0;
208     my $aref = [
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+/,
211     ];
212
213     for(@$aref) {
214         local $Carp::MaxArgNums = $i++;
215         local $SIG{__WARN__} = sub {
216             like "@_", $_, 'MaxArgNums';
217         };
218
219         package Z;
220         main::w(1..4);
221     }
222 }
223
224 # $Carp::CarpLevel
225 {   my $i = 0;
226     my $aref = [
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+$/,
229     ];
230
231     for (@$aref) {
232         local $Carp::CarpLevel = $i++;
233         local $SIG{__WARN__} = sub {
234             like "@_", $_, 'CarpLevel';
235         };
236
237         package Z;
238         main::w(1);
239     }
240 }
241
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 }
256
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
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 }