Commit | Line | Data |
fa8e8936 |
1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*- |
2 | #!/usr/local/bin/perl -w |
3 | |
f0c07f2e |
4 | use strict; |
ac734d8b |
5 | |
cfbab81b |
6 | use Test::More tests => 59; |
fa8e8936 |
7 | use IO::Handle; |
8 | |
9 | BEGIN { use_ok('CGI::Carp') }; |
10 | |
11 | #----------------------------------------------------------------------------- |
12 | # Test id |
13 | #----------------------------------------------------------------------------- |
14 | |
15 | # directly invoked |
16 | my $expect_f = __FILE__; |
17 | my $expect_l = __LINE__ + 1; |
18 | my ($file, $line, $id) = CGI::Carp::id(0); |
19 | is($file, $expect_f, "file"); |
20 | is($line, $expect_l, "line"); |
21 | is($id, "carp.t", "id"); |
22 | |
23 | # one level of indirection |
24 | sub id1 { my $level = shift; return CGI::Carp::id($level); }; |
25 | |
26 | $expect_l = __LINE__ + 1; |
27 | ($file, $line, $id) = id1(1); |
28 | is($file, $expect_f, "file"); |
29 | is($line, $expect_l, "line"); |
30 | is($id, "carp.t", "id"); |
31 | |
32 | # two levels of indirection |
33 | sub id2 { my $level = shift; return id1($level); }; |
34 | |
35 | $expect_l = __LINE__ + 1; |
36 | ($file, $line, $id) = id2(2); |
37 | is($file, $expect_f, "file"); |
38 | is($line, $expect_l, "line"); |
39 | is($id, "carp.t", "id"); |
40 | |
41 | #----------------------------------------------------------------------------- |
42 | # Test stamp |
43 | #----------------------------------------------------------------------------- |
44 | |
45 | my $stamp = "/^\\[ |
46 | ([a-z]{3}\\s){2}\\s? |
47 | [\\s\\d:]+ |
48 | \\]\\s$id:/ix"; |
49 | |
50 | like(CGI::Carp::stamp(), |
51 | $stamp, |
52 | "Time in correct format"); |
53 | |
54 | sub stamp1 {return CGI::Carp::stamp()}; |
55 | sub stamp2 {return stamp1()}; |
56 | |
57 | like(stamp2(), $stamp, "Time in correct format"); |
58 | |
59 | #----------------------------------------------------------------------------- |
60 | # Test warn and _warn |
61 | #----------------------------------------------------------------------------- |
62 | |
63 | # set some variables to control what's going on. |
64 | $CGI::Carp::WARN = 0; |
65 | $CGI::Carp::EMIT_WARNINGS = 0; |
fa8e8936 |
66 | my $q_file = quotemeta($file); |
67 | |
68 | |
69 | # Test that realwarn is called |
70 | { |
71 | local $^W = 0; |
72 | eval "sub CGI::Carp::realwarn {return 'Called realwarn'};"; |
73 | } |
74 | |
75 | $expect_l = __LINE__ + 1; |
76 | is(CGI::Carp::warn("There is a problem"), |
77 | "Called realwarn", |
78 | "CGI::Carp::warn calls CORE::warn"); |
fa8e8936 |
79 | |
80 | # Test that message is constructed correctly |
81 | eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};'; |
82 | |
83 | $expect_l = __LINE__ + 1; |
84 | like(CGI::Carp::warn("There is a problem"), |
85 | "/] $id: There is a problem at $q_file line $expect_l.".'$/', |
86 | "CGI::Carp::warn builds correct message"); |
fa8e8936 |
87 | |
88 | # Test that _warn is called at the correct time |
89 | $CGI::Carp::WARN = 1; |
90 | |
2ed511ec |
91 | my $warn_expect_l = $expect_l = __LINE__ + 1; |
fa8e8936 |
92 | like(CGI::Carp::warn("There is a problem"), |
93 | "/] $id: There is a problem at $q_file line $expect_l.".'$/', |
94 | "CGI::Carp::warn builds correct message"); |
95 | |
fa8e8936 |
96 | #----------------------------------------------------------------------------- |
97 | # Test ineval |
98 | #----------------------------------------------------------------------------- |
99 | |
100 | ok(!CGI::Carp::ineval, 'ineval returns false when not in eval'); |
101 | eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');}; |
102 | |
103 | #----------------------------------------------------------------------------- |
104 | # Test die |
105 | #----------------------------------------------------------------------------- |
106 | |
107 | # set some variables to control what's going on. |
108 | $CGI::Carp::WRAP = 0; |
109 | |
110 | $expect_l = __LINE__ + 1; |
111 | eval { CGI::Carp::die('There is a problem'); }; |
112 | like($@, |
113 | '/^There is a problem/', |
114 | 'CGI::Carp::die calls CORE::die without altering argument in eval'); |
115 | |
116 | # Test that realwarn is called |
117 | { |
118 | local $^W = 0; |
cfbab81b |
119 | local *CGI::Carp::realdie = sub { my $mess = shift; return $mess }; |
fa8e8936 |
120 | |
cfbab81b |
121 | like(CGI::Carp::die('There is a problem'), |
122 | $stamp, |
123 | 'CGI::Carp::die calls CORE::die, but adds stamp'); |
124 | |
125 | } |
fa8e8936 |
126 | |
127 | #----------------------------------------------------------------------------- |
128 | # Test set_message |
129 | #----------------------------------------------------------------------------- |
130 | |
131 | is(CGI::Carp::set_message('My new Message'), |
132 | 'My new Message', |
133 | 'CGI::Carp::set_message returns new message'); |
134 | |
135 | is($CGI::Carp::CUSTOM_MSG, |
136 | 'My new Message', |
137 | 'CGI::Carp::set_message message set correctly'); |
138 | |
139 | # set the message back to the empty string so that the tests later |
140 | # work properly. |
141 | CGI::Carp::set_message(''), |
142 | |
143 | #----------------------------------------------------------------------------- |
188ba755 |
144 | # Test set_progname |
145 | #----------------------------------------------------------------------------- |
146 | |
147 | import CGI::Carp qw(name=new_progname); |
148 | is($CGI::Carp::PROGNAME, |
149 | 'new_progname', |
150 | 'CGI::Carp::import set program name correctly'); |
151 | |
152 | is(CGI::Carp::set_progname('newer_progname'), |
153 | 'newer_progname', |
154 | 'CGI::Carp::set_progname returns new program name'); |
155 | |
156 | is($CGI::Carp::PROGNAME, |
157 | 'newer_progname', |
158 | 'CGI::Carp::set_progname program name set correctly'); |
159 | |
160 | # set the message back to the empty string so that the tests later |
161 | # work properly. |
162 | is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly"); |
163 | is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly"); |
164 | |
165 | #----------------------------------------------------------------------------- |
fa8e8936 |
166 | # Test warnings_to_browser |
167 | #----------------------------------------------------------------------------- |
168 | |
169 | CGI::Carp::warningsToBrowser(0); |
170 | is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off"); |
fa8e8936 |
171 | |
172 | # turn off STDOUT (prevents spurious warnings to screen |
173 | tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT"; |
174 | CGI::Carp::warningsToBrowser(1); |
175 | my $fake_out = join '', <STDOUT>; |
176 | untie *STDOUT; |
177 | |
178 | open(STDOUT, ">&REAL_STDOUT"); |
0106e1e7 |
179 | my $fname = $0; |
180 | $fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also |
2ed511ec |
181 | is( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n", |
fa8e8936 |
182 | 'warningsToBrowser() on' ); |
183 | |
184 | is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off"); |
fa8e8936 |
185 | |
186 | #----------------------------------------------------------------------------- |
187 | # Test fatals_to_browser |
188 | #----------------------------------------------------------------------------- |
189 | |
190 | package StoreStuff; |
191 | |
192 | sub TIEHANDLE { |
193 | my $class = shift; |
194 | bless [], $class; |
195 | } |
196 | |
197 | sub PRINT { |
198 | my $self = shift; |
199 | push @$self, @_; |
200 | } |
201 | |
202 | sub READLINE { |
203 | my $self = shift; |
204 | shift @$self; |
205 | } |
206 | |
207 | package main; |
208 | |
209 | tie *STDOUT, "StoreStuff"; |
210 | |
211 | # do tests |
212 | my @result; |
213 | |
214 | CGI::Carp::fatalsToBrowser(); |
215 | $result[0] .= $_ while (<STDOUT>); |
216 | |
217 | CGI::Carp::fatalsToBrowser('Message to the world'); |
218 | $result[1] .= $_ while (<STDOUT>); |
219 | |
220 | $ENV{SERVER_ADMIN} = 'foo@bar.com'; |
221 | CGI::Carp::fatalsToBrowser(); |
222 | $result[2] .= $_ while (<STDOUT>); |
223 | |
224 | CGI::Carp::set_message('Override the message passed in'), |
225 | |
226 | CGI::Carp::fatalsToBrowser('Message to the world'); |
227 | $result[3] .= $_ while (<STDOUT>); |
228 | CGI::Carp::set_message(''), |
229 | delete $ENV{SERVER_ADMIN}; |
230 | |
231 | # now restore STDOUT |
232 | untie *STDOUT; |
233 | |
234 | |
235 | like($result[0], |
236 | '/Content-type: text/html/', |
237 | "Default string has header"); |
238 | |
239 | ok($result[0] !~ /Message to the world/, "Custom message not in default string"); |
240 | |
241 | like($result[1], |
242 | '/Message to the world/', |
243 | "Custom Message appears in output"); |
244 | |
245 | ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message"); |
246 | |
247 | like($result[2], |
248 | '/foo@bar.com/', |
249 | "Server Admin appears in output"); |
250 | |
251 | like($result[3], |
252 | '/Message to the world/', |
253 | "Custom message not in result"); |
254 | |
255 | like($result[3], |
256 | '/Override the message passed in/', |
257 | "Correct message in string"); |
258 | |
259 | #----------------------------------------------------------------------------- |
260 | # Test to_filehandle |
261 | #----------------------------------------------------------------------------- |
262 | |
263 | sub buffer { |
264 | CGI::Carp::to_filehandle (@_); |
265 | } |
266 | |
267 | tie *STORE, "StoreStuff"; |
268 | |
269 | require FileHandle; |
270 | my $fh = FileHandle->new; |
271 | |
272 | ok( defined buffer(\*STORE), '\*STORE returns proper filehandle'); |
273 | ok( defined buffer( $fh ), '$fh returns proper filehandle'); |
274 | ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle'); |
275 | ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle'); |
276 | ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle'); |
cfbab81b |
277 | |
278 | # Calling die with code refs with no WRAP |
279 | { |
280 | local $CGI::Carp::WRAP = 0; |
281 | |
282 | eval { CGI::Carp::die( 'regular string' ) }; |
283 | like $@ => qr/regular string/, 'die with string'; |
284 | |
285 | eval { CGI::Carp::die( [ 1..10 ] ) }; |
286 | like $@ => qr/ARRAY\(0x[\da-f]+\)/, 'die with array ref'; |
287 | |
288 | eval { CGI::Carp::die( { a => 1 } ) }; |
289 | like $@ => qr/HASH\(0x[\da-f]+\)/, 'die with hash ref'; |
290 | |
291 | eval { CGI::Carp::die( sub { 'Farewell' } ) }; |
292 | like $@ => qr/CODE\(0x[\da-f]+\)/, 'die with code ref'; |
293 | |
294 | eval { CGI::Carp::die( My::Plain::Object->new ) }; |
295 | isa_ok $@, 'My::Plain::Object'; |
296 | |
297 | eval { CGI::Carp::die( My::Plain::Object->new, ' and another argument' ) }; |
298 | like $@ => qr/My::Plain::Object/, 'object is stringified'; |
299 | like $@ => qr/and another argument/, 'second argument is present'; |
300 | |
301 | eval { CGI::Carp::die( My::Stringified::Object->new ) }; |
302 | isa_ok $@, 'My::Stringified::Object'; |
303 | |
304 | eval { CGI::Carp::die( My::Stringified::Object->new, ' and another argument' ) }; |
305 | like $@ => qr/stringified/, 'object is stringified'; |
306 | like $@ => qr/and another argument/, 'second argument is present'; |
307 | |
308 | eval { CGI::Carp::die() }; |
309 | like $@ => qr/Died at/, 'die with no argument'; |
310 | } |
311 | |
312 | # Calling die with code refs when WRAPped |
313 | { |
314 | local $CGI::Carp::WRAP = 1; |
315 | local *CGI::Carp::realdie = sub { return @_ }; |
316 | local *STDOUT; |
317 | |
318 | tie *STDOUT, 'StoreStuff'; |
319 | |
320 | my %result; # store results because stdout is kidnapped |
321 | |
322 | CGI::Carp::die( 'regular string' ); |
323 | $result{string} .= $_ while <STDOUT>; |
324 | |
325 | CGI::Carp::die( [ 1..10 ] ); |
326 | $result{array_ref} .= $_ while <STDOUT>; |
327 | |
328 | CGI::Carp::die( { a => 1 } ); |
329 | $result{hash_ref} .= $_ while <STDOUT>; |
330 | |
331 | CGI::Carp::die( sub { 'Farewell' } ); |
332 | $result{code_ref} .= $_ while <STDOUT>; |
333 | |
334 | CGI::Carp::die( My::Plain::Object->new ); |
335 | $result{plain_object} .= $_ while <STDOUT>; |
336 | |
337 | CGI::Carp::die( My::Stringified::Object->new ); |
338 | $result{string_object} .= $_ while <STDOUT>; |
339 | |
340 | CGI::Carp::die(); |
341 | $result{no_args} .= $_ while <STDOUT>; |
342 | |
343 | untie *STDOUT; |
344 | |
345 | like $result{string} => qr/regular string/, 'regular string, wrapped'; |
346 | like $result{array_ref} => qr/ARRAY\(\w+?\)/, 'array ref, wrapped'; |
347 | like $result{hash_ref} => qr/HASH\(\w+?\)/, 'hash ref, wrapped'; |
348 | like $result{code_ref} => qr/CODE\(\w+?\)/, 'code ref, wrapped'; |
349 | like $result{plain_object} => qr/My::Plain::Object/, |
350 | 'plain object, wrapped'; |
351 | like $result{string_object} => qr/stringified/, |
352 | 'stringified object, wrapped'; |
353 | like $result{no_args} => qr/Died at/, 'no args, wrapped'; |
354 | |
355 | } |
356 | |
357 | { |
358 | package My::Plain::Object; |
359 | |
360 | sub new { |
361 | return bless {}, shift; |
362 | } |
363 | } |
364 | |
365 | { |
366 | package My::Stringified::Object; |
367 | |
368 | use overload '""' => sub { 'stringified' }; |
369 | |
370 | sub new { |
371 | return bless {}, shift; |
372 | } |
373 | } |