cpan/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
   6 use Test::More tests => 41;
   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 my $q_file = quotemeta($file);
  67
  68
  69 # Test that realwarn is called
  70 {
  71   local $^W = 0;
  72   eval "sub CGI::Carp::realwarn {return 'Called realwarn'};";
  73 }
  74
  75 $expect_l = __LINE__ + 1;
  76 is(CGI::Carp::warn("There is a problem"),
  77    "Called realwarn",
  78    "CGI::Carp::warn calls CORE::warn");
  79
  80 # Test that message is constructed correctly
  81 eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};';
  82
  83 $expect_l = __LINE__ + 1;
  84 like(CGI::Carp::warn("There is a problem"),
  85    "/] $id: There is a problem at $q_file line $expect_l.".'$/',
  86    "CGI::Carp::warn builds correct message");
  87
  88 # Test that _warn is called at the correct time
  89 $CGI::Carp::WARN = 1;
  90
  91 my $warn_expect_l = $expect_l = __LINE__ + 1;
  92 like(CGI::Carp::warn("There is a problem"),
  93    "/] $id: There is a problem at $q_file line $expect_l.".'$/',
  94    "CGI::Carp::warn builds correct message");
  95
  96 #-----------------------------------------------------------------------------
  97 # Test ineval
  98 #-----------------------------------------------------------------------------
  99
 100 ok(!CGI::Carp::ineval, 'ineval returns false when not in eval');
 101 eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');};
 102
 103 #-----------------------------------------------------------------------------
 104 # Test die
 105 #-----------------------------------------------------------------------------
 106
 107 # set some variables to control what's going on.
 108 $CGI::Carp::WRAP = 0;
 109
 110 $expect_l = __LINE__ + 1;
 111 eval { CGI::Carp::die('There is a problem'); };
 112 like($@,
 113      '/^There is a problem/',
 114      'CGI::Carp::die calls CORE::die without altering argument in eval');
 115
 116 # Test that realwarn is called
 117 {
 118   local $^W = 0;
 119   eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
 120 }
 121
 122 like(CGI::Carp::die('There is a problem'),
 123      $stamp,
 124      'CGI::Carp::die calls CORE::die, but adds stamp');
 125
 126 #-----------------------------------------------------------------------------
 127 # Test set_message
 128 #-----------------------------------------------------------------------------
 129
 130 is(CGI::Carp::set_message('My new Message'),
 131    'My new Message',
 132    'CGI::Carp::set_message returns new message');
 133
 134 is($CGI::Carp::CUSTOM_MSG,
 135    'My new Message',
 136    'CGI::Carp::set_message message set correctly');
 137
 138 # set the message back to the empty string so that the tests later
 139 # work properly.
 140 CGI::Carp::set_message(''),
 141
 142 #-----------------------------------------------------------------------------
 143 # Test set_progname
 144 #-----------------------------------------------------------------------------
 145
 146 import CGI::Carp qw(name=new_progname);
 147 is($CGI::Carp::PROGNAME,
 148      'new_progname',
 149      'CGI::Carp::import set program name correctly');
 150
 151 is(CGI::Carp::set_progname('newer_progname'),
 152    'newer_progname',
 153    'CGI::Carp::set_progname returns new program name');
 154
 155 is($CGI::Carp::PROGNAME,
 156    'newer_progname',
 157    'CGI::Carp::set_progname program name set correctly');
 158
 159 # set the message back to the empty string so that the tests later
 160 # work properly.
 161 is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly");
 162 is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly");
 163
 164 #-----------------------------------------------------------------------------
 165 # Test warnings_to_browser
 166 #-----------------------------------------------------------------------------
 167
 168 CGI::Carp::warningsToBrowser(0);
 169 is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off");
 170
 171 # turn off STDOUT (prevents spurious warnings to screen
 172 tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
 173 CGI::Carp::warningsToBrowser(1);
 174 my $fake_out = join '', <STDOUT>;
 175 untie *STDOUT;
 176
 177 open(STDOUT, ">&REAL_STDOUT");
 178 my $fname = $0;
 179 $fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also
 180 is( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n",
 181                         'warningsToBrowser() on' );
 182
 183 is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");
 184
 185 #-----------------------------------------------------------------------------
 186 # Test fatals_to_browser
 187 #-----------------------------------------------------------------------------
 188
 189 package StoreStuff;
 190
 191 sub TIEHANDLE {
 192   my $class = shift;
 193   bless [], $class;
 194 }
 195
 196 sub PRINT {
 197   my $self = shift;
 198   push @$self, @_;
 199 }
 200
 201 sub READLINE {
 202   my $self = shift;
 203   shift @$self;
 204 }
 205
 206 package main;
 207
 208 tie *STDOUT, "StoreStuff";
 209
 210 # do tests
 211 my @result;
 212
 213 CGI::Carp::fatalsToBrowser();
 214 $result[0] .= $_ while (<STDOUT>);
 215
 216 CGI::Carp::fatalsToBrowser('Message to the world');
 217 $result[1] .= $_ while (<STDOUT>);
 218
 219 $ENV{SERVER_ADMIN} = 'foo@bar.com';
 220 CGI::Carp::fatalsToBrowser();
 221 $result[2] .= $_ while (<STDOUT>);
 222
 223 CGI::Carp::set_message('Override the message passed in'),
 224
 225 CGI::Carp::fatalsToBrowser('Message to the world');
 226 $result[3] .= $_ while (<STDOUT>);
 227 CGI::Carp::set_message(''),
 228 delete $ENV{SERVER_ADMIN};
 229
 230 # now restore STDOUT
 231 untie *STDOUT;
 232
 233
 234 like($result[0],
 235      '/Content-type: text/html/',
 236      "Default string has header");
 237
 238 ok($result[0] !~ /Message to the world/, "Custom message not in default string");
 239
 240 like($result[1],
 241     '/Message to the world/',
 242     "Custom Message appears in output");
 243
 244 ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");
 245
 246 like($result[2],
 247     '/foo@bar.com/',
 248     "Server Admin appears in output");
 249
 250 like($result[3],
 251      '/Message to the world/',
 252      "Custom message not in result");
 253
 254 like($result[3],
 255      '/Override the message passed in/',
 256      "Correct message in string");
 257
 258 #-----------------------------------------------------------------------------
 259 # Test to_filehandle
 260 #-----------------------------------------------------------------------------
 261
 262 sub buffer {
 263   CGI::Carp::to_filehandle (@_);
 264 }
 265
 266 tie *STORE, "StoreStuff";
 267
 268 require FileHandle;
 269 my $fh = FileHandle->new;
 270
 271 ok( defined buffer(\*STORE),       '\*STORE returns proper filehandle');
 272 ok( defined buffer( $fh ),         '$fh returns proper filehandle');
 273 ok( defined buffer('::STDOUT'),    'STDIN returns proper filehandle');
 274 ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
 275 ok(!defined buffer("WIBBLE"),      '"WIBBLE" doesn\'t returns proper filehandle');