Upgrade to CGI.pm-3.48
[perl.git] / cpan / CGI / t / carp.t
1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
2 #!/usr/local/bin/perl -w
3
4 use strict;
5
6 use Test::More tests => 41;
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 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");
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");
87
88 # Test that _warn is called at the correct time
89 $CGI::Carp::WARN = 1;
90
91 my $warn_expect_l = $expect_l = __LINE__ + 1;
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
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;
119   eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
120 }
121
122 like(CGI::Carp::die('There is a problem'),
123      $stamp,
124      'CGI::Carp::die calls CORE::die, but adds stamp');
125
126 #-----------------------------------------------------------------------------
127 # Test set_message
128 #-----------------------------------------------------------------------------
129
130 is(CGI::Carp::set_message('My new Message'),
131    'My new Message',
132    'CGI::Carp::set_message returns new message');
133
134 is($CGI::Carp::CUSTOM_MSG,
135    'My new Message',
136    'CGI::Carp::set_message message set correctly');
137
138 # set the message back to the empty string so that the tests later
139 # work properly.
140 CGI::Carp::set_message(''),
141
142 #-----------------------------------------------------------------------------
143 # Test set_progname
144 #-----------------------------------------------------------------------------
145
146 import CGI::Carp qw(name=new_progname);
147 is($CGI::Carp::PROGNAME,
148      'new_progname',
149      'CGI::Carp::import set program name correctly');
150
151 is(CGI::Carp::set_progname('newer_progname'),
152    'newer_progname',
153    'CGI::Carp::set_progname returns new program name');
154
155 is($CGI::Carp::PROGNAME,
156    'newer_progname',
157    'CGI::Carp::set_progname program name set correctly');
158
159 # set the message back to the empty string so that the tests later
160 # work properly.
161 is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly");
162 is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly");
163
164 #-----------------------------------------------------------------------------
165 # Test warnings_to_browser
166 #-----------------------------------------------------------------------------
167
168 CGI::Carp::warningsToBrowser(0);
169 is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off");
170
171 # turn off STDOUT (prevents spurious warnings to screen
172 tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
173 CGI::Carp::warningsToBrowser(1);
174 my $fake_out = join '', <STDOUT>;
175 untie *STDOUT;
176
177 open(STDOUT, ">&REAL_STDOUT");
178 my $fname = $0;
179 $fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also
180 is( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n",
181                         'warningsToBrowser() on' );
182
183 is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");
184
185 #-----------------------------------------------------------------------------
186 # Test fatals_to_browser
187 #-----------------------------------------------------------------------------
188
189 package StoreStuff;
190
191 sub TIEHANDLE {
192   my $class = shift;
193   bless [], $class;
194 }
195
196 sub PRINT {
197   my $self = shift;
198   push @$self, @_;
199 }
200
201 sub READLINE {
202   my $self = shift;
203   shift @$self;
204 }
205
206 package main;
207
208 tie *STDOUT, "StoreStuff";
209
210 # do tests
211 my @result;
212
213 CGI::Carp::fatalsToBrowser();
214 $result[0] .= $_ while (<STDOUT>);
215
216 CGI::Carp::fatalsToBrowser('Message to the world');
217 $result[1] .= $_ while (<STDOUT>);
218
219 $ENV{SERVER_ADMIN} = 'foo@bar.com';
220 CGI::Carp::fatalsToBrowser();
221 $result[2] .= $_ while (<STDOUT>);
222
223 CGI::Carp::set_message('Override the message passed in'),
224
225 CGI::Carp::fatalsToBrowser('Message to the world');
226 $result[3] .= $_ while (<STDOUT>);
227 CGI::Carp::set_message(''),
228 delete $ENV{SERVER_ADMIN};
229
230 # now restore STDOUT
231 untie *STDOUT;
232
233
234 like($result[0],
235      '/Content-type: text/html/',
236      "Default string has header");
237
238 ok($result[0] !~ /Message to the world/, "Custom message not in default string");
239
240 like($result[1],
241     '/Message to the world/',
242     "Custom Message appears in output");
243
244 ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");
245
246 like($result[2],
247     '/foo@bar.com/',
248     "Server Admin appears in output");
249
250 like($result[3],
251      '/Message to the world/',
252      "Custom message not in result");
253
254 like($result[3],
255      '/Override the message passed in/',
256      "Correct message in string");
257
258 #-----------------------------------------------------------------------------
259 # Test to_filehandle
260 #-----------------------------------------------------------------------------
261
262 sub buffer {
263   CGI::Carp::to_filehandle (@_);
264 }
265
266 tie *STORE, "StoreStuff";
267
268 require FileHandle;
269 my $fh = FileHandle->new;
270
271 ok( defined buffer(\*STORE),       '\*STORE returns proper filehandle');
272 ok( defined buffer( $fh ),         '$fh returns proper filehandle');
273 ok( defined buffer('::STDOUT'),    'STDIN returns proper filehandle');
274 ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
275 ok(!defined buffer("WIBBLE"),      '"WIBBLE" doesn\'t returns proper filehandle');