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
   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);
  10
  11 use Test::More tests => 47;
  12 use IO::Handle;
  13
  14 BEGIN { use_ok('CGI::Carp') };
  15
  16 #-----------------------------------------------------------------------------
  17 # Test id
  18 #-----------------------------------------------------------------------------
  19
  20 # directly invoked
  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");
  27
  28 # one level of indirection
  29 sub id1 { my $level = shift; return CGI::Carp::id($level); };
  30
  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");
  36
  37 # two levels of indirection
  38 sub id2 { my $level = shift; return id1($level); };
  39
  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");
  45
  46 #-----------------------------------------------------------------------------
  47 # Test stamp
  48 #-----------------------------------------------------------------------------
  49
  50 my $stamp = "/^\\[
  51       ([a-z]{3}\\s){2}\\s?
  52       [\\s\\d:]+
  53       \\]\\s$id:/ix";
  54
  55 like(CGI::Carp::stamp(),
  56      $stamp,
  57      "Time in correct format");
  58
  59 sub stamp1 {return CGI::Carp::stamp()};
  60 sub stamp2 {return stamp1()};
  61
  62 like(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;
  71 @CGI::Carp::WARNINGS = ();
  72 my $q_file = quotemeta($file);
  73
  74
  75 # Test that realwarn is called
  76 {
  77   local $^W = 0;
  78   eval "sub CGI::Carp::realwarn {return 'Called realwarn'};";
  79 }
  80
  81 $expect_l = __LINE__ + 1;
  82 is(CGI::Carp::warn("There is a problem"),
  83    "Called realwarn",
  84    "CGI::Carp::warn calls CORE::warn");
  85 is(@CGI::Carp::WARNINGS, 0, "_warn not called");
  86
  87 # Test that message is constructed correctly
  88 eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};';
  89
  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");
  95
  96 # Test that _warn is called at the correct time
  97 $CGI::Carp::WARN = 1;
  98
  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");
 103
 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)");
 108
 109 #-----------------------------------------------------------------------------
 110 # Test ineval
 111 #-----------------------------------------------------------------------------
 112
 113 ok(!CGI::Carp::ineval, 'ineval returns false when not in eval');
 114 eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');};
 115
 116 #-----------------------------------------------------------------------------
 117 # Test die
 118 #-----------------------------------------------------------------------------
 119
 120 # set some variables to control what's going on.
 121 $CGI::Carp::WRAP = 0;
 122
 123 $expect_l = __LINE__ + 1;
 124 eval { CGI::Carp::die('There is a problem'); };
 125 like($@,
 126      '/^There is a problem/',
 127      'CGI::Carp::die calls CORE::die without altering argument in eval');
 128
 129 # Test that realwarn is called
 130 {
 131   local $^W = 0;
 132   eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
 133 }
 134
 135 like(CGI::Carp::die('There is a problem'),
 136      $stamp,
 137      'CGI::Carp::die calls CORE::die, but adds stamp');
 138
 139 #-----------------------------------------------------------------------------
 140 # Test set_message
 141 #-----------------------------------------------------------------------------
 142
 143 is(CGI::Carp::set_message('My new Message'),
 144    'My new Message',
 145    'CGI::Carp::set_message returns new message');
 146
 147 is($CGI::Carp::CUSTOM_MSG,
 148    'My new Message',
 149    'CGI::Carp::set_message message set correctly');
 150
 151 # set the message back to the empty string so that the tests later
 152 # work properly.
 153 CGI::Carp::set_message(''),
 154
 155 #-----------------------------------------------------------------------------
 156 # Test set_progname
 157 #-----------------------------------------------------------------------------
 158
 159 import CGI::Carp qw(name=new_progname);
 160 is($CGI::Carp::PROGNAME,
 161      'new_progname',
 162      'CGI::Carp::import set program name correctly');
 163
 164 is(CGI::Carp::set_progname('newer_progname'),
 165    'newer_progname',
 166    'CGI::Carp::set_progname returns new program name');
 167
 168 is($CGI::Carp::PROGNAME,
 169    'newer_progname',
 170    'CGI::Carp::set_progname program name set correctly');
 171
 172 # set the message back to the empty string so that the tests later
 173 # work properly.
 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");
 176
 177 #-----------------------------------------------------------------------------
 178 # Test warnings_to_browser
 179 #-----------------------------------------------------------------------------
 180
 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;
 185 }
 186
 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>;
 191 untie *STDOUT;
 192
 193 open(STDOUT, ">&REAL_STDOUT");
 194 my $fname = $0;
 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' );
 198
 199 is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");
 200 is(@CGI::Carp::WARNINGS, 0, "_warn is called");
 201
 202 #-----------------------------------------------------------------------------
 203 # Test fatals_to_browser
 204 #-----------------------------------------------------------------------------
 205
 206 package StoreStuff;
 207
 208 sub TIEHANDLE {
 209   my $class = shift;
 210   bless [], $class;
 211 }
 212
 213 sub PRINT {
 214   my $self = shift;
 215   push @$self, @_;
 216 }
 217
 218 sub READLINE {
 219   my $self = shift;
 220   shift @$self;
 221 }
 222
 223 package main;
 224
 225 tie *STDOUT, "StoreStuff";
 226
 227 # do tests
 228 my @result;
 229
 230 CGI::Carp::fatalsToBrowser();
 231 $result[0] .= $_ while (<STDOUT>);
 232
 233 CGI::Carp::fatalsToBrowser('Message to the world');
 234 $result[1] .= $_ while (<STDOUT>);
 235
 236 $ENV{SERVER_ADMIN} = 'foo@bar.com';
 237 CGI::Carp::fatalsToBrowser();
 238 $result[2] .= $_ while (<STDOUT>);
 239
 240 CGI::Carp::set_message('Override the message passed in'),
 241
 242 CGI::Carp::fatalsToBrowser('Message to the world');
 243 $result[3] .= $_ while (<STDOUT>);
 244 CGI::Carp::set_message(''),
 245 delete $ENV{SERVER_ADMIN};
 246
 247 # now restore STDOUT
 248 untie *STDOUT;
 249
 250
 251 like($result[0],
 252      '/Content-type: text/html/',
 253      "Default string has header");
 254
 255 ok($result[0] !~ /Message to the world/, "Custom message not in default string");
 256
 257 like($result[1],
 258     '/Message to the world/',
 259     "Custom Message appears in output");
 260
 261 ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");
 262
 263 like($result[2],
 264     '/foo@bar.com/',
 265     "Server Admin appears in output");
 266
 267 like($result[3],
 268      '/Message to the world/',
 269      "Custom message not in result");
 270
 271 like($result[3],
 272      '/Override the message passed in/',
 273      "Correct message in string");
 274
 275 #-----------------------------------------------------------------------------
 276 # Test to_filehandle
 277 #-----------------------------------------------------------------------------
 278
 279 sub buffer {
 280   CGI::Carp::to_filehandle (@_);
 281 }
 282
 283 tie *STORE, "StoreStuff";
 284
 285 require FileHandle;
 286 my $fh = FileHandle->new;
 287
 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');