use lib qw(t/lib blib/lib blib/arch);
use Test;
use Carp;
use strict;
use vars qw(%field %in);
$|++;
BEGIN { plan tests => 331, }
do{ run_renumber(); exit } if $ARGV[0];
# BEGIN
use CGI::Simple;
ok(1); # test 1
my ( $q, $sv, @av );
my $debug = 1;
my $tmpfile = './cgi-tmpfile.tmp';
do { $^W = 1; } if $debug;
$ENV{'AUTH_TYPE'} = 'PGP MD5 DES rot13';
$ENV{'CONTENT_LENGTH'} = '42';
$ENV{'CONTENT_TYPE'} = 'application/x-www-form-urlencoded';
$ENV{'COOKIE'} = 'foo=a%20phrase; bar=yes%2C%20a%20phrase&I%20say;';
$ENV{'DOCUMENT_ROOT'} = '/vs/www/foo';
$ENV{'GATEWAY_INTERFACE'} = 'bleeding edge';
$ENV{'HTTPS'} = 'ON';
$ENV{'HTTPS_A'} = 'A';
$ENV{'HTTPS_B'} = 'B';
$ENV{'HTTP_ACCEPT'} = 'text/html;q=1, text/plain;q=0.8, image/jpg, image/gif;q=0.42, */*;q=0.001';
$ENV{'HTTP_COOKIE'} = '';
$ENV{'HTTP_FROM'} = 'spammer@nowhere.com';
$ENV{'HTTP_HOST'} = 'the.vatican.org';
$ENV{'HTTP_REFERER'} = 'xxx.sex.com';
$ENV{'HTTP_USER_AGENT'} = 'LWP';
$ENV{'PATH_INFO'} = '/somewhere/else';
$ENV{'PATH_TRANSLATED'} = '/usr/local/somewhere/else';
$ENV{'QUERY_STRING'} = 'name=JaPh%2C&color=red&color=green&color=blue';
$ENV{'REDIRECT_QUERY_STRING'} = '';
$ENV{'REMOTE_ADDR'} = '127.0.0.1';
$ENV{'REMOTE_HOST'} = 'localhost';
$ENV{'REMOTE_IDENT'} = 'None of your damn business';
$ENV{'REMOTE_USER'} = 'Just another Perl hacker,';
$ENV{'REQUEST_METHOD'} = 'GET';
$ENV{'SCRIPT_NAME'} = '/cgi-bin/foo.cgi';
$ENV{'SERVER_NAME'} = 'nowhere.com';
$ENV{'SERVER_PORT'} = '8080';
$ENV{'SERVER_PROTOCOL'} = 'HTTP/1.0';
$ENV{'SERVER_SOFTWARE'} = 'Apache - accept no substitutes';
$q = new CGI::Simple;
eval { goto HERE };
sub undef_globals {
undef $CGI::Simple::USE_CGI_PM_DEFAULTS;
undef $CGI::Simple::DISABLE_UPLOADS;
undef $CGI::Simple::POST_MAX;
undef $CGI::Simple::NO_UNDEF_PARAMS;
undef $CGI::Simple::USE_PARAM_SEMICOLONS;
undef $CGI::Simple::HEADERS_ONCE;
undef $CGI::Simple::NPH;
undef $CGI::Simple::DEBUG;
undef $CGI::Simple::NO_NULL;
undef $CGI::Simple::FATAL;
}
undef_globals();
# _initialize_globals()
print "Testing: _initialize_globals()\n" if $debug;
$q->_initialize_globals();
ok( $CGI::Simple::USE_CGI_PM_DEFAULTS , 0 ); # test 2
ok( $CGI::Simple::DISABLE_UPLOADS , 1 ); # test 3
ok( $CGI::Simple::POST_MAX , 102_400 ); # test 4
ok( $CGI::Simple::NO_UNDEF_PARAMS , 0 ); # test 5
ok( $CGI::Simple::USE_PARAM_SEMICOLONS , 0 ); # test 6
ok( $CGI::Simple::HEADERS_ONCE , 0 ); # test 7
ok( $CGI::Simple::NPH , 0 ); # test 8
ok( $CGI::Simple::DEBUG , 0 ); # test 9
ok( $CGI::Simple::NO_NULL , 1 ); # test 10
ok( $CGI::Simple::FATAL , -1 ); # test 11
undef_globals();
# _use_cgi_pm_global_settings()
print "Testing: _use_cgi_pm_global_settings()\n" if $debug;
$q->_use_cgi_pm_global_settings();
ok( $CGI::Simple::DISABLE_UPLOADS , 0 ); # test 12
ok( $CGI::Simple::POST_MAX , -1 ); # test 13
ok( $CGI::Simple::NO_UNDEF_PARAMS , 0 ); # test 14
ok( $CGI::Simple::USE_PARAM_SEMICOLONS , 1 ); # test 15
ok( $CGI::Simple::HEADERS_ONCE , 0 ); # test 16
ok( $CGI::Simple::NPH , 0 ); # test 17
ok( $CGI::Simple::DEBUG , 1 ); # test 18
ok( $CGI::Simple::NO_NULL , 0 ); # test 19
ok( $CGI::Simple::FATAL , -1 ); # test 20
# _store_globals()
print "Testing: _store_globals()\n" if $debug;
undef %{$q};
ok ( (! defined $q->{'.globals'}->{'DISABLE_UPLOADS'}) ,1 ); # test 21
ok ( (! defined $q->{'.globals'}->{'POST_MAX'}) ,1 ); # test 22
ok ( (! defined $q->{'.globals'}->{'NO_UNDEF_PARAMS'}) ,1 ); # test 23
ok ( (! defined $q->{'.globals'}->{'USE_PARAM_SEMICOLONS'}) ,1 ); # test 24
ok ( (! defined $q->{'.globals'}->{'HEADERS_ONCE'}) ,1 ); # test 25
ok ( (! defined $q->{'.globals'}->{'NPH'}) ,1 ); # test 26
ok ( (! defined $q->{'.globals'}->{'DEBUG'}) ,1 ); # test 27
ok ( (! defined $q->{'.globals'}->{'NO_NULL'}) ,1 ); # test 28
ok ( (! defined $q->{'.globals'}->{'FATAL'}) ,1 ); # test 29
ok ( (! defined $q->{'.globals'}->{'USE_CGI_PM_DEFAULTS'}) ,1 ); # test 30
$q->_store_globals();
ok ( defined $q->{'.globals'}->{'DISABLE_UPLOADS'} ,1 ); # test 31
ok ( defined $q->{'.globals'}->{'POST_MAX'} ,1 ); # test 32
ok ( defined $q->{'.globals'}->{'NO_UNDEF_PARAMS'} ,1 ); # test 33
ok ( defined $q->{'.globals'}->{'USE_PARAM_SEMICOLONS'} ,1 ); # test 34
ok ( defined $q->{'.globals'}->{'HEADERS_ONCE'} ,1 ); # test 35
ok ( defined $q->{'.globals'}->{'NPH'} ,1 ); # test 36
ok ( defined $q->{'.globals'}->{'DEBUG'} ,1 ); # test 37
ok ( defined $q->{'.globals'}->{'NO_NULL'} ,1 ); # test 38
ok ( defined $q->{'.globals'}->{'FATAL'} ,1 ); # test 39
ok ( defined $q->{'.globals'}->{'USE_CGI_PM_DEFAULTS'} ,1 ); # test 40
# import() - used to set paragmas
print "Testing: import()\n" if $debug;
my @args = qw( -default -no_upload -unique_header -nph -no_debug -newstyle_url -no_undef_param );
undef_globals();
$q->import(@args);
ok( $CGI::Simple::USE_CGI_PM_DEFAULTS , 1 ); # test 41
ok( $CGI::Simple::DISABLE_UPLOADS , 1 ); # test 42
ok( $CGI::Simple::NO_UNDEF_PARAMS , 1 ); # test 43
ok( $CGI::Simple::USE_PARAM_SEMICOLONS , 1 ); # test 44
ok( $CGI::Simple::HEADERS_ONCE , 1 ); # test 45
ok( $CGI::Simple::NPH , 1 ); # test 46
ok( $CGI::Simple::DEBUG , 0 ); # test 47
undef_globals();
$q->import( qw ( -upload -oldstyle_url -debug ) );
ok( $CGI::Simple::DISABLE_UPLOADS , 0 ); # test 48
ok( $CGI::Simple::USE_PARAM_SEMICOLONS , 0 ); # test 49
ok( $CGI::Simple::DEBUG , 2 ); # test 50
undef_globals();
# _reset_globals()
print "Testing: _reset_globals()\n" if $debug;
$q->_reset_globals();
ok( $CGI::Simple::DISABLE_UPLOADS , 0 ); # test 51
ok( $CGI::Simple::POST_MAX , -1 ); # test 52
ok( $CGI::Simple::NO_UNDEF_PARAMS , 0 ); # test 53
ok( $CGI::Simple::USE_PARAM_SEMICOLONS , 1 ); # test 54
ok( $CGI::Simple::HEADERS_ONCE , 0 ); # test 55
ok( $CGI::Simple::NPH , 0 ); # test 56
ok( $CGI::Simple::DEBUG , 1 ); # test 57
ok( $CGI::Simple::NO_NULL , 0 ); # test 58
ok( $CGI::Simple::FATAL , -1 ); # test 59
undef_globals();
$q = new CGI::Simple;
# url_decode() - scalar context, void argument
print "Testing: url_decode()\n" if $debug;
$sv = $q->url_decode();
ok ( $sv, undef ); # test 60
# url_decode() - scalar context, valid argument
print "Testing: url_decode(\$enc_string)\n" if $debug;
my ( $string, $enc_string );
for (32..255) { $string .= chr ; $enc_string .= uc sprintf "%%%02x", ord chr }
ok ( $q->url_decode($enc_string), $string ); # test 61
# url_encode() - scalar context, void argument
print "Testing: url_encode()\n" if $debug;
$sv = $q->url_encode();
ok ( $sv, undef ); # test 62
# url_encode() - scalar context, valid argument
print "Testing: url_encode(\$string)\n" if $debug;
$sv = $q->url_encode($string);
$sv =~ tr/+/ /;
$sv =~ s/%([a-fA-F0-9]{2})/ pack "C", hex $1 /eg;
ok ( $sv, $string ); # test 63
# url encoding - circular test
print "Testing: url encoding via circular test\n" if $debug;
ok ( $q->url_decode($q->url_encode($string)), $string ); # test 64
# new() plain constructor
print "Testing: new() plain constructor\n" if $debug;
$q = CGI::Simple->new;
ok( $q, qr/CGI::Simple/ ); # test 65
# new('') empty constructor
print "Testing: new() empty constructor\n" if $debug;
$q = new CGI::Simple('');
ok( $q, qr/CGI::Simple/ ); # test 66
$q = new CGI::Simple({});
ok( $q, qr/CGI::Simple/ ); # test 67
# new() hash constructor
print "Testing: new() hash constructor\n" if $debug;
$q = new CGI::Simple( { 'foo'=>'1', 'bar'=>[2,3,4] } );
@av = $q->param;
# fix OS bug with testing
ok( (join' ',@av) eq 'foo bar' or (join' ',@av) eq 'bar foo' ); # test 68
ok( $q->param('foo'), 1); # test 69
ok( $q->param('bar'), 2 ); # test 70
@av = $q->param('bar');
ok( (join'',@av), 234 ); # test 71
$q = new CGI::Simple( 'foo=1&bar=2&bar=3&bar=4' );
open FH, ">$tmpfile", or carp "Can't create $tmpfile $!\n";
$q->save(\*FH);
close FH;
# new() query string constructor
print "Testing: new() query string constructor\n" if $debug;
$q = new CGI::Simple( 'foo=5&bar=6&bar=7&bar=8' );
@av = $q->param;
ok( (join' ',@av), 'foo bar' ); # test 72
ok( $q->param('foo'), 5); # test 73
ok( $q->param('bar'), 6 ); # test 74
@av = $q->param('bar');
ok( (join'',@av), 678 ); # test 75
open FH, ">>$tmpfile", or carp "Can't append $tmpfile $!\n";
$q->save_parameters(\*FH);
close FH;
# new() file constructor
print "Testing: new() file constructor\n" if $debug;
open FH, $tmpfile, or carp "Can't open temp file\n";
ok( (join'',<FH>), "foo=1\nbar=2\nbar=3\nbar=4\n=\nfoo=5\nbar=6\nbar=7\nbar=8\n=\n" ); # test 76
close FH;
open FH, $tmpfile, or carp "Can't open temp file\n";
$q = new CGI::Simple(\*FH);
close FH;
@av = $q->param;
ok( (join' ',@av), 'foo bar' ); # test 77
ok( $q->param('foo'), 1); # test 78
ok( $q->param('bar'), 2 ); # test 79
@av = $q->param('bar');
ok( (join'',@av), 234 ); # test 80
# call new twice to read two sections of file
open FH, $tmpfile, or carp "Can't open temp file\n";
$q = new CGI::Simple(\*FH);
@av = $q->param;
ok( (join' ',@av), 'foo bar' ); # test 81
ok( $q->param('foo'), 1); # test 82
ok( $q->param('bar'), 2 ); # test 83
@av = $q->param('bar');
ok( (join'',@av), 234 ); # test 84
# call new again
$q = new CGI::Simple(\*FH);
close FH;
@av = $q->param;
ok( (join' ',@av), 'foo bar' ); # test 85
ok( $q->param('foo'), 5); # test 86
ok( $q->param('bar'), 6 ); # test 87
@av = $q->param('bar');
ok( (join'',@av), 678 ); # test 88
# call new with a blessed glob ( test chromatic's patch with chromatic's test!)
open FH, $tmpfile, or carp "Can't open temp file\n";
my $fh = bless \*FH, 'Some::Class';
$q = new CGI::Simple( $fh );
close FH;
@av = $q->param;
ok( (join' ',@av), 'foo bar' ); # test 89
# new() CGI::Simple object constructor
print "Testing: new() CGI::Simple object constructor\n" if $debug;
my $q_old = new CGI::Simple( 'foo=1&bar=2&bar=3&bar=4' );
my $q_new = new CGI::Simple( $q_old );
ok( $q_old->query_string, 'foo=1&bar=2&bar=3&bar=4' ); # test 90
ok( $q_new->query_string, 'foo=1&bar=2&bar=3&bar=4' ); # test 91
# new() \@ARGV constructor
print "Testing: new() \@ARGV constructor\n" if $debug;
$ENV{'REQUEST_METHOD'} = '';
$CGI::Simple::DEBUG = 1;
@ARGV = qw( foo=bar\=baz foo=bar\&baz );
$q = new CGI::Simple;
ok( (join ' ', $q->param('foo')), 'bar=baz bar&baz' ); # test 92
$ENV{'REQUEST_METHOD'} = 'GET';
################ The Core Methods ################
$q = new CGI::Simple;
# param() - scalar and array context, void argument
print "Testing: param() void argument\n" if $debug;
$sv = $q->param();
@av = $q->param();
ok ( $sv, '2' ); # test 93
ok ( (join' ',@av), 'name color' ); # test 94
# param() - scalar and array context, single argument (valid)
print "Testing: param('color') single argument (valid)\n" if $debug;
$sv = $q->param('color');
@av = $q->param('color');
ok ( $sv, 'red' ); # test 95
ok ( (join' ',@av), 'red green blue' ); # test 96
# param() - scalar and array context, single argument (invalid)
print "Testing: param('invalid') single argument (invalid)\n" if $debug;
$sv = $q->param('invalid');
@av = $q->param('invalid');
ok ( $sv, undef ); # test 97
ok ( (join' ',@av), '' ); # test 98
# param() - scalar and array context, -name=>'param' (valid)
print "Testing: param( -name=>'color' ) get values\n" if $debug;
$sv = $q->param( -name=>'color' );
@av = $q->param( -name=>'color' );
ok ( $sv, 'red' ); # test 99
ok ( (join' ',@av), 'red green blue' ); # test 100
# param() - scalar and array context, -name=>'param' (invalid)
print "Testing: param( -name=>'invalid' ) get values\n" if $debug;
$sv = $q->param( -name=>'invalid' );
@av = $q->param( -name=>'invalid' );
ok ( $sv, undef ); # test 101
ok ( (join' ',@av), '' ); # test 102
$CGI::Simple::NO_UNDEF_PARAMS = 0;
$q = new CGI::Simple ( 'name=&color=' );
# param() - scalar and array context, void values void arg
print "Testing: param() void values 1\n" if $debug;
$sv = $q->param();
@av = $q->param();
ok ( $sv, '2' ); # test 103
ok ( (join' ',@av), 'name color' ); # test 104
# param() - scalar and array context, void values, valid arg
print "Testing: param('name') void values 1, valid param\n" if $debug;
$sv = $q->param('name');
@av = $q->param('name');
ok ( $sv, '' ); # test 105
ok ( (join' ',@av), '' ); # test 106
$q = new CGI::Simple ( 'name&color' );
# param() - scalar and array context, void values void arg
print "Testing: param() void values 2\n" if $debug;
$sv = $q->param();
@av = $q->param();
ok ( $sv, '2' ); # test 107
ok ( (join' ',@av), 'name color' ); # test 108
# param() - scalar and array context, void values, valid arg
print "Testing: param('name') void values 2 , valid param\n" if $debug;
$sv = $q->param('name');
@av = $q->param('name');
ok ( $sv, '' ); # test 109
ok ( (join' ',@av), '' ); # test 110
$CGI::Simple::NO_UNDEF_PARAMS = 1;
$q = new CGI::Simple ( 'name=&color=' );
# param() - scalar and array context, void values void arg
print "Testing: param() void values 1, no undef\n" if $debug;
$sv = $q->param();
@av = $q->param();
ok ( $sv, '0' ); # test 111
ok ( (join' ',@av), '' ); # test 112
# param() - scalar and array context, void values, valid arg
print "Testing: param('name') void values 1, valid param, no undef\n" if $debug;
$sv = $q->param('name');
@av = $q->param('name');
ok ( $sv, undef ); # test 113
ok ( (join' ',@av), '' ); # test 114
$q = new CGI::Simple ( 'name&color' );
# param() - scalar and array context, void values void arg
print "Testing: param() void values 2, no undef\n" if $debug;
$sv = $q->param();
@av = $q->param();
ok ( $sv, '0' ); # test 115
ok ( (join' ',@av), '' ); # test 116
# param() - scalar and array context, void values, valid arg
print "Testing: param('name') void values 2, valid param, no undef\n" if $debug;
$sv = $q->param('name');
@av = $q->param('name');
ok ( $sv, undef ); # test 117
ok ( (join' ',@av), '' ); # test 118
$CGI::Simple::NO_UNDEF_PARAMS = 0;
$q = new CGI::Simple;
# param() - scalar and array context, set values
print "Testing: param( 'foo', 'some', 'new', 'values' ) set values\n" if $debug;
$sv = $q->param( 'foo', 'some', 'new', 'values' );
@av = $q->param( 'foo', 'some', 'new', 'values' );
ok ( $sv, 'some' ); # test 119
ok ( (join' ',@av), 'some new values' ); # test 120
# param() - scalar and array context
print "Testing: param( -name=>'foo', -value=>'bar' ) set values\n" if $debug;
$sv = $q->param( -name=>'foo', -value=>'bar' );
@av = $q->param( -name=>'foo', -value=>'bar' );
ok ( $sv, 'bar' ); # test 121
ok ( (join' ',@av), 'bar' ); # test 122
# param() - scalar and array context
print "Testing: param(-name=>'foo',-value=>['bar','baz']) set values\n" if $debug;
$sv = $q->param( -name=>'foo', -value=>['bar','baz'] );
@av = $q->param( -name=>'foo', -value=>['bar','baz'] );
ok ( $sv, 'bar' ); # test 123
ok ( (join' ',@av), 'bar baz' ); # test 124
# add_param() - scalar and array context, void argument
print "Testing: add_param()\n" if $debug;
$sv = $q->add_param();
@av = $q->add_param();
ok ( $sv, undef ); # test 125
ok ( (join' ',@av), '' ); # test 126
# add_param() - scalar and array context, existing param argument
print "Testing: add_param( 'foo', 'new' )\n" if $debug;
$q->add_param('foo', 'new');
@av = $q->param('foo');
ok ( (join' ',@av), 'bar baz new' ); # test 127
$q->add_param('foo', [1,2,3,4,5]);
@av = $q->param('foo');
ok ( (join' ',@av), 'bar baz new 1 2 3 4 5' ); # test 128
# add_param() - existing param argument, overwrite
print "Testing: add_param('foo', 'bar', 'overwrite' )\n" if $debug;
$q->add_param( 'foo', 'bar', 'overwrite' );
@av = $q->param('foo');
ok ( (join' ',@av), 'bar' ); # test 129
# add_param() - scalar and array context, existing param argument
print "Testing: add_param( 'new', 'new' )\n" if $debug;
$q->add_param( 'new', 'new%2C' );
@av = $q->param('new');
ok ( (join' ',@av), 'new%2C' ); # test 130
$q->add_param('new', [1,2,3,4,5]);
@av = $q->param('new');
ok ( (join' ',@av), 'new%2C 1 2 3 4 5' ); # test 131
# param_fetch() - scalar context, void argument
print "Testing: param_fetch()\n" if $debug;
$sv = $q->param_fetch();
ok ( $sv, undef ); # test 132
# param_fetch() - scalar context, 'color' syntax
print "Testing: param_fetch( 'color' )\n" if $debug;
$sv = $q->param_fetch( 'color' );
ok ( ref $sv, 'ARRAY' ); # test 133
ok ( (join' ',@$sv), 'red green blue' ); # test 134
# param_fetch() - scalar context, -name=>'color' syntax
print "Testing: param_fetch( -name=>'color' )\n" if $debug;
$sv = $q->param_fetch( -name=>'color' );
ok ( ref $sv, 'ARRAY' ); # test 135
ok ( (join' ',@$sv), 'red green blue' ); # test 136
# url_param() - scalar and array context, void argument
print "Testing: url_param() void argument\n" if $debug;
$sv = $q->url_param();
@av = $q->url_param();
ok ( $sv, '2' ); # test 137
ok ( (join' ',@av), 'name color' ); # test 138
# url_param() - scalar and array context, single argument (valid)
print "Testing: url_param('color') single argument (valid)\n" if $debug;
$sv = $q->url_param('color');
@av = $q->url_param('color');
ok ( $sv, 'red' ); # test 139
ok ( (join' ',@av), 'red green blue' ); # test 140
# url_param() - scalar and array context, single argument (invalid)
print "Testing: url_param('invalid') single argument (invalid)\n" if $debug;
$sv = $q->url_param('invalid');
@av = $q->url_param('invalid');
ok ( $sv, undef ); # test 141
ok ( (join' ',@av), '' ); # test 142
# keywords() - scalar and array context, void argument
print "Testing: keywords()\n" if $debug;
$q = new CGI::Simple( 'here+are++++some%20keywords' );
$sv = $q->keywords;
@av = $q->keywords;
ok ( $sv, '4' ); # test 143
ok ( (join' ',@av), 'here are some keywords' ); # test 144
# keywords() - scalar and array context, array argument
print "Testing: keywords( 'foo', 'bar', 'baz' )\n" if $debug;
$sv = $q->keywords( 'foo', 'bar', 'baz' );
@av = $q->keywords( 'foo', 'bar', 'baz' );
ok ( $sv, '3' ); # test 145
ok ( (join' ',@av), 'foo bar baz' ); # test 146
# keywords() - scalar and array context, array ref argument
print "Testing: keywords( ['foo', 'man', 'chu'] )\n" if $debug;
$q = new CGI::Simple;
$sv = $q->keywords( ['foo', 'man', 'chu'] );
@av = $q->keywords( ['foo', 'man', 'chu'] );
ok ( $sv, '3' ); # test 147
ok ( (join' ',@av), 'foo man chu' ); # test 148
print "Testing: Vars() - tied interface\n" if $debug;
$sv = $q->Vars();
ok ( $sv->{'color'}, "red\0green\0blue" ); # test 149
$sv->{'color'} = "foo\0bar\0baz";
ok( (join' ',$q->param('color')), 'foo bar baz'); # test 150
$q = new CGI::Simple;
# Vars() - hash context, void argument
print "Testing: Vars()\n" if $debug;
my %hv = $q->Vars();
ok ( $hv{'name'}, 'JaPh,' ); # test 151
# Vars() - hash context, "|" argument
print "Testing: Vars(',')\n" if $debug;
%hv = $q->Vars(',');
ok ( $hv{'color'}, 'red,green,blue' ); # test 152
# append() - scalar and array context, void argument
print "Testing: append()\n" if $debug;
$sv = $q->append();
@av = $q->append();
ok ( $sv, undef ); # test 153
ok ( (join'',@av), '' ); # test 154
# append() - scalar and array context, set values, valid param
print "Testing: append( 'foo', 'some' ) set values\n" if $debug;
$q->add_param( 'foo', 'bar', 'overwrite' );
$sv = $q->append( 'foo', 'some' );
@av = $q->append( 'foo', 'some-more' );
ok ( $sv, 'bar' ); # test 155
ok ( (join' ',@av), 'bar some some-more' ); # test 156
# append() - scalar and array context, set values, non-existant param
print "Testing: append( 'invalid', 'param' ) set values\n" if $debug;
$sv = $q->append( 'invalid', 'param1' );
@av = $q->append( 'invalid', 'param2' );;
ok ( $sv, 'param1' ); # test 157
ok ( (join' ',@av), 'param1 param2' ); # test 158
ok ( (join' ',$q->param('invalid')), 'param1 param2' ); # test 159
# append() - scalar and array context, set values
print "Testing: append( 'foo', 'some', 'new', 'values' ) set values\n" if $debug;
$sv = $q->append( 'foo', 'some', 'new', 'values' );
@av = $q->append( 'foo', 'even', 'more', 'stuff' );
ok ( $sv, 'bar' ); # test 160
ok ( (join' ',@av), 'bar some some-more some new values even more stuff' ); # test 161
# append() - scalar and array context
print "Testing: append( -name=>'foo', -value=>'bar' ) set values\n" if $debug;
$sv = $q->append( -name=>'foo', -value=>'baz' );
@av = $q->append( -name=>'foo', -value=>'xyz' );
ok ( $sv, 'bar' ); # test 162
ok ( (join' ',@av), 'bar some some-more some new values even more stuff baz xyz' ); # test 163
# append() - scalar and array context
print "Testing: append(-name=>'foo',-value=>['bar','baz']) set values\n" if $debug;
$sv = $q->append( -name=>'foo', -value=>[1,2] );
@av = $q->append( -name=>'foo', -value=>[3,4] );
ok ( $sv, 'bar' ); # test 164
ok ( (join' ',@av), 'bar some some-more some new values even more stuff baz xyz 1 2 3 4' ); # test 165
# delete() - void/valid argument
print "Testing: delete()\n" if $debug;
$q->delete();
ok ( (join' ',$q->param) , 'name color foo invalid' ); # test 166
$q->delete('foo');
ok ( (join' ',$q->param) , 'name color invalid' ); # test 167
# Delete() - void/valid argument
print "Testing: Delete()\n" if $debug;
$q->Delete();
ok ( (join' ',$q->param) , 'name color invalid' ); # test 168
$q->Delete('invalid');
ok ( (join' ',$q->param) , 'name color' ); # test 169
# delete_all() - scalar and array context, void/invalid/valid argument
print "Testing: delete_all()\n" if $debug;
$q->delete_all();
ok ( (join'',$q->param), '' ); # test 170
ok ( $q->globals, '10'); # test 171
$ENV{'CONTENT_TYPE'} = 'NOT multipart/form-data';
$q = new CGI::Simple;
# delete_all() - scalar and array context, void/invalid/valid argument
print "Testing: Delete_all()\n" if $debug;
ok ( (join' ',$q->param), 'name color' ); # test 172
$q->Delete_all();
ok ( (join'',$q->param), '' ); # test 173
$ENV{'CONTENT_TYPE'} = 'application/x-www-form-urlencoded';
# upload() - invalid CONTENT_TYPE
print "Testing: upload() - invalid CONTENT_TYPE\n" if $debug;
$sv = $q->upload();
ok ( $sv, undef ); # test 174
ok ( $q->cgi_error(), 'Oops! File uploads only work if you specify ENCTYPE="multipart/form-data" in your <FORM> tag' ); # test 175
$ENV{'CONTENT_TYPE'} = 'multipart/form-data';
# upload() - scalar and array context, void/invalid/valid argument
print "Testing: upload() - no files available\n" if $debug;
$sv = $q->upload();
@av = $q->upload();
ok ( $sv, undef ); # test 176
ok ( (join' ', @av), '' ); # test 177
# upload() - scalar and array context, files available, void arg
print "Testing: upload() - files available\n" if $debug;
$q->{'.filehandles'}->{$_} = $_ for qw( File1 File2 File3 );
$sv = $q->upload();
@av = $q->upload();
ok ( $sv, 3); # test 178
ok ( (join' ', sort @av), 'File1 File2 File3' ); # test 179
$q->{'.filehandles'} = {};
# upload() - scalar context, valid argument
print "Testing: upload('/some/path/to/myfile') - real files\n" if $debug;
open FH, $tmpfile or carp "Can't read $tmpfile $!\n";
my $data = join'',<FH>;
ok ( $data && 1, 1); # test 180
seek FH, 0,0;
$q->{'.filehandles'}->{ '/some/path/to/myfile' } = \*FH;
my $handle = $q->upload( '/some/path/to/myfile' );
my $upload = join'', <$handle>;
ok ( $upload, $data ); # test 181
# upload() - scalar context, invalid argument
print "Testing: upload('invalid')\n" if $debug;
$sv = $q->upload('invalid');
ok( $sv, undef ); # test 182
ok( $q->cgi_error, "No filehandle for 'invalid'. Are uploads enabled (\$DISABLE_UPLOADS = 0)? Is \$POST_MAX big enough?" ); # test 183
print "Testing: upload( '/some/path/to/myfile', \"$tmpfile.bak\" ) - real files\n" if $debug;
my $ok = $q->upload( '/some/path/to/myfile', "$tmpfile.bak" );
ok ( $ok, 1 ); # test 184
open $handle, "$tmpfile.bak" or carp "Can't read $tmpfile.bak $!\n";
$upload = join'', <$handle>;
ok ( $upload, $data ); # test 185
$sv = $q->upload( '/some/path/to/myfile', "$tmpfile.bak" );
ok ( $sv, undef ); # test 186
unlink $tmpfile, "$tmpfile.bak";
$ENV{'CONTENT_TYPE'} = 'application/x-www-form-urlencoded';
$q = new CGI::Simple;
# query_string() - scalar and array context, void/invalid/valid argument
print "Testing: query_string()\n" if $debug;
$sv = $q->query_string();
ok ( $sv, 'name=JaPh%2C&color=red&color=green&color=blue' ); # test 187
# parse_query_string()
print "Testing: parse_query_string()\n" if $debug;
$q->delete_all;
ok ( $q->param, 0 ); # test 188
$ENV{'REQUEST_METHOD'} = 'POST';
$q->parse_query_string();
$sv = $q->query_string();
ok ( $sv, 'name=JaPh%2C&color=red&color=green&color=blue' ); # test 189
$ENV{'REQUEST_METHOD'} = 'GET';
# parse_keywordlist() - scalar and array context
print "Testing: parse_keywordlist()\n" if $debug;
$sv = $q->parse_keywordlist('Just+another++Perl%20hacker%2C');
@av = $q->parse_keywordlist('Just+another++Perl%20hacker%2C');
ok ( $sv, '4' ); # test 190
ok ( (join' ',@av), 'Just another Perl hacker,' ); # test 191
################ Save and Restore params from file ###############
# _init_from_file()
# save() - scalar and array context, void/invalid/valid argument
# save_parameters() - scalar and array context, void/invalid/valid argument
# all tested in constructor section
################ Miscelaneous Methods ################
$q = new CGI::Simple;
# escapeHTML()
print "Testing: escapeHTML()\n" if $debug;
$sv = $q->escapeHTML();
ok ( $sv, undef ); # test 192
$sv = $q->escapeHTML("<>&\"\012\015<>&\"\012\015", 0 );
ok( $sv, "<>&"\012\015<>&"\012\015" ); # test 193
$sv = $q->escapeHTML("<>&\"\012\015<>&\"\012\015", 'newlines too' );
ok( $sv, "<>&" <>&" " ); # test 194
# unescapeHTML()
print "Testing: unescapeHTML()\n" if $debug;
$sv = $q->unescapeHTML();
ok ( $sv, undef ); # test 195
$sv = $q->unescapeHTML("<>&" <>&" " );
ok( $sv, "<>&\"\012\015<>&\"\012\015" ); # test 196
# put()
print "Testing: put()\n" if $debug;
ok ($q->put(''), 1 ); # test 197
# print()
print "Testing: print()\n" if $debug;
ok ($q->print(''), 1 ); # test 198
################# Cookie Methods ################
$q = new CGI::Simple;
# raw_cookie() - scalar and array context, void argument
print "Testing: raw_cookie()\n" if $debug;
$sv = $q->raw_cookie();
@av = $q->raw_cookie();
ok ( $sv, 'foo=a%20phrase; bar=yes%2C%20a%20phrase&I%20say;' ); # test 199
ok ( (join'',@av), 'foo=a%20phrase; bar=yes%2C%20a%20phrase&I%20say;' ); # test 200
# raw_cookie() - scalar and array context, valid argument
print "Testing: raw_cookie('foo')\n" if $debug;
$sv = $q->raw_cookie('foo');
@av = $q->raw_cookie('foo');
ok ( $sv, 'a%20phrase' ); # test 201
ok ( (join'',@av), 'a%20phrase' ); # test 202
# raw_cookie() - scalar and array context, invalid argument
print "Testing: raw_cookie('invalid')\n" if $debug;
$sv = $q->raw_cookie('invalid');
@av = $q->raw_cookie('invalid');
ok ( $sv, undef ); # test 203
ok ( (join'',@av), '' ); # test 204
# cookie() - scalar and array context, void argument
print "Testing: cookie()\n" if $debug;
$sv = $q->cookie();
@av = $q->cookie();
ok ( $sv, '2' ); # test 205
# fix OS perl version test bug
ok( (join' ',@av) eq 'foo bar' or (join' ',@av) eq 'bar foo' ); # test 206
# cookie() - scalar and array context, valid argument, single value
print "Testing: cookie('foo')\n" if $debug;
$sv = $q->cookie('foo');
@av = $q->cookie('foo');
ok ( $sv, 'a phrase' ); # test 207
ok ( (join'',@av), 'a phrase' ); # test 208
# cookie() - scalar and array context, valid argument, multiple values
print "Testing: cookie('foo')\n" if $debug;
$sv = $q->cookie('bar');
@av = $q->cookie('bar');
ok ( $sv, 'yes, a phrase' ); # test 209
ok ( (join' ',@av), 'yes, a phrase I say' ); # test 210
# cookie() - scalar and array context, invalid argument
print "Testing: cookie('invalid')\n" if $debug;
$sv = $q->cookie('invalid');
@av = $q->cookie('invalid');
ok ( $sv, undef ); # test 211
ok ( (join'',@av), '' ); # test 212
my @vals = ( -name => 'Password',
-value => ['superuser','god','open sesame','mydog woofie'],
-expires => 'Mon, 11-Nov-2018 11:00:00 GMT',
-domain => '.nowhere.com',
-path => '/cgi-bin/database',
-secure => 1
);
# cookie() - scalar and array context, full argument set, correct order
print "Testing: cookie(\@vals) correct order\n" if $debug;
$sv = $q->cookie(@vals);
@av = $q->cookie(@vals);
ok ( $sv, 'Password=superuser&god&open%20sesame&mydog%20woofie; domain=.nowhere.com; path=/cgi-bin/database; expires=Mon, 11-Nov-2018 11:00:00 GMT; secure' ); # test 213
ok ( (join'',@av), 'Password=superuser&god&open%20sesame&mydog%20woofie; domain=.nowhere.com; path=/cgi-bin/database; expires=Mon, 11-Nov-2018 11:00:00 GMT; secure' ); # test 214
# cookie() - scalar and array context, full argument set, incorrect order
print "Testing: cookie(\@vals) incorrect order\n" if $debug;
$sv = $q->cookie(@vals[0,1,10,11,8,9,2,3,4,5,6,7]);
@av = $q->cookie(@vals[0,1,10,11,8,9,2,3,4,5,6,7]);
ok ( $sv, 'Password=superuser&god&open%20sesame&mydog%20woofie; domain=.nowhere.com; path=/cgi-bin/database; expires=Mon, 11-Nov-2018 11:00:00 GMT; secure' ); # test 215
ok ( (join'',@av), 'Password=superuser&god&open%20sesame&mydog%20woofie; domain=.nowhere.com; path=/cgi-bin/database; expires=Mon, 11-Nov-2018 11:00:00 GMT; secure' ); # test 216
my $cookie = $sv; # save a cookie for header testing
# cookie() - scalar and array context, partial argument set
print "Testing: cookie( -name=>'foo', -value=>'bar' )\n" if $debug;
$sv = $q->cookie( -name=>'foo', -value=>'bar' );
@av = $q->cookie( -name=>'foo', -value=>'bar' );
ok ( $sv, 'foo=bar; path=/' ); # test 217
ok ( (join'',@av), 'foo=bar; path=/' ); # test 218
################# Header Methods ################
$q = new CGI::Simple
my $CRLF = $q->crlf;
# header() - scalar and array context, void argument
print "Testing: header()\n" if $debug;
$sv = $q->header();
@av = $q->header();
ok ( $sv, "Content-Type: text/html; charset=ISO-8859-1$CRLF$CRLF" ); # test 219
ok ( (join'',@av), "Content-Type: text/html; charset=ISO-8859-1$CRLF$CRLF" ); # test 220
# header() - scalar context, single argument
print "Testing: header('image/gif')\n" if $debug;
$sv = $q->header('image/gif');
ok ( $sv, "Content-Type: image/gif$CRLF$CRLF" ); # test 221
@vals = ( -type=>'image/gif',
-nph=>1,
-status=>'402 Payment required',
-expires=>'Mon, 11-Nov-2018 11:00:00 GMT',
-cookie=>$cookie,
-charset=>'utf-7',
-attachment=>'foo.gif',
-Cost=>'$2.00');
# header() - scalar context, complex header
print "Testing: header(\@vals) - complex header\n" if $debug;
$sv = $q->header(@vals);
my $header = <<'HEADER';
HTTP/1.0 402 Payment required
Server: Apache - accept no substitutes
Status: 402 Payment required
Set-Cookie: Password=superuser&god&open%20sesame&mydog%20woofie; domain=.nowhere.com; path=/cgi-bin/database; expires=Mon, 11-Nov-2018 11:00:00 GMT; secure
Expires: Mon, 11-Nov-2018 11:00:00 GMT
Date: Tue, 11-Nov-2018 11:00:00 GMT
Content-Disposition: attachment; filename="foo.gif"
Cost: $2.00
Content-Type: image/gif
HEADER
$sv =~ s/[\012\015]//g;
$header =~ s/[\012\015]//g;
$sv =~ s/(?:Expires|Date).*?GMT//g; # strip the time elements
$header =~ s/(?:Expires|Date).*?GMT//g; # strip the time elements
ok ( $sv, $header ); # test 222
# cache() - scalar and array context, void argument
print "Testing: cache()\n" if $debug;
$sv = $q->cache();
ok ( $sv, undef ); # test 223
# cache() - scalar and array context, true argument, sets no cache paragma
print "Testing: cache(1)\n" if $debug;
$sv = $q->cache(1);
ok ( $sv, 1 ); # test 224
$sv = $q->header();
ok ( $sv =~ /Pragma: no-cache/, 1 ); # test 225
# no_cache() - scalar and array context, void argument
print "Testing: cache()\n" if $debug;
$sv = $q->no_cache();
ok ( $sv, undef ); # test 226
# no_cache() - scalar and array context, true argument, sets no cache paragma
print "Testing: cache(1)\n" if $debug;
$sv = $q->no_cache(1);
ok ( $sv, 1 ); # test 227
$sv = $q->header();
ok ( ($sv =~ /Pragma: no-cache/ and $sv =~ /Expires:(.*?)GMT/ and $sv =~ /Date:$1GMT/) , 1 ); # test 228
# redirect() - scalar and array context, void argument
print "Testing: redirect()\n" if $debug;
$sv = $q->redirect('http://a.galaxy.far.away.gov');
$header = <<'HEADER';
Status: 302 Moved
Expires: Tue, 13 Nov 2001 06:45:15 GMT
Date: Tue, 13 Nov 2001 06:45:15 GMT
Pragma: no-cache
Location: http://a.galaxy.far.away.gov
HEADER
$sv =~ s/[\012\015]//g;
$header =~ s/[\012\015]//g;
$sv =~ s/(?:Expires|Date).*?GMT//g; # strip the time elements
$header =~ s/(?:Expires|Date).*?GMT//g; # strip the time elements
ok ( $sv, $header ); # test 229
# redirect() - scalar and array context, void argument
print "Testing: redirect() - nph\n" if $debug;
$sv = $q->redirect( -uri=>'http://a.galaxy.far.away.gov', -nph=>1 );
$header = <<'HEADER';
HTTP/1.0 302 Moved
Server: Apache - accept no substitutes
Status: 302 Moved
Expires: Tue, 13 Nov 2001 06:49:24 GMT
Date: Tue, 13 Nov 2001 06:49:24 GMT
Pragma: no-cache
Location: http://a.galaxy.far.away.gov
HEADER
$sv =~ s/[\012\015]//g;
$header =~ s/[\012\015]//g;
$sv =~ s/(?:Expires|Date).*?GMT//g; # strip the time elements
$header =~ s/(?:Expires|Date).*?GMT//g; # strip the time elements
ok ( $sv, $header ); # test 230
################# Server Push Methods #################
$q = new CGI::Simple;
print "Testing: multipart_init()\n" if $debug;
$sv = $q->multipart_init();
ok ( $sv, qr|Content-Type: multipart/x-mixed-replace;boundary="------- =_aaaaaaaaaa0"| ); # test 231
ok ( $sv, qr/--------- =_aaaaaaaaaa0$CRLF/ ); # test 232
$sv = $q->multipart_init('this_is_the_boundary');
ok ( $sv, qr/boundary="this_is_the_boundary"/ ); # test 233
$sv = $q->multipart_init(-boundary=>'this_is_another_boundary');
ok ( $sv, qr/boundary="this_is_another_boundary"/ ); # test 234
# multipart_start()
print "Testing: multipart_start()\n" if $debug;
$sv = $q->multipart_start();
ok ( $sv, "Content-Type: text/html$CRLF$CRLF" ); # test 235
$sv = $q->multipart_start('foo/bar');
ok ( $sv, "Content-Type: foo/bar$CRLF$CRLF" ); # test 236
$sv = $q->multipart_start(-type=>'text/plain' );
ok ( $sv, "Content-Type: text/plain$CRLF$CRLF" ); # test 237
# multipart_end()
print "Testing: multipart_end()\n" if $debug;
$sv = $q->multipart_end();
ok ( $sv, "$CRLF--this_is_another_boundary$CRLF" ); # test 238
# multipart_final() - scalar and array context, void/invalid/valid argument
print "Testing: multipart_final()\n" if $debug;
$sv = $q->multipart_final();
ok ( $sv, qr|--this_is_another_boundary--| ); # test 239
################# Debugging Methods ################
# Dump() - scalar context, void argument
print "Testing: Dump()\n" if $debug;
$sv = $q->Dump();
ok ( $sv =~ m/JaPh,/, 1 ); # test 240
# as_string()
print "Testing: as_string()\n" if $debug;
ok ( $q->as_string(), $q->Dump() ); # test 241
# cgi_error()
print "Testing: cgi_error()\n" if $debug;
$ENV{'REQUEST_METHOD'} = 'GET';
$ENV{'QUERY_STRING'} = '';
$q = CGI::Simple->new;
ok( $q->cgi_error, qr/400 No data received via method: GET/ ); # test 242
$ENV{'QUERY_STRING'} = 'name=JaPh%2C&color=red&color=green&color=blue';
############## cgi-lib.pl tests ################
# ReadParse() - scalar and array context, void/invalid/valid argument
print "Testing: ReadParse()\n" if $debug;
CGI::Simple::ReadParse();
ok ( $in{'name'}, 'JaPh,' ); # test 243
%in = ();
$q = new CGI::Simple;
$q->ReadParse();
ok ( $in{'name'}, 'JaPh,' ); # test 244
CGI::Simple::ReadParse(*field);
ok ( $field{'name'}, 'JaPh,' ); # test 245
%field = ();
$q = new CGI::Simple;
$q->ReadParse(*field);
ok ( $field{'name'}, 'JaPh,' ); # test 246
$q = $field{'CGI'};
ok ( $q->param('name'), 'JaPh,' ); # test 247
# SplitParam() - scalar and array context, void/invalid/valid argument
print "Testing: SplitParam()\n" if $debug;
ok ( (join ' ', $q->SplitParam($field{'color'})), 'red green blue' ); # test 248
ok ( (join ' ', CGI::Simple::SplitParam($field{'color'})), 'red green blue' ); # test 249
ok ( scalar $q->SplitParam($field{'color'}), 'red' ); # test 250
ok ( scalar CGI::Simple::SplitParam($field{'color'}), 'red' ); # test 251
# MethGet() - scalar and array context, void/invalid/valid argument
print "Testing: MethGet()\n" if $debug;
ok ( $q->MethGet, 1 ); # test 252
# MethPost() - scalar and array context, void/invalid/valid argument
print "Testing: MethPost()\n" if $debug;
ok ( ! $q->MethPost, 1 ); # test 253
# MyBaseUrl() - scalar and array context, void/invalid/valid argument
print "Testing: MyBaseUrl()\n" if $debug;
ok ( $q->MyBaseUrl, 'http://nowhere.com:8080/cgi-bin/foo.cgi' ); # test 254
$ENV{'SERVER_PORT'} = 80;
ok ( $q->MyBaseUrl, 'http://nowhere.com/cgi-bin/foo.cgi' ); # test 255
$ENV{'SERVER_PORT'} = 8080;
# MyURL() - scalar and array context, void/invalid/valid argument
print "Testing: MyURL()\n" if $debug;
ok ( $q->MyURL, 'http://nowhere.com:8080/cgi-bin/foo.cgi' ); # test 256
# MyFullUrl() - scalar and array context, void/invalid/valid argument
print "Testing: MyFullUrl()\n" if $debug;
ok ( $q->MyFullUrl, 'http://nowhere.com:8080/cgi-bin/foo.cgi/somewhere/else?name=JaPh%2C&color=red&color=green&color=blue' ); # test 257
$ENV{'QUERY_STRING'} = '';
$ENV{'PATH_INFO'} ='';
ok ( $q->MyFullUrl, 'http://nowhere.com:8080/cgi-bin/foo.cgi' ); # test 258
$ENV{'QUERY_STRING'} = 'name=JaPh%2C&color=red&color=green&color=blue';
$ENV{'PATH_INFO'} = '/somewhere/else';
# PrintHeader() - scalar and array context, void/invalid/valid argument
print "Testing: PrintHeader()\n" if $debug;
ok ( $q->PrintHeader, qr|Content-Type: text/html| ); # test 259
# HtmlTop() - scalar and array context, void/invalid/valid argument
print "Testing: HtmlTop()\n" if $debug;
ok ( $q->HtmlTop('$'), "<html>\n<head>\n<title>\$</title>\n</head>\n<body>\n<h1>\$</h1>\n" ); # test 260
ok ( CGI::Simple::HtmlTop('$'), "<html>\n<head>\n<title>\$</title>\n</head>\n<body>\n<h1>\$</h1>\n" ); # test 261
# HtmlBot() - scalar and array context, void/invalid/valid argument
print "Testing: HtmlBot()\n" if $debug;
ok ( $q->HtmlBot, "</body>\n</html>\n" ); # test 262
# PrintVariables() - scalar and array context, void/invalid/valid argument
print "Testing: PrintVariables()\n" if $debug;
ok ( $q->PrintVariables(\%field), qr/JaPh,/ ); # test 263
# PrintEnv() - scalar and array context, void/invalid/valid argument
print "Testing: PrintEnv()\n" if $debug;
ok ( $q->PrintEnv, qr/PATH_TRANSLATED/ ); # test 264
# CgiDie() - scalar and array context, void/invalid/valid argument
# CgiError() - scalar and array context, void/invalid/valid argument
################ Accessor Methods ################
$q = new CGI::Simple;
# version() - scalar context, void argument
print "Testing: version()\n" if $debug;
ok ( $q->version(), qr/[\d\.]+/ ); # test 265
# nph() - scalar context, void argument
print "Testing: nph()\n" if $debug;
ok ( $q->nph(), $q->globals('NPH') ); # test 266
# nph() - scalar context, valid argument
print "Testing: nph(42)\n" if $debug;
ok ( $q->nph(42), 42 ); # test 267
ok ( $q->globals('NPH'), 42 ); # test 268
# all_parameters() - array context, void/invalid/valid argument
print "Testing: all_parameters()\n" if $debug;
$sv = $q->all_parameters();
@av = $q->all_parameters();
ok ( $sv, 2 ); # test 269
ok ( (join' ',@av), 'name color' ); # test 270
# charset() - scalar context, void argument
print "Testing: charset()\n" if $debug;
$sv = $q->charset();
ok ( $sv, 'utf-7'); # test 271
# charset() - scalar context, void argument
print "Testing: charset()\n" if $debug;
$sv = $q->charset('Linear B');
ok ( $sv, 'Linear B'); # test 272
$sv = $q->charset();
ok ( $sv, 'Linear B'); # test 273
# crlf() - scalar context, void argument
print "Testing: crlf()\n" if $debug;
$sv = $q->crlf();
ok ( $sv, qr/[\012\015]{1,2}/ ); # test 274
# globals() - scalar and array context, void argument
print "Testing: globals()\n" if $debug;
$sv = $q->globals();
ok ( $sv, 10 ); # test 275
@av = $q->globals();
ok ( (join' ',sort@av), 'DEBUG DISABLE_UPLOADS FATAL HEADERS_ONCE NO_NULL NO_UNDEF_PARAMS NPH POST_MAX USE_CGI_PM_DEFAULTS USE_PARAM_SEMICOLONS' ); # test 276
# globals() - scalar context, invalid argument
print "Testing: globals('FOO') - invalid arg\n" if $debug;
$sv = $q->globals('FOO');
ok ( $sv, undef ); # test 277
# globals() - scalar context, valid argument
print "Testing: globals('VERSION') - valid arg\n" if $debug;
ok( $q->globals('VERSION', '3.1415' ), '3.1415' ); # test 278
ok( $q->globals('VERSION'), '3.1415' ); # test 279
# auth_type() - scalar context, void argument
print "Testing: auth_type()\n" if $debug;
$sv = $q->auth_type();
ok ( $sv, 'PGP MD5 DES rot13' ); # test 280
# content_length() - scalar context, void argument
print "Testing: content_length()\n" if $debug;
$sv = $q->content_length();
ok ( $sv, '42' ); # test 281
# content_type() - scalar context, void argument
print "Testing: content_type()\n" if $debug;
$sv = $q->content_type();
ok ( $sv, 'application/x-www-form-urlencoded' ); # test 282
# document_root() - scalar context, void argument
print "Testing: document_root()\n" if $debug;
$sv = $q->document_root();
ok ( $sv, '/vs/www/foo' ); # test 283
# gateway_interface() - scalar context, void argument
print "Testing: gateway_interface()\n" if $debug;
$sv = $q->gateway_interface();
ok ( $sv, 'bleeding edge' ); # test 284
# path_translated() - scalar context, void argument
print "Testing: path_translated()\n" if $debug;
$sv = $q->path_translated();
ok ( $sv, '/usr/local/somewhere/else' ); # test 285
# referer() - scalar context, void argument
print "Testing: referer()\n" if $debug;
$sv = $q->referer();
ok ( $sv, 'xxx.sex.com' ); # test 286
# remote_addr() - scalar and array context, void/invalid/valid argument
print "Testing: remote_addr()\n" if $debug;
$sv = $q->remote_addr();
ok ( $sv, '127.0.0.1' ); # test 287
# remote_host() - scalar context, void argument
print "Testing: remote_host()\n" if $debug;
$sv = $q->remote_host();
ok ( $sv, 'localhost' ); # test 288
# remote_ident() - scalar context, void argument
print "Testing: remote_ident()\n" if $debug;
$sv = $q->remote_ident();
ok ( $sv, 'None of your damn business' ); # test 289
# remote_user() - scalar context, void argument
print "Testing: remote_user()\n" if $debug;
$sv = $q->remote_user();
ok ( $sv, 'Just another Perl hacker,' ); # test 290
# request_method() - scalar context, void argument
print "Testing: request_method()\n" if $debug;
$sv = $q->request_method();
ok ( $sv, 'GET' ); # test 291
# script_name() - scalar context, void argument
print "Testing: script_name()\n" if $debug;
$sv = $q->script_name();
ok ( $sv, '/cgi-bin/foo.cgi' ); # test 292
# server_name() - scalar context, void argument
print "Testing: server_name()\n" if $debug;
$sv = $q->server_name();
ok ( $sv, 'nowhere.com' ); # test 293
# server_port() - scalar context, void argument
print "Testing: server_port()\n" if $debug;
$sv = $q->server_port();
ok ( $sv, '8080' ); # test 294
# server_protocol() - scalar context, void argument
print "Testing: server_protocol()\n" if $debug;
$sv = $q->server_protocol();
ok ( $sv, 'HTTP/1.0' ); # test 295
# server_software() - scalar context, void argument
print "Testing: server_software()\n" if $debug;
$sv = $q->server_software();
ok ( $sv, 'Apache - accept no substitutes' ); # test 296
# user_name() - scalar context, void argument
print "Testing: user_name()\n" if $debug;
$sv = $q->user_name();
ok ( $sv, 'spammer@nowhere.com' ); # test 297
# user_agent() - scalar context, void argument
print "Testing: user_agent()\n" if $debug;
$sv = $q->user_agent();
ok ( $sv, 'LWP' ); # test 298
# user_agent() - scalar context, void argument
print "Testing: user_agent()\n" if $debug;
$sv = $q->user_agent('lwp');
ok ( $sv, 1 ); # test 299
$sv = $q->user_agent('mozilla');
ok ( $sv, '' ); # test 300
# virtual_host() - scalar context, void argument
print "Testing: virtual_host()\n" if $debug;
$sv = $q->virtual_host();
ok ( $sv, 'the.vatican.org' ); # test 301
# path_info() - scalar and array context, void/valid argument
print "Testing: path_info()\n" if $debug;
$sv = $q->path_info();
ok ( $sv, '/somewhere/else' ); # test 302
$sv = $q->path_info('somewhere/else/again');
ok ( $sv, '/somewhere/else/again' ); # test 303
$sv = $q->path_info();
ok ( $sv, '/somewhere/else/again' ); # test 304
$q->path_info('/somewhere/else');
# Accept() - scalar and array context, void argument
print "Testing: Accept()\n" if $debug;
$sv = $q->Accept();
@av = $q->Accept();
ok ( $sv, 5 ); # test 305
ok ( (join' ',sort@av), '*/* image/gif image/jpg text/html text/plain' ); # test 306
# Accept() - scalar context, invalid argument (matches '*/*'
print "Testing: Accept('foo/bar')\n" if $debug;
$sv = $q->Accept('foo/bar');
ok ( $sv, '0.001' ); # test 307
# Accept() - scalar and array context, void argument
print "Testing: Accept()\n" if $debug;
$sv = $q->Accept('*/*');
ok ( $sv, '0.001' ); # test 308
# http() - scalar and array context, void argument
print "Testing: http()\n" if $debug;
$sv = $q->http();
@av = $q->http();
ok ( $sv > 0 ); # test 309
ok ( $av[0] =~ m/HTTP/ ); # test 310
# http() - scalar context, invalid arguments
print "Testing: http('invalid arg')\n" if $debug;
$sv = $q->http('http-hell');
ok ( $sv, undef ); # test 311
$sv = $q->http('hell');
ok ( $sv, undef ); # test 312
# http() - scalar context, valid arguments
print "Testing: http('valid arg')\n" if $debug;
$sv = $q->http('http-from');
ok ( $sv, 'spammer@nowhere.com' ); # test 313
$sv = $q->http('from');
ok ( $sv, 'spammer@nowhere.com' ); # test 314
# https() - scalar and array context, void argument
print "Testing: https()\n" if $debug;
$sv = $q->https();
ok ( $sv, 'ON' ); # test 315
# https() - scalar context, invalid argument
print "Testing: https('invalid arg')\n" if $debug;
$sv = $q->https('hell');
ok ( $sv, undef ); # test 316
# https() - scalar context, valid arguments
print "Testing: https('valid arg')\n" if $debug;
$sv = $q->https('https-a');
ok ( $sv, 'A' ); # test 317
$sv = $q->https('a');
ok ( $sv, 'A' ); # test 318
# protocol() - scalar context, void arguments
print "Testing: protocol()\n" if $debug;
$sv = $q->protocol();
ok ( $sv, 'https' ); # test 319
$ENV{'HTTPS'} = 'OFF';
$ENV{'SERVER_PORT'} = '443';
$sv = $q->protocol();
ok ( $sv, 'https' ); # test 320
$ENV{'SERVER_PORT'} = '8080';
$sv = $q->protocol();
ok ( $sv, 'http' ); # test 321
# url() - scalar context, void argument
print "Testing: url()\n" if $debug;
$ENV{'HTTP_HOST'} = '';
ok( $q->url, 'http://nowhere.com:8080/cgi-bin/foo.cgi' ); # test 322
# url() - scalar context, valid argument
print "Testing: url()\n" if $debug;
ok( $q->url(-absolute=>1), '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); # test 323
# url() - scalar context, valid argument
print "Testing: url(-relative=>1)\n" if $debug;
ok( $q->url(-relative=>1), 'foo.cgi' ); # test 324
# url() - scalar context, valid argument
print "Testing: url(-relative=>1,-path=>1)\n" if $debug;
ok( $q->url(-relative=>1,-path=>1), 'foo.cgi/somewhere/else' ); # test 325
# url() - scalar context, valid argument
print "Testing: url(-relative=>1,-path=>1,-query=>1)\n" if $debug;
ok( $q->url(-relative=>1,-path=>1,-query=>1), 'foo.cgi/somewhere/else?name=JaPh%2C&color=red&color=green&color=blue' ); # test 326
# self_url() - scalar context, void argument
print "Testing: self_url()\n" if $debug;
$sv = $q->self_url();
@av = $q->self_url();
ok( $sv , 'http://nowhere.com:8080/cgi-bin/foo.cgi/somewhere/else?name=JaPh%2C&color=red&color=green&color=blue' ); # test 327
# state() - scalar and array context, void/invalid/valid argument
print "Testing: state()\n" if $debug;
ok( $q->state(), $q->self_url() ); # test 328
################ Yet More Tests ################
print "Yet more tests\n" if $debug;
$CGI::Simple::POST_MAX = 20;
$ENV{'REQUEST_METHOD'} = 'POST';
$q = new CGI::Simple;
ok( $q->cgi_error, '413 Request entity too large: 42 bytes on STDIN exceeds $POST_MAX!' ); # test 329
$ENV{'REQUEST_METHOD'} = 'HEAD';
$ENV{'QUERY_STRING'} = '';
$ENV{'REDIRECT_QUERY_STRING'} = 'name=JAPH&color=red&color=green&color=blue';
$CGI::Simple::POST_MAX = 50;
$q = new CGI::Simple;
@av = $q->param;
ok ( (join' ',@av), 'name color' ); # test 330
@av = $q->param('color');
ok( (join' ',@av), 'red green blue' ); # test 331
# END
################ Wrap Up ################
my $tests = $Test::ntest - 1;
my $fail = @Test::FAILDETAIL;
$ok = $tests - $fail;
print "\nCompleted $tests tests $ok/$tests OK, failed $fail/$tests\n";
printf "%3.1f%% of tests completed successfully, %3.1f%% failed\n" , $ok*100/$tests, $fail*100/$tests;
print "Please email \$VERSION, OS and test numbers failed
to jfreeman\@tassie.net.au so I can fix them
Set \$debug = 1 to see where tests are failing\n" if $fail;
if ($debug) {
use Data::Dumper;
print "\n",Dumper(@Test::FAILDETAIL);
}
sub run_renumber {
rename $0, "$0.bak" or die "Rename $0 to $0.bak failed $!\n";
open I, "$0.bak" or die "Can't open self $0.bak $!\n";
open O, ">$0" or die "Can't write new file\n";
my $num = 0;
my $file = '';
my $found_begin = 0;
my $found_end = 0;
while (<I>) {
$found_end = 1 if m/# END/;
$found_begin = 1 if m/# BEGIN/;
if ( $found_begin and m/^\s*(ok\s*\(.*;)/ and ! $found_end ) {
$num++;
$file .= "$1 # test $num\n";
}
else {
$file .= $_;
}
}
$file =~ s/plan\s+tests\s*=>\s*\d+/plan tests => $num/;
print O $file;
close O;
close I;
print "Added test numbers 1..$num to $0 and fixed plan OK\n";
unlink "$0.bak" or warn "Can't unlink backup $0.bak $!\n";
}