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 <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>');
$q->autoEscape(1);
test(25,$q->p({title=>"hello worldè"},'hello á') eq '<p title="hello world&egrave;">hello á</p>');
$q->autoEscape(0);
test(26,$q->p({title=>"hello worldè"},'hello á') eq '<p title="hello worldè">hello á</p>');
test(27,p({title=>"hello worldè"},'hello á') eq '<p title="hello world&egrave;">hello á</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