1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*- 2#!/usr/local/bin/perl -w 3 4use strict; 5use lib qw(t/lib); 6 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 9use lib qw(blib/lib blib/arch); 10 11use Test::More tests => 41; 12use IO::Handle; 13 14BEGIN { use_ok('CGI::Carp') }; 15 16#----------------------------------------------------------------------------- 17# Test id 18#----------------------------------------------------------------------------- 19 20# directly invoked 21my $expect_f = __FILE__; 22my $expect_l = __LINE__ + 1; 23my ($file, $line, $id) = CGI::Carp::id(0); 24is($file, $expect_f, "file"); 25is($line, $expect_l, "line"); 26is($id, "carp.t", "id"); 27 28# one level of indirection 29sub id1 { my $level = shift; return CGI::Carp::id($level); }; 30 31$expect_l = __LINE__ + 1; 32($file, $line, $id) = id1(1); 33is($file, $expect_f, "file"); 34is($line, $expect_l, "line"); 35is($id, "carp.t", "id"); 36 37# two levels of indirection 38sub id2 { my $level = shift; return id1($level); }; 39 40$expect_l = __LINE__ + 1; 41($file, $line, $id) = id2(2); 42is($file, $expect_f, "file"); 43is($line, $expect_l, "line"); 44is($id, "carp.t", "id"); 45 46#----------------------------------------------------------------------------- 47# Test stamp 48#----------------------------------------------------------------------------- 49 50my $stamp = "/^\\[ 51 ([a-z]{3}\\s){2}\\s? 52 [\\s\\d:]+ 53 \\]\\s$id:/ix"; 54 55like(CGI::Carp::stamp(), 56 $stamp, 57 "Time in correct format"); 58 59sub stamp1 {return CGI::Carp::stamp()}; 60sub stamp2 {return stamp1()}; 61 62like(stamp2(), $stamp, "Time in correct format"); 63 64#----------------------------------------------------------------------------- 65# Test warn and _warn 66#----------------------------------------------------------------------------- 67 68# set some variables to control what's going on. 69$CGI::Carp::WARN = 0; 70$CGI::Carp::EMIT_WARNINGS = 0; 71my $q_file = quotemeta($file); 72 73 74# Test that realwarn is called 75{ 76 local $^W = 0; 77 eval "sub CGI::Carp::realwarn {return 'Called realwarn'};"; 78} 79 80$expect_l = __LINE__ + 1; 81is(CGI::Carp::warn("There is a problem"), 82 "Called realwarn", 83 "CGI::Carp::warn calls CORE::warn"); 84 85# Test that message is constructed correctly 86eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};'; 87 88$expect_l = __LINE__ + 1; 89like(CGI::Carp::warn("There is a problem"), 90 "/] $id: There is a problem at $q_file line $expect_l.".'$/', 91 "CGI::Carp::warn builds correct message"); 92 93# Test that _warn is called at the correct time 94$CGI::Carp::WARN = 1; 95 96my $warn_expect_l = $expect_l = __LINE__ + 1; 97like(CGI::Carp::warn("There is a problem"), 98 "/] $id: There is a problem at $q_file line $expect_l.".'$/', 99 "CGI::Carp::warn builds correct message"); 100 101#----------------------------------------------------------------------------- 102# Test ineval 103#----------------------------------------------------------------------------- 104 105ok(!CGI::Carp::ineval, 'ineval returns false when not in eval'); 106eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');}; 107 108#----------------------------------------------------------------------------- 109# Test die 110#----------------------------------------------------------------------------- 111 112# set some variables to control what's going on. 113$CGI::Carp::WRAP = 0; 114 115$expect_l = __LINE__ + 1; 116eval { CGI::Carp::die('There is a problem'); }; 117like($@, 118 '/^There is a problem/', 119 'CGI::Carp::die calls CORE::die without altering argument in eval'); 120 121# Test that realwarn is called 122{ 123 local $^W = 0; 124 eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};'; 125} 126 127like(CGI::Carp::die('There is a problem'), 128 $stamp, 129 'CGI::Carp::die calls CORE::die, but adds stamp'); 130 131#----------------------------------------------------------------------------- 132# Test set_message 133#----------------------------------------------------------------------------- 134 135is(CGI::Carp::set_message('My new Message'), 136 'My new Message', 137 'CGI::Carp::set_message returns new message'); 138 139is($CGI::Carp::CUSTOM_MSG, 140 'My new Message', 141 'CGI::Carp::set_message message set correctly'); 142 143# set the message back to the empty string so that the tests later 144# work properly. 145CGI::Carp::set_message(''), 146 147#----------------------------------------------------------------------------- 148# Test set_progname 149#----------------------------------------------------------------------------- 150 151import CGI::Carp qw(name=new_progname); 152is($CGI::Carp::PROGNAME, 153 'new_progname', 154 'CGI::Carp::import set program name correctly'); 155 156is(CGI::Carp::set_progname('newer_progname'), 157 'newer_progname', 158 'CGI::Carp::set_progname returns new program name'); 159 160is($CGI::Carp::PROGNAME, 161 'newer_progname', 162 'CGI::Carp::set_progname program name set correctly'); 163 164# set the message back to the empty string so that the tests later 165# work properly. 166is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly"); 167is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly"); 168 169#----------------------------------------------------------------------------- 170# Test warnings_to_browser 171#----------------------------------------------------------------------------- 172 173CGI::Carp::warningsToBrowser(0); 174is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off"); 175 176# turn off STDOUT (prevents spurious warnings to screen 177tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT"; 178CGI::Carp::warningsToBrowser(1); 179my $fake_out = join '', <STDOUT>; 180untie *STDOUT; 181 182open(STDOUT, ">&REAL_STDOUT"); 183my $fname = $0; 184$fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also 185is( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n", 186 'warningsToBrowser() on' ); 187 188is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off"); 189 190#----------------------------------------------------------------------------- 191# Test fatals_to_browser 192#----------------------------------------------------------------------------- 193 194package StoreStuff; 195 196sub TIEHANDLE { 197 my $class = shift; 198 bless [], $class; 199} 200 201sub PRINT { 202 my $self = shift; 203 push @$self, @_; 204} 205 206sub READLINE { 207 my $self = shift; 208 shift @$self; 209} 210 211package main; 212 213tie *STDOUT, "StoreStuff"; 214 215# do tests 216my @result; 217 218CGI::Carp::fatalsToBrowser(); 219$result[0] .= $_ while (<STDOUT>); 220 221CGI::Carp::fatalsToBrowser('Message to the world'); 222$result[1] .= $_ while (<STDOUT>); 223 224$ENV{SERVER_ADMIN} = 'foo@bar.com'; 225CGI::Carp::fatalsToBrowser(); 226$result[2] .= $_ while (<STDOUT>); 227 228CGI::Carp::set_message('Override the message passed in'), 229 230CGI::Carp::fatalsToBrowser('Message to the world'); 231$result[3] .= $_ while (<STDOUT>); 232CGI::Carp::set_message(''), 233delete $ENV{SERVER_ADMIN}; 234 235# now restore STDOUT 236untie *STDOUT; 237 238 239like($result[0], 240 '/Content-type: text/html/', 241 "Default string has header"); 242 243ok($result[0] !~ /Message to the world/, "Custom message not in default string"); 244 245like($result[1], 246 '/Message to the world/', 247 "Custom Message appears in output"); 248 249ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message"); 250 251like($result[2], 252 '/foo@bar.com/', 253 "Server Admin appears in output"); 254 255like($result[3], 256 '/Message to the world/', 257 "Custom message not in result"); 258 259like($result[3], 260 '/Override the message passed in/', 261 "Correct message in string"); 262 263#----------------------------------------------------------------------------- 264# Test to_filehandle 265#----------------------------------------------------------------------------- 266 267sub buffer { 268 CGI::Carp::to_filehandle (@_); 269} 270 271tie *STORE, "StoreStuff"; 272 273require FileHandle; 274my $fh = FileHandle->new; 275 276ok( defined buffer(\*STORE), '\*STORE returns proper filehandle'); 277ok( defined buffer( $fh ), '$fh returns proper filehandle'); 278ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle'); 279ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle'); 280ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle'); 281