You are viewing a plain text version of this content. The canonical link for it is here.
Posted to apreq-cvs@httpd.apache.org by jo...@apache.org on 2002/11/18 00:14:22 UTC
cvs commit: httpd-apreq/t api.pl book.gif cookie.t request-cookie.pl request-param.pl request-upload.pl request.t
joes 2002/11/17 15:14:22
Added: t api.pl book.gif cookie.t request-cookie.pl
request-param.pl request-upload.pl request.t
Log:
Adopted modperl test files.
Revision Changes Path
1.1 httpd-apreq/t/api.pl
Index: api.pl
===================================================================
#!perl
use Apache ();
use Apache::Constants qw(:server :common :methods);
use Apache::test;
use strict;
Apache->register_cleanup(sub {0});
my $r;
if(Apache->module("Apache::Request")) {
$r = Apache::Request->new(shift);
}
else {
$r = Apache->request;
}
my $is_xs = ($r->uri =~ /_xs/);
my $tests = 81;
my $is_win32 = WIN32;
$tests += 4 unless $is_win32;
my $test_get_set = Apache->can('set_handlers') && ($tests += 4);
my $test_custom_response = (MODULE_MAGIC_NUMBER >= 19980324) && ($tests += 4);
my $test_dir_config = $INC{'Apache/TestDirectives.pm'} && ($tests += 9);
my $i;
$r->content_type("text/plain");
$r->content_languages([qw(en)]);
$r->no_cache(1);
$r->send_http_header;
$r->print("1..$tests\n");
test ++$i, $ENV{MOD_PERL};
print "ENV{MOD_PERL} = $ENV{MOD_PERL}\n";
#backward compat
%ENV = $r->cgi_env;
my $envk = keys %ENV;
#print "cgi_env ($envk):\n";
#print map { "$_ = $ENV{$_}\n" } keys %ENV;
$r->subprocess_env; #test void context
$envk = keys %ENV;
#print "subprocess_env ($envk):\n";
#print map { "$_ = $ENV{$_}\n" } keys %ENV;
test ++$i, $r->as_string;
print $r->as_string;
print "r == $r\n";
test ++$i, $r->filename eq $0;
test ++$i, -d $Apache::Server::CWD;
print "\$Apache::Server::CWD == $Apache::Server::CWD\n";
print "\$0 == $0\n";
if($Apache::Server::Starting) {
warn "Apache::ServerStarting var is broken\n";
}
if($Apache::Server::ReStarting) {
warn "Apache::ReServerStarting var is broken\n";
}
unless ($is_win32) {
my $ft_s = -s $INC{'Apache.pm'};
$r->finfo;
my $ft_def = -s _;
print "Apache.pm == $ft_s, $0 == $ft_def\n";
test ++$i, $ft_s != $ft_def;
test ++$i, (-s $r->finfo) == $ft_def;
test ++$i, -T $r->finfo;
test ++$i, not -B $r->finfo;
}
my $the_request = $r->the_request;
my $request_string = $r->method . ' ' .
$r->uri . '?' .
$r->args . ' ' .
$r->protocol;
$r->the_request($request_string);
test ++$i, $the_request eq $r->the_request;
printf "old=$the_request, new=%s\n", $r->the_request;
$r->the_request(undef);
test ++$i, not $r->the_request;
test ++$i, not defined $r->the_request;
my $doc_root = $r->document_root;
$r->document_root('/tmp');
test ++$i, $r->document_root eq '/tmp';
$r->document_root($doc_root);
test ++$i, $r->document_root eq $doc_root;
my $loc = $r->location;
print "<Location $loc>\n";
test ++$i, $loc and $r->uri =~ m:^$loc:;
test ++$i, $r->get_remote_host;
test ++$i, $r->get_server_port;
test ++$i, SERVER_VERSION =~ /mod_perl/;
test ++$i, $r->last;
test ++$i, $ENV{GATEWAY_INTERFACE};
test ++$i, defined $ENV{KeyForPerlSetEnv};
test ++$i, scalar $r->cgi_var('GATEWAY_INTERFACE');
test ++$i, defined($r->seqno);
test ++$i, $r->protocol;
#hostname
test ++$i, $r->status;
test ++$i, $r->status_line;
test ++$i, $r->method eq "GET";
#test ++$i, $r->method_number
# args
test ++$i, $r->args eq 'arg1=one&arg2=two';
$r->args('foo=bar');
test ++$i, $r->args eq 'foo=bar';
$r->args(undef);
test ++$i, not $r->args;
test ++$i, not defined $r->args;
$r->subprocess_env(SetKey => 'value');
test ++$i, $r->subprocess_env('SetKey') eq 'value';
my(%headers_in) = $r->headers_in;
test ++$i, keys %headers_in;
test ++$i, $r->header_in('UserAgent') || $r->header_in('User-Agent');
$r->header_in('X-Hello' => "goodbye");
test ++$i, $r->header_in("X-Hello") eq "goodbye";
$r->header_out('X-Camel-Message' => "I can fly");
test ++$i, $r->header_out("X-Camel-Message") eq "I can fly";
my(%headers_out) = $r->headers_out;
test ++$i, keys %headers_out;
my(%err_headers_out) = $r->headers_out;
test ++$i, keys %err_headers_out;
#test ++$i, $r->err_header_out("Content-Type");
$r->err_header_out('X-Die' => "uhoh");
test ++$i, $r->err_header_out("X-Die") eq "uhoh";
for (1..3) {
test ++$i, not $r->pnotes("NO_CHANCE");
$r->pnotes(KEY => [qw(one two)]);
my $val = $r->pnotes('KEY');
test ++$i, $val && (ref($val) eq 'ARRAY');
$val = $r->pnotes;
test ++$i, $val && (ref($val) eq 'HASH');
while(my($kk,$vv) = each %$val) {
test ++$i, $kk && $vv;
}
# use Data::Dumper;
# print Dumper $val;
}
$r->notes("FOO", 1);
$r->notes("ANoteKey", "TRUE");
test ++$i, $r->notes("ANoteKey");
test ++$i, $r->content_type;
test ++$i, $r->handler;
$r->header_out(ByeBye => "TRUE");
test ++$i, $r->header_out("ByeBye");
$r->header_out(ByeBye => undef);
test ++$i, not $r->header_out("ByeBye");
#content_encoding
test ++$i, $r->content_languages;
#no_cache
test ++$i, $r->uri;
test ++$i, $r->filename;
#test ++$i, $r->path_info;
#test ++$i, $r->query_string;
#just make sure we can actually call these
test ++$i, $r->satisfies || 1;
test ++$i, $r->some_auth_required || 1;
$r->allowed(1 << M_GET);
test ++$i, $r->allowed & (1 << M_GET);
test ++$i, ! ($r->allowed & (1 << M_PUT));
$r->allowed($r->allowed | (1 << M_PUT));
test ++$i, $r->allowed & (1 << M_PUT);
#dir_config
my $c = $r->connection;
test ++$i, $c;
test ++$i, $c->remote_ip;
test ++$i, $c->remote_addr;
test ++$i, $c->local_addr;
#Connection::remote_host
#Connection::remote_logname
#Connection::user
#Connection::auth_type
test ++$i, $r->server_root_relative;
my $s = $r->server;
test ++$i, $s;
test ++$i, $s->server_admin;
test ++$i, $s->server_hostname;
test ++$i, $s->port;
my $port = $s->port;
for (32768, 65535) {
$s->port($_);
test ++$i, $s->port; # == $_;
}
$s->port($port);
test ++$i, $s->port == $port;
test ++$i, $s->timeout;
for (my $srv = $r->server; $srv; $srv = $srv->next) {
my $name = $srv->server_hostname;
}
++$i;
my $str = "ok $i\n";
$r->print(\$str);
test ++$i, $r->define("FOO") || 1; #just make sure we can call it
for (qw(TEST NOCHANCE)) {
if(Apache->define($_)) {
print "IfDefine $_\n";
}
}
test ++$i, $r->module("Apache");
test ++$i, not Apache->module("Not::A::Chance");
test ++$i, Apache->module("Apache::Constants");
test ++$i, not Apache->module("mod_nochance.c");
test ++$i, Apache->module("mod_perl.c");
#just make sure we can call this one
if($test_custom_response) {
test ++$i, $r->custom_response(403, "no chance") || 1;
test ++$i, $r->custom_response(403) =~ /chance/;
test ++$i, $r->custom_response(403, undef) || 1;
test ++$i, not defined $r->custom_response(403);
}
if($test_get_set) {
$r->set_handlers(PerlLogHandler => ['My::Logger']);
my $handlers = $r->get_handlers('PerlLogHandler');
test ++$i, @$handlers >= 1;
$r->set_handlers(PerlLogHandler => undef);
$handlers = $r->get_handlers('PerlLogHandler');
test ++$i, @$handlers == 0;
$handlers = $r->get_handlers('PerlHandler');
test ++$i, @$handlers == 1;
$r->set_handlers('PerlHandler', $handlers);
$r->set_handlers(PerlTransHandler => DONE); #make sure a per-server config thing works
$handlers = $r->get_handlers('PerlTransHandler');
test ++$i, @$handlers == 0;
}
if($test_dir_config) {
require Data::Dumper;
require Apache::ModuleConfig;
my $dc = Apache::ModuleConfig->get($r);
test ++$i, not $dc;
{
package Apache::TestDirectives;
use Apache::test 'test';
my $scfg = Apache::ModuleConfig->get($r->server);
test ++$i, $scfg;
test ++$i, __PACKAGE__->isa($scfg->{ServerClass});
print Data::Dumper::Dumper($scfg);
}
for my $cv (
sub {
package Apache::TestDirectives;
Apache::ModuleConfig->get(Apache->request);
},
sub {
Apache::ModuleConfig->get($r, "Apache::TestDirectives");
})
{
my $cfg = $cv->();
$r->print(Data::Dumper::Dumper($cfg));
test ++$i, "$cfg" =~ /HASH/;
test ++$i, keys(%$cfg) >= 3;
test ++$i, $cfg->{FromNew};
unless ($cfg->{SetFromScript}) {
$cfg->{SetFromScript} = [$0,$$];
}
}
}
@My::Req::ISA = qw(Apache);
my $hr = bless {
_r => $r,
}, "My::Req";
test ++$i, $hr->filename;
delete $hr->{_r};
my $uri;
eval {
$uri = $hr->uri;
};
test ++$i, not $uri;
print $@ if $@;
use Apache::test qw($USE_THREAD);
if ($USE_THREAD) {
#under Solaris at least, according to Brian P Millett <bp...@ec-group.com>
warn "XXX: need to fix \$r->exit in t/net/api w/ threads\n";
}
else {
$r->exit unless $is_xs;
}
1.1 httpd-apreq/t/book.gif
<<Binary file>>
1.1 httpd-apreq/t/cookie.t
Index: cookie.t
===================================================================
use strict;
use Apache::test qw(skip_test have_httpd test have_module);
use Apache::src ();
#use lib qw(lib blib/lib blib/arch);
eval 'require Apache::Cookie' or die $@;
#warn "No CGI::Cookie" and skip_test unless have_module "CGI::Cookie";
#warn "$@:No Apache::Cookie" and skip_test unless have_module "Apache::Cookie";
#unless (Apache::src->mmn_eq) {
# skip_test if not $Is_dougm;
#}
my $ua = LWP::UserAgent->new;
my $cookie = "one=bar-one&a; two=bar-two&b; three=bar-three&c";
my $url = "http://localhost:$ENV{PORT}/request-cookie.pl";
my $request = HTTP::Request->new('GET', $url);
$request->header(Cookie => $cookie);
my $response = $ua->request($request, undef, undef);
print $response->content;
1.1 httpd-apreq/t/request-cookie.pl
Index: request-cookie.pl
===================================================================
#!perl
use strict;
use CGI;
use Apache::test;
eval {
require Apache::Request;
require Apache::Cookie;
require CGI::Cookie;
};
my $r = Apache->request;
$r->send_http_header('text/plain');
unless (have_module "Apache::Cookie" and Apache::Request->can('upload')) {
print "1..0\n";
print $@ if $@;
print "$INC{'Apache/Request.pm'}\n";
return;
}
my $i = 0;
my $tests = 33;
$tests += 7 if $r->headers_in->get("Cookie");
print "1..$tests\n";
my $letter = 'a';
for my $name (qw(one two three)) {
my $c = Apache::Cookie->new($r,
-name => $name,
-value => ["bar_$name", $letter],
-expires => '+3M',
-path => '/'
);
my $cc = CGI::Cookie->new(
-name => $name,
-value => ["bar_$name", $letter],
-expires => '+3M',
-path => '/'
);
++$letter;
$c->bake;
my $cgi_as_string = $cc->as_string;
my $as_string = $c->as_string;
my $header_out = ($r->err_headers_out->get("Set-Cookie"))[-1];
my @val = $c->value;
print "VALUE: @val\n";
for my $v ("string", [@val]) {
$c->value($v);
my @arr = $c->value;
my $n = @arr;
if (ref $v) {
test ++$i, $n == 2;
}
else {
test ++$i, $n == 1;
}
print " VALUE: @arr ($n)\n";
$c->value(\@val); #reset
}
for (1,0) {
my $secure = $c->secure;
$c->secure($_);
print "secure: $secure\n";
}
print "as_string: `$as_string'\n";
print "header_out: `$header_out'\n";
print "cgi cookie: `$cgi_as_string\n";
test ++$i, cookie_eq($as_string, $header_out);
test ++$i, cookie_eq($as_string, $cgi_as_string);
}
my (@Hargs) = (
"-name" => "key",
"-values" => {qw(val two)},
"-domain" => ".cp.net",
);
my (@Aargs) = (
"-name" => "key",
"-values" => [qw(val two)],
"-domain" => ".cp.net",
);
my (@Sargs) = (
"-name" => "key",
"-values" => 'one',
"-domain" => ".cp.net",
);
my $done_meth = 0;
for my $rv (\@Hargs, \@Aargs, \@Sargs) {
my $c1 = Apache::Cookie->new($r, @$rv);
my $c2 = CGI::Cookie->new(@$rv);
for ($c1, $c2) {
$_->expires("+3h");
}
for my $meth (qw(as_string name domain path expires secure)) {
my $one = $c1->$meth() || "";
my $two = $c2->$meth() || "";
print "Apache::Cookie: $meth => $one\n";
print "CGI::Cookie: $meth => $two\n";
test ++$i, cookie_eq($one, $two);
}
}
if(my $string = $r->headers_in->get('Cookie')) {
print $string, $/;
my %done = ();
print "SCALAR context (as_string method):\n";
print " Apache::Cookie:\n";
my $hv = Apache::Cookie->new($r)->parse($string);
for (sort keys %$hv) {
print " $_ => ", $hv->{$_}->as_string, $/;
$done{$_} = $hv->{$_}->as_string;
}
print " CGI::Cookie:\n";
$hv = CGI::Cookie->parse($string);
for (sort keys %$hv) {
print " $_ => ", $hv->{$_}->as_string, $/;
test ++$i, cookie_eq($done{$_}, $hv->{$_}->as_string);
}
%done = ();
print "ARRAY context (value method):\n";
print " Apache::Cookie:\n";
my %hv = Apache::Cookie->new($r)->parse($string);
my %fetch = Apache::Cookie->fetch;
test ++$i, keys %hv == keys %fetch;
for (sort keys %hv) {
$done{$_} = join ", ", $hv{$_}->value;
print " $_ => $done{$_}\n";
}
print " CGI::Cookie:\n";
%hv = CGI::Cookie->parse($string);
for (sort keys %hv) {
my $val = join ", ", $hv{$_}->value;
test ++$i, cookie_eq($done{$_}, $val);
print " $_ => $val\n";
}
}
else {
print "NO Cookie set";
}
{
my $cgi_exp = CGI::expires('-1d', 'cookie');
my $cookie_exp = Apache::Cookie->expires('-1d');
print "cookie: $cookie_exp\ncgi: $cgi_exp\n";
test ++$i, cookie_eq($cookie_exp, $cgi_exp);
}
{
my $cgi_exp = CGI::expires('-1d', 'http');
my $apr_exp = Apache::Request->expires('-1d');
print "apr: $apr_exp\ncgi: $cgi_exp\n";
test ++$i, cookie_eq($apr_exp, $cgi_exp);
}
test ++$i, 1;
sub cookie_eq {
my($one, $two) = @_;
unless ($one eq $two) {
print STDERR "cookie mismatch:\n",
"`$one'\n", " vs.\n", "`$two'\n";
}
($one && $two) || (!$one && !$two);
}
1.1 httpd-apreq/t/request-param.pl
Index: request-param.pl
===================================================================
#!perl
use strict;
use Apache::test;
my $r = Apache->request;
$r->send_http_header('text/plain');
eval {
require Apache::Request;
};
unless (have_module "Apache::Request" and Apache::Request->can('upload')) {
print "1..0\n";
print $@ if $@;
print "$INC{'Apache/Request.pm'}\n";
return;
}
my $apr = Apache::Request->new($r);
for ($apr->param) {
my(@v) = $apr->param($_);
print "param $_ => ", join ",", @v;
print $/;
}
1.1 httpd-apreq/t/request-upload.pl
Index: request-upload.pl
===================================================================
#!perl
use strict;
use Apache::test;
my $r = Apache->request;
$r->send_http_header('text/plain');
eval {
require Apache::Request;
};
unless (have_module "Apache::Request" and Apache::Request->can('upload')) {
print "1..0\n";
print $@ if $@;
print "$INC{'Apache/Request.pm'}\n";
return;
}
my $apr = Apache::Request->new($r);
for ($apr->param) {
my(@v) = $apr->param($_);
print "param $_ => @v\n";
}
for (my $upload = $apr->upload; $upload; $upload = $upload->next) {
my $fh = $upload->fh;
my $filename = $upload->filename;
my $name = $upload->name;
my $type = $upload->type;
next unless $filename;
print "$name $filename ($type)";
if ($fh and $name) {
no strict;
if (my $no = fileno($filename)) {
print " fileno => $no";
}
}
print "\n";
close $fh;
}
my $first = $apr->upload->name;
my $first_filename = $apr->upload->filename;
my $first_fh = $apr->upload->fh;
if ($first_fh) {
while (<$first_fh>) { }
}
close $first_fh;
for my $upload ($apr->upload) {
my $fh = $upload->fh;
my $filename = $upload->filename;
my $name = $upload->name;
next unless $filename;
my($lines, $bytes);
$lines = $bytes = 0;
{
no strict;
if (fileno($filename)) {
$fh = *$filename{IO};
print "COMPAT: $fh\n";
}
}
use File::Basename;
local *OUT;
if (my $dir = $apr->header_in("X-Upload-Tmp")) {
if (-d $dir) {
Apache->untaint($dir);
my $file = basename $filename;
open OUT, ">$dir/$file" or die $!;
}
}
while(<$fh>) {
++$lines;
$bytes += length;
print OUT $_ if fileno OUT;
}
close OUT if fileno OUT;
close $fh;
my $info = $upload->info;
while (my($k,$v) = each %$info) {
print "INFO: $k => $v\n";
}
unless ($name eq $first) {
print "-" x 40, $/;
my $info = $apr->upload($first)->info;
print "Lookup `$first':[$info]\n";
while (my($k,$v) = each %$info) {
print "INFO: $k => $v\n";
}
my $type = $apr->upload($first)->info("content-type");
unless ($type) {
die "upload->info is broken";
}
print "TYPE: $type\n";
print "-" x 40, $/;
}
my $wanted = $upload->size;
unless ($bytes == $wanted) {
die "wanted $wanted bytes, got $bytes bytes";
}
print "Server: Lines: $lines\n";
print "$filename bytes=$bytes,wanted=$wanted\n";
}
1.1 httpd-apreq/t/request.t
Index: request.t
===================================================================
use strict;
use Apache::test;
use Apache::src ();
use Cwd qw(fastcwd);
require HTTP::Request::Common;
require CGI;
$HTTP::Request::Common::VERSION ||= '1.00'; #-w
unless ($CGI::VERSION >= 2.39 and
$HTTP::Request::Common::VERSION >= 1.08) {
print "CGI.pm: $CGI::VERSION\n";
print "HTTP::Request::Common: $HTTP::Request::Common::VERSION\n";
skip_test;
}
my $PWD = fastcwd;
my @binary = "$PWD/book.gif";
my $test_pods = 3;
my $tests = 2;
unless ($USE_SFIO) {
$tests += ($test_pods * 2) + (@binary * 2);
}
print "1..$tests\n";
my $i = 0;
my $ua = LWP::UserAgent->new;
use DirHandle ();
for my $cv (\&post_test, \&get_test) {
$cv->();
}
upload_test($_) for qw(perlfunc.pod perlpod.pod perlxs.pod), @binary;
sub post_test {
my $enc = 'application/x-www-form-urlencoded';
param_test(sub {
my($url, $data) = @_;
HTTP::Request::Common::POST($url,
Content_Type => $enc,
Content => $data,
);
});
}
sub get_test {
my $enc = 'application/x-www-form-urlencoded';
param_test(sub {
my($url, $data) = @_;
HTTP::Request::Common::GET("$url?$data");
});
}
sub param_test {
my $cv = shift;
my $url = "http://localhost:$ENV{PORT}/request-param.pl";
my $data =
"ONE=ONE_value&TWO=TWO_value&" .
"THREE=M1&THREE=M2&THREE=M3";
my $response = $ua->request($cv->($url, $data));
my $page = $response->content;
print $response->as_string unless $response->is_success;
my $expect = <<EOF;
param ONE => ONE_value
param TWO => TWO_value
param THREE => M1,M2,M3
EOF
my $ok = $page eq $expect;
test ++$i, $ok;
print $response->as_string unless $ok;
}
sub upload_test {
my $podfile = shift || "func";
my $url = "http://localhost:$ENV{PORT}/request-upload.pl";
my $file = "";
if (-e $podfile) {
$file = $podfile;
}
else {
for my $path (@INC) {
last if -e ($file = "$path/pod/$podfile");
}
}
$file = $0 unless -e $file;
my $lines = 0;
local *FH;
open FH, $file or die "open $file $!";
binmode FH; #for win32
++$lines while defined <FH>;
close FH;
my(@headers);
my $response = $ua->request(HTTP::Request::Common::POST($url,
@headers,
Content_Type => 'multipart/form-data',
Content => [count => 'count lines',
filename => [$file],
]));
my $page = $response->content;
print $response->as_string unless $response->is_success;
test ++$i, ($page =~ m/Lines:\s+(\d+)/m);
print "$file should have $lines lines (request-upload.pl says: $1)\n"
unless $1 == $lines;
test ++$i, $1 == $lines;
}