use Test::More tests => 319;
use Carp;
use strict;
use vars qw(%field %in);
use CGI::Simple;
my ( $q, $sv, @av );
my $tmpfile = './cgi-tmpfile.tmp';
$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 = CGI::Simple->new;
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()
$q->_initialize_globals();
is( $CGI::Simple::USE_CGI_PM_DEFAULTS, 0, '_initialize_globals(), 1' );
is( $CGI::Simple::DISABLE_UPLOADS, 1, '_initialize_globals(), 2' );
is( $CGI::Simple::POST_MAX, 102_400, '_initialize_globals(), 3' );
is( $CGI::Simple::NO_UNDEF_PARAMS, 0, '_initialize_globals(), 4' );
is( $CGI::Simple::USE_PARAM_SEMICOLONS, 0, '_initialize_globals(), 5' );
is( $CGI::Simple::HEADERS_ONCE, 0, '_initialize_globals(), 6' );
is( $CGI::Simple::NPH, 0, '_initialize_globals(), 7' );
is( $CGI::Simple::DEBUG, 0, '_initialize_globals(), 8' );
is( $CGI::Simple::NO_NULL, 1, '_initialize_globals(), 9' );
is( $CGI::Simple::FATAL, -1, '_initialize_globals(), 10' );
undef_globals();
# _use_cgi_pm_global_settings()
$q->_use_cgi_pm_global_settings();
is( $CGI::Simple::DISABLE_UPLOADS, 0,
'_use_cgi_pm_global_settings(), 1' );
is( $CGI::Simple::POST_MAX, -1, '_use_cgi_pm_global_settings(), 2' );
is( $CGI::Simple::NO_UNDEF_PARAMS, 0,
'_use_cgi_pm_global_settings(), 3' );
is( $CGI::Simple::USE_PARAM_SEMICOLONS,
1, '_use_cgi_pm_global_settings(), 4' );
is( $CGI::Simple::HEADERS_ONCE, 0, '_use_cgi_pm_global_settings(), 5' );
is( $CGI::Simple::NPH, 0, '_use_cgi_pm_global_settings(), 6' );
is( $CGI::Simple::DEBUG, 1, '_use_cgi_pm_global_settings(), 7' );
is( $CGI::Simple::NO_NULL, 0, '_use_cgi_pm_global_settings(), 8' );
is( $CGI::Simple::FATAL, -1, '_use_cgi_pm_global_settings(), 9' );
# _store_globals()
undef %{$q};
ok( !defined $q->{'.globals'}->{'DISABLE_UPLOADS'},
'_store_globals(), 1' );
ok( !defined $q->{'.globals'}->{'POST_MAX'}, '_store_globals(), 2' );
ok( !defined $q->{'.globals'}->{'NO_UNDEF_PARAMS'},
'_store_globals(), 3' );
ok( !defined $q->{'.globals'}->{'USE_PARAM_SEMICOLONS'},
'_store_globals(), 4' );
ok( !defined $q->{'.globals'}->{'HEADERS_ONCE'},
'_store_globals(), 5' );
ok( !defined $q->{'.globals'}->{'NPH'}, '_store_globals(), 6' );
ok( !defined $q->{'.globals'}->{'DEBUG'}, '_store_globals(), 7' );
ok( !defined $q->{'.globals'}->{'NO_NULL'}, '_store_globals(), 8' );
ok( !defined $q->{'.globals'}->{'FATAL'}, '_store_globals(), 9' );
ok( !defined $q->{'.globals'}->{'USE_CGI_PM_DEFAULTS'},
'_store_globals(), 10' );
$q->_store_globals();
ok( defined $q->{'.globals'}->{'DISABLE_UPLOADS'},
'_store_globals(), 11' );
ok( defined $q->{'.globals'}->{'POST_MAX'}, '_store_globals(), 12' );
ok( defined $q->{'.globals'}->{'NO_UNDEF_PARAMS'},
'_store_globals(), 13' );
ok( defined $q->{'.globals'}->{'USE_PARAM_SEMICOLONS'},
'_store_globals(), 14' );
ok( defined $q->{'.globals'}->{'HEADERS_ONCE'},
'_store_globals(), 15' );
ok( defined $q->{'.globals'}->{'NPH'}, '_store_globals(), 16' );
ok( defined $q->{'.globals'}->{'DEBUG'}, '_store_globals(), 17' );
ok( defined $q->{'.globals'}->{'NO_NULL'}, '_store_globals(), 18' );
ok( defined $q->{'.globals'}->{'FATAL'}, '_store_globals(), 19' );
ok( defined $q->{'.globals'}->{'USE_CGI_PM_DEFAULTS'},
'_store_globals(), 20' );
# import() - used to set paragmas
my @args
= qw( -default -no_upload -unique_header -nph -no_debug -newstyle_url -no_undef_param );
undef_globals();
$q->import( @args );
is( $CGI::Simple::USE_CGI_PM_DEFAULTS, 1, 'import(), 1' );
is( $CGI::Simple::DISABLE_UPLOADS, 1, 'import(), 2' );
is( $CGI::Simple::NO_UNDEF_PARAMS, 1, 'import(), 3' );
is( $CGI::Simple::USE_PARAM_SEMICOLONS, 1, 'import(), 4' );
is( $CGI::Simple::HEADERS_ONCE, 1, 'import(), 5' );
is( $CGI::Simple::NPH, 1, 'import(), 6' );
is( $CGI::Simple::DEBUG, 0, 'import(), 7' );
undef_globals();
$q->import( qw ( -upload -oldstyle_url -debug ) );
is( $CGI::Simple::DISABLE_UPLOADS, 0, 'import(), 8' );
is( $CGI::Simple::USE_PARAM_SEMICOLONS, 0, 'import(), 9' );
is( $CGI::Simple::DEBUG, 2, 'import(), 10' );
undef_globals();
# _reset_globals()
$q->_reset_globals();
is( $CGI::Simple::DISABLE_UPLOADS, 0, '_reset_globals(), 1' );
is( $CGI::Simple::POST_MAX, -1, '_reset_globals(), 2' );
is( $CGI::Simple::NO_UNDEF_PARAMS, 0, '_reset_globals(), 3' );
is( $CGI::Simple::USE_PARAM_SEMICOLONS, 1, '_reset_globals(), 4' );
is( $CGI::Simple::HEADERS_ONCE, 0, '_reset_globals(), 5' );
is( $CGI::Simple::NPH, 0, '_reset_globals(), 6' );
is( $CGI::Simple::DEBUG, 1, '_reset_globals(), 7' );
is( $CGI::Simple::NO_NULL, 0, '_reset_globals(), 8' );
is( $CGI::Simple::FATAL, -1, '_reset_globals(), 9' );
undef_globals();
$q = CGI::Simple->new;
# url_decode() - scalar context, void argument
$sv = $q->url_decode();
is( $sv, undef, 'url_decode(), 1' );
# url_decode() - scalar context, valid argument
my ( $string, $enc_string );
for ( 32 .. 255 ) {
$string .= chr;
$enc_string .= uc sprintf "%%%02x", ord chr;
}
is( $q->url_decode( $enc_string ),
$string, 'url_decode(\$enc_string), 1' );
# url_encode() - scalar context, void argument
$sv = $q->url_encode();
is( $sv, undef, 'url_encode(), 1' );
# url_encode() - scalar context, valid argument
$sv = $q->url_encode( $string );
$sv =~ tr/+/ /;
$sv =~ s/%([a-fA-F0-9]{2})/ pack "C", hex $1 /eg;
is( $sv, $string, 'url_encode(\$string), 1' );
# url encoding - circular test
is( $q->url_decode( $q->url_encode( $string ) ),
$string, 'url encoding via circular test, 1' );
# new() plain constructor
$q = CGI::Simple->new;
like( $q, qr/CGI::Simple/, 'new() plain constructor, 1' );
# new('') empty constructor
$q = CGI::Simple->new( '' );
like( $q, qr/CGI::Simple/, 'new() empty constructor, 1' );
$q = CGI::Simple->new( {} );
like( $q, qr/CGI::Simple/, 'new() empty constructor, 2' );
# new() hash constructor
$q = CGI::Simple->new( { 'foo' => '1', 'bar' => [ 2, 3, 4 ] } );
@av = $q->param;
# fix OS bug with testing
is( join( ' ', sort @av ), 'bar foo', 'new() hash constructor, 1' );
is( $q->param( 'foo' ), 1, 'new() hash constructor, 2' );
is( $q->param( 'bar' ), 2, 'new() hash constructor, 3' );
@av = $q->param( 'bar' );
is( join( '', @av ), 234, 'new() hash constructor, 4' );
$q = CGI::Simple->new( '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
$q = CGI::Simple->new( 'foo=5&bar=6&bar=7&bar=8' );
@av = $q->param;
is( join( ' ', @av ), 'foo bar', 'new() query string constructor, 1' );
is( $q->param( 'foo' ), 5, 'new() query string constructor, 2' );
is( $q->param( 'bar' ), 6, 'new() query string constructor, 3' );
@av = $q->param( 'bar' );
is( join( '', @av ), 678, 'new() query string constructor, 4' );
open FH, ">>$tmpfile", or carp "Can't append $tmpfile $!\n";
$q->save_parameters( \*FH );
close FH;
# new() CGI::Simple object constructor
my $q_old = CGI::Simple->new( 'foo=1&bar=2&bar=3&bar=4' );
my $q_new = CGI::Simple->new( $q_old );
is( $q_old->query_string, 'foo=1&bar=2&bar=3&bar=4',
'new() CGI::Simple object constructor, 1' );
is( $q_new->query_string, 'foo=1&bar=2&bar=3&bar=4',
'new() CGI::Simple object constructor, 2' );
# new() \@ARGV constructor
$ENV{'REQUEST_METHOD'} = '';
$CGI::Simple::DEBUG = 1;
@ARGV = qw( foo=bar\=baz foo=bar\&baz );
$q = CGI::Simple->new;
is(
join( ' ', $q->param( 'foo' ) ),
'bar=baz bar&baz',
'new() \@ARGV constructor, 1'
);
$ENV{'REQUEST_METHOD'} = 'GET';
################ The Core Methods ################
$q = CGI::Simple->new;
# param() - scalar and array context, void argument
$sv = $q->param();
@av = $q->param();
is( $sv, '2', 'param() void argument, 1' );
is( join( ' ', @av ), 'name color', 'param() void argument, 2' );
# param() - scalar and array context, single argument (valid)
$sv = $q->param( 'color' );
@av = $q->param( 'color' );
is( $sv, 'red', 'param(\'color\') single argument (valid), 1' );
is(
join( ' ', @av ),
'red green blue',
'param(\'color\') single argument (valid), 2'
);
# param() - scalar and array context, single argument (invalid)
$sv = $q->param( 'invalid' );
@av = $q->param( 'invalid' );
is( $sv, undef, 'param(\'invalid\') single argument (invalid), 1' );
is( join( ' ', @av ),
'', 'param(\'invalid\') single argument (invalid), 2' );
# param() - scalar and array context, -name=>'param' (valid)
$sv = $q->param( -name => 'color' );
@av = $q->param( -name => 'color' );
is( $sv, 'red', 'param( -name=>\'color\' ) get values, 1' );
is(
join( ' ', @av ),
'red green blue',
'param( -name=>\'color\' ) get values, 2'
);
# param() - scalar and array context, -name=>'param' (invalid)
$sv = $q->param( -name => 'invalid' );
@av = $q->param( -name => 'invalid' );
is( $sv, undef, 'param( -name=>\'invalid\' ) get values, 1' );
is( join( ' ', @av ), '', 'param( -name=>\'invalid\' ) get values, 2' );
$CGI::Simple::NO_UNDEF_PARAMS = 0;
$q = CGI::Simple->new( 'name=&color=' );
# param() - scalar and array context, void values void arg
$sv = $q->param();
@av = $q->param();
is( $sv, '2', 'param() void values 1, 1' );
is( join( ' ', @av ), 'name color', 'param() void values 1, 2' );
# param() - scalar and array context, void values, valid arg
$sv = $q->param( 'name' );
@av = $q->param( 'name' );
is( $sv, '', 'param(\'name\') void values 1, valid param, 1' );
is( join( ' ', @av ),
'', 'param(\'name\') void values 1, valid param, 2' );
$q = CGI::Simple->new( 'name&color' );
# param() - scalar and array context, void values void arg
$sv = $q->param();
@av = $q->param();
is( $sv, '2', 'param() void values 2, 1' );
is( join( ' ', @av ), 'name color', 'param() void values 2, 2' );
# param() - scalar and array context, void values, valid arg
$sv = $q->param( 'name' );
@av = $q->param( 'name' );
is( $sv, '', 'param(\'name\') void values 2 , valid param, 1' );
is( join( ' ', @av ),
'', 'param(\'name\') void values 2 , valid param, 2' );
$CGI::Simple::NO_UNDEF_PARAMS = 1;
$q = CGI::Simple->new( 'name=&color=' );
# param() - scalar and array context, void values void arg
$sv = $q->param();
@av = $q->param();
is( $sv, '0', 'param() void values 1, no undef, 1' );
is( join( ' ', @av ), '', 'param() void values 1, no undef, 2' );
# param() - scalar and array context, void values, valid arg
$sv = $q->param( 'name' );
@av = $q->param( 'name' );
is( $sv, undef,
'param(\'name\') void values 1, valid param, no undef, 1' );
is( join( ' ', @av ),
'', 'param(\'name\') void values 1, valid param, no undef, 2' );
$q = CGI::Simple->new( 'name&color' );
# param() - scalar and array context, void values void arg
$sv = $q->param();
@av = $q->param();
is( $sv, '0', 'param() void values 2, no undef, 1' );
is( join( ' ', @av ), '', 'param() void values 2, no undef, 2' );
# param() - scalar and array context, void values, valid arg
$sv = $q->param( 'name' );
@av = $q->param( 'name' );
is( $sv, undef,
'param(\'name\') void values 2, valid param, no undef, 1' );
is( join( ' ', @av ),
'', 'param(\'name\') void values 2, valid param, no undef, 2' );
$CGI::Simple::NO_UNDEF_PARAMS = 0;
$q = CGI::Simple->new;
# param() - scalar and array context, set values
$sv = $q->param( 'foo', 'some', 'new', 'values' );
@av = $q->param( 'foo', 'some', 'new', 'values' );
is( $sv, 'some',
'param( \'foo\', \'some\', \'new\', \'values\' ) set values, 1' );
is(
join( ' ', @av ),
'some new values',
'param( \'foo\', \'some\', \'new\', \'values\' ) set values, 2'
);
# param() - scalar and array context
$sv = $q->param( -name => 'foo', -value => 'bar' );
@av = $q->param( -name => 'foo', -value => 'bar' );
is( $sv, 'bar',
'param( -name=>\'foo\', -value=>\'bar\' ) set values, 1' );
is( join( ' ', @av ),
'bar', 'param( -name=>\'foo\', -value=>\'bar\' ) set values, 2' );
# param() - scalar and array context
$sv = $q->param( -name => 'foo', -value => [ 'bar', 'baz' ] );
@av = $q->param( -name => 'foo', -value => [ 'bar', 'baz' ] );
is( $sv, 'bar',
'param(-name=>\'foo\',-value=>[\'bar\',\'baz\']) set values, 1' );
is( join( ' ', @av ),
'bar baz',
'param(-name=>\'foo\',-value=>[\'bar\',\'baz\']) set values, 2' );
# add_param() - scalar and array context, void argument
$sv = $q->add_param();
@av = $q->add_param();
is( $sv, undef, 'add_param(), 1' );
is( join( ' ', @av ), '', 'add_param(), 2' );
# add_param() - scalar and array context, existing param argument
$q->add_param( 'foo', 'new' );
@av = $q->param( 'foo' );
is( join( ' ', @av ),
'bar baz new', 'add_param( \'foo\', \'new\' ), 1' );
$q->add_param( 'foo', [ 1, 2, 3, 4, 5 ] );
@av = $q->param( 'foo' );
is(
join( ' ', @av ),
'bar baz new 1 2 3 4 5',
'add_param( \'foo\', \'new\' ), 2'
);
# add_param() - existing param argument, overwrite
$q->add_param( 'foo', 'bar', 'overwrite' );
@av = $q->param( 'foo' );
is( join( ' ', @av ),
'bar', 'add_param(\'foo\', \'bar\', \'overwrite\' ), 1' );
# add_param() - scalar and array context, existing param argument
$q->add_param( 'new', 'new%2C' );
@av = $q->param( 'new' );
is( join( ' ', @av ), 'new%2C', 'add_param( \'new\', \'new\' ), 1' );
$q->add_param( 'new', [ 1, 2, 3, 4, 5 ] );
@av = $q->param( 'new' );
is(
join( ' ', @av ),
'new%2C 1 2 3 4 5',
'add_param( \'new\', \'new\' ), 2'
);
# param_fetch() - scalar context, void argument
$sv = $q->param_fetch();
is( $sv, undef, 'param_fetch(), 1' );
# param_fetch() - scalar context, 'color' syntax
$sv = $q->param_fetch( 'color' );
is( ref $sv, 'ARRAY', 'param_fetch( \'color\' ), 1' );
is( join( ' ', @$sv ), 'red green blue',
'param_fetch( \'color\' ), 2' );
# param_fetch() - scalar context, -name=>'color' syntax
$sv = $q->param_fetch( -name => 'color' );
is( ref $sv, 'ARRAY', 'param_fetch( -name=>\'color\' ), 1' );
is(
join( ' ', @$sv ),
'red green blue',
'param_fetch( -name=>\'color\' ), 2'
);
# url_param() - scalar and array context, void argument
$sv = $q->url_param();
@av = $q->url_param();
is( $sv, '2', 'url_param() void argument, 1' );
is( join( ' ', @av ), 'name color', 'url_param() void argument, 2' );
# url_param() - scalar and array context, single argument (valid)
$sv = $q->url_param( 'color' );
@av = $q->url_param( 'color' );
is( $sv, 'red', 'url_param(\'color\') single argument (valid), 1' );
is(
join( ' ', @av ),
'red green blue',
'url_param(\'color\') single argument (valid), 2'
);
# url_param() - scalar and array context, single argument (invalid)
$sv = $q->url_param( 'invalid' );
@av = $q->url_param( 'invalid' );
is( $sv, undef, 'url_param(\'invalid\') single argument (invalid), 1' );
is( join( ' ', @av ),
'', 'url_param(\'invalid\') single argument (invalid), 2' );
# keywords() - scalar and array context, void argument
$q = CGI::Simple->new( 'here+are++++some%20keywords' );
$sv = $q->keywords;
@av = $q->keywords;
is( $sv, '4', 'keywords(), 1' );
is( join( ' ', @av ), 'here are some keywords', 'keywords(), 2' );
# keywords() - scalar and array context, array argument
$sv = $q->keywords( 'foo', 'bar', 'baz' );
@av = $q->keywords( 'foo', 'bar', 'baz' );
is( $sv, '3', 'keywords( \'foo\', \'bar\', \'baz\' ), 1' );
is( join( ' ', @av ),
'foo bar baz', 'keywords( \'foo\', \'bar\', \'baz\' ), 2' );
# keywords() - scalar and array context, array ref argument
$q = CGI::Simple->new;
$sv = $q->keywords( [ 'foo', 'man', 'chu' ] );
@av = $q->keywords( [ 'foo', 'man', 'chu' ] );
is( $sv, '3', 'keywords( [\'foo\', \'man\', \'chu\'] ), 1' );
is( join( ' ', @av ),
'foo man chu', 'keywords( [\'foo\', \'man\', \'chu\'] ), 2' );
$sv = $q->Vars();
is( $sv->{'color'}, "red\0green\0blue", 'Vars() - tied interface, 1' );
$sv->{'color'} = "foo\0bar\0baz";
is( join( ' ', $q->param( 'color' ) ),
'foo bar baz', 'Vars() - tied interface, 2' );
$q = CGI::Simple->new;
# Vars() - hash context, void argument
my %hv = $q->Vars();
is( $hv{'name'}, 'JaPh,', 'Vars(), 1' );
# Vars() - hash context, "|" argument
%hv = $q->Vars( ',' );
is( $hv{'color'}, 'red,green,blue', 'Vars(\',\'), 1' );
# append() - scalar and array context, void argument
$sv = $q->append();
@av = $q->append();
is( $sv, undef, 'append(), 1' );
is( join( '', @av ), '', 'append(), 2' );
# append() - scalar and array context, set values, valid param
$q->add_param( 'foo', 'bar', 'overwrite' );
$sv = $q->append( 'foo', 'some' );
@av = $q->append( 'foo', 'some-more' );
is( $sv, 'bar', 'append( \'foo\', \'some\' ) set values, 1' );
is(
join( ' ', @av ),
'bar some some-more',
'append( \'foo\', \'some\' ) set values, 2'
);
# append() - scalar and array context, set values, non-existant param
$sv = $q->append( 'invalid', 'param1' );
@av = $q->append( 'invalid', 'param2' );
is( $sv, 'param1', 'append( \'invalid\', \'param\' ) set values, 1' );
is(
join( ' ', @av ),
'param1 param2',
'append( \'invalid\', \'param\' ) set values, 2'
);
is(
join( ' ', $q->param( 'invalid' ) ),
'param1 param2',
'append( \'invalid\', \'param\' ) set values, 3'
);
# append() - scalar and array context, set values
$sv = $q->append( 'foo', 'some', 'new', 'values' );
@av = $q->append( 'foo', 'even', 'more', 'stuff' );
is( $sv, 'bar',
'append( \'foo\', \'some\', \'new\', \'values\' ) set values, 1' );
is(
join( ' ', @av ),
'bar some some-more some new values even more stuff',
'append( \'foo\', \'some\', \'new\', \'values\' ) set values, 2'
);
# append() - scalar and array context
$sv = $q->append( -name => 'foo', -value => 'baz' );
@av = $q->append( -name => 'foo', -value => 'xyz' );
is( $sv, 'bar',
'append( -name=>\'foo\', -value=>\'bar\' ) set values, 1' );
is(
join( ' ', @av ),
'bar some some-more some new values even more stuff baz xyz',
'append( -name=>\'foo\', -value=>\'bar\' ) set values, 2'
);
# append() - scalar and array context
$sv = $q->append( -name => 'foo', -value => [ 1, 2 ] );
@av = $q->append( -name => 'foo', -value => [ 3, 4 ] );
is( $sv, 'bar',
'append(-name=>\'foo\',-value=>[\'bar\',\'baz\']) set values, 1' );
is(
join( ' ', @av ),
'bar some some-more some new values even more stuff baz xyz 1 2 3 4',
'append(-name=>\'foo\',-value=>[\'bar\',\'baz\']) set values, 2'
);
# delete() - void/valid argument
$q->delete();
is( join( ' ', $q->param ), 'name color foo invalid', 'delete(), 1' );
$q->delete( 'foo' );
is( join( ' ', $q->param ), 'name color invalid', 'delete(), 2' );
# Delete() - void/valid argument
$q->Delete();
is( join( ' ', $q->param ), 'name color invalid', 'Delete(), 1' );
$q->Delete( 'invalid' );
is( join( ' ', $q->param ), 'name color', 'Delete(), 2' );
# delete_all() - scalar and array context, void/invalid/valid argument
$q->delete_all();
is( join( '', $q->param ), '', 'delete_all(), 1' );
is( $q->globals, '11', 'delete_all(), 2' );
$ENV{'CONTENT_TYPE'} = 'NOT multipart/form-data';
$q = CGI::Simple->new;
# delete_all() - scalar and array context, void/invalid/valid argument
is( join( ' ', $q->param ), 'name color', 'Delete_all(), 1' );
$q->Delete_all();
is( join( '', $q->param ), '', 'Delete_all(), 2' );
$ENV{'CONTENT_TYPE'} = 'application/x-www-form-urlencoded';
# upload() - invalid CONTENT_TYPE
$sv = $q->upload( 'foo' );
is( $sv, undef, 'upload() - invalid CONTENT_TYPE, 1' );
is(
$q->cgi_error(),
'Oops! File uploads only work if you specify ENCTYPE="multipart/form-data" in your <FORM> tag',
'upload() - invalid CONTENT_TYPE, 2'
);
$ENV{'CONTENT_TYPE'} = 'multipart/form-data';
# upload() - scalar and array context, void/invalid/valid argument
$sv = $q->upload();
@av = $q->upload();
is( $sv, undef, 'upload() - no files available, 1' );
is( join( ' ', @av ), '', 'upload() - no files available, 2' );
# upload() - scalar and array context, files available, void arg
$q->{'.filehandles'}->{$_} = $_ for qw( File1 File2 File3 );
$sv = $q->upload();
@av = $q->upload();
is( $sv, 3, 'upload() - files available, 1' );
is(
join( ' ', sort @av ),
'File1 File2 File3',
'upload() - files available, 2'
);
$q->{'.filehandles'} = {};
# upload() - scalar context, valid argument
open FH, $tmpfile or carp "Can't read $tmpfile $!\n";
my $data = join '', <FH>;
is( $data && 1, 1, 'upload(\'/some/path/to/myfile\') - real files, 1' );
seek FH, 0, 0;
$q->{'.filehandles'}->{'/some/path/to/myfile'} = \*FH;
my $handle = $q->upload( '/some/path/to/myfile' );
my $upload = join '', <$handle>;
is( $upload, $data,
'upload(\'/some/path/to/myfile\') - real files, 2' );
# upload() - scalar context, invalid argument
$sv = $q->upload( 'invalid' );
is( $sv, undef, 'upload(\'invalid\'), 1' );
is(
$q->cgi_error,
"No filehandle for 'invalid'. Are uploads enabled (\$DISABLE_UPLOADS = 0)? Is \$POST_MAX big enough?",
'upload(\'invalid\'), 2'
);
my $ok = $q->upload( '/some/path/to/myfile', "$tmpfile.bak" );
is( $ok, 1, 'upload(\'invalid\'), 3' );
open $handle, "$tmpfile.bak" or carp "Can't read $tmpfile.bak $!\n";
$upload = join '', <$handle>;
is( $upload, $data, 'upload(\'invalid\'), 4' );
$sv = $q->upload( '/some/path/to/myfile', "$tmpfile.bak" );
is( $sv, undef, 'upload(\'invalid\'), 5' );
unlink $tmpfile, "$tmpfile.bak";
$ENV{'CONTENT_TYPE'} = 'application/x-www-form-urlencoded';
$q = CGI::Simple->new;
# query_string() - scalar and array context, void/invalid/valid argument
$sv = $q->query_string();
is(
$sv,
'name=JaPh%2C&color=red&color=green&color=blue',
'query_string(), 1'
);
# parse_query_string()
$q->delete_all;
is( $q->param, 0, 'parse_query_string(), 1' );
$ENV{'REQUEST_METHOD'} = 'POST';
$q->parse_query_string();
$sv = $q->query_string();
is(
$sv,
'name=JaPh%2C&color=red&color=green&color=blue',
'parse_query_string(), 2'
);
$ENV{'REQUEST_METHOD'} = 'GET';
# parse_keywordlist() - scalar and array context
$sv = $q->parse_keywordlist( 'Just+another++Perl%20hacker%2C' );
@av = $q->parse_keywordlist( 'Just+another++Perl%20hacker%2C' );
is( $sv, '4', 'parse_keywordlist(), 1' );
is(
join( ' ', @av ),
'Just another Perl hacker,',
'parse_keywordlist(), 2'
);
################ 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 = CGI::Simple->new;
# escapeHTML()
$sv = $q->escapeHTML();
is( $sv, undef, 'escapeHTML(), 1' );
$sv = $q->escapeHTML( "<>&\"\012\015<>&\"\012\015", 0 );
is(
$sv,
"<>&"\012\015<>&"\012\015",
'escapeHTML(), 2'
);
$sv = $q->escapeHTML( "<>&\"\012\015<>&\"\012\015", 'newlines too' );
is(
$sv,
"<>&" <>&" ",
'escapeHTML(), 3'
);
# unescapeHTML()
$sv = $q->unescapeHTML();
is( $sv, undef, 'unescapeHTML(), 1' );
$sv = $q->unescapeHTML(
"<>&" <>&" " );
is( $sv, "<>&\"\012\015<>&\"\012\015", 'unescapeHTML(), 2' );
$sv = $q->unescapeHTML(
'Jack & Jill went up the hill; to get a pail of water' );
is(
$sv,
'Jack & Jill went up the hill; to get a pail of water',
'unescapeHTML(), 3 '
);
# put()
is( $q->put( '' ), 1, 'put(), 1' );
# print()
is( $q->print( '' ), 1, 'print(), 1' );
################# Cookie Methods ################
$q = CGI::Simple->new;
# raw_cookie() - scalar and array context, void argument
$sv = $q->raw_cookie();
@av = $q->raw_cookie();
is(
$sv,
'foo=a%20phrase; bar=yes%2C%20a%20phrase&I%20say;',
'raw_cookie(), 1'
);
is(
join( '', @av ),
'foo=a%20phrase; bar=yes%2C%20a%20phrase&I%20say;',
'raw_cookie(), 2'
);
# raw_cookie() - scalar and array context, valid argument
$sv = $q->raw_cookie( 'foo' );
@av = $q->raw_cookie( 'foo' );
is( $sv, 'a%20phrase', 'raw_cookie(\'foo\'), 1' );
is( join( '', @av ), 'a%20phrase', 'raw_cookie(\'foo\'), 2' );
# raw_cookie() - scalar and array context, invalid argument
$sv = $q->raw_cookie( 'invalid' );
@av = $q->raw_cookie( 'invalid' );
is( $sv, undef, 'raw_cookie(\'invalid\'), 1' );
is( join( '', @av ), '', 'raw_cookie(\'invalid\'), 2' );
# cookie() - scalar and array context, void argument
$sv = $q->cookie();
@av = $q->cookie();
is( $sv, '2', 'cookie(), 1' );
# fix OS perl version test bug
is( join( ' ', sort @av ), 'bar foo', 'cookie(), 2' );
# cookie() - scalar and array context, valid argument, single value
$sv = $q->cookie( 'foo' );
@av = $q->cookie( 'foo' );
is( $sv, 'a phrase', 'cookie(\'foo\'), 1' );
is( join( '', @av ), 'a phrase', 'cookie(\'foo\'), 2' );
# cookie() - scalar and array context, valid argument, multiple values
$sv = $q->cookie( 'bar' );
@av = $q->cookie( 'bar' );
is( $sv, 'yes, a phrase', 'cookie(\'foo\'), 1' );
is( join( ' ', @av ), 'yes, a phrase I say', 'cookie(\'foo\'), 2' );
# cookie() - scalar and array context, invalid argument
$sv = $q->cookie( 'invalid' );
@av = $q->cookie( 'invalid' );
is( $sv, undef, 'cookie(\'invalid\'), 1' );
is( join( '', @av ), '', 'cookie(\'invalid\'), 2' );
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,
-httponly => 1
);
# cookie() - scalar and array context, full argument set, correct order
$sv = $q->cookie( @vals );
@av = $q->cookie( @vals );
is(
$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; HttpOnly',
'cookie(\@vals) correct order, 1'
);
is(
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; HttpOnly',
'cookie(\@vals) correct order, 2'
);
# cookie() - scalar and array context, full argument set, incorrect order
$sv
= $q->cookie( @vals[ 0, 1, 10, 11, 12, 13, 8, 9, 2, 3, 4, 5, 6, 7 ] );
@av
= $q->cookie( @vals[ 0, 1, 10, 11, 12, 13, 8, 9, 2, 3, 4, 5, 6, 7 ] );
is(
$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; HttpOnly',
'cookie(\@vals) incorrect order, 1'
);
is(
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; HttpOnly',
'cookie(\@vals) incorrect order, 2'
);
my $cookie = $sv; # save a cookie for header testing
# cookie() - scalar and array context, partial argument set
$sv = $q->cookie( -name => 'foo', -value => 'bar' );
@av = $q->cookie( -name => 'foo', -value => 'bar' );
is(
$sv,
'foo=bar; path=/',
'cookie( -name=>\'foo\', -value=>\'bar\' ), 1'
);
is(
join( '', @av ),
'foo=bar; path=/',
'cookie( -name=>\'foo\', -value=>\'bar\' ), 2'
);
################# Header Methods ################
$q = CGI::Simple->new;
my $CRLF = $q->crlf;
# header() - scalar and array context, void argument
$sv = $q->header();
@av = $q->header();
is( $sv, "Content-Type: text/html; charset=ISO-8859-1$CRLF$CRLF",
'header(), 1' );
is(
join( '', @av ),
"Content-Type: text/html; charset=ISO-8859-1$CRLF$CRLF",
'header(), 2'
);
# header() - scalar context, single argument
$sv = $q->header( 'image/gif' );
is(
$sv,
"Content-Type: image/gif$CRLF$CRLF",
'header(\'image/gif\'), 1'
);
@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
$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; HttpOnly
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
is( $sv, $header, 'header(\@vals) - complex header, 1' );
# cache() - scalar and array context, void argument
$sv = $q->cache();
is( $sv, undef, 'cache(), 1' );
# cache() - scalar and array context, true argument, sets no cache paragma
$sv = $q->cache( 1 );
is( $sv, 1, 'cache(1), 1' );
$sv = $q->header();
is( $sv =~ /Pragma: no-cache/, 1, 'cache(1), 2' );
# no_cache() - scalar and array context, void argument
$sv = $q->no_cache();
is( $sv, undef, 'cache(), 1' );
# no_cache() - scalar and array context, true argument, sets no cache paragma
$sv = $q->no_cache( 1 );
is( $sv, 1, 'cache(1), 1' );
$sv = $q->header();
like( $sv, qr/Pragma: no-cache/, 'cache(1), 2' );
ok( $sv =~ /Expires:(.*?)GMT/, 'cache(1), 3' );
ok( $sv =~ /Date:$1GMT/ . 'cache(1), 4' );
# redirect() - scalar and array context, void argument
$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
is( $sv, $header, 'redirect(), 1' );
# redirect() - scalar and array context, void argument
$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
is( $sv, $header, 'redirect() - nph, 1' );
################# Server Push Methods #################
$q = CGI::Simple->new;
$sv = $q->multipart_init();
like(
$sv,
qr|Content-Type: multipart/x-mixed-replace;boundary="------- =_[a-zA-Z0-9]{17}"|,
'multipart_init(), 1'
);
like( $sv, qr/--------- =_[a-zA-Z0-9]{17}$CRLF/,
'multipart_init(), 2' );
$sv = $q->multipart_init( 'this_is_the_boundary' );
like( $sv, qr/boundary="this_is_the_boundary"/, 'multipart_init(), 3' );
{
my $sv1 = $q->multipart_init;
my $sv2 = $q->multipart_init;
isnt( $sv1, $sv2,
"due to random boundaries, multiple calls produce different results"
);
}
$sv = $q->multipart_init( -boundary => 'this_is_another_boundary' );
like(
$sv,
qr/boundary="this_is_another_boundary"/,
'multipart_init(), 4'
);
# multipart_start()
$sv = $q->multipart_start();
is( $sv, "Content-Type: text/html$CRLF$CRLF", 'multipart_start(), 1' );
$sv = $q->multipart_start( 'foo/bar' );
is( $sv, "Content-Type: foo/bar$CRLF$CRLF", 'multipart_start(), 2' );
$sv = $q->multipart_start( -type => 'text/plain' );
is( $sv, "Content-Type: text/plain$CRLF$CRLF", 'multipart_start(), 3' );
# multipart_end()
$sv = $q->multipart_end();
is( $sv, "$CRLF--this_is_another_boundary$CRLF", 'multipart_end(), 1' );
# multipart_final() - scalar and array context, void/invalid/valid argument
$sv = $q->multipart_final();
like( $sv, qr|--this_is_another_boundary--|, 'multipart_final(), 1' );
################# Debugging Methods ################
# Dump() - scalar context, void argument
$sv = $q->Dump();
like( $sv, qr/JaPh,/, 'Dump(), 1' );
# as_string()
is( $q->as_string(), $q->Dump(), 'as_string(), 1' );
# cgi_error()
$ENV{'REQUEST_METHOD'} = 'GET';
$ENV{'QUERY_STRING'} = '';
$q = CGI::Simple->new;
# we have changes this behaviour
# is( $q->cgi_error, qr/400 No data received via method: GET/ , 'cgi_error(), 1');
is( $q->cgi_error, undef, 'cgi_error(), 2' );
$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
CGI::Simple::ReadParse();
is( $in{'name'}, 'JaPh,', 'ReadParse(), 1' );
%in = ();
$q = CGI::Simple->new;
$q->ReadParse();
is( $in{'name'}, 'JaPh,', 'ReadParse(), 2' );
CGI::Simple::ReadParse( *field );
is( $field{'name'}, 'JaPh,', 'ReadParse(), 3' );
%field = ();
$q = CGI::Simple->new;
$q->ReadParse( *field );
is( $field{'name'}, 'JaPh,', 'ReadParse(), 4' );
$q = $field{'CGI'};
is( $q->param( 'name' ), 'JaPh,', 'ReadParse(), 5' );
# SplitParam() - scalar and array context, void/invalid/valid argument
is(
join( ' ', $q->SplitParam( $field{'color'} ) ),
'red green blue',
'SplitParam(), 1'
);
is(
join( ' ', CGI::Simple::SplitParam( $field{'color'} ) ),
'red green blue',
'SplitParam(), 2'
);
is( scalar $q->SplitParam( $field{'color'} ), 'red',
'SplitParam(), 3' );
is( scalar CGI::Simple::SplitParam( $field{'color'} ),
'red', 'SplitParam(), 4' );
# MethGet() - scalar and array context, void/invalid/valid argument
is( $q->MethGet, 1, 'MethGet(), 1' );
# MethPost() - scalar and array context, void/invalid/valid argument
is( !$q->MethPost, 1, 'MethPost(), 1' );
# MyBaseUrl() - scalar and array context, void/invalid/valid argument
is(
$q->MyBaseUrl,
'http://nowhere.com:8080/cgi-bin/foo.cgi',
'MyBaseUrl(), 1'
);
$ENV{'SERVER_PORT'} = 80;
is(
$q->MyBaseUrl,
'http://nowhere.com/cgi-bin/foo.cgi',
'MyBaseUrl(), 2'
);
$ENV{'SERVER_PORT'} = 8080;
# MyURL() - scalar and array context, void/invalid/valid argument
is( $q->MyURL, 'http://nowhere.com:8080/cgi-bin/foo.cgi',
'MyURL(), 1' );
# MyFullUrl() - scalar and array context, void/invalid/valid argument
is(
$q->MyFullUrl,
'http://nowhere.com:8080/cgi-bin/foo.cgi/somewhere/else?name=JaPh%2C&color=red&color=green&color=blue',
'MyFullUrl(), 1'
);
$ENV{'QUERY_STRING'} = '';
$ENV{'PATH_INFO'} = '';
is(
$q->MyFullUrl,
'http://nowhere.com:8080/cgi-bin/foo.cgi',
'MyFullUrl(), 2'
);
$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
like( $q->PrintHeader, qr|Content-Type: text/html|,
'PrintHeader(), 1' );
# HtmlTop() - scalar and array context, void/invalid/valid argument
is(
$q->HtmlTop( '$' ),
"<html>\n<head>\n<title>\$</title>\n</head>\n<body>\n<h1>\$</h1>\n",
'HtmlTop(), 1'
);
is(
CGI::Simple::HtmlTop( '$' ),
"<html>\n<head>\n<title>\$</title>\n</head>\n<body>\n<h1>\$</h1>\n",
'HtmlTop(), 2'
);
# HtmlBot() - scalar and array context, void/invalid/valid argument
is( $q->HtmlBot, "</body>\n</html>\n", 'HtmlBot(), 1' );
# PrintVariables() - scalar and array context, void/invalid/valid argument
like( $q->PrintVariables( \%field ), qr/JaPh,/, 'PrintVariables(), 1' );
# PrintEnv() - scalar and array context, void/invalid/valid argument
like( $q->PrintEnv, qr/PATH_TRANSLATED/, 'PrintEnv(), 1' );
# CgiDie() - scalar and array context, void/invalid/valid argument
# CgiError() - scalar and array context, void/invalid/valid argument
################ Accessor Methods ################
$q = CGI::Simple->new;
# version() - scalar context, void argument
like( $q->version(), qr/[\d\.]+/, 'version(), 1' );
# nph() - scalar context, void argument
is( $q->nph(), $q->globals( 'NPH' ), 'nph(), 1' );
# nph() - scalar context, valid argument
is( $q->nph( 42 ), 42, 'nph(42), 1' );
is( $q->globals( 'NPH' ), 42, 'nph(42), 2' );
# all_parameters() - array context, void/invalid/valid argument
$sv = $q->all_parameters();
@av = $q->all_parameters();
is( $sv, 2, 'all_parameters(), 1' );
is( join( ' ', @av ), 'name color', 'all_parameters(), 2' );
# charset() - scalar context, void argument
$sv = $q->charset();
is( $sv, 'utf-7', 'charset(), 1' );
# charset() - scalar context, void argument
$sv = $q->charset( 'Linear B' );
is( $sv, 'Linear B', 'charset(), 1' );
$sv = $q->charset();
is( $sv, 'Linear B', 'charset(), 2' );
# crlf() - scalar context, void argument
$sv = $q->crlf();
like( $sv, qr/[\012\015]{1,2}/, 'crlf(), 1' );
# globals() - scalar and array context, void argument
$sv = $q->globals();
is( $sv, 11, 'globals(), 1' );
@av = $q->globals();
is(
join( ' ', sort @av ),
'DEBUG DISABLE_UPLOADS FATAL HEADERS_ONCE NO_NULL NO_UNDEF_PARAMS NPH PARAM_UTF8 POST_MAX USE_CGI_PM_DEFAULTS USE_PARAM_SEMICOLONS',
'globals(), 2'
);
# globals() - scalar context, invalid argument
$sv = $q->globals( 'FOO' );
is( $sv, undef, 'globals(\'FOO\') - invalid arg, 1' );
# globals() - scalar context, valid argument
is( $q->globals( 'VERSION', '3.1415' ),
'3.1415', 'globals(\'VERSION\') - valid arg, 1' );
is( $q->globals( 'VERSION' ),
'3.1415', 'globals(\'VERSION\') - valid arg, 2' );
# auth_type() - scalar context, void argument
$sv = $q->auth_type();
is( $sv, 'PGP MD5 DES rot13', 'auth_type(), 1' );
# content_length() - scalar context, void argument
$sv = $q->content_length();
is( $sv, '42', 'content_length(), 1' );
# content_type() - scalar context, void argument
$sv = $q->content_type();
is( $sv, 'application/x-www-form-urlencoded', 'content_type(), 1' );
# document_root() - scalar context, void argument
$sv = $q->document_root();
is( $sv, '/vs/www/foo', 'document_root(), 1' );
# gateway_interface() - scalar context, void argument
$sv = $q->gateway_interface();
is( $sv, 'bleeding edge', 'gateway_interface(), 1' );
# path_translated() - scalar context, void argument
$sv = $q->path_translated();
is( $sv, '/usr/local/somewhere/else', 'path_translated(), 1' );
# referer() - scalar context, void argument
$sv = $q->referer();
is( $sv, 'xxx.sex.com', 'referer(), 1' );
# remote_addr() - scalar and array context, void/invalid/valid argument
$sv = $q->remote_addr();
is( $sv, '127.0.0.1', 'remote_addr(), 1' );
# remote_host() - scalar context, void argument
$sv = $q->remote_host();
is( $sv, 'localhost', 'remote_host(), 1' );
# remote_ident() - scalar context, void argument
$sv = $q->remote_ident();
is( $sv, 'None of your damn business', 'remote_ident(), 1' );
# remote_user() - scalar context, void argument
$sv = $q->remote_user();
is( $sv, 'Just another Perl hacker,', 'remote_user(), 1' );
# request_method() - scalar context, void argument
$sv = $q->request_method();
is( $sv, 'GET', 'request_method(), 1' );
# script_name() - scalar context, void argument
$sv = $q->script_name();
is( $sv, '/cgi-bin/foo.cgi', 'script_name(), 1' );
# server_name() - scalar context, void argument
$sv = $q->server_name();
is( $sv, 'nowhere.com', 'server_name(), 1' );
# server_port() - scalar context, void argument
$sv = $q->server_port();
is( $sv, '8080', 'server_port(), 1' );
# server_protocol() - scalar context, void argument
$sv = $q->server_protocol();
is( $sv, 'HTTP/1.0', 'server_protocol(), 1' );
# server_software() - scalar context, void argument
$sv = $q->server_software();
is( $sv, 'Apache - accept no substitutes', 'server_software(), 1' );
# user_name() - scalar context, void argument
$sv = $q->user_name();
is( $sv, 'spammer@nowhere.com', 'user_name(), 1' );
# user_agent() - scalar context, void argument
$sv = $q->user_agent();
is( $sv, 'LWP', 'user_agent(), 1' );
# user_agent() - scalar context, void argument
$sv = $q->user_agent( 'lwp' );
is( $sv, 1, 'user_agent(), 1' );
$sv = $q->user_agent( 'mozilla' );
is( $sv, '', 'user_agent(), 2' );
# virtual_host() - scalar context, void argument
$sv = $q->virtual_host();
is( $sv, 'the.vatican.org', 'virtual_host(), 1' );
# path_info() - scalar and array context, void/valid argument
$sv = $q->path_info();
is( $sv, '/somewhere/else', 'path_info(), 1' );
$sv = $q->path_info( 'somewhere/else/again' );
is( $sv, '/somewhere/else/again', 'path_info(), 2' );
$sv = $q->path_info();
is( $sv, '/somewhere/else/again', 'path_info(), 3' );
$q->path_info( '/somewhere/else' );
# Accept() - scalar and array context, void argument
$sv = $q->Accept();
@av = $q->Accept();
is( $sv, 5, 'Accept(), 1' );
is(
join( ' ', sort @av ),
'*/* image/gif image/jpg text/html text/plain',
'Accept(), 2'
);
# Accept() - scalar context, invalid argument (matches '*/*'
$sv = $q->Accept( 'foo/bar' );
is( $sv, '0.001', 'Accept(\'foo/bar\'), 1' );
# Accept() - scalar and array context, void argument
$sv = $q->Accept( '*/*' );
is( $sv, '0.001', 'Accept(), 1' );
# http() - scalar and array context, void argument
$sv = $q->http();
@av = $q->http();
ok( $sv > 0, 'http(), 1' );
like( $av[0], qr/HTTP/, 'http(), 2' );
# http() - scalar context, invalid arguments
$sv = $q->http( 'http-hell' );
is( $sv, undef, 'http(\'invalid arg\'), 1' );
$sv = $q->http( 'hell' );
is( $sv, undef, 'http(\'invalid arg\'), 2' );
# http() - scalar context, valid arguments
$sv = $q->http( 'http-from' );
is( $sv, 'spammer@nowhere.com', 'http(\'valid arg\'), 1' );
$sv = $q->http( 'from' );
is( $sv, 'spammer@nowhere.com', 'http(\'valid arg\'), 2' );
# https() - scalar and array context, void argument
$sv = $q->https();
is( $sv, 'ON', 'https(), 1' );
# https() - scalar context, invalid argument
$sv = $q->https( 'hell' );
is( $sv, undef, 'https(\'invalid arg\'), 1' );
# https() - scalar context, valid arguments
$sv = $q->https( 'https-a' );
is( $sv, 'A', 'https(\'valid arg\'), 1' );
$sv = $q->https( 'a' );
is( $sv, 'A', 'https(\'valid arg\'), 2' );
# protocol() - scalar context, void arguments
$sv = $q->protocol();
is( $sv, 'https', 'protocol(), 1' );
$ENV{'HTTPS'} = 'OFF';
$ENV{'SERVER_PORT'} = '443';
$sv = $q->protocol();
is( $sv, 'https', 'protocol(), 2' );
$ENV{'SERVER_PORT'} = '8080';
$sv = $q->protocol();
is( $sv, 'http', 'protocol(), 3' );
# url() - scalar context, void argument
$ENV{'HTTP_HOST'} = '';
is( $q->url, 'http://nowhere.com:8080/cgi-bin/foo.cgi', 'url(), 1' );
# url() - scalar context, valid argument
is( $q->url( -absolute => 1 ),
'/cgi-bin/foo.cgi', 'CGI::url(-absolute=>1)' );
# url() - scalar context, valid argument
is( $q->url( -relative => 1 ), 'foo.cgi', 'url(-relative=>1), 1' );
# url() - scalar context, valid argument
is( $q->url( -relative => 1, -path => 1 ),
'foo.cgi/somewhere/else', 'url(-relative=>1,-path=>1), 1' );
# url() - scalar context, valid argument
is(
$q->url( -relative => 1, -path => 1, -query => 1 ),
'foo.cgi/somewhere/else?name=JaPh%2C&color=red&color=green&color=blue',
'url(-relative=>1,-path=>1,-query=>1), 1'
);
# self_url() - scalar context, void argument
$sv = $q->self_url();
@av = $q->self_url();
is(
$sv,
'http://nowhere.com:8080/cgi-bin/foo.cgi/somewhere/else?name=JaPh%2C&color=red&color=green&color=blue',
'self_url(), 1'
);
# state() - scalar and array context, void/invalid/valid argument
is( $q->state(), $q->self_url(), 'state(), 1' );
################ Yet More Tests ################
#$CGI::Simple::POST_MAX = 20;
#$ENV{'REQUEST_METHOD'} = 'POST';
#$q = CGI::Simple->new;
#is( $q->cgi_error, '413 Request entity too large: 42 bytes on STDIN exceeds $POST_MAX!' , 'Yet more tests, 1');
$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 = CGI::Simple->new;
@av = $q->param;
is( join( ' ', @av ), 'name color', 'Yet more tests, 2' );
@av = $q->param( 'color' );
is( join( ' ', @av ), 'red green blue', 'Yet more tests, 3' );