lib/CGI/t/carp.t

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