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');