You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by st...@apache.org on 2002/08/14 17:12:55 UTC
cvs commit: modperl-2.0/t/response/TestApache compat.pm compat2.pm
stas 2002/08/14 08:12:55
Added: t/compat compat.t
t/response/TestCompat compat2.pm compat.pm
Removed: t/apache compat.t
t/response/TestApache compat.pm compat2.pm
Log:
moving compat testa into their own group, preparing for the split into
several compat tests
Revision Changes Path
1.1 modperl-2.0/t/compat/compat.t
Index: compat.t
===================================================================
use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::TestUtil;
use Apache::TestRequest;
plan tests => 3;
my $location = "/TestCompat::compat";
# $r->send_http_header('text/plain');
{
my @data = (test => 'content-type');
ok t_cmp(
"text/plain",
HEAD(query(@data))->content_type(),
q{$r->send_http_header('text/plain')}
);
}
# $r->content
{
my @data = (test => 'content');
my $content = join '=', @data;
ok t_cmp(
"@data",
POST_BODY($location, content => $content),
q{$r->content via POST}
);
}
# $r->Apache::args
{
my @data = (test => 'args');
ok t_cmp(
"@data",
GET_BODY(query(@data)),
q{$r->Apache::args}
);
}
### helper subs ###
sub query {
my(%args) = (@_ % 2) ? %{+shift} : @_;
"$location?" . join '&', map { "$_=$args{$_}" } keys %args;
}
# accepts multiline var where, the lines matching:
# ^ok\n$ results in ok(1)
# ^nok\n$ results in ok(0)
# the rest is printed as is
sub ok_nok {
for (split /\n/, shift) {
if (/^ok\n?$/) {
ok 1;
} elsif (/^nok\n?$/) {
ok 0;
} else {
print "$_\n";
}
}
}
1.1 modperl-2.0/t/response/TestCompat/compat2.pm
Index: compat2.pm
===================================================================
package TestCompat::compat2;
# these Apache::compat tests are all run and validated on the server
# side. See also TestCompat::compat.
use strict;
use warnings FATAL => 'all';
use Apache::TestUtil;
use Apache::Test;
use Apache::compat ();
use Apache::Constants qw(OK);
my %string_size = (
'-1' => " -",
0 => " 0k",
42 => " 1k",
42_000 => " 41k",
42_000_000 => "40.1M",
42_000_000_000 => "40054M",
);
sub handler {
my $r = shift;
plan $r, tests => 51;
$r->send_http_header('text/plain');
my $cfg = Apache::Test::config();
my $vars = $cfg->{vars};
### Apache-> tests
my $fh = Apache->gensym;
ok t_cmp('GLOB', ref($fh), "Apache->gensym");
ok t_cmp(1, Apache->module('mod_perl.c'),
"Apache::module('mod_perl.c')");
ok t_cmp(0, Apache->module('mod_ne_exists.c'),
"Apache::module('mod_ne_exists.c')");
### $r-> tests
# test header_in and header_out
# and err_header_out
for my $prefix ('err_', '') {
my @ways = 'out';
push @ways, 'in' unless $prefix;
for my $way (@ways) {
my $sub_test = "${prefix}header_$way";
my $sub_good = "${prefix}headers_$way";
my $key = 'header-test';
# scalar context
{
my $key;
if ($way eq 'in') {
$key = "user-agent"; # should exist with lwp
} else {
# outgoing headers aren't set yet, so we set one
$key = "X-barabara";
$r->$sub_good->set($key, $key x 2);
}
ok t_cmp($r->$sub_good->get($key),
$r->$sub_test($key),
"\$r->$sub_test in scalar context");
}
# list context
{
my @exp = qw(foo bar);
$r->$sub_good->add($key => $_) for @exp;
ok t_cmp(\@exp,
[ $r->$sub_test($key) ],
"\$r->$sub_test in list context");
}
# set
{
my $exp = $key x 2;
$r->$sub_test($key => $exp);
my $got = $r->$sub_test($key);
ok t_cmp($exp, $got, "\$r->$sub_test set()");
}
# unset
{
my $exp = undef;
$r->$sub_test($key => $exp);
my $got = $r->$sub_test($key);
ok t_cmp($exp, $got, "\$r->$sub_test unset()");
}
}
}
# Apache::File
{
require Apache::File;
my $file = $vars->{t_conf_file};
t_debug "new Apache::File file object";
ok my $fh = Apache::File->new;
t_debug "open itself";
if ($fh->open($file)) {
ok 1;
t_debug "read from file";
my $read = <$fh>;
ok $read;
t_debug "close file";
ok $fh->close;
}
else {
t_debug "open $file failed: $!";
ok 0;
t_debug "ok: cannot read from the closed fh";
ok 1;
t_debug "ok: close file should fail, wasn't opened";
ok !$fh->close;
}
t_debug "open non-exists";
ok !$fh->open("$file.nochance");
t_debug "new+open";
if (my $fh = Apache::File->new($file)) {
ok 1;
$fh->close;
}
else {
ok 0;
}
t_debug "new+open non-exists";
ok !Apache::File->new("$file.yeahright");
# tmpfile
my ($tmpfile, $tmpfh) = Apache::File->tmpfile;
t_debug "open tmpfile fh";
ok $tmpfh;
t_debug "open tmpfile name";
ok $tmpfile;
my $write = "test $$";
print $tmpfh $write;
seek $tmpfh, 0, 0;
ok t_cmp($write, scalar(<$tmpfh>), "write/read from tmpfile");
ok t_cmp(Apache::OK,
$r->discard_request_body,
"\$r->discard_request_body");
ok t_cmp(Apache::OK,
$r->meets_conditions,
"\$r->meets_conditions");
my $csize = 10;
$r->set_content_length($csize);
ok t_cmp($csize,
$r->headers_out->{"Content-length"},
"\$r->set_content_length($csize) w/ setting explicit size");
# $r->set_content_length();
# TODO
# ok t_cmp(0, # XXX: $r->finfo->csize is not available yet
# $r->headers_out->{"Content-length"},
# "\$r->set_content_length() w/o setting explicit size");
# XXX: how to test etag?
t_debug "\$r->set_etag";
$r->set_etag;
ok 1;
# $r->update_mtime
t_debug "\$r->update_mtime()";
$r->update_mtime; # just check that it's valid
ok 1;
my $time = time;
$r->update_mtime($time);
ok t_cmp($time, $r->mtime, "\$r->update_mtime(\$time)/\$r->mtime");
# $r->set_last_modified
$r->set_last_modified();
ok t_cmp($time, $r->mtime, "\$r->set_last_modified()");
$r->set_last_modified($time);
ok t_cmp($time, $r->mtime, "\$r->set_last_modified(\$time)");
}
# $r->get_remote_host
ok $r->get_remote_host() || 1;
# Apache::Util::size_string
{
while (my($k, $v) = each %string_size) {
ok t_cmp($v, Apache::Util::size_string($k));
}
}
my $uri = "http://foo.com/a file.html";
(my $esc_uri = $uri) =~ s/ /\%20/g;
my $uri2 = $uri;
$uri = Apache::Util::escape_uri($uri);
$uri2 = Apache::Util::escape_path($uri2, $r->pool);
ok t_cmp($esc_uri, $uri, "Apache::Util::escape_uri");
ok t_cmp($esc_uri, $uri2, "Apache::Util::escape_path");
ok t_cmp(Apache::unescape_url($uri),
Apache::Util::unescape_uri($uri2),
"Apache::URI::unescape_uri vs Apache::Util::unescape_uri");
ok t_cmp($uri,
$uri2,
"Apache::URI::unescape_uri vs Apache::Util::unescape_uri");
my $html = '<p>"hi"&foo</p>';
my $esc_html = '<p>"hi"&foo</p>';
ok t_cmp($esc_html, Apache::Util::escape_html($html),
"Apache::Util::escape_html");
my $time = time;
my $fmtdate = Apache::Util::ht_time($time);
ok t_cmp($fmtdate, $fmtdate, "Apache::Util::ht_time");
my $ptime = Apache::Util::parsedate($fmtdate);
ok t_cmp($time, $ptime, "Apache::Util::parsedate");
my $t = Apache::Table->new($r);
my $t_class = ref $t;
ok t_cmp('APR::Table', $t_class, "Apache::Table->new");
ok t_cmp(!$r->main, $r->is_main,
'$r->is_main');
ok t_cmp(Apache::exists_config_define('MODPERL2'),
Apache->define('MODPERL2'),
'Apache->define');
#note these are not actually part of the tests
#since i think on platforms where crypt is not supported,
#these tests will fail. but at least we can look with t/TEST -v
my $hash = "aX9eP53k4DGfU";
t_cmp(1, Apache::Util::validate_password("dougm", $hash));
t_cmp(0, Apache::Util::validate_password("mguod", $hash));
$r->post_connection(sub { OK });
Apache::log_error("Apache::log_error test ok");
ok 1;
OK;
}
1;
__END__
PerlOptions +GlobalRequest
1.1 modperl-2.0/t/response/TestCompat/compat.pm
Index: compat.pm
===================================================================
package TestCompat::compat;
# these Apache::compat tests are all run on the server
# side and validated on the client side. See also TestCompat::compat2.
use strict;
use warnings FATAL => 'all';
use Apache::TestUtil;
use Apache::Test ();
use Apache::compat ();
use Apache::Constants qw(OK M_POST DECLINED);
use subs qw(ok debug);
my $gr;
sub handler {
my $r = shift;
$gr = $r;
$r->send_http_header('text/plain');
my $cfg = Apache::Test::config();
my $vars = $cfg->{vars};
my %data;
if ($r->method_number == M_POST) {
%data = $r->content;
}
else {
%data = $r->Apache::args;
}
return DECLINED unless exists $data{test};
if ($data{test} eq 'content' || $data{test} eq 'args') {
$r->print("test $data{test}");
}
OK;
}
sub ok { $gr->print($_[0] ? "ok\n" : "nok\n"); }
sub debug { $gr->print("# $_\n") for @_; }
1;
__END__
PerlOptions +GlobalRequest