Commit | Line | Data |
fa8e8936 |
1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*- |
2 | #!/usr/local/bin/perl -w |
3 | |
4 | use strict; |
5 | use lib qw(t/lib); |
6 | use Test::More tests => 42; |
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; |
66 | @CGI::Carp::WARNINGS = (); |
67 | my $q_file = quotemeta($file); |
68 | |
69 | |
70 | # Test that realwarn is called |
71 | { |
72 | local $^W = 0; |
73 | eval "sub CGI::Carp::realwarn {return 'Called realwarn'};"; |
74 | } |
75 | |
76 | $expect_l = __LINE__ + 1; |
77 | is(CGI::Carp::warn("There is a problem"), |
78 | "Called realwarn", |
79 | "CGI::Carp::warn calls CORE::warn"); |
80 | is(@CGI::Carp::WARNINGS, 0, "_warn not called"); |
81 | |
82 | # Test that message is constructed correctly |
83 | eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};'; |
84 | |
85 | $expect_l = __LINE__ + 1; |
86 | like(CGI::Carp::warn("There is a problem"), |
87 | "/] $id: There is a problem at $q_file line $expect_l.".'$/', |
88 | "CGI::Carp::warn builds correct message"); |
89 | is(@CGI::Carp::WARNINGS, 0, "_warn not called"); |
90 | |
91 | # Test that _warn is called at the correct time |
92 | $CGI::Carp::WARN = 1; |
93 | |
94 | $expect_l = __LINE__ + 1; |
95 | like(CGI::Carp::warn("There is a problem"), |
96 | "/] $id: There is a problem at $q_file line $expect_l.".'$/', |
97 | "CGI::Carp::warn builds correct message"); |
98 | |
99 | is(@CGI::Carp::WARNINGS, 1, "_warn now called"); |
100 | like($CGI::Carp::WARNINGS[0], |
101 | "/There is a problem at $q_file line $expect_l.".'$/', |
102 | "CGI::Carp::WARNINGS has correct message (without stamp)"); |
103 | |
104 | #----------------------------------------------------------------------------- |
105 | # Test ineval |
106 | #----------------------------------------------------------------------------- |
107 | |
108 | ok(!CGI::Carp::ineval, 'ineval returns false when not in eval'); |
109 | eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');}; |
110 | |
111 | #----------------------------------------------------------------------------- |
112 | # Test die |
113 | #----------------------------------------------------------------------------- |
114 | |
115 | # set some variables to control what's going on. |
116 | $CGI::Carp::WRAP = 0; |
117 | |
118 | $expect_l = __LINE__ + 1; |
119 | eval { CGI::Carp::die('There is a problem'); }; |
120 | like($@, |
121 | '/^There is a problem/', |
122 | 'CGI::Carp::die calls CORE::die without altering argument in eval'); |
123 | |
124 | # Test that realwarn is called |
125 | { |
126 | local $^W = 0; |
127 | eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};'; |
128 | } |
129 | |
130 | like(CGI::Carp::die('There is a problem'), |
131 | $stamp, |
132 | 'CGI::Carp::die calls CORE::die, but adds stamp'); |
133 | |
134 | #----------------------------------------------------------------------------- |
135 | # Test set_message |
136 | #----------------------------------------------------------------------------- |
137 | |
138 | is(CGI::Carp::set_message('My new Message'), |
139 | 'My new Message', |
140 | 'CGI::Carp::set_message returns new message'); |
141 | |
142 | is($CGI::Carp::CUSTOM_MSG, |
143 | 'My new Message', |
144 | 'CGI::Carp::set_message message set correctly'); |
145 | |
146 | # set the message back to the empty string so that the tests later |
147 | # work properly. |
148 | CGI::Carp::set_message(''), |
149 | |
150 | #----------------------------------------------------------------------------- |
151 | # Test warnings_to_browser |
152 | #----------------------------------------------------------------------------- |
153 | |
154 | CGI::Carp::warningsToBrowser(0); |
155 | is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off"); |
156 | unless( is(@CGI::Carp::WARNINGS, 1, "_warn not called") ) { |
157 | print join "\n", map "'$_'", @CGI::Carp::WARNINGS; |
158 | } |
159 | |
160 | # turn off STDOUT (prevents spurious warnings to screen |
161 | tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT"; |
162 | CGI::Carp::warningsToBrowser(1); |
163 | my $fake_out = join '', <STDOUT>; |
164 | untie *STDOUT; |
165 | |
166 | open(STDOUT, ">&REAL_STDOUT"); |
167 | is( $fake_out, "<!-- warning: There is a problem at $0 line 95. -->\n", |
168 | 'warningsToBrowser() on' ); |
169 | |
170 | is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off"); |
171 | is(@CGI::Carp::WARNINGS, 0, "_warn is called"); |
172 | |
173 | #----------------------------------------------------------------------------- |
174 | # Test fatals_to_browser |
175 | #----------------------------------------------------------------------------- |
176 | |
177 | package StoreStuff; |
178 | |
179 | sub TIEHANDLE { |
180 | my $class = shift; |
181 | bless [], $class; |
182 | } |
183 | |
184 | sub PRINT { |
185 | my $self = shift; |
186 | push @$self, @_; |
187 | } |
188 | |
189 | sub READLINE { |
190 | my $self = shift; |
191 | shift @$self; |
192 | } |
193 | |
194 | package main; |
195 | |
196 | tie *STDOUT, "StoreStuff"; |
197 | |
198 | # do tests |
199 | my @result; |
200 | |
201 | CGI::Carp::fatalsToBrowser(); |
202 | $result[0] .= $_ while (<STDOUT>); |
203 | |
204 | CGI::Carp::fatalsToBrowser('Message to the world'); |
205 | $result[1] .= $_ while (<STDOUT>); |
206 | |
207 | $ENV{SERVER_ADMIN} = 'foo@bar.com'; |
208 | CGI::Carp::fatalsToBrowser(); |
209 | $result[2] .= $_ while (<STDOUT>); |
210 | |
211 | CGI::Carp::set_message('Override the message passed in'), |
212 | |
213 | CGI::Carp::fatalsToBrowser('Message to the world'); |
214 | $result[3] .= $_ while (<STDOUT>); |
215 | CGI::Carp::set_message(''), |
216 | delete $ENV{SERVER_ADMIN}; |
217 | |
218 | # now restore STDOUT |
219 | untie *STDOUT; |
220 | |
221 | |
222 | like($result[0], |
223 | '/Content-type: text/html/', |
224 | "Default string has header"); |
225 | |
226 | ok($result[0] !~ /Message to the world/, "Custom message not in default string"); |
227 | |
228 | like($result[1], |
229 | '/Message to the world/', |
230 | "Custom Message appears in output"); |
231 | |
232 | ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message"); |
233 | |
234 | like($result[2], |
235 | '/foo@bar.com/', |
236 | "Server Admin appears in output"); |
237 | |
238 | like($result[3], |
239 | '/Message to the world/', |
240 | "Custom message not in result"); |
241 | |
242 | like($result[3], |
243 | '/Override the message passed in/', |
244 | "Correct message in string"); |
245 | |
246 | #----------------------------------------------------------------------------- |
247 | # Test to_filehandle |
248 | #----------------------------------------------------------------------------- |
249 | |
250 | sub buffer { |
251 | CGI::Carp::to_filehandle (@_); |
252 | } |
253 | |
254 | tie *STORE, "StoreStuff"; |
255 | |
256 | require FileHandle; |
257 | my $fh = FileHandle->new; |
258 | |
259 | ok( defined buffer(\*STORE), '\*STORE returns proper filehandle'); |
260 | ok( defined buffer( $fh ), '$fh returns proper filehandle'); |
261 | ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle'); |
262 | ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle'); |
263 | ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle'); |