diff options
author | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-18 04:17:15 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-18 04:17:15 +0000 |
commit | b695f709e8a342e35e482b0437eb6cdacdc58b6b (patch) | |
tree | 2d16192636e6ba806ff7a907f682c74f7705a920 /lib/CGI/t | |
parent | d780cd7a0195e946e636d3ee546f6ef4f21d6acc (diff) | |
download | perl-b695f709e8a342e35e482b0437eb6cdacdc58b6b.tar.gz |
The Grand Trek: move the *.t files from t/ to lib/ and ext/.
No doubt I made some mistakes like missed some files or
misnamed some files. The naming rules were more or less:
(1) if the module is from CPAN, follows its ways, be it
t/*.t or test.pl.
(2) otherwise if there are multiple tests for a module
put them in a t/
(3) otherwise if there's only one test put it in Module.t
(4) helper files go to module/ (locale, strict, warnings)
(5) use longer filenames now that we can (but e.g. the
compat-0.6.t and the Text::Balanced test files still
were renamed to be more civil against the 8.3 people)
installperl was updated appropriately not to install the
*.t files or the help files from under lib.
TODO: some helper files still remain under t/ that could
follow their 'masters'. UPDATE: On second thoughts, why
should they. They can continue to live under t/lib, and
in fact the locale/strict/warnings helpers that were moved
could be moved back. This way the amount of non-installable
stuff under lib/ stays smaller.
p4raw-id: //depot/perl@10676
Diffstat (limited to 'lib/CGI/t')
-rwxr-xr-x | lib/CGI/t/form.t | 90 | ||||
-rwxr-xr-x | lib/CGI/t/function.t | 111 | ||||
-rwxr-xr-x | lib/CGI/t/html.t | 95 | ||||
-rwxr-xr-x | lib/CGI/t/pretty.t | 41 | ||||
-rwxr-xr-x | lib/CGI/t/request.t | 103 | ||||
-rw-r--r-- | lib/CGI/t/util.t | 56 |
6 files changed, 496 insertions, 0 deletions
diff --git a/lib/CGI/t/form.t b/lib/CGI/t/form.t new file mode 100755 index 0000000000..2922903499 --- /dev/null +++ b/lib/CGI/t/form.t @@ -0,0 +1,90 @@ +#!/usr/local/bin/perl -w + +BEGIN { + chdir('t') if -d 't'; + @INC = '../lib'; +} + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..17\n"; } +END {print "not ok 1\n" unless $loaded;} +use CGI (':standard','-no_debug'); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# util +sub test { + local($^W) = 0; + my($num, $true,$msg) = @_; + print($true ? "ok $num\n" : "not ok $num $msg\n"); +} + +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + + +# Set up a CGI environment +$ENV{REQUEST_METHOD}='GET'; +$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} ='/somewhere/else'; +$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; + +test(2,start_form(-action=>'foobar',-method=>'get') eq + qq(<form method="get" action="foobar" enctype="application/x-www-form-urlencoded">\n), + "start_form()"); + +test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()"); +test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)"); +test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})"); +test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})"); +test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})"); +test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />), + "textfield({-name,-value,-override})"); +test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<input type="checkbox" name="weather" value="nice" />weather), + "checkbox()"); +test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq + qq(<input type="checkbox" name="weather" value="nice" />forecast), + "checkbox()"); +test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq + qq(<input type="checkbox" name="weather" value="nice" checked />forecast), + "checkbox()"); +test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq + qq(<input type="checkbox" name="weather" value="dull" checked />forecast), + "checkbox()"); + +test(13,radio_group(-name=>'game') eq + qq(<input type="radio" name="game" value="chess" checked />chess <input type="radio" name="game" value="checkers" />checkers), + 'radio_group()'); +test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq + qq(<input type="radio" name="game" value="chess" checked />ping pong <input type="radio" name="game" value="checkers" />checkers), + 'radio_group()'); + +test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq + qq(<input type="checkbox" name="game" value="checkers" checked />checkers <input type="checkbox" name="game" value="chess" checked />chess <input type="checkbox" name="game" value="cribbage" />cribbage), + 'checkbox_group()'); + +test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq + qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage), + 'checkbox_group()'); +test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); +<select name="game"> +<option value="checkers">checkers</option> +<option value="chess">chess</option> +<option selected value="cribbage">cribbage</option> +</select> +END + diff --git a/lib/CGI/t/function.t b/lib/CGI/t/function.t new file mode 100755 index 0000000000..b670e33cd7 --- /dev/null +++ b/lib/CGI/t/function.t @@ -0,0 +1,111 @@ +#!/usr/local/bin/perl -w + +BEGIN { + chdir('t') if -d 't'; + @INC = '../lib'; +} + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..27\n"; } +END {print "not ok 1\n" unless $loaded;} +use Config; +use CGI (':standard','keywords'); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# util +sub test { + local($^W) = 0; + my($num, $true,$msg) = @_; + print($true ? "ok $num\n" : "not ok $num $msg\n"); +} + +my $CRLF = "\015\012"; + +# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS +# is that a CR character gets inserted automatically in the web server +# case but not internal to perl's double quoted strings "\n". This +# test would need to be modified to use the "\015\012" on VMS if it +# were actually run through a web server. +# Thanks to Peter Prymmer for this + +if ($^O eq 'VMS') { $CRLF = "\n"; } + +# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII +# translation hence CRLF is used as \r\n within CGI.pm on such machines. + +if (ord("\t") != 9) { $CRLF = "\r\n"; } + +# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII +# translation hence CRLF is used as \r\n within CGI.pm on such machines. + +if (ord("\t") != 9) { $CRLF = "\r\n"; } + +# Set up a CGI environment +$ENV{REQUEST_METHOD}='GET'; +$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} ='/somewhere/else'; +$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{HTTP_LOVE} = 'true'; + +test(2,request_method() eq 'GET',"CGI::request_method()"); +test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); +test(4,param() == 2,"CGI::param()"); +test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()"); +test(6,param('game') eq 'chess',"CGI::param()"); +test(7,param('weather') eq 'dull',"CGI::param()"); +test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()"); +test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put'); +test(10,param(-name=>'foo') eq 'bar','CGI::param() get'); +test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); +test(12,http('love') eq 'true',"CGI::http()"); +test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()"); +test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); +test(15,self_url() eq + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + "CGI::url()"); +test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); +test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); +test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); +test(19,url(-relative=>1,-path=>1,-query=>1) eq + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + 'CGI::url(-relative=>1,-path=>1,-query=>1)'); +Delete('foo'); +test(20,!param('foo'),'CGI::delete()'); + +CGI::_reset_globals(); +$ENV{QUERY_STRING}='mary+had+a+little+lamb'; +test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords'); +test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords'); + +CGI::_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(23,param('weather') eq 'nice',"CGI::param() from POST"); + test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()"); +} else { + print "ok 23 # Skip\n"; + print "ok 24 # Skip\n"; +} +test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1"); +my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html'); +test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); +test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); diff --git a/lib/CGI/t/html.t b/lib/CGI/t/html.t new file mode 100755 index 0000000000..93e5dac648 --- /dev/null +++ b/lib/CGI/t/html.t @@ -0,0 +1,95 @@ +#!/usr/local/bin/perl -w + +BEGIN { + chdir('t') if -d 't'; + @INC = '../lib'; +} + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..24\n"; } +END {print "not ok 1\n" unless $loaded;} +use CGI (':standard','-no_debug','*h3','start_table'); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + + +# util +sub test { + local($^W) = 0; + my($num, $true,$msg) = @_; + print($true ? "ok $num\n" : "not ok $num $msg\n"); +} + +# all the automatic tags +test(2,h1() eq '<h1 />',"single tag"); +test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag"); +test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple"); +test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute"); +test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute"); +test(7,h1({-align=>'CENTER'},['fred','agnes']) eq + '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', + "distributive tag with attribute"); +{ + local($") = '-'; + test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation"); +} +test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()"); +test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()"); +test(13,start_html() ."\n" eq <<END,"start_html()"); +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +</head><body> +END + ; +test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()"); +<!DOCTYPE html + PUBLIC "-//IETF//DTD HTML 3.2//FR"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +</head><body> +END + ; +test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title> +</head><body> +END + ; +test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); +my $h = header(-Cookie=>$cookie); +test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, + "header(-cookie)"); +test(18,start_h3 eq '<h3>'); +test(19,end_h3 eq '</h3>'); +test(20,start_table({-border=>undef}) eq '<table border>'); +test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +charset('utf-8'); +if (ord("\t") == 9) { +test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +} +else { +test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> »rightº</h1>'); +} +test(23,i(p('hello there')) eq '<i><p>hello there</p></i>'); +my $q = new CGI; +test(24,$q->h1('hi') eq '<h1>hi</h1>'); diff --git a/lib/CGI/t/pretty.t b/lib/CGI/t/pretty.t new file mode 100755 index 0000000000..14f6447033 --- /dev/null +++ b/lib/CGI/t/pretty.t @@ -0,0 +1,41 @@ +#!/usr/local/bin/perl -w + +BEGIN { + chdir('t') if -d 't'; + @INC = '../lib'; +} + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..5\n"; } +END {print "not ok 1\n" unless $loaded;} +use CGI::Pretty (':standard','-no_debug','*h3','start_table'); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# util +sub test { + local($^W) = 0; + my($num, $true,$msg) = @_; + print($true ? "ok $num\n" : "not ok $num $msg\n"); +} + +# all the automatic tags +test(2,h1() eq '<h1>',"single tag"); +test(3,ol(li('fred'),li('ethel')) eq "<ol>\n\t<li>\n\t\tfred\n\t</li>\n\t <li>\n\t\tethel\n\t</li>\n</ol>\n","basic indentation"); +test(4,p('hi',pre('there'),'frog') eq +'<p> + hi <pre>there</pre> + frog +</p> +',"<pre> tags"); +test(5,p('hi',a({-href=>'frog'},'there'),'frog') eq +'<p> + hi <a href="frog">there</a> + frog +</p> +',"as-is"); diff --git a/lib/CGI/t/request.t b/lib/CGI/t/request.t new file mode 100755 index 0000000000..fde3fd04cf --- /dev/null +++ b/lib/CGI/t/request.t @@ -0,0 +1,103 @@ +#!/usr/local/bin/perl -w + +BEGIN { + chdir('t') if -d 't'; + @INC = '../lib'; +} + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..33\n"; } +END {print "not ok 1\n" unless $loaded;} +use CGI (); +use Config; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# util +sub test { + local($^W) = 0; + my($num, $true,$msg) = @_; + print($true ? "ok $num\n" : "not ok $num $msg\n"); +} + +# Set up a CGI environment +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; +$ENV{HTTP_LOVE} = 'true'; + +$q = new CGI; +test(2,$q,"CGI::new()"); +test(3,$q->request_method eq 'GET',"CGI::request_method()"); +test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); +test(5,$q->param() == 2,"CGI::param()"); +test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()"); +test(7,$q->param('game') eq 'chess',"CGI::param()"); +test(8,$q->param('weather') eq 'dull',"CGI::param()"); +test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()"); +test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'); +test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get'); +test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); +test(13,$q->http('love') eq 'true',"CGI::http()"); +test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()"); +test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); +test(16,$q->self_url eq + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + "CGI::url()"); +test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); +test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); +test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); +test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + 'CGI::url(-relative=>1,-path=>1,-query=>1)'); +$q->delete('foo'); +test(21,!$q->param('foo'),'CGI::delete()'); + +$q->_reset_globals; +$ENV{QUERY_STRING}='mary+had+a+little+lamb'; +test(22,$q=new CGI,"CGI::new() redux"); +test(23,join(' ',$q->keywords) eq 'mary had a little lamb','CGI::keywords'); +test(24,join(' ',$q->param('keywords')) eq 'mary had a little lamb','CGI::keywords'); +test(25,$q=new CGI('foo=bar&foo=baz'),"CGI::new() redux"); +test(26,$q->param('foo') eq 'bar','CGI::param() redux'); +test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"); +test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2"); + +# test tied interface +my $p = $q->Vars; +test(29,$p->{bar} eq 'froz',"tied interface fetch"); +$p->{bar} = join("\0",qw(foo bar baz)); +test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store'); + +# test posting +$q->_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(31,$q=new CGI,"CGI::new() from POST"); + test(32,$q->param('weather') eq 'nice',"CGI::param() from POST"); + test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); +} else { + print "ok 31 # Skip\n"; + print "ok 32 # Skip\n"; + print "ok 33 # Skip\n"; +} diff --git a/lib/CGI/t/util.t b/lib/CGI/t/util.t new file mode 100644 index 0000000000..f0471cfed3 --- /dev/null +++ b/lib/CGI/t/util.t @@ -0,0 +1,56 @@ +#!/usr/local/bin/perl -w + +BEGIN { + chdir('t') if -d 't'; + @INC = '../lib'; +} + +# Test ability to escape() and unescape() punctuation characters +# except for qw(- . _). +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..59\n"; } +END {print "not ok 1\n" unless $loaded;} +use Config; +use CGI::Util qw(escape unescape); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# util +sub test { + local($^W) = 0; + my($num, $true,$msg) = @_; + print($true ? "ok $num\n" : "not ok $num $msg\n"); +} + +# ASCII order, ASCII codepoints, ASCII repertoire + +my %punct = ( + ' ' => '20', '!' => '21', '"' => '22', '#' => '23', + '$' => '24', '%' => '25', '&' => '26', '\'' => '27', + '(' => '28', ')' => '29', '*' => '2A', '+' => '2B', + ',' => '2C', '/' => '2F', # '-' => '2D', '.' => '2E' + ':' => '3A', ';' => '3B', '<' => '3C', '=' => '3D', + '>' => '3E', '?' => '3F', '[' => '5B', '\\' => '5C', + ']' => '5D', '^' => '5E', '`' => '60', # '_' => '5F', + '{' => '7B', '|' => '7C', '}' => '7D', '~' => '7E', + ); + +# The sort order may not be ASCII on EBCDIC machines: + +my $i = 1; + +foreach(sort(keys(%punct))) { + $i++; + my $escape = "AbC\%$punct{$_}dEF"; + my $cgi_escape = escape("AbC$_" . "dEF"); + test($i, $escape eq $cgi_escape , "# $escape ne $cgi_escape"); + $i++; + my $unescape = "AbC$_" . "dEF"; + my $cgi_unescape = unescape("AbC\%$punct{$_}dEF"); + test($i, $unescape eq $cgi_unescape , "# $unescape ne $cgi_unescape"); +} + |