summaryrefslogtreecommitdiff
path: root/lib/CGI/t
diff options
context:
space:
mode:
authorJarkko Hietaniemi <jhi@iki.fi>2001-06-18 04:17:15 +0000
committerJarkko Hietaniemi <jhi@iki.fi>2001-06-18 04:17:15 +0000
commitb695f709e8a342e35e482b0437eb6cdacdc58b6b (patch)
tree2d16192636e6ba806ff7a907f682c74f7705a920 /lib/CGI/t
parentd780cd7a0195e946e636d3ee546f6ef4f21d6acc (diff)
downloadperl-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-xlib/CGI/t/form.t90
-rwxr-xr-xlib/CGI/t/function.t111
-rwxr-xr-xlib/CGI/t/html.t95
-rwxr-xr-xlib/CGI/t/pretty.t41
-rwxr-xr-xlib/CGI/t/request.t103
-rw-r--r--lib/CGI/t/util.t56
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 &lt;not&gt; &#139;right&#155;</h1>');
+charset('utf-8');
+if (ord("\t") == 9) {
+test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; ‹right›</h1>');
+}
+else {
+test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; »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");
+}
+