CGI/t/carp.t

1N/A# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
1N/A#!perl -w
1N/A
1N/Ause strict;
1N/A
1N/Ause Test::More tests => 61;
1N/Ause IO::Handle;
1N/A
1N/Ause CGI::Carp;
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test id
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A# directly invoked
1N/Amy $expect_f = __FILE__;
1N/Amy $expect_l = __LINE__ + 1;
1N/Amy ($file, $line, $id) = CGI::Carp::id(0);
1N/Ais($file, $expect_f, "file");
1N/Ais($line, $expect_l, "line");
1N/Ais($id, "carp.t", "id");
1N/A
1N/A# one level of indirection
1N/Asub id1 { my $level = shift; return CGI::Carp::id($level); };
1N/A
1N/A$expect_l = __LINE__ + 1;
1N/A($file, $line, $id) = id1(1);
1N/Ais($file, $expect_f, "file");
1N/Ais($line, $expect_l, "line");
1N/Ais($id, "carp.t", "id");
1N/A
1N/A# two levels of indirection
1N/Asub id2 { my $level = shift; return id1($level); };
1N/A
1N/A$expect_l = __LINE__ + 1;
1N/A($file, $line, $id) = id2(2);
1N/Ais($file, $expect_f, "file");
1N/Ais($line, $expect_l, "line");
1N/Ais($id, "carp.t", "id");
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test stamp
1N/A#-----------------------------------------------------------------------------
1N/A
1N/Amy $stamp = "/^\\[
1N/A      ([a-z]{3}\\s){2}\\s?
1N/A      [\\s\\d:]+
1N/A      \\]\\s$id:/ix";
1N/A
1N/Alike(CGI::Carp::stamp(),
1N/A     $stamp,
1N/A     "Time in correct format");
1N/A
1N/Asub stamp1 {return CGI::Carp::stamp()};
1N/Asub stamp2 {return stamp1()};
1N/A
1N/Alike(stamp2(), $stamp, "Time in correct format");
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test warn and _warn
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A# set some variables to control what's going on.
1N/A$CGI::Carp::WARN = 0;
1N/A$CGI::Carp::EMIT_WARNINGS = 0;
1N/Amy $q_file = quotemeta($file);
1N/A
1N/A
1N/A# Test that realwarn is called
1N/A{
1N/A  local $^W = 0;
1N/A  eval "sub CGI::Carp::realwarn {return 'Called realwarn'};";
1N/A}
1N/A
1N/A$expect_l = __LINE__ + 1;
1N/Ais(CGI::Carp::warn("There is a problem"),
1N/A   "Called realwarn",
1N/A   "CGI::Carp::warn calls CORE::warn");
1N/A
1N/A# Test that message is constructed correctly
1N/Aeval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};';
1N/A
1N/A$expect_l = __LINE__ + 1;
1N/Alike(CGI::Carp::warn("There is a problem"),
1N/A   "/] $id: There is a problem at $q_file line $expect_l.".'$/',
1N/A   "CGI::Carp::warn builds correct message");
1N/A
1N/A# Test that _warn is called at the correct time
1N/A$CGI::Carp::WARN = 1;
1N/A
1N/Amy $warn_expect_l = $expect_l = __LINE__ + 1;
1N/Alike(CGI::Carp::warn("There is a problem"),
1N/A   "/] $id: There is a problem at $q_file line $expect_l.".'$/',
1N/A   "CGI::Carp::warn builds correct message");
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test ineval
1N/A#-----------------------------------------------------------------------------
1N/A
1N/Aok(!CGI::Carp::ineval, 'ineval returns false when not in eval');
1N/Aeval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');};
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test die
1N/A#-----------------------------------------------------------------------------
1N/A
1N/A# set some variables to control what's going on.
1N/A$CGI::Carp::WRAP = 0;
1N/A
1N/A$expect_l = __LINE__ + 1;
1N/Aeval { CGI::Carp::die('There is a problem'); };
1N/Alike($@,
1N/A     '/^There is a problem/',
1N/A     'CGI::Carp::die calls CORE::die without altering argument in eval');
1N/A
1N/A# Test that realwarn is called
1N/A{
1N/A  local $^W = 0;
1N/A  local *CGI::Carp::realdie = sub { my $mess = shift; return $mess };
1N/A
1N/A    like(CGI::Carp::die('There is a problem'),
1N/A        $stamp,
1N/A        'CGI::Carp::die calls CORE::die, but adds stamp');
1N/A
1N/A}
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test set_message
1N/A#-----------------------------------------------------------------------------
1N/A
1N/Ais(CGI::Carp::set_message('My new Message'),
1N/A   'My new Message',
1N/A   'CGI::Carp::set_message returns new message');
1N/A
1N/Ais($CGI::Carp::CUSTOM_MSG,
1N/A   'My new Message',
1N/A   'CGI::Carp::set_message message set correctly');
1N/A
1N/A# set the message back to the empty string so that the tests later
1N/A# work properly.
1N/ACGI::Carp::set_message(''),
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test set_progname
1N/A#-----------------------------------------------------------------------------
1N/A
1N/Aimport CGI::Carp qw(name=new_progname);
1N/Ais($CGI::Carp::PROGNAME,
1N/A     'new_progname',
1N/A     'CGI::Carp::import set program name correctly');
1N/A
1N/Ais(CGI::Carp::set_progname('newer_progname'),
1N/A   'newer_progname',
1N/A   'CGI::Carp::set_progname returns new program name');
1N/A
1N/Ais($CGI::Carp::PROGNAME,
1N/A   'newer_progname',
1N/A   'CGI::Carp::set_progname program name set correctly');
1N/A
1N/A# set the message back to the empty string so that the tests later
1N/A# work properly.
1N/Ais (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly");
1N/Ais ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly");
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test warnings_to_browser
1N/A#-----------------------------------------------------------------------------
1N/A
1N/ACGI::Carp::warningsToBrowser(0);
1N/Ais($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off");
1N/A
1N/A# turn off STDOUT (prevents spurious warnings to screen
1N/Atie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
1N/ACGI::Carp::warningsToBrowser(1);
1N/Amy $fake_out = join '', <STDOUT>;
1N/Auntie *STDOUT;
1N/A
1N/Aopen(STDOUT, ">&REAL_STDOUT");
1N/Amy $fname = $0;
1N/A$fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also
1N/Ais( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n",
1N/A                        'warningsToBrowser() on' );
1N/A
1N/Ais($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test fatals_to_browser
1N/A#-----------------------------------------------------------------------------
1N/A
1N/Apackage StoreStuff;
1N/A
1N/Asub TIEHANDLE {
1N/A  my $class = shift;
1N/A  bless [], $class;
1N/A}
1N/A
1N/Asub PRINT {
1N/A  my $self = shift;
1N/A  push @$self, @_;
1N/A}
1N/A
1N/Asub READLINE {
1N/A  my $self = shift;
1N/A  shift @$self;
1N/A}
1N/A
1N/Apackage main;
1N/A
1N/Atie *STDOUT, "StoreStuff";
1N/A
1N/A# do tests
1N/Amy @result;
1N/A
1N/ACGI::Carp::fatalsToBrowser();
1N/A$result[0] .= $_ while (<STDOUT>);
1N/A
1N/ACGI::Carp::fatalsToBrowser('Message to the world');
1N/A$result[1] .= $_ while (<STDOUT>);
1N/A
1N/A$ENV{SERVER_ADMIN} = 'foo@bar.com';
1N/ACGI::Carp::fatalsToBrowser();
1N/A$result[2] .= $_ while (<STDOUT>);
1N/A
1N/ACGI::Carp::set_message('Override the message passed in'),
1N/A
1N/ACGI::Carp::fatalsToBrowser('Message to the world');
1N/A$result[3] .= $_ while (<STDOUT>);
1N/ACGI::Carp::set_message(''),
1N/Adelete $ENV{SERVER_ADMIN};
1N/A
1N/A# now restore STDOUT
1N/Auntie *STDOUT;
1N/A
1N/A
1N/Alike($result[0],
1N/A     '/Content-type: text/html/',
1N/A     "Default string has header");
1N/A
1N/Aok($result[0] !~ /Message to the world/, "Custom message not in default string");
1N/A
1N/Alike($result[1],
1N/A    '/Message to the world/',
1N/A    "Custom Message appears in output");
1N/A
1N/Aok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");
1N/A
1N/Alike($result[2],
1N/A    '/foo@bar.com/',
1N/A    "Server Admin appears in output");
1N/A
1N/Alike($result[3],
1N/A     '/Message to the world/',
1N/A     "Custom message not in result");
1N/A
1N/Alike($result[3],
1N/A     '/Override the message passed in/',
1N/A     "Correct message in string");
1N/A
1N/A#-----------------------------------------------------------------------------
1N/A# Test to_filehandle
1N/A#-----------------------------------------------------------------------------
1N/A
1N/Asub buffer {
1N/A  CGI::Carp::to_filehandle (@_);
1N/A}
1N/A
1N/Atie *STORE, "StoreStuff";
1N/A
1N/Arequire FileHandle;
1N/Amy $fh = FileHandle->new;
1N/A
1N/Aok( defined buffer(\*STORE),       '\*STORE returns proper filehandle');
1N/Aok( defined buffer( $fh ),         '$fh returns proper filehandle');
1N/Aok( defined buffer('::STDOUT'),    'STDIN returns proper filehandle');
1N/Aok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
1N/Aok(!defined buffer("WIBBLE"),      '"WIBBLE" doesn\'t returns proper filehandle');
1N/A
1N/A# Calling die with code refs with no WRAP
1N/A{
1N/A    local $CGI::Carp::WRAP = 0;
1N/A
1N/A    eval { CGI::Carp::die( 'regular string' ) };
1N/A    like $@ => qr/regular string/, 'die with string';
1N/A
1N/A    eval { CGI::Carp::die( [ 1..10 ] ) };
1N/A    like $@ => qr/ARRAY\(0x[\da-f]+\)/, 'die with array ref';
1N/A
1N/A    eval { CGI::Carp::die( { a => 1 } ) };
1N/A    like $@ => qr/HASH\(0x[\da-f]+\)/, 'die with hash ref';
1N/A
1N/A    eval { CGI::Carp::die( sub { 'Farewell' } ) };
1N/A    like $@ => qr/CODE\(0x[\da-f]+\)/, 'die with code ref';
1N/A
1N/A    eval { CGI::Carp::die( My::Plain::Object->new ) };
1N/A    isa_ok $@, 'My::Plain::Object';
1N/A
1N/A    eval { CGI::Carp::die( My::Plain::Object->new, ' and another argument' ) };
1N/A    like $@ => qr/My::Plain::Object/,     'object is stringified';
1N/A    like $@ => qr/and another argument/, 'second argument is present';
1N/A
1N/A    eval { CGI::Carp::die( My::Stringified::Object->new ) };
1N/A    isa_ok $@, 'My::Stringified::Object';
1N/A
1N/A    eval { CGI::Carp::die( My::Stringified::Object->new, ' and another argument' ) };
1N/A    like $@ => qr/stringified/,          'object is stringified';
1N/A    like $@ => qr/and another argument/, 'second argument is present';
1N/A
1N/A    eval { CGI::Carp::die() };
1N/A    like $@ => qr/Died at/, 'die with no argument';
1N/A}
1N/A
1N/A# Calling die with code refs when WRAPped
1N/A{
1N/A    local $CGI::Carp::WRAP = 1;
1N/A    local *CGI::Carp::realdie = sub { return @_ };
1N/A    local *STDOUT;
1N/A
1N/A    tie *STDOUT, 'StoreStuff';
1N/A
1N/A    my %result;   # store results because stdout is kidnapped
1N/A
1N/A    CGI::Carp::die( 'regular string' );
1N/A    $result{string} .= $_ while <STDOUT>;
1N/A
1N/A    CGI::Carp::die( [ 1..10 ] );
1N/A    $result{array_ref} .= $_ while <STDOUT>;
1N/A
1N/A    CGI::Carp::die( { a => 1 } );
1N/A    $result{hash_ref} .= $_ while <STDOUT>;
1N/A
1N/A    CGI::Carp::die( sub { 'Farewell' } );
1N/A    $result{code_ref} .= $_ while <STDOUT>;
1N/A
1N/A    CGI::Carp::die( My::Plain::Object->new );
1N/A    $result{plain_object} .= $_ while <STDOUT>;
1N/A
1N/A    CGI::Carp::die( My::Stringified::Object->new );
1N/A    $result{string_object} .= $_ while <STDOUT>;
1N/A
1N/A    undef $@;
1N/A    CGI::Carp::die();
1N/A    $result{no_args} .= $_ while <STDOUT>;
1N/A
1N/A    $@ = "I think I caught a virus";
1N/A    CGI::Carp::die();
1N/A    $result{propagated} .= $_ while <STDOUT>;
1N/A
1N/A    untie *STDOUT;
1N/A
1N/A    like $result{string}    => qr/regular string/, 'regular string, wrapped';
1N/A    like $result{array_ref} => qr/ARRAY\(\w+?\)/,  'array ref, wrapped';
1N/A    like $result{hash_ref}  => qr/HASH\(\w+?\)/,   'hash ref, wrapped';
1N/A    like $result{code_ref}  => qr/CODE\(\w+?\)/,   'code ref, wrapped';
1N/A    like $result{plain_object} => qr/My::Plain::Object/,
1N/A      'plain object, wrapped';
1N/A    like $result{string_object} => qr/stringified/,
1N/A      'stringified object, wrapped';
1N/A    like $result{no_args} => qr/Died at/, 'no args, wrapped';
1N/A
1N/A    like $result{propagated} => qr/I think I caught a virus\t\.{3}propagated/,
1N/A        'propagating $@ if no argument';
1N/A
1N/A}
1N/A
1N/A{
1N/A    package My::Plain::Object;
1N/A
1N/A    sub new {
1N/A        return bless {}, shift;
1N/A    }
1N/A}
1N/A
1N/A{
1N/A    package My::Stringified::Object;
1N/A
1N/A    use overload '""' => sub { 'stringified' };
1N/A
1N/A    sub new {
1N/A        return bless {}, shift;
1N/A    }
1N/A}
1N/A
1N/A
1N/A@result = ();
1N/Atie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
1N/A {
1N/A    eval {
1N/A        $CGI::Carp::TO_BROWSER = 0;
1N/A        die 'Message ToBrowser = 0';
1N/A    };
1N/A    $result[0] = $@;
1N/A    $result[1] .= $_ while (<STDOUT>);
1N/A }
1N/Auntie *STDOUT;
1N/A
1N/A like $result[0] => qr/Message ToBrowser/, 'die message for ToBrowser = 0 is OK';
1N/A ok !$result[1], 'No output for ToBrowser = 0';
1N/A