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 my $fname = $0;
 168 $fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also
 169 is( $fake_out, "<!-- warning: There is a problem at $fname line 95. -->\n",
 170                         'warningsToBrowser() on' );
 171
 172 is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");
 173 is(@CGI::Carp::WARNINGS, 0, "_warn is called");
 174
 175 #-----------------------------------------------------------------------------
 176 # Test fatals_to_browser
 177 #-----------------------------------------------------------------------------
 178
 179 package StoreStuff;
 180
 181 sub TIEHANDLE {
 182   my $class = shift;
 183   bless [], $class;
 184 }
 185
 186 sub PRINT {
 187   my $self = shift;
 188   push @$self, @_;
 189 }
 190
 191 sub READLINE {
 192   my $self = shift;
 193   shift @$self;
 194 }
 195
 196 package main;
 197
 198 tie *STDOUT, "StoreStuff";
 199
 200 # do tests
 201 my @result;
 202
 203 CGI::Carp::fatalsToBrowser();
 204 $result[0] .= $_ while (<STDOUT>);
 205
 206 CGI::Carp::fatalsToBrowser('Message to the world');
 207 $result[1] .= $_ while (<STDOUT>);
 208
 209 $ENV{SERVER_ADMIN} = 'foo@bar.com';
 210 CGI::Carp::fatalsToBrowser();
 211 $result[2] .= $_ while (<STDOUT>);
 212
 213 CGI::Carp::set_message('Override the message passed in'),
 214
 215 CGI::Carp::fatalsToBrowser('Message to the world');
 216 $result[3] .= $_ while (<STDOUT>);
 217 CGI::Carp::set_message(''),
 218 delete $ENV{SERVER_ADMIN};
 219
 220 # now restore STDOUT
 221 untie *STDOUT;
 222
 223
 224 like($result[0],
 225      '/Content-type: text/html/',
 226      "Default string has header");
 227
 228 ok($result[0] !~ /Message to the world/, "Custom message not in default string");
 229
 230 like($result[1],
 231     '/Message to the world/',
 232     "Custom Message appears in output");
 233
 234 ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");
 235
 236 like($result[2],
 237     '/foo@bar.com/',
 238     "Server Admin appears in output");
 239
 240 like($result[3],
 241      '/Message to the world/',
 242      "Custom message not in result");
 243
 244 like($result[3],
 245      '/Override the message passed in/',
 246      "Correct message in string");
 247
 248 #-----------------------------------------------------------------------------
 249 # Test to_filehandle
 250 #-----------------------------------------------------------------------------
 251
 252 sub buffer {
 253   CGI::Carp::to_filehandle (@_);
 254 }
 255
 256 tie *STORE, "StoreStuff";
 257
 258 require FileHandle;
 259 my $fh = FileHandle->new;
 260
 261 ok( defined buffer(\*STORE),       '\*STORE returns proper filehandle');
 262 ok( defined buffer( $fh ),         '$fh returns proper filehandle');
 263 ok( defined buffer('::STDOUT'),    'STDIN returns proper filehandle');
 264 ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
 265 ok(!defined buffer("WIBBLE"),      '"WIBBLE" doesn\'t returns proper filehandle');