1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
2 #!/usr/local/bin/perl -w
7 # Due to a bug in older versions of MakeMaker & Test::Harness, we must
8 # ensure the blib's are in @INC, else we might use the core CGI.pm
9 use lib qw(blib/lib blib/arch);
11 use Test::More tests => 47;
14 BEGIN { use_ok('CGI::Carp') };
16 #-----------------------------------------------------------------------------
18 #-----------------------------------------------------------------------------
21 my $expect_f = __FILE__;
22 my $expect_l = __LINE__ + 1;
23 my ($file, $line, $id) = CGI::Carp::id(0);
24 is($file, $expect_f, "file");
25 is($line, $expect_l, "line");
26 is($id, "carp.t", "id");
28 # one level of indirection
29 sub id1 { my $level = shift; return CGI::Carp::id($level); };
31 $expect_l = __LINE__ + 1;
32 ($file, $line, $id) = id1(1);
33 is($file, $expect_f, "file");
34 is($line, $expect_l, "line");
35 is($id, "carp.t", "id");
37 # two levels of indirection
38 sub id2 { my $level = shift; return id1($level); };
40 $expect_l = __LINE__ + 1;
41 ($file, $line, $id) = id2(2);
42 is($file, $expect_f, "file");
43 is($line, $expect_l, "line");
44 is($id, "carp.t", "id");
46 #-----------------------------------------------------------------------------
48 #-----------------------------------------------------------------------------
55 like(CGI::Carp::stamp(),
57 "Time in correct format");
59 sub stamp1 {return CGI::Carp::stamp()};
60 sub stamp2 {return stamp1()};
62 like(stamp2(), $stamp, "Time in correct format");
64 #-----------------------------------------------------------------------------
66 #-----------------------------------------------------------------------------
68 # set some variables to control what's going on.
70 $CGI::Carp::EMIT_WARNINGS = 0;
71 @CGI::Carp::WARNINGS = ();
72 my $q_file = quotemeta($file);
75 # Test that realwarn is called
78 eval "sub CGI::Carp::realwarn {return 'Called realwarn'};";
81 $expect_l = __LINE__ + 1;
82 is(CGI::Carp::warn("There is a problem"),
84 "CGI::Carp::warn calls CORE::warn");
85 is(@CGI::Carp::WARNINGS, 0, "_warn not called");
87 # Test that message is constructed correctly
88 eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};';
90 $expect_l = __LINE__ + 1;
91 like(CGI::Carp::warn("There is a problem"),
92 "/] $id: There is a problem at $q_file line $expect_l.".'$/',
93 "CGI::Carp::warn builds correct message");
94 is(@CGI::Carp::WARNINGS, 0, "_warn not called");
96 # Test that _warn is called at the correct time
99 $expect_l = __LINE__ + 1;
100 like(CGI::Carp::warn("There is a problem"),
101 "/] $id: There is a problem at $q_file line $expect_l.".'$/',
102 "CGI::Carp::warn builds correct message");
104 is(@CGI::Carp::WARNINGS, 1, "_warn now called");
105 like($CGI::Carp::WARNINGS[0],
106 "/There is a problem at $q_file line $expect_l.".'$/',
107 "CGI::Carp::WARNINGS has correct message (without stamp)");
109 #-----------------------------------------------------------------------------
111 #-----------------------------------------------------------------------------
113 ok(!CGI::Carp::ineval, 'ineval returns false when not in eval');
114 eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');};
116 #-----------------------------------------------------------------------------
118 #-----------------------------------------------------------------------------
120 # set some variables to control what's going on.
121 $CGI::Carp::WRAP = 0;
123 $expect_l = __LINE__ + 1;
124 eval { CGI::Carp::die('There is a problem'); };
126 '/^There is a problem/',
127 'CGI::Carp::die calls CORE::die without altering argument in eval');
129 # Test that realwarn is called
132 eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
135 like(CGI::Carp::die('There is a problem'),
137 'CGI::Carp::die calls CORE::die, but adds stamp');
139 #-----------------------------------------------------------------------------
141 #-----------------------------------------------------------------------------
143 is(CGI::Carp::set_message('My new Message'),
145 'CGI::Carp::set_message returns new message');
147 is($CGI::Carp::CUSTOM_MSG,
149 'CGI::Carp::set_message message set correctly');
151 # set the message back to the empty string so that the tests later
153 CGI::Carp::set_message(''),
155 #-----------------------------------------------------------------------------
157 #-----------------------------------------------------------------------------
159 import CGI::Carp qw(name=new_progname);
160 is($CGI::Carp::PROGNAME,
162 'CGI::Carp::import set program name correctly');
164 is(CGI::Carp::set_progname('newer_progname'),
166 'CGI::Carp::set_progname returns new program name');
168 is($CGI::Carp::PROGNAME,
170 'CGI::Carp::set_progname program name set correctly');
172 # set the message back to the empty string so that the tests later
174 is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly");
175 is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly");
177 #-----------------------------------------------------------------------------
178 # Test warnings_to_browser
179 #-----------------------------------------------------------------------------
181 CGI::Carp::warningsToBrowser(0);
182 is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off");
183 unless( is(@CGI::Carp::WARNINGS, 1, "_warn not called") ) {
184 print join "\n", map "'$_'", @CGI::Carp::WARNINGS;
187 # turn off STDOUT (prevents spurious warnings to screen
188 tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
189 CGI::Carp::warningsToBrowser(1);
190 my $fake_out = join '', <STDOUT>;
193 open(STDOUT, ">&REAL_STDOUT");
195 $fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also
196 is( $fake_out, "<!-- warning: There is a problem at $fname line 100. -->\n",
197 'warningsToBrowser() on' );
199 is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");
200 is(@CGI::Carp::WARNINGS, 0, "_warn is called");
202 #-----------------------------------------------------------------------------
203 # Test fatals_to_browser
204 #-----------------------------------------------------------------------------
225 tie *STDOUT, "StoreStuff";
230 CGI::Carp::fatalsToBrowser();
231 $result[0] .= $_ while (<STDOUT>);
233 CGI::Carp::fatalsToBrowser('Message to the world');
234 $result[1] .= $_ while (<STDOUT>);
236 $ENV{SERVER_ADMIN} = 'foo@bar.com';
237 CGI::Carp::fatalsToBrowser();
238 $result[2] .= $_ while (<STDOUT>);
240 CGI::Carp::set_message('Override the message passed in'),
242 CGI::Carp::fatalsToBrowser('Message to the world');
243 $result[3] .= $_ while (<STDOUT>);
244 CGI::Carp::set_message(''),
245 delete $ENV{SERVER_ADMIN};
252 '/Content-type: text/html/',
253 "Default string has header");
255 ok($result[0] !~ /Message to the world/, "Custom message not in default string");
258 '/Message to the world/',
259 "Custom Message appears in output");
261 ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");
265 "Server Admin appears in output");
268 '/Message to the world/',
269 "Custom message not in result");
272 '/Override the message passed in/',
273 "Correct message in string");
275 #-----------------------------------------------------------------------------
277 #-----------------------------------------------------------------------------
280 CGI::Carp::to_filehandle (@_);
283 tie *STORE, "StoreStuff";
286 my $fh = FileHandle->new;
288 ok( defined buffer(\*STORE), '\*STORE returns proper filehandle');
289 ok( defined buffer( $fh ), '$fh returns proper filehandle');
290 ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle');
291 ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
292 ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle');