This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Part Integrate mainline
[perl5.git] / lib / 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 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');