dslinux/user/perl/lib/CGI/t apache.t can.t carp.t cookie.t fast.t form.t function.t html.t no_tabindex.t pretty.t push.t request.t switch.t util-58.t util.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:27 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/CGI/t
In directory antilope:/tmp/cvs-serv17422/lib/CGI/t

Added Files:
	apache.t can.t carp.t cookie.t fast.t form.t function.t html.t 
	no_tabindex.t pretty.t push.t request.t switch.t util-58.t 
	util.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: apache.t ---
#!/usr/local/bin/perl -w

use lib qw(t/lib);

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(blib/lib blib/arch);

use strict;
use Test::More tests => 1;

# Can't do much with this other than make sure it loads properly
BEGIN { use_ok('CGI::Apache') };

--- NEW FILE: fast.t ---
#!./perl -w

use lib qw(t/lib);

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(blib/lib blib/arch);

my $fcgi;
BEGIN {
	local $@;
	eval { require FCGI };
	$fcgi = $@ ? 0 : 1;
}

use Test::More tests => 7;

# Shut up "used only once" warnings.
() = $CGI::Q;
() = $CGI::Fast::Ext_Request;

SKIP: {
	skip( 'FCGI not installed, cannot continue', 7 ) unless $fcgi;

	use_ok( CGI::Fast );
	ok( my $q = CGI::Fast->new(), 'created new CGI::Fast object' );
	is( $q, $CGI::Q, 'checking to see if the object was stored properly' );
	is( $q->param(), (), 'no params' );

	ok( $q = CGI::Fast->new({ foo => 'bar' }), 'creating obect with params' );
	is( $q->param('foo'), 'bar', 'checking passed param' );

	# if this is false, the package var will be empty
	$ENV{FCGI_SOCKET_PATH} = 0;
	is( $CGI::Fast::Ext_Request, '', 'checking no active request' );

}

--- NEW FILE: util.t ---
#!/usr/local/bin/perl -w

# 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");
}


--- NEW FILE: pretty.t ---
#!/bin/perl -w

use strict;
use lib '.', 't/lib','../blib/lib','./blib/lib';
use Test::More tests => 18;

BEGIN { use_ok('CGI::Pretty') };

# This is silly use_ok should take arguments
use CGI::Pretty (':all');

is(h1(), '<h1 />
',"single tag");

is(ol(li('fred'),li('ethel')), <<HTML,   "basic indentation");
<ol>
	<li>
		fred
	</li>
	<li>
		ethel
	</li>
</ol>
HTML


is(p('hi',pre('there'),'frog'), <<HTML, "<pre> tags");
<p>
	hi <pre>there</pre>
	frog
</p>
HTML

is(h1({-align=>'CENTER'},'fred'), <<HTML, "open/close tag with attribute");
<h1 align="CENTER">
	fred
</h1>
HTML

is(h1({-align=>undef},'fred'), <<HTML,"open/close tag with orphan attribute");
<h1 align>
	fred
</h1>
HTML

is(h1({-align=>'CENTER'},['fred','agnes']), <<HTML, "distributive tag with attribute");
<h1 align="CENTER">
	fred
</h1>
<h1 align="CENTER">
	agnes
</h1>
HTML

is(p('hi',a({-href=>'frog'},'there'),'frog'), <<HTML,   "as-is");
<p>
	hi <a href="frog">there</a>
	frog
</p>
HTML

is(p([ qw( hi there frog ) ] ), <<HTML,   "array-reference");
<p>
	hi
</p>
<p>
	there
</p>
<p>
	frog
</p>
HTML

is(p(p(p('hi'), 'there' ), 'frog'), <<HTML,   "nested tags");
<p>
	<p>
		<p>
			hi
		</p>
		there
	</p>
	frog
</p>
HTML

is(table(TR(td(table(TR(td('hi', 'there', 'frog')))))), <<HTML,   "nested as-is tags");
<table>
	<tr>
		<td><table>
			<tr>
				<td>hi there frog</td>
			</tr>
		</table></td>
	</tr>
</table>
HTML

is(table(TR(td(table(TR(td( [ qw( hi there frog ) ])))))), <<HTML,   "nested as-is array-reference");
<table>
	<tr>
		<td><table>
			<tr>
				<td>hi</td>
				<td>there</td>
				<td>frog</td>
			</tr>
		</table></td>
	</tr>
</table>
HTML

$CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = ""; 

is(h1(), '<h1 />',"single tag (pretty turned off)");
is(h1('fred'), '<h1>fred</h1>',"open/close tag (pretty turned off)");
is(h1('fred','agnes','maura'), '<h1>fred agnes maura</h1>',"open/close tag multiple (pretty turned off)");
is(h1({-align=>'CENTER'},'fred'), '<h1 align="CENTER">fred</h1>',"open/close tag with attribute (pretty turned off)");
is(h1({-align=>undef},'fred'), '<h1 align>fred</h1>',"open/close tag with orphan attribute (pretty turned off)");
is(h1({-align=>'CENTER'},['fred','agnes']), '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>',
   "distributive tag with attribute (pretty turned off)");


--- NEW FILE: no_tabindex.t ---
#!/usr/local/bin/perl -w

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(. ./blib/lib ./blib/arch);

use Test::More tests => 18;

BEGIN { use_ok('CGI'); };
use CGI (':standard','-no_debug');

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';

ok( (not $CGI::TABINDEX), "Tab index turned off.");

is(submit(),
   qq(<input type="submit" name=".submit" />),
   "submit()");

is(submit(-name  => 'foo',
	  -value => 'bar'),
   qq(<input type="submit" name="foo" value="bar" />),
   "submit(-name,-value)");

is(submit({-name  => 'foo',
	   -value => 'bar'}),
   qq(<input type="submit" name="foo" value="bar" />),
   "submit({-name,-value})");

is(textfield(-name => 'weather'),
   qq(<input type="text" name="weather" value="dull" />),
   "textfield({-name})");

is(textfield(-name  => 'weather',
	     -value => 'nice'),
   qq(<input type="text" name="weather" value="dull" />),
   "textfield({-name,-value})");

is(textfield(-name     => 'weather',
	     -value    => 'nice',
	     -override => 1),
   qq(<input type="text" name="weather" value="nice" />),
   "textfield({-name,-value,-override})");

is(checkbox(-name  => 'weather',
	    -value => 'nice'),
   qq(<label><input type="checkbox" name="weather" value="nice" />weather</label>),
   "checkbox()");

is(checkbox(-name  => 'weather',
	    -value => 'nice',
	    -label => 'forecast'),
   qq(<label><input type="checkbox" name="weather" value="nice" />forecast</label>),
   "checkbox()");

is(checkbox(-name     => 'weather',
	    -value    => 'nice',
	    -label    => 'forecast',
	    -checked  => 1,
	    -override => 1),
   qq(<label><input type="checkbox" name="weather" value="nice" checked="checked" />forecast</label>),
   "checkbox()");

is(checkbox(-name  => 'weather',
	    -value => 'dull',
	    -label => 'forecast'),
   qq(<label><input type="checkbox" name="weather" value="dull" checked="checked" />forecast</label>),
   "checkbox()");

is(radio_group(-name => 'game'),
   qq(<label><input type="radio" name="game" value="chess" checked="checked" />chess</label> <label><input type="radio" name="game" value="checkers" />checkers</label>),
   'radio_group()');

is(radio_group(-name   => 'game',
	       -labels => {'chess' => 'ping pong'}),
   qq(<label><input type="radio" name="game" value="chess" checked="checked" />ping pong</label> <label><input type="radio" name="game" value="checkers" />checkers</label>),
   'radio_group()');

is(checkbox_group(-name   => 'game',
		  -Values => [qw/checkers chess cribbage/]),
   qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" />checkers</label> <label><input type="checkbox" name="game" value="chess" checked="checked" />chess</label> <label><input type="checkbox" name="game" value="cribbage" />cribbage</label>),
   'checkbox_group()');

is(checkbox_group(-name       => 'game',
		  '-values'   => [qw/checkers chess cribbage/],
		  '-defaults' => ['cribbage'],
		  -override=>1),
   qq(<label><input type="checkbox" name="game" value="checkers" />checkers</label> <label><input type="checkbox" name="game" value="chess" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" />cribbage</label>),
   'checkbox_group()');

is(popup_menu(-name     => 'game',
	      '-values' => [qw/checkers chess cribbage/],
	      -default  => 'cribbage',
	      -override => 1),
   '<select name="game" >
<option value="checkers">checkers</option>
<option value="chess">chess</option>
<option selected="selected" value="cribbage">cribbage</option>
</select>',
   'popup_menu()');


is(textarea(-name=>'foo',
	    -default=>'starting value',
	    -rows=>10,
	    -columns=>50),
   '<textarea name="foo"  rows="10" cols="50">starting value</textarea>',
   'textarea()');


--- NEW FILE: function.t ---
#!/usr/local/bin/perl -w

use lib qw(t/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..31\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");

test(28,escapeHTML('CGI') eq 'CGI','escapeHTML(CGI) failing again');

test(29, charset("UTF-8") && header() eq "Content-Type: text/html; charset=UTF-8${CRLF}${CRLF}", "UTF-8 charset");
test(30, !charset("") && header() eq "Content-Type: text/html${CRLF}${CRLF}", "Empty charset");

test(31, header(-foo=>'bar') eq "Foo: bar${CRLF}Content-Type: text/html${CRLF}${CRLF}", "Custom header");

--- NEW FILE: switch.t ---
#!/usr/local/bin/perl -w

use lib qw(t/lib);

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(blib/lib blib/arch);

use strict;
use Test::More tests => 1;

# Can't do much with this other than make sure it loads properly
BEGIN { use_ok('CGI::Switch') };

--- NEW FILE: util-58.t ---
#
# This tests CGI::Util::escape() when fed with UTF-8-flagged string
# -- dankogai
BEGIN {
    if ($] < 5.008) {
       print "1..0 # \$] == $] < 5.008\n";
       exit(0);
    }
}

use Test::More tests => 2;
use_ok("CGI::Util");
my $uri = "\x{5c0f}\x{98fc} \x{5f3e}.txt"; # KOGAI, Dan, in Kanji
is(CGI::Util::escape($uri), "%E5%B0%8F%E9%A3%BC%20%E5%BC%BE.txt",
   "# Escape string with UTF-8 flag");
__END__

--- NEW FILE: request.t ---
#!/usr/local/bin/perl -w

# 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";
}

--- NEW FILE: html.t ---
#!/usr/local/bin/perl -w

# Test ability to retrieve HTTP request info
######################### We start with some black magic to print on failure.
use lib '../blib/lib','../blib/arch';

END {print "not ok 1\n" unless $loaded;}
use CGI (':standard','-no_debug','*h3','start_table');
$loaded = 1;
print "ok 1\n";

BEGIN {
   $| = 1; print "1..27\n";
  if( $] > 5.006 ) {
    # no utf8
    require utf8; # we contain Latin-1
    utf8->unimport;
  }
}

######################### 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() eq <<END,"start_html()");
<!DOCTYPE html
	PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
<head>
<title>Untitled Document</title>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
</head>
<body>
END
    ;
test(14,start_html(-Title=>'The world of foo') eq <<END,"start_html()");
<!DOCTYPE html
	PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
<head>
<title>The world of foo</title>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
</head>
<body>
END
    ;
# Note that this test will turn off XHTML until we make a new CGI object.
test(15,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR",-lang=>'fr') eq <<END,"start_html()");
<!DOCTYPE html
	PUBLIC "-//IETF//DTD HTML 3.2//FR">
<html lang="fr"><head><title>Untitled Document</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; &#8249;right&#8250;</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>');

$q->autoEscape(1);
test(25,$q->p({title=>"hello world&egrave;"},'hello &aacute;') eq '<p title="hello world&amp;egrave;">hello &aacute;</p>');
$q->autoEscape(0);
test(26,$q->p({title=>"hello world&egrave;"},'hello &aacute;') eq '<p title="hello world&egrave;">hello &aacute;</p>');
test(27,p({title=>"hello world&egrave;"},'hello &aacute;') eq '<p title="hello world&amp;egrave;">hello &aacute;</p>');

--- NEW FILE: cookie.t ---
#!/usr/local/bin/perl -w

use lib qw(t/lib);
use strict;

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(blib/lib blib/arch);

use Test::More tests => 86;
use CGI::Util qw(escape unescape);
use POSIX qw(strftime);

#-----------------------------------------------------------------------------
# make sure module loaded
#-----------------------------------------------------------------------------

BEGIN {use_ok('CGI::Cookie');}

my @test_cookie = (
		   'foo=123; bar=qwerty; baz=wibble; qux=a1',
		   'foo=123; bar=qwerty; baz=wibble;',
		   'foo=vixen; bar=cow; baz=bitch; qux=politician',
		   'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
		   );

#-----------------------------------------------------------------------------
# Test parse
#-----------------------------------------------------------------------------

{
  my $result = CGI::Cookie->parse($test_cookie[0]);

  is(ref($result), 'HASH', "Hash ref returned in scalar context");

  my @result = CGI::Cookie->parse($test_cookie[0]);

  is(@result, 8, "returns correct number of fields");

  @result = CGI::Cookie->parse($test_cookie[1]);

  is(@result, 6, "returns correct number of fields");

  my %result = CGI::Cookie->parse($test_cookie[0]);

  is($result{foo}->value, '123', "cookie foo is correct");
  is($result{bar}->value, 'qwerty', "cookie bar is correct");
  is($result{baz}->value, 'wibble', "cookie baz is correct");
  is($result{qux}->value, 'a1', "cookie qux is correct");
}

#-----------------------------------------------------------------------------
# Test fetch
#-----------------------------------------------------------------------------

{
  # make sure there are no cookies in the environment
  delete $ENV{HTTP_COOKIE};
  delete $ENV{COOKIE};

  my %result = CGI::Cookie->fetch();
  ok(keys %result == 0, "No cookies in environment, returns empty list");

  # now set a cookie in the environment and try again
  $ENV{HTTP_COOKIE} = $test_cookie[2];
  %result = CGI::Cookie->fetch();
  ok(eq_set([keys %result], [qw(foo bar baz qux)]),
     "expected cookies extracted");

  is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
  is($result{foo}->value, 'vixen',      "cookie foo is correct");
  is($result{bar}->value, 'cow',        "cookie bar is correct");
  is($result{baz}->value, 'bitch',      "cookie baz is correct");
  is($result{qux}->value, 'politician', "cookie qux is correct");

  # Delete that and make sure it goes away
  delete $ENV{HTTP_COOKIE};
  %result = CGI::Cookie->fetch();
  ok(keys %result == 0, "No cookies in environment, returns empty list");

  # try another cookie in the other environment variable thats supposed to work
  $ENV{COOKIE} = $test_cookie[3];
  %result = CGI::Cookie->fetch();
  ok(eq_set([keys %result], [qw(foo bar baz qux)]),
     "expected cookies extracted");

  is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct');
  is($result{foo}->value, 'a phrase', "cookie foo is correct");
  is($result{bar}->value, 'yes, a phrase', "cookie bar is correct");
  is($result{baz}->value, '^wibble', "cookie baz is correct");
  is($result{qux}->value, "'", "cookie qux is correct");
}

#-----------------------------------------------------------------------------
# Test raw_fetch
#-----------------------------------------------------------------------------

{
  # make sure there are no cookies in the environment
  delete $ENV{HTTP_COOKIE};
  delete $ENV{COOKIE};

  my %result = CGI::Cookie->raw_fetch();
  ok(keys %result == 0, "No cookies in environment, returns empty list");

  # now set a cookie in the environment and try again
  $ENV{HTTP_COOKIE} = $test_cookie[2];
  %result = CGI::Cookie->raw_fetch();
  ok(eq_set([keys %result], [qw(foo bar baz qux)]),
     "expected cookies extracted");

  is(ref($result{foo}), '', 'Plain scalar returned');
  is($result{foo}, 'vixen',      "cookie foo is correct");
  is($result{bar}, 'cow',        "cookie bar is correct");
  is($result{baz}, 'bitch',      "cookie baz is correct");
  is($result{qux}, 'politician', "cookie qux is correct");

  # Delete that and make sure it goes away
  delete $ENV{HTTP_COOKIE};
  %result = CGI::Cookie->raw_fetch();
  ok(keys %result == 0, "No cookies in environment, returns empty list");

  # try another cookie in the other environment variable thats supposed to work
  $ENV{COOKIE} = $test_cookie[3];
  %result = CGI::Cookie->raw_fetch();
  ok(eq_set([keys %result], [qw(foo bar baz qux)]),
     "expected cookies extracted");

  is(ref($result{foo}), '', 'Plain scalar returned');
  is($result{foo}, 'a%20phrase', "cookie foo is correct");
  is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
  is($result{baz}, '%5Ewibble', "cookie baz is correct");
  is($result{qux}, '%27', "cookie qux is correct");
}

#-----------------------------------------------------------------------------
# Test new
#-----------------------------------------------------------------------------

{
  # Try new with full information provided
  my $c = CGI::Cookie->new(-name    => 'foo',
			   -value   => 'bar',
			   -expires => '+3M',
			   -domain  => '.capricorn.com',
			   -path    => '/cgi-bin/database',
			   -secure  => 1
			  );
  is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
  is($c->name   , 'foo',               'name is correct');
  is($c->value  , 'bar',               'value is correct');
  like($c->expires, '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires in correct format');
  is($c->domain , '.capricorn.com',    'domain is correct');
  is($c->path   , '/cgi-bin/database', 'path is correct');
  ok($c->secure , 'secure attribute is set');

  # now try it with the only two manditory values (should also set the default path)
  $c = CGI::Cookie->new(-name    =>  'baz',
			-value   =>  'qux',
		       );
  is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
  is($c->name   , 'baz', 'name is correct');
  is($c->value  , 'qux', 'value is correct');
  ok(!defined $c->expires,       'expires is not set');
  ok(!defined $c->domain ,       'domain attributeis not set');
  is($c->path, '/',      'path atribute is set to default');
  ok(!defined $c->secure ,       'secure attribute is set');

# I'm really not happy about the restults of this section.  You pass
# the new method invalid arguments and it just merilly creates a
# broken object :-)
# I've commented them out because they currently pass but I don't
# think they should.  I think this is testing broken behaviour :-(

#    # This shouldn't work
#    $c = CGI::Cookie->new(-name => 'baz' );
#
#    is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
#    is($c->name   , 'baz',     'name is correct');
#    ok(!defined $c->value, "Value is undefined ");
#    ok(!defined $c->expires, 'expires is not set');
#    ok(!defined $c->domain , 'domain attributeis not set');
#    is($c->path   , '/', 'path atribute is set to default');
#    ok(!defined $c->secure , 'secure attribute is set');

}

#-----------------------------------------------------------------------------
# Test as_string
#-----------------------------------------------------------------------------

{
  my $c = CGI::Cookie->new(-name    => 'Jam',
			   -value   => 'Hamster',
			   -expires => '+3M',
			   -domain  => '.pie-shop.com',
			   -path    => '/',
			   -secure  => 1
			  );

  my $name = $c->name;
  like($c->as_string, "/$name/", "Stringified cookie contains name");

  my $value = $c->value;
  like($c->as_string, "/$value/", "Stringified cookie contains value");

  my $expires = $c->expires;
  like($c->as_string, "/$expires/", "Stringified cookie contains expires");

  my $domain = $c->domain;
  like($c->as_string, "/$domain/", "Stringified cookie contains domain");

  my $path = $c->path;
  like($c->as_string, "/$path/", "Stringified cookie contains path");

  like($c->as_string, '/secure/', "Stringified cookie contains secure");

  $c = CGI::Cookie->new(-name    =>  'Hamster-Jam',
			-value   =>  'Tulip',
		       );

  $name = $c->name;
  like($c->as_string, "/$name/", "Stringified cookie contains name");

  $value = $c->value;
  like($c->as_string, "/$value/", "Stringified cookie contains value");

  ok($c->as_string !~ /expires/, "Stringified cookie has no expires field");

  ok($c->as_string !~ /domain/, "Stringified cookie has no domain field");

  $path = $c->path;
  like($c->as_string, "/$path/", "Stringified cookie contains path");

  ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
}

#-----------------------------------------------------------------------------
# Test compare
#-----------------------------------------------------------------------------

{
  my $c1 = CGI::Cookie->new(-name    => 'Jam',
			    -value   => 'Hamster',
			    -expires => '+3M',
			    -domain  => '.pie-shop.com',
			    -path    => '/',
			    -secure  => 1
			   );

  # have to use $c1->expires because the time will occasionally be
  # different between the two creates causing spurious failures.
  my $c2 = CGI::Cookie->new(-name    => 'Jam',
			    -value   => 'Hamster',
			    -expires => $c1->expires,
			    -domain  => '.pie-shop.com',
			    -path    => '/',
			    -secure  => 1
			   );

  # This looks titally whacked, but it does the -1, 0, 1 comparison
  # thing so 0 means they match
  is($c1->compare("$c1"), 0, "Cookies are identical");
  is($c1->compare("$c2"), 0, "Cookies are identical");

  $c1 = CGI::Cookie->new(-name   => 'Jam',
			 -value  => 'Hamster',
			 -domain => '.foo.bar.com'
			);

  # have to use $c1->expires because the time will occasionally be
  # different between the two creates causing spurious failures.
  $c2 = CGI::Cookie->new(-name    =>  'Jam',
			 -value   =>  'Hamster',
			);

  # This looks titally whacked, but it does the -1, 0, 1 comparison
  # thing so 0 (i.e. false) means they match
  is($c1->compare("$c1"), 0, "Cookies are identical");
  ok($c1->compare("$c2"), "Cookies are not identical");

  $c2->domain('.foo.bar.com');
  is($c1->compare("$c2"), 0, "Cookies are identical");
}

#-----------------------------------------------------------------------------
# Test name, value, domain, secure, expires and path
#-----------------------------------------------------------------------------

{
  my $c = CGI::Cookie->new(-name    => 'Jam',
			   -value   => 'Hamster',
			   -expires => '+3M',
			   -domain  => '.pie-shop.com',
			   -path    => '/',
			   -secure  => 1
			   );

  is($c->name,          'Jam',   'name is correct');
  is($c->name('Clash'), 'Clash', 'name is set correctly');
  is($c->name,          'Clash', 'name now returns updated value');

  # this is insane!  it returns a simple scalar but can't accept one as
  # an argument, you have to give it an arrary ref.  It's totally
  # inconsitent with these other methods :-(
  is($c->value,           'Hamster', 'value is correct');
  is($c->value(['Gerbil']), 'Gerbil',  'value is set correctly');
  is($c->value,           'Gerbil',  'value now returns updated value');

  my $exp = $c->expires;
  like($c->expires,         '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is correct');
  like($c->expires('+12h'), '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires is set correctly');
  like($c->expires,         '/^[a-z]{3},\s*\d{2}-[a-z]{3}-\d{4}/i', 'expires now returns updated value');
  isnt($c->expires, $exp, "Expiry time has changed");

  is($c->domain,                  '.pie-shop.com', 'domain is correct');
  is($c->domain('.wibble.co.uk'), '.wibble.co.uk', 'domain is set correctly');
  is($c->domain,                  '.wibble.co.uk', 'domain now returns updated value');

  is($c->path,             '/',        'path is correct');
  is($c->path('/basket/'), '/basket/', 'path is set correctly');
  is($c->path,             '/basket/', 'path now returns updated value');

  ok($c->secure,     'secure attribute is set');
  ok(!$c->secure(0), 'secure attribute is cleared');
  ok(!$c->secure,    'secure attribute is cleared');
}

--- NEW FILE: can.t ---
#!/usr/local/bin/perl -w

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm

use lib qw(blib/lib blib/arch);

use Test::More tests => 2;

BEGIN{ use_ok('CGI'); }

can_ok('CGI', qw/cookie param/);
--- NEW FILE: push.t ---
#!./perl -wT

use lib qw(t/lib);

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(blib/lib blib/arch);

use Test::More tests => 12; 

use_ok( 'CGI::Push' );

ok( my $q = CGI::Push->new(), 'create a new CGI::Push object' );

# test the simple_counter() method
like( join('', $q->simple_counter(10)) , '/updated.+?10.+?times./', 'counter' );

# test do_sleep, except we don't want to bog down the tests
# there's also a potential timing-related failure lurking here
# change this variable at your own risk
my $sleep_in_tests = 0;

SKIP: {
	skip( 'do_sleep() test may take a while', 1 ) unless $sleep_in_tests;

	my $time = time;
	CGI::Push::do_sleep(2);
	is(time - $time, 2, 'slept for a while' );
}

# test push_delay()
ok( ! defined $q->push_delay(), 'no initial delay' );
is( $q->push_delay(.5), .5, 'set a delay' );

my $out = tie *STDOUT, 'TieOut';

# next_page() to be called twice, last_page() once, no delay
my %vars = (
	-next_page	=> sub { return if $_[1] > 2; 'next page' },
	-last_page	=> sub { 'last page' },
	-delay		=> 0,
);

$q->do_push(%vars);

# this seems to appear on every page
like( $$out, '/WARNING: YOUR BROWSER/', 'unsupported browser warning' );

# these should appear correctly
is( ($$out =~ s/next page//g), 2, 'next_page callback called appropriately' );
is( ($$out =~ s/last page//g), 1, 'last_page callback called appropriately' );

# send a fake content type (header capitalization varies in CGI, CGI::Push)
$$out = '';
$q->do_push(%vars, -type => 'fake' );
like( $$out, '/Content-[Tt]ype: fake/', 'set custom Content-type' );

# use our own counter, as $COUNTER in CGI::Push is now off
my $i;
$$out = '';

# no delay, custom headers from callback, only call callback once
$q->do_push(
	-delay		=> 0,
	-type		=> 'dynamic',
	-next_page	=> sub { 
		return if $i++;
		return $_[0]->header('text/plain'), 'arduk';
	 },
);

# header capitalization again, our word should appear only once
like( $$out, '/ype: text\/plain/', 'set custom Content-type in next_page()' );
is( $$out =~ s/arduk//g, 1, 'found text from next_page()' );
	
package TieOut;

sub TIEHANDLE {
	bless( \(my $text), $_[0] );
}

sub PRINT {
	my $self = shift;
	$$self .= join( $/, @_ );
}

--- NEW FILE: form.t ---
#!/usr/local/bin/perl -w

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(. ./blib/lib ./blib/arch);

use Test::More tests => 18;

BEGIN { use_ok('CGI'); };
use CGI (':standard','-no_debug','-tabindex');

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';

is(start_form(-action=>'foobar',-method=>'get'),
   qq(<form method="get" action="foobar" enctype="multipart/form-data">\n),
   "start_form()");

is(submit(),
   qq(<input type="submit" tabindex="1" name=".submit" />),
   "submit()");

is(submit(-name  => 'foo',
	  -value => 'bar'),
   qq(<input type="submit" tabindex="2" name="foo" value="bar" />),
   "submit(-name,-value)");

is(submit({-name  => 'foo',
	   -value => 'bar'}),
   qq(<input type="submit" tabindex="3" name="foo" value="bar" />),
   "submit({-name,-value})");

is(textfield(-name => 'weather'),
   qq(<input type="text" name="weather" tabindex="4" value="dull" />),
   "textfield({-name})");

is(textfield(-name  => 'weather',
	     -value => 'nice'),
   qq(<input type="text" name="weather" tabindex="5" value="dull" />),
   "textfield({-name,-value})");

is(textfield(-name     => 'weather',
	     -value    => 'nice',
	     -override => 1),
   qq(<input type="text" name="weather" tabindex="6" value="nice" />),
   "textfield({-name,-value,-override})");

is(checkbox(-name  => 'weather',
	    -value => 'nice'),
   qq(<label><input type="checkbox" name="weather" value="nice" tabindex="7" />weather</label>),
   "checkbox()");

is(checkbox(-name  => 'weather',
	    -value => 'nice',
	    -label => 'forecast'),
   qq(<label><input type="checkbox" name="weather" value="nice" tabindex="8" />forecast</label>),
   "checkbox()");

is(checkbox(-name     => 'weather',
	    -value    => 'nice',
	    -label    => 'forecast',
	    -checked  => 1,
	    -override => 1),
   qq(<label><input type="checkbox" name="weather" value="nice" tabindex="9" checked="checked" />forecast</label>),
   "checkbox()");

is(checkbox(-name  => 'weather',
	    -value => 'dull',
	    -label => 'forecast'),
   qq(<label><input type="checkbox" name="weather" value="dull" tabindex="10" checked="checked" />forecast</label>),
   "checkbox()");

is(radio_group(-name => 'game'),
   qq(<label><input type="radio" name="game" value="chess" checked="checked" tabindex="11" />chess</label> <label><input type="radio" name="game" value="checkers" tabindex="12" />checkers</label>),
   'radio_group()');

is(radio_group(-name   => 'game',
	       -labels => {'chess' => 'ping pong'}),
   qq(<label><input type="radio" name="game" value="chess" checked="checked" tabindex="13" />ping pong</label> <label><input type="radio" name="game" value="checkers" tabindex="14" />checkers</label>),
   'radio_group()');

is(checkbox_group(-name   => 'game',
		  -Values => [qw/checkers chess cribbage/]),
   qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" tabindex="15" />checkers</label> <label><input type="checkbox" name="game" value="chess" checked="checked" tabindex="16" />chess</label> <label><input type="checkbox" name="game" value="cribbage" tabindex="17" />cribbage</label>),
   'checkbox_group()');

is(checkbox_group(-name       => 'game',
		  '-values'   => [qw/checkers chess cribbage/],
		  '-defaults' => ['cribbage'],
		  -override=>1),
   qq(<label><input type="checkbox" name="game" value="checkers" tabindex="18" />checkers</label> <label><input type="checkbox" name="game" value="chess" tabindex="19" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" tabindex="20" />cribbage</label>),
   'checkbox_group()');

is(popup_menu(-name     => 'game',
	      '-values' => [qw/checkers chess cribbage/],
	      -default  => 'cribbage',
	      -override => 1),
   '<select name="game" tabindex="21" >
<option value="checkers">checkers</option>
<option value="chess">chess</option>
<option selected="selected" value="cribbage">cribbage</option>
</select>',
   'popup_menu()');
is(scrolling_list(-name => 'game',
		  '-values' => [qw/checkers chess cribbage/],
		  -default => 'cribbage',
		  -override=>1),
   '<select name="game" tabindex="22"  size="3">
<option value="checkers">checkers</option>
<option value="chess">chess</option>
<option selected="selected" value="cribbage">cribbage</option>
</select>',
  'scrolling_list()');

--- NEW FILE: carp.t ---
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
#!/usr/local/bin/perl -w

use strict;
use lib qw(t/lib);

# Due to a bug in older versions of MakeMaker & Test::Harness, we must
# ensure the blib's are in @INC, else we might use the core CGI.pm
use lib qw(blib/lib blib/arch);

use Test::More tests => 41;
use IO::Handle;

BEGIN { use_ok('CGI::Carp') };

#-----------------------------------------------------------------------------
# Test id
#-----------------------------------------------------------------------------

# directly invoked
my $expect_f = __FILE__;
my $expect_l = __LINE__ + 1;
my ($file, $line, $id) = CGI::Carp::id(0);
is($file, $expect_f, "file");
is($line, $expect_l, "line");
is($id, "carp.t", "id");

# one level of indirection
sub id1 { my $level = shift; return CGI::Carp::id($level); };

$expect_l = __LINE__ + 1;
($file, $line, $id) = id1(1);
is($file, $expect_f, "file");
is($line, $expect_l, "line");
is($id, "carp.t", "id");

# two levels of indirection
sub id2 { my $level = shift; return id1($level); };

$expect_l = __LINE__ + 1;
($file, $line, $id) = id2(2);
is($file, $expect_f, "file");
is($line, $expect_l, "line");
is($id, "carp.t", "id");

#-----------------------------------------------------------------------------
# Test stamp
#-----------------------------------------------------------------------------

my $stamp = "/^\\[
      ([a-z]{3}\\s){2}\\s?
      [\\s\\d:]+
      \\]\\s$id:/ix";

like(CGI::Carp::stamp(),
     $stamp,
     "Time in correct format");

sub stamp1 {return CGI::Carp::stamp()};
sub stamp2 {return stamp1()};

like(stamp2(), $stamp, "Time in correct format");

#-----------------------------------------------------------------------------
# Test warn and _warn
#-----------------------------------------------------------------------------

# set some variables to control what's going on.
$CGI::Carp::WARN = 0;
$CGI::Carp::EMIT_WARNINGS = 0;
my $q_file = quotemeta($file);


# Test that realwarn is called
{
  local $^W = 0;
  eval "sub CGI::Carp::realwarn {return 'Called realwarn'};";
}

$expect_l = __LINE__ + 1;
is(CGI::Carp::warn("There is a problem"),
   "Called realwarn",
   "CGI::Carp::warn calls CORE::warn");

# Test that message is constructed correctly
eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};';

$expect_l = __LINE__ + 1;
like(CGI::Carp::warn("There is a problem"),
   "/] $id: There is a problem at $q_file line $expect_l.".'$/',
   "CGI::Carp::warn builds correct message");

# Test that _warn is called at the correct time
$CGI::Carp::WARN = 1;

my $warn_expect_l = $expect_l = __LINE__ + 1;
like(CGI::Carp::warn("There is a problem"),
   "/] $id: There is a problem at $q_file line $expect_l.".'$/',
   "CGI::Carp::warn builds correct message");

#-----------------------------------------------------------------------------
# Test ineval
#-----------------------------------------------------------------------------

ok(!CGI::Carp::ineval, 'ineval returns false when not in eval');
eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');};

#-----------------------------------------------------------------------------
# Test die
#-----------------------------------------------------------------------------

# set some variables to control what's going on.
$CGI::Carp::WRAP = 0;

$expect_l = __LINE__ + 1;
eval { CGI::Carp::die('There is a problem'); };
like($@,
     '/^There is a problem/',
     'CGI::Carp::die calls CORE::die without altering argument in eval');

# Test that realwarn is called
{
  local $^W = 0;
  eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
}

like(CGI::Carp::die('There is a problem'),
     $stamp,
     'CGI::Carp::die calls CORE::die, but adds stamp');

#-----------------------------------------------------------------------------
# Test set_message
#-----------------------------------------------------------------------------

is(CGI::Carp::set_message('My new Message'),
   'My new Message',
   'CGI::Carp::set_message returns new message');

is($CGI::Carp::CUSTOM_MSG,
   'My new Message',
   'CGI::Carp::set_message message set correctly');

# set the message back to the empty string so that the tests later
# work properly.
CGI::Carp::set_message(''),

#-----------------------------------------------------------------------------
# Test set_progname
#-----------------------------------------------------------------------------

import CGI::Carp qw(name=new_progname);
is($CGI::Carp::PROGNAME,
     'new_progname',
     'CGI::Carp::import set program name correctly');

is(CGI::Carp::set_progname('newer_progname'),
   'newer_progname',
   'CGI::Carp::set_progname returns new program name');

is($CGI::Carp::PROGNAME,
   'newer_progname',
   'CGI::Carp::set_progname program name set correctly');

# set the message back to the empty string so that the tests later
# work properly.
is (CGI::Carp::set_progname(undef),undef,"CGI::Carp::set_progname returns unset name correctly");
is ($CGI::Carp::PROGNAME,undef,"CGI::Carp::set_progname program name unset correctly");

#-----------------------------------------------------------------------------
# Test warnings_to_browser
#-----------------------------------------------------------------------------

CGI::Carp::warningsToBrowser(0);
is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off");

# turn off STDOUT (prevents spurious warnings to screen
tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
CGI::Carp::warningsToBrowser(1);
my $fake_out = join '', <STDOUT>;
untie *STDOUT;

open(STDOUT, ">&REAL_STDOUT");
my $fname = $0;
$fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also
is( $fake_out, "<!-- warning: There is a problem at $fname line $warn_expect_l. -->\n",
                        'warningsToBrowser() on' );

is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");

#-----------------------------------------------------------------------------
# Test fatals_to_browser
#-----------------------------------------------------------------------------

package StoreStuff;

sub TIEHANDLE {
  my $class = shift;
  bless [], $class;
}

sub PRINT {
  my $self = shift;
  push @$self, @_;
}

sub READLINE {
  my $self = shift;
  shift @$self;
}

package main;

tie *STDOUT, "StoreStuff";

# do tests
my @result;

CGI::Carp::fatalsToBrowser();
$result[0] .= $_ while (<STDOUT>);

CGI::Carp::fatalsToBrowser('Message to the world');
$result[1] .= $_ while (<STDOUT>);

$ENV{SERVER_ADMIN} = 'foo at bar.com';
CGI::Carp::fatalsToBrowser();
$result[2] .= $_ while (<STDOUT>);

CGI::Carp::set_message('Override the message passed in'),

CGI::Carp::fatalsToBrowser('Message to the world');
$result[3] .= $_ while (<STDOUT>);
CGI::Carp::set_message(''),
delete $ENV{SERVER_ADMIN};

# now restore STDOUT
untie *STDOUT;


like($result[0],
     '/Content-type: text/html/',
     "Default string has header");

ok($result[0] !~ /Message to the world/, "Custom message not in default string");

like($result[1],
    '/Message to the world/',
    "Custom Message appears in output");

ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");

like($result[2],
    '/foo at bar.com/',
    "Server Admin appears in output");

like($result[3],
     '/Message to the world/',
     "Custom message not in result");

like($result[3],
     '/Override the message passed in/',
     "Correct message in string");

#-----------------------------------------------------------------------------
# Test to_filehandle
#-----------------------------------------------------------------------------

sub buffer {
  CGI::Carp::to_filehandle (@_);
}

tie *STORE, "StoreStuff";

require FileHandle;
my $fh = FileHandle->new;

ok( defined buffer(\*STORE),       '\*STORE returns proper filehandle');
ok( defined buffer( $fh ),         '$fh returns proper filehandle');
ok( defined buffer('::STDOUT'),    'STDIN returns proper filehandle');
ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
ok(!defined buffer("WIBBLE"),      '"WIBBLE" doesn\'t returns proper filehandle');




More information about the dslinux-commit mailing list