cvs commit: modperl-2.0/Apache-Test/lib/Apache - New directory
dougm 01/04/02 01:49:36 modperl-2.0/Apache-Test/lib/Apache - New directory
cvs commit: modperl-2.0/Apache-Test/t - New directory
dougm 01/04/02 01:51:22 modperl-2.0/Apache-Test/t - New directory
cvs commit: modperl-2.0/Apache-Test/lib/Apache Test.pm
dougm 01/04/02 01:53:06
Added: Apache-Test/lib/Apache Test.pm
Log:
Test.pm wrapper to run under mod_perl
Revision ChangesPath
1.1 modperl-2.0/Apache-Test/lib/Apache/Test.pm
Index: Test.pm
===
package Apache::Test;
use strict;
use warnings FATAL = 'all';
use Test qw(ok);
use Exporter ();
our @ISA = qw(Exporter);
our @EXPORT = qw(ok plan);
our $VERSION = '0.01';
#so Perl's Test.pm can be run inside mod_perl
sub init_test_pm {
my $r = shift;
if (defined Apache::RequestRec::puts) {
package Apache::RequestRec;
unless (defined PRINT) {
*PRINT = \puts;
}
tie *STDOUT, __PACKAGE__, $r;
}
else {
$r-send_http_header; #1.xx
}
$r-content_type('text/plain');
$Test::TESTOUT = \*STDOUT;
$Test::planned = 0;
$Test::ntest = 1;
}
sub plan {
init_test_pm(shift) if ref $_[0];
my $condition = pop @_ if ref $_[-1];
if ($condition and ! $condition-()) {
print "0..1\n";
exit; #XXX: Apache-exit
}
Test::plan(@_);
}
1;
cvs commit: modperl-2.0/Apache-Test/lib/Apache TestRequest.pm
dougm 01/04/02 01:55:43
Added: Apache-Test/lib/Apache TestRequest.pm
Log:
lwp wrappers / fallback for no lwp
Revision ChangesPath
1.1 modperl-2.0/Apache-Test/lib/Apache/TestRequest.pm
Index: TestRequest.pm
===
package Apache::TestRequest;
use strict;
use warnings FATAL = 'all';
use Apache::TestConfig ();
my $have_lwp = eval {
require LWP::UserAgent;
require HTTP::Request::Common;
};
sub has_lwp { $have_lwp }
require Exporter;
*import = \Exporter::import;
our @EXPORT = @HTTP::Request::Common::EXPORT;
our @ISA = qw(LWP::UserAgent);
my $UA;
my $Config;
sub resolve_url {
my $url = shift;
return $url if $url =~ m,^(\w+):/,;
$url = "/$url" unless $url =~ m,^/,;
return "http://$Config-{hostport}$url";
}
my %wanted_args = map {$_, 1} qw(username password realm content);
sub wanted_args {
\%wanted_args;
}
sub filter_args {
my $args = shift;
my(@pass, %keep);
my @filter = @$args;
if (ref($filter[0])) {
push @pass, shift @filter;
}
while (my($key, $val) = splice @filter, 0, 2) {
if ($wanted_args{$key}) {
$keep{$key} = $val;
}
else {
push @pass, $key, $val;
}
}
return (\@pass, \%keep);
}
my %credentials;
sub get_basic_credentials {
my($self, $realm, $uri, $proxy) = @_;
for ($realm, '__ALL__') {
next unless $credentials{$_};
return @{ $credentials{$_} };
}
return (undef,undef);
}
sub test_config {
$Config ||= Apache::TestConfig-thaw;
}
sub vhost_socket {
my $module = shift;
my $hostport = test_config()-{vhosts}-{$module}-{hostport};
require IO::Socket;
IO::Socket::INET-new($hostport);
}
sub prepare {
eval { $UA ||= __PACKAGE__-new; };
$Config ||= test_config();
my $url = resolve_url(shift);
my($pass, $keep) = filter_args(\@_);
%credentials = ();
if ($keep-{username}) {
$credentials{$keep-{realm} || '__ALL__'} =
[$keep-{username}, $keep-{password}];
}
if (my $content = $keep-{content}) {
if ($content eq '-') {
$content = join '', STDIN;
}
push @$pass, content = $content;
}
return ($url, $pass, $keep);
}
my %shortcuts = (RC = sub { shift-code },
OK = sub { shift-is_success },
STR = sub { shift-as_string },
BODY = sub { shift-content });
for my $name (@EXPORT) {
my $method = \{"HTTP::Request::Common::$name"};
no strict 'refs';
*$name = sub {
my($url, $pass, $keep) = prepare(@_);
return $UA-request($method-($url, @$pass));
};
while (my($shortcut, $cv) = each %shortcuts) {
my $alias = join '_', $name, $shortcut;
*$alias = sub { (\{$name})-(@_)-$cv; };
}
}
my @export_std = @EXPORT;
for my $method (@export_std) {
push @EXPORT, map { join '_', $method, $_ } keys %shortcuts;
}
#this is intended to be a fallback if LWP is not installed
#so at least some tests can be run, it is not meant to be robust
for my $name (qw(GET HEAD)) {
next if defined $name;
no strict 'refs';
*$name = sub {
return test_config()-http_raw_get(shift, $name);
};
}
sub http_raw_get {
my($hostport, $url, $want_headers) = @_;
$url ||= "/";
require IO::Socket;
my $s = IO::Socket::INET-new($hostport);
unless ($s) {
warn "cannot connect to $hostport $!";
return undef;
}
print $s "GET $url HTTP/1.0\n\n";
my($response_line, $header_term, $headers);
$headers = "";
while ($s) {
$headers .= $_;
if(m:^(HTTP/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*):i) {
$response_line = 1;
}
elsif(/^([a-zA-Z0-9_\-]+)\s*:\s*(.*)/) {
}
elsif(/^\015?\012$/) {
$header_term = 1;
last;
}
}
unless ($response_line and $header_term) {
warn "malformed response";
}
my @body = $s;
close $s;
if ($want_headers) {
if ($want_headers 1) {
@body = (); #HEAD
}
unshift @body, $headers;
}
return wantarray ? @body : join '', @body;
}
sub to_string {
my $obj = shift;
ref($obj) ? $obj-as_string : $obj;
}
1;
cvs commit: modperl-2.0/Apache-Test/lib/Apache TestConfigPerl.pm
dougm 01/04/02 01:57:34
Added: Apache-Test/lib/Apache TestConfigPerl.pm
Log:
test config stuff specific to modperl
Revision ChangesPath
1.1 modperl-2.0/Apache-Test/lib/Apache/TestConfigPerl.pm
Index: TestConfigPerl.pm
===
package Apache::TestConfig; #not TestConfigPerl on purpose
#things specific to mod_perl
use strict;
use warnings FATAL = 'all';
use File::Spec::Functions qw(catfile splitdir abs2rel);
use File::Find qw(finddepth);
my %libmodperl = (1 = 'libperl.so', 2 = 'libmodperl.so');
sub configure_libmodperl {
my $self = shift;
my $server = $self-{server};
my $libname = $server-version_of(\%libmodperl);
if ($server-{rev} = 2) {
if (my $build_config = $self-build_config()) {
$libname = $build_config-{MODPERL_LIB_SHARED}
}
}
my $vars = $self-{vars};
$vars-{libmodperl} ||= $self-find_apache_module($libname);
my $cfg;
if (-e $vars-{libmodperl}) {
$cfg = {LoadModule = qq(perl_module "$vars-{libmodperl}")};
}
else {
my $msg = "unable to locate $libname\n";
$cfg = "#$msg";
$self-trace($msg);
}
$self-preamble(IfModule = '!mod_perl.c', $cfg);
}
sub configure_inc {
my $self = shift;
my $top = $self-{vars}-{top_dir};
my $inc = $self-{inc};
my @trys = (catfile($top, 'lib'),
catfile($top, qw(blib lib)),
catfile($top, qw(blib arch)));
for (@trys) {
push @$inc, $_ if -d $_;
}
}
sub write_pm_test {
my($self, $pm, $base, $sub) = @_;
my $dir = catfile $self-{vars}-{t_dir}, $base;
my $t = catfile $dir, "$sub.t";
return if -e $t;
$self-gendir($dir);
my $fh = $self-genfile($t);
print $fh EOF;
use Apache::TestConfig ();
print Apache::TestConfig-thaw-http_raw_get("/$pm");
EOF
close $fh or die "close $t: $!";
}
my %startup_pl = (1 = 'PerlRequire', 2 = 'PerlSwitches');
sub startup_pl_code {
return 'EOF';
BEGIN {
for my $file (qw(modperl_inc.pl modperl_extra.pl)) {
eval { require "conf/$file" };
}
}
1;
EOF
}
sub configure_startup_pl {
my $self = shift;
#for 2.0 we could just use PerlSwitches -Mlib=...
#but this will work for both 2.0 and 1.xx
if (my $inc = $self-{inc}) {
my $include_pl = catfile $self-{vars}-{t_conf}, 'modperl_inc.pl';
my $fh = $self-genfile($include_pl);
for (@$inc) {
print $fh "use lib '$_';\n";
}
print $fh "1;\n";
}
if ($self-server-{rev} = 2) {
$self-postamble(PerlSwitches = "-Mlib=$self-{vars}-{serverroot}");
}
my $startup_pl = catfile $self-{vars}-{t_conf}, 'modperl_startup.pl';
unless (-e $startup_pl) {
my $fh = $self-genfile($startup_pl);
print $fh $self-startup_pl_code;
close $fh;
}
my $directive = $self-server-version_of(\%startup_pl);
$self-postamble($directive = $startup_pl);
}
my %sethandler_modperl = (1 = 'perl-script', 2 = 'modperl');
my %add_hook_config = (
Response = sub { my($self, $module, $args) = @_;
push @$args,
SetHandler =
$self-server-version_of(\%sethandler_modperl) },
ProcessConnection = sub { my($self, $module, $args) = @_;
my $port = $self-new_vhost($module);
$self-postamble(Listen = $port); },
);
my %container_config = (
ProcessConnection = \vhost_container,
);
sub location_container {
my($self, $module) = @_;
Location = "/$module";
}
sub vhost_container {
my($self, $module) = @_;
my $port = $self-{vhosts}-{$module}-{port};
VirtualHost = "_default_:$port";
}
sub new_vhost {
my($self, $module) = @_;
my $port = $self-server-select_port;
my $servername = $self-{vars}-{servername};
my $vhost = $self-{vhosts}-{$module} = {};
$vhost-{port} = $port;
$vhost-{servername} = $servername;
$vhost-{name} = join ':', $servername, $port;
$vhost-{hostport} = $self-hostport($vhost);
$port;
}
#test .pm's can have configuration after the __DATA__ token
sub add_module_config {
my($self, $module, $args) = @_;
open(my $fh, $module) or return;
while ($fh) {
last if /^__DATA__/;
}
while ($fh) {
next unless /\S+/;
push @$args, split /\s+/, $_, 2;
}
}
#the idea for each group:
# Response: there will be many of these, mostly modules to test the API
# that plan tests
cvs commit: modperl-2.0/Apache-Test/lib/Apache TestConfig.pm
dougm 01/04/02 01:58:08
Added: Apache-Test/lib/Apache TestConfig.pm
Log:
base test config generator
Revision ChangesPath
1.1 modperl-2.0/Apache-Test/lib/Apache/TestConfig.pm
Index: TestConfig.pm
===
package Apache::TestConfig;
use strict;
use warnings FATAL = 'all';
use constant WIN32 = $^O eq 'MSWin32';
use File::Spec::Functions qw(catfile abs2rel splitdir);
use Cwd qw(fastcwd);
use Apache::TestConfigPerl ();
use Apache::TestConfigParse ();
use Apache::TestServer ();
my %usage = (
top_dir = 'top-level directory (default is $PWD)',
t_dir = 'the t/ test directory (default is $top_dir/t)',
t_conf= 'the conf/ test directory (default is $t_dir/conf)',
t_logs= 'the logs/ test directory (default is $t_dir/logs)',
t_conf_file = 'test httpd.conf file (default is $t_conf/httpd.conf)',
src_dir = 'source directory to look for mod_foos.so',
serverroot= 'ServerRoot (default is $t_dir)',
documentroot = 'DocumentRoot (default is $ServerRoot/htdocs',
port = 'Port (default is 8529)',
servername= 'ServerName (default is localhost)',
user = 'User to run test server as (default is $USER)',
group = 'Group to run test server as (default is $GROUP)',
bindir= 'Apache bin/ dir (default is apxs -q SBINDIR)',
httpd = 'server to use for testing (default is $bindir/httpd)',
target= 'name of server binary (default is apxs -q TARGET)',
apxs = 'location of apxs (default is from Apache::BuildConfig)',
httpd_conf= 'inherit config from this file (default is apxs derived)',
);
sub usage {
for my $hash (\%usage) {
while (my($key, $val) = each %$hash) {
printf " %-16s %s\n", $key, $val;
}
}
}
my %passenv = map { $_,1 } qw{
APXS APACHE APACHE_GROUP APACHE_USER APACHE_PORT
};
sub passenv {
\%passenv;
}
sub server { shift-{server} }
sub build_config {
eval {
require Apache::BuildConfig;
} or return undef;
return Apache::Build-build_config;
}
sub new_test_server {
my($self, $args) = @_;
Apache::TestServer-new($args || $self)
}
sub new {
my($class, $args) = @_;
$args = ($args and ref($args)) ? {%$args} : {@_}; #copy
my $thaw = {};
#thaw current config
for (qw(conf t/conf)) {
last if eval {
require "$_/apache_test_config.pm";
$thaw = 'apache_test_config'-new;
delete $thaw-{save};
};
};
if ($args-{thaw}) {
#dont generate any new config
$thaw-{$_} = $args-{$_} for keys %$args;
$thaw-{server} = $thaw-new_test_server;
return $thaw;
}
#regenerating config, so forget old
if ($args-{save}) {
for (qw(vhosts inherit_config modules inc)) {
delete $thaw-{$_} if exists $thaw-{$_};
}
}
my $self = bless {
clean = {},
vhosts = {},
inherit_config = {},
modules = {},
inc = [],
%$thaw,
vars = $args,
postamble = [],
preamble = [],
postamble_hooks = [],
preamble_hooks = [],
}, $class;
my $vars = $self-{vars}; #things that can be overridden
for (qw(save verbose)) {
next unless exists $args-{$_};
$self-{$_} = delete $args-{$_};
}
$vars-{top_dir} ||= fastcwd;
$vars-{top_dir} = pop_dir($vars-{top_dir}, 't');
$self-add_inc;
#help to find libmodperl.so
my $src_dir = catfile $vars-{top_dir}, qw(src modules perl);
$vars-{src_dir} ||= $src_dir if -d $src_dir;
$vars-{t_dir}||= catfile $vars-{top_dir}, 't';
$vars-{serverroot} ||= $vars-{t_dir};
$vars-{documentroot} ||= catfile $vars-{serverroot}, 'htdocs';
$vars-{t_conf} ||= catfile $vars-{serverroot}, 'conf';
$vars-{t_logs} ||= catfile $vars-{serverroot}, 'logs';
$vars-{t_conf_file} ||= catfile $vars-{t_conf}, 'httpd.conf';
$vars-{port} ||= $self-default_port;
$vars-{servername} ||= $self-default_servername;
$vars-{user} ||= $self-default_user;
$vars-{group}||= $self-default_group;
$vars-{serveradmin} ||= join '@', $vars-{user}, $vars-{servername};
$self-configure_apxs;
$self-configure_httpd;
$self-inherit_config; #see TestConfigParse.pm
$self-{hostport} = $self-hostport;
$self-{server} = $self-new_test_server;
$self;
}
sub configure_apxs {
my $self = shift;
return unless $self-{MP_APXS} = $self-default_apxs;
my $vars
cvs commit: modperl-2.0/Apache-Test/lib/Apache TestServer.pm
dougm 01/04/02 01:58:38
Added: Apache-Test/lib/Apache TestServer.pm
Log:
methods to configure/control test server
Revision ChangesPath
1.1 modperl-2.0/Apache-Test/lib/Apache/TestServer.pm
Index: TestServer.pm
===
package Apache::TestServer;
use strict;
use warnings FATAL = 'all';
use Socket ();
use File::Spec::Functions qw(catfile);
use Apache::TestConfig ();
sub trace {
shift-{config}-trace(@_);
}
sub new {
my $class = shift;
my $config = shift;
my $self = bless {
config = $config || Apache::TestConfig-thaw,
}, $class;
$self-{name} = join ':',
map { $self-{config}-{vars}-{$_} } qw(servername port);
$self-{port_counter} = $self-{config}-{vars}-{port};
$self-{version} = $self-{config}-httpd_version || '';
($self-{rev}) = $self-{version} =~ m:^Apache/(\d)\.:;
$self-{rev} ||= 2;
$self;
}
sub version_of {
my($self, $thing) = @_;
$thing-{$self-{rev}};
}
sub clean {
my $self = shift;
my $dir = $self-{config}-{vars}-{t_logs};
for (qw(error_log access_log httpd.pid)) {
my $file = catfile $dir, $_;
if (unlink $file) {
$self-trace("unlink $file");
}
}
}
sub pid_file {
my $self = shift;
catfile $self-{config}-{vars}-{t_logs}, 'httpd.pid';
}
sub args {
my $self = shift;
"-f $self-{config}-{vars}-{t_conf_file}";
}
my %one_process = (1 = '-X', 2 = '-DONE_PROCESS');
sub start_cmd {
my $self = shift;
#XXX: threaded mpm does not respond to SIGTERM with -DONE_PROCESS
my $one = $self-{rev} == 1 ? '-X' : '';
my $args = $self-args;
return "$self-{config}-{vars}-{httpd} $one $args";
}
sub start_gdb {
my $self = shift;
my $config = $self-{config};
my $args = $self-args;
my $one_process = $self-version_of(\%one_process);
my $file = catfile $config-{vars}-{serverroot}, '.gdb-test-start';
my $fh = $config-genfile($file);
print $fh "run $one_process $args";
close $fh;
system "gdb $config-{vars}-{httpd} -command $file";
unlink $file;
}
sub start_debugger {
shift-start_gdb; #XXX support dbx and others
}
sub pid {
my $self = shift;
my $file = $self-pid_file;
open my $fh, $file or do {
return 0;
};
chomp(my $pid = $fh);
$pid;
}
sub select_port {
my $self = shift;
my $max_tries = 100; #XXX
while (! $self-port_available(++$self-{port_counter})) {
return 0 if --$max_tries = 0;
}
return $self-{port_counter};
}
sub port_available {
my $self = shift;
my $port = shift || $self-{config}-{vars}-{port};
local *S;
my $proto = getprotobyname('tcp');
socket(S, Socket::PF_INET(),
Socket::SOCK_STREAM(), $proto) || die "socket: $!";
setsockopt(S, Socket::SOL_SOCKET(),
Socket::SO_REUSEADDR(),
pack("l", 1)) || die "setsockopt: $!";
if (bind(S, Socket::sockaddr_in($port, Socket::INADDR_ANY( {
close S;
return 1;
}
else {
return 0;
}
}
sub stop {
my $self = shift;
my $aborted = shift;
my $pid = 0;
my $tries = 3;
my $tried_kill = 0;
my $port = $self-{config}-{vars}-{port};
while ($self-ping) {
#my $state = $tried_kill ? "still" : "already";
#print "Port $port $state in use\n";
if ($pid = $self-pid and !$tried_kill++) {
if (kill TERM = $pid) {
print "server $self-{name} shutdown (pid=$pid)\n";
sleep 1;
for (1..4) {
if (! $self-ping) {
return $pid if $_ == 1;
last;
}
if ($_ == 1) {
print "port $port still in use...";
}
else {
print "...";
}
sleep $_;
}
if ($self-ping) {
print "\nserver was shutdown but port $port ",
"is still in use, please shutdown the service ",
"using this port or select another port ",
"for the tests\n";
}
else {
print "done\n";
}
}
else {
print "kill $pid failed: $!\n";
}
}
else {
print "port $port is in use, ",
"cannot
cvs commit: modperl-2.0/Apache-Test/lib/Apache TestRun.pm
dougm 01/04/02 01:59:56
Added: Apache-Test/lib/Apache TestRun.pm
Log:
methods to drive the tests
Revision ChangesPath
1.1 modperl-2.0/Apache-Test/lib/Apache/TestRun.pm
Index: TestRun.pm
===
package Apache::TestRun;
use strict;
use warnings FATAL = 'all';
use Apache::TestConfig ();
use Apache::TestRequest ();
use Apache::TestHarness ();
use File::Spec::Functions qw(catfile);
use Getopt::Long qw(GetOptions);
my @std_run = qw(start-httpd run-tests stop-httpd);
my @others = qw(verbose configure clean help ping);
my @flag_opts= (@std_run, @others);
my @list_opts= qw(preamble postamble);
my @hash_opts= qw(header);
my @exit_opts= qw(clean help ping debug);
my @request_opts = qw(get head post);
my %usage = (
'start-httpd' = 'start the test server',
'run-tests' = 'run the tests',
'stop-httpd' = 'stop the test server',
'verbose' = 'verbose output',
'configure' = 'force regeneration of httpd.conf',
'clean' = 'remove all generated test files',
'help'= 'display this message',
'preamble'= 'config to add at the beginning of httpd.conf',
'postamble' = 'config to add at the end of httpd.conf',
'ping'= 'test if server is running or port in use',
'debug' = 'start server under debugger (e.g. gdb)',
'header' = "add headers to (".join('|', @request_opts).") request",
(map { $_, "\U$_\E url" } @request_opts),
);
sub new {
my $class = shift;
bless {
tests = [],
@_,
}, $class;
}
#split arguments into test files/dirs and options
#take extra care if -e, the file matches /\.t$/
#if -d, the dir contains .t files
#so we dont slurp arguments that are not tests, example:
# httpd $HOME/apache-2.0/bin/httpd
sub split_args {
my($self, $argv) = @_;
my(@tests, @args);
for (@$argv) {
my $arg = $_;
#need the t/ for stat-ing, but dont want to include it in test output
$arg =~ s:^t/::;
my $t_dir = catfile qw(.. t);
my $file = catfile $t_dir, $arg;
if (-d $file and $_ ne '/') {
my @files = $file/*.t;
if (@files) {
my $remove = catfile $t_dir, "";
push @tests, map { s,^\Q$remove,,; $_ } @files;
next;
}
}
else {
if ($file =~ /\.t$/ and -e $file) {
push @tests, "$arg";
next;
}
elsif (-e "$file.t") {
push @tests, "$arg.t";
next;
}
}
push @args, $_;
}
#default HEAD|GET to /
for (my $i = 0; $i @args; $i++) {
if ($args[$i] =~ /^-(get|head)/) {
unless ($args[$i+1] and $args[$i+1] =~ m:^/:) {
splice @args, $i+1, 0, '/';
}
last;
}
}
$self-{tests} = \@tests;
$self-{args} = \@args;
}
sub passenv {
my $passenv = Apache::TestConfig-passenv;
for (keys %$passenv) {
return 1 if $ENV{$_};
}
0;
}
sub getopts {
my($self, $argv) = @_;
$self-split_args($argv);
#dont count test files/dirs as @ARGV arguments
local *ARGV = $self-{args};
my(%opts, %vopts, %conf_opts);
GetOptions(\%opts, @flag_opts, @exit_opts,
(map "$_=s", @request_opts),
(map { ("$_=s", $vopts{$_} ||= []) } @list_opts),
(map { ("$_=s", $vopts{$_} ||= {}) } @hash_opts));
$opts{$_} = $vopts{$_} for keys %vopts;
#force regeneration of httpd.conf if commandline args want to modify it
$opts{configure} ||=
(grep { $opts{$_}-[0] } qw(preamble postamble)) ||
@ARGV || $self-passenv() || (! -e 'conf/httpd.conf');
while (my($key, $val) = splice @ARGV, 0, 2) {
$conf_opts{lc $key} = $val;
}
if ($opts{configure}) {
$conf_opts{save} = 1;
}
else {
$conf_opts{thaw} = 1;
}
#propagate some values
for (qw(verbose)) {
$conf_opts{$_} = $opts{$_};
}
$self-{opts} = \%opts;
$self-{conf_opts} = \%conf_opts;
}
sub default_run_opts {
my $self = shift;
my($opts, $tests) = ($self-{opts}, $self-{tests});
unless (grep { $opts-{$_} } @std_run, @request_opts) {
if (@$tests $self-{server}-ping) {
#if certain tests are specified and server is running, dont restart
$opts-{'run-tests'} = 1;
}
else {
#default is server-server run-tests stop-server
$opts-{$_} = 1 for @std_run;
cvs commit: modperl-2.0/Apache-Test/lib/Apache TestHandler.pm
dougm 01/04/02 02:00:29
Added: Apache-Test/lib/Apache TestHandler.pm
Log:
Perl*Handler utilities
Revision ChangesPath
1.1 modperl-2.0/Apache-Test/lib/Apache/TestHandler.pm
Index: TestHandler.pm
===
package Apache::TestHandler;
use Apache::Test ();
#some utility handlers for testing hooks other than response
#see modperl-2.0/t/hooks/TestHooks/authen.pm
#compat with 1.xx
my $send_http_header = Apache-can('send_http_header') || sub {};
my $print = Apache-can('print') || Apache::RequestRec-can('puts');
sub ok {
my $r = shift;
$r-$send_http_header;
$r-content_type('text/plain');
$r-$print("ok");
0;
}
sub ok1 {
my $r = shift;
Apache::Test::plan($r, tests = 1);
Apache::Test::ok(1);
0;
}
1;
cvs commit: modperl-2.0/Apache-Test/t TEST ping.t request.t
dougm 01/04/02 02:01:25
Added: Apache-Test/t TEST ping.t request.t
Log:
test test files
Revision ChangesPath
1.1 modperl-2.0/Apache-Test/t/TEST
Index: TEST
===
#!perl
use strict;
use warnings FATAL = 'all';
use lib qw(lib ../lib);
use Apache::TestRun ();
package MyTest;
our @ISA = qw(Apache::TestRun);
sub configure_modperl {} #dont configure mod_perl for these tests
MyTest-new-run(@ARGV);
1.1 modperl-2.0/Apache-Test/t/ping.t
Index: ping.t
===
use strict;
use warnings FATAL = 'all';
use Apache::Test;
plan tests = 3;
use Apache::TestConfig ();
my $test_config = Apache::TestConfig-thaw;
ok $test_config;
my $server = $test_config-server;
ok $server;
ok $server-ping;
1.1 modperl-2.0/Apache-Test/t/request.t
Index: request.t
===
use strict;
use warnings FATAL = 'all';
use Apache::Test;
use Apache::TestRequest;
plan tests = 9, \Apache::TestRequest::has_lwp;
my $url = '/';
ok GET_OK $url;
ok GET_RC $url;
ok GET_STR $url;
ok GET_BODY $url;
ok HEAD_OK $url;
ok HEAD_RC $url;
ok HEAD_STR $url;
ok GET_OK $url, username = 'dougm', password = ''; #e.g. for auth
ok GET_OK $url, Referer = $0; #add headers
#post a string
#ok POST_OK $url, content = 'post body data';
#or key/value pairs (see HTTP::Request::Common
#ok POST_OK $url, [university = 'arizona', team = 'wildcats']
cvs commit: modperl-2.0/t - New directory
dougm 01/04/02 02:03:17 modperl-2.0/t - New directory
cvs commit: modperl-2.0/t/conf - New directory
dougm 01/04/02 02:03:25 modperl-2.0/t/conf - New directory
cvs commit: modperl-2.0/t/response/TestAPR - New directory
dougm 01/04/02 02:03:57 modperl-2.0/t/response/TestAPR - New directory
cvs commit: modperl-2.0/t/response/TestApache - New directory
dougm 01/04/02 02:03:59 modperl-2.0/t/response/TestApache - New directory
cvs commit: modperl-2.0/t/response/TestApache post.pm
dougm 01/04/02 02:06:07
Added: t/response/TestApache post.pm
Log:
start of extended apache test
Revision ChangesPath
1.1 modperl-2.0/t/response/TestApache/post.pm
Index: post.pm
===
package TestApache::post;
use strict;
use warnings FATAL = 'all';
use APR::Table ();
sub read_post {
my $r = shift;
$r-setup_client_block;
return undef unless $r-should_client_block;
my $len = $r-headers_in-get('content-length');
my $buf;
$r-get_client_block($buf, $len);
return $buf;
}
sub handler {
my $r = shift;
$r-content_type('text/plain');
my $data = read_post($r) || "";
$r-puts(join ':', length($data), $data);
0;
}
1;
cvs commit: modperl-2.0/t/hooks/TestHooks - New directory
dougm 01/04/02 02:09:04 modperl-2.0/t/hooks/TestHooks - New directory
cvs commit: modperl-2.0/t/hooks/TestHooks authen.pm
dougm 01/04/02 02:09:40
Added: t/hooks authen.t
t/hooks/TestHooks authen.pm
Log:
start of hooks tests
Revision ChangesPath
1.1 modperl-2.0/t/hooks/authen.t
Index: authen.t
===
use strict;
use warnings FATAL = 'all';
use Test;
use Apache::TestRequest;
plan tests = 3;
my $location = "/TestHooks::authen";
ok ! GET_OK $location;
my $rc = GET_RC $location;
ok $rc == 401;
ok GET_OK $location, username = 'dougm', password = 'foo';
1.1 modperl-2.0/t/hooks/TestHooks/authen.pm
Index: authen.pm
===
package TestHooks::authen;
use strict;
use warnings FATAL = 'all';
use Apache::Access ();
sub handler {
my $r = shift;
#auth api not complete yet
0;
}
1;
__DATA__
require valid-user
AuthType Basic
AuthName simple
PerlResponseHandler Apache::TestHandler::ok1
SetHandler modperl
cvs commit: modperl-2.0/t TEST.PL
dougm 01/04/02 02:11:18
Added: tTEST.PL
Log:
the TEST template
Revision ChangesPath
1.1 modperl-2.0/t/TEST.PL
Index: TEST.PL
===
#!perl
use strict;
use warnings FATAL = 'all';
use lib map { "$_/Apache-Test/lib" } qw(. ..);
use Apache::TestRun ();
Apache::TestRun-new-run(@ARGV);
cvs commit: modperl-2.0 Makefile.PL
dougm 01/04/02 02:17:41
Modified:.Makefile.PL
Log:
hook into test stuff
Revision ChangesPath
1.30 +23 -1 modperl-2.0/Makefile.PL
Index: Makefile.PL
===
RCS file: /home/cvs/modperl-2.0/Makefile.PL,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- Makefile.PL 2001/03/27 02:32:49 1.29
+++ Makefile.PL 2001/04/02 09:17:40 1.30
@@ -3,15 +3,20 @@
use warnings FATAL = 'all';
use lib qw(lib);
+use Config;
use Apache::Build ();
use ModPerl::Code ();
use ModPerl::MM ();
+use lib qw(Apache-Test/lib);
+use Apache::TestMM qw(test);
+
our $VERSION;
my $build = Apache::Build-new(init = 1);
my $code = ModPerl::Code-new;
+my @scripts = qw(t/TEST);
configure();
ModPerl::MM::WriteMakefile(
@@ -58,6 +63,10 @@
#ModPerl::MM will use Apache::BuildConfig in subdir/Makefile.PL's
$build-save;
+for (@scripts) {
+generate_script($_);
+}
+
generate_xs($httpd_version) if $build-{MP_GENERATE_XS};
}
@@ -103,6 +112,19 @@
shift @INC;
}
+sub generate_script {
+my $file = shift;
+open my $in, "$file.PL" or die "Couldn't open $file.PL: $!";
+open my $out, '', $file or die "Couldn't open $file: $!";
+print "generating script...$file\n";
+print $out "#!$Config{perlpath}\n",
+ "# WARNING: this file is generated, edit $file.PL instead\n",
+ join '', $in;
+close $out or die "close $file: $!";
+close $in;
+chmod 0544, $file;
+}
+
sub echo_cmd {
my $cmd = shift;
print "$cmd\n";
@@ -112,7 +134,7 @@
sub clean_files {
my $path = $code-path;
-return [@{ $build-clean_files },
+return [@{ $build-clean_files }, @scripts,
map { "$path/$_"} @{ $code-clean_files }];
}
cvs commit: modperl-2.0/t/filter/TestFilter - New directory
dougm 01/04/02 11:16:33 modperl-2.0/t/filter/TestFilter - New directory
cvs commit: modperl-2.0/t/filter reverse.t
dougm 01/04/02 11:36:31
Modified:Apache-Test/lib/Apache TestConfig.pm TestConfigPerl.pm
TestServer.pm
Added: t/filter reverse.t
Log:
put a warning inside files that are generated
Revision ChangesPath
1.2 +17 -5 modperl-2.0/Apache-Test/lib/Apache/TestConfig.pm
Index: TestConfig.pm
===
RCS file: /home/cvs/modperl-2.0/Apache-Test/lib/Apache/TestConfig.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- TestConfig.pm 2001/04/02 08:58:08 1.1
+++ TestConfig.pm 2001/04/02 18:36:23 1.2
@@ -364,13 +364,25 @@
}
#generate files and directories
+
+sub genwarning {
+my($self, $type) = @_;
+return unless $type;
+return "#WARNING: this file is generated, do not edit\n";
+}
+
sub genfile {
-my($self, $file) = @_;
+my($self, $file, $warn) = @_;
my $name = abs2rel $file, $self-{vars}-{t_dir};
$self-trace("generating $name");
open my $fh, '', $file or die "open $file: $!";
+
+if (my $msg = $self-genwarning($warn)) {
+print $fh $msg, "\n";
+}
+
$self-{clean}-{files}-{$file} = 1;
return $fh;
@@ -450,7 +462,7 @@
unless ($self-{inherit_config}-{TypesConfig}) {
my $types = catfile $self-{vars}-{t_conf}, 'mime.types';
unless (-e $types) {
-my $fh = $self-genfile($types);
+my $fh = $self-genfile($types, 1);
print $fh $self-types_config_template;
close $fh;
}
@@ -478,7 +490,7 @@
my $extra_conf_in = join '.', $extra_conf, 'in';
open(my $in, $extra_conf_in) or return;
-my $out = $self-genfile($extra_conf);
+my $out = $self-genfile($extra_conf, 1);
$self-replace_vars($in, $out);
close $in;
@@ -507,7 +519,7 @@
my $in = $self-httpd_conf_template($conf_file_in);
-my $out = $self-genfile($conf_file);
+my $out = $self-genfile($conf_file, 1);
$self-preamble_run($out);
@@ -610,7 +622,7 @@
my $name = 'apache_test_config';
my $file = catfile $self-{vars}-{t_conf}, "$name.pm";
-my $fh = $self-genfile($file);
+my $fh = $self-genfile($file, 1);
$self-trace("saving config data to $name.pm");
1.2 +3 -3 modperl-2.0/Apache-Test/lib/Apache/TestConfigPerl.pm
Index: TestConfigPerl.pm
===
RCS file: /home/cvs/modperl-2.0/Apache-Test/lib/Apache/TestConfigPerl.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- TestConfigPerl.pm 2001/04/02 08:57:34 1.1
+++ TestConfigPerl.pm 2001/04/02 18:36:24 1.2
@@ -61,7 +61,7 @@
return if -e $t;
$self-gendir($dir);
-my $fh = $self-genfile($t);
+my $fh = $self-genfile($t, 1);
print $fh EOF;
use Apache::TestConfig ();
@@ -93,7 +93,7 @@
#but this will work for both 2.0 and 1.xx
if (my $inc = $self-{inc}) {
my $include_pl = catfile $self-{vars}-{t_conf}, 'modperl_inc.pl';
-my $fh = $self-genfile($include_pl);
+my $fh = $self-genfile($include_pl, 1);
for (@$inc) {
print $fh "use lib '$_';\n";
}
@@ -107,7 +107,7 @@
my $startup_pl = catfile $self-{vars}-{t_conf}, 'modperl_startup.pl';
unless (-e $startup_pl) {
-my $fh = $self-genfile($startup_pl);
+my $fh = $self-genfile($startup_pl, 1);
print $fh $self-startup_pl_code;
close $fh;
}
1.2 +1 -1 modperl-2.0/Apache-Test/lib/Apache/TestServer.pm
Index: TestServer.pm
===
RCS file: /home/cvs/modperl-2.0/Apache-Test/lib/Apache/TestServer.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- TestServer.pm 2001/04/02 08:58:38 1.1
+++ TestServer.pm 2001/04/02 18:36:25 1.2
@@ -78,7 +78,7 @@
my $one_process = $self-version_of(\%one_process);
my $file = catfile $config-{vars}-{serverroot}, '.gdb-test-start';
-my $fh = $config-genfile($file);
+my $fh = $config-genfile($file, 1);
print $fh "run $one_process $args";
close $fh;
1.1 modperl-2.0/t/filter/reverse.t
Index: reverse.t
===
#WARNING: this file is generated, do not edit
use Apache::TestConfig ();
print Apache::TestConfig-thaw-http_raw_get("/TestFilter::reverse");
cvs commit: modperl-2.0/t/filter .cvsignore reverse.t
dougm 01/04/02 11:55:00 Added: t/filter .cvsignore Removed: t/filter reverse.t Log: whoops Revision ChangesPath 1.1 modperl-2.0/t/filter/.cvsignore Index: .cvsignore === reverse.t
cvs commit: modperl-2.0/xs/Apache/Access - New directory
dougm 01/04/02 12:25:23 modperl-2.0/xs/Apache/Access - New directory
cvs commit: modperl-2.0/xs/maps apache_functions.map
dougm 01/04/02 12:30:40
Modified:t/hooks authen.t
t/hooks/TestHooks authen.pm
xs modperl_xs_util.h
xs/maps apache_functions.map
Added: xs/Apache/Access Apache__Access.h
Log:
add get_basic_auth_pw() wrapper and tests
Revision ChangesPath
1.2 +3 -1 modperl-2.0/t/hooks/authen.t
Index: authen.t
===
RCS file: /home/cvs/modperl-2.0/t/hooks/authen.t,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- authen.t 2001/04/02 09:09:40 1.1
+++ authen.t 2001/04/02 19:30:22 1.2
@@ -4,7 +4,7 @@
use Test;
use Apache::TestRequest;
-plan tests = 3;
+plan tests = 4;
my $location = "/TestHooks::authen";
@@ -15,5 +15,7 @@
ok $rc == 401;
ok GET_OK $location, username = 'dougm', password = 'foo';
+
+ok ! GET_OK $location, username = 'dougm', password = 'wrong';
1.2 +12 -1 modperl-2.0/t/hooks/TestHooks/authen.pm
Index: authen.pm
===
RCS file: /home/cvs/modperl-2.0/t/hooks/TestHooks/authen.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- authen.pm 2001/04/02 09:09:40 1.1
+++ authen.pm 2001/04/02 19:30:27 1.2
@@ -7,7 +7,18 @@
sub handler {
my $r = shift;
-#auth api not complete yet
+
+my($rc, $sent_pw) = $r-get_basic_auth_pw;
+
+return $rc if $rc != 0;
+
+my $user = $r-user;
+
+unless ($user eq 'dougm' and $sent_pw eq 'foo') {
+$r-note_basic_auth_failure;
+return 401;
+}
+
0;
}
1.4 +9 -0 modperl-2.0/xs/modperl_xs_util.h
Index: modperl_xs_util.h
===
RCS file: /home/cvs/modperl-2.0/xs/modperl_xs_util.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- modperl_xs_util.h 2001/03/13 06:49:12 1.3
+++ modperl_xs_util.h 2001/04/02 19:30:31 1.4
@@ -9,6 +9,15 @@
#define dITEMS I32 items = SP - MARK
#endif
+#define mpxs_PPCODE(code) STMT_START { \
+SP -= items; \
+code; \
+PUTBACK; \
+} STMT_END
+
+#define PUSHs_mortal_iv(iv) PUSHs(sv_2mortal(newSViv(iv)))
+#define PUSHs_mortal_pv(pv) PUSHs(sv_2mortal(newSVpv((char *)pv,0)))
+
#define mpxs_sv_grow(sv, len) \
(void)SvUPGRADE(sv, SVt_PV); \
SvGROW(sv, len+1)
1.1 modperl-2.0/xs/Apache/Access/Apache__Access.h
Index: Apache__Access.h
===
static XS(MPXS_ap_get_basic_auth_pw)
{
dXSARGS;
request_rec *r;
const char *sent_pw = NULL;
int rc;
mpxs_usage_items_1("r");
mpxs_PPCODE({
r = mp_xs_sv2_r(ST(0));
rc = ap_get_basic_auth_pw(r, sent_pw);
EXTEND(SP, 2);
PUSHs_mortal_iv(rc);
if (rc == OK) {
PUSHs_mortal_pv(sent_pw);
}
else {
PUSHs(PL_sv_undef);
}
});
}
1.8 +1 -1 modperl-2.0/xs/maps/apache_functions.map
Index: apache_functions.map
===
RCS file: /home/cvs/modperl-2.0/xs/maps/apache_functions.map,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- apache_functions.map 2001/03/25 22:32:11 1.7
+++ apache_functions.map 2001/04/02 19:30:37 1.8
@@ -106,7 +106,7 @@
#MODULE=Apache::Auth
ap_auth_name
ap_auth_type
- ap_get_basic_auth_pw
+ ap_get_basic_auth_pw | MPXS_ | r
ap_note_auth_failure
ap_note_basic_auth_failure
ap_note_digest_auth_failure
cvs commit: modperl-2.0/Apache-Test/lib/Apache TestConfig.pm TestConfigPerl.pm
dougm 01/04/02 17:27:02
Modified:Apache-Test/lib/Apache TestConfig.pm TestConfigPerl.pm
Log:
shift certain .pm __DATA__ config directives outside its container, e.g. Alias
allow containers inside .pm __DATA__ config
Revision ChangesPath
1.4 +1 -1 modperl-2.0/Apache-Test/lib/Apache/TestConfig.pm
Index: TestConfig.pm
===
RCS file: /home/cvs/modperl-2.0/Apache-Test/lib/Apache/TestConfig.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- TestConfig.pm 2001/04/02 20:07:38 1.3
+++ TestConfig.pm 2001/04/03 00:26:58 1.4
@@ -221,7 +221,7 @@
}
else {
$args = "$directive " .
- (ref($arg) (ref($arg) eq 'ARRAY') ? "@$arg" : $arg);
+ (ref($arg) (ref($arg) eq 'ARRAY') ? "@$arg" : $arg || "");
}
push @{ $self-{$where} }, $args;
1.4 +20 -1 modperl-2.0/Apache-Test/lib/Apache/TestConfigPerl.pm
Index: TestConfigPerl.pm
===
RCS file: /home/cvs/modperl-2.0/Apache-Test/lib/Apache/TestConfigPerl.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- TestConfigPerl.pm 2001/04/02 23:45:55 1.3
+++ TestConfigPerl.pm 2001/04/03 00:26:58 1.4
@@ -158,6 +158,10 @@
$port;
}
+my %outside_container = map { $_, 1 } qw{
+Alias AliasMatch AddType
+};
+
#test .pm's can have configuration after the __DATA__ token
sub add_module_config {
my($self, $module, $args) = @_;
@@ -170,7 +174,22 @@
while ($fh) {
next unless /\S+/;
$self-replace;
-push @$args, split /\s+/, $_, 2;
+my($directive, $rest) = split /\s+/, $_, 2;
+if ($outside_container{$directive}) {
+$self-postamble($directive = $rest);
+}
+elsif ($directive =~ m/^(\w+)/) {
+$self-postamble($directive = $rest);
+my $end = "/$1";
+while ($fh) {
+$self-replace;
+$self-postamble($_);
+last if m:^\Q$end:;
+}
+}
+else {
+push @$args, $directive, $rest;
+}
}
}
cvs commit: modperl-2.0/t/filter/TestFilter lc.pm
dougm 01/04/02 17:28:27
Added: t/filter lc.t
t/filter/TestFilter lc.pm
Log:
add another filter test (lowercase filter)
Revision ChangesPath
1.1 modperl-2.0/t/filter/lc.t
Index: lc.t
===
use strict;
use warnings FATAL = 'all';
use Test;
use Apache::TestRequest;
plan tests = 1;
my $location = "/pod/modperl_2.0.pod";
my $str = GET_BODY $location;
ok $str !~ /[A-Z]/;
1.1 modperl-2.0/t/filter/TestFilter/lc.pm
Index: lc.pm
===
package TestFilter::lc;
use strict;
use warnings FATAL = 'all';
use Apache::Filter ();
sub handler {
my $filter = shift;
while ($filter-read(my $buffer, 1024)) {
$filter-print(lc $buffer);
}
0;
}
1;
__DATA__
Location /pod
PerlOutputFilterHandler TestFilter::lc
/Location
Alias /pod @top_dir@/pod
cvs commit: modperl-2.0/Apache-Test/t/conf - New directory
dougm 01/04/02 21:26:23 modperl-2.0/Apache-Test/t/conf - New directory
cvs commit: modperl-2.0/src/modules/perl modperl_callback.c
dougm 01/04/02 22:23:47
Modified:src/modules/perl modperl_callback.c
Log:
if handler is resolved at request time and not duped (prefork-mpm case), need to use
s-process-pconf pool
Revision ChangesPath
1.37 +12 -2 modperl-2.0/src/modules/perl/modperl_callback.c
Index: modperl_callback.c
===
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_callback.c,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- modperl_callback.c2001/03/17 06:03:37 1.36
+++ modperl_callback.c2001/04/03 05:23:47 1.37
@@ -6,7 +6,7 @@
CV *cv=Nullcv;
I32 flags = G_EVAL|G_SCALAR;
dSP;
-int count, status;
+int count, status, duped=0;
#ifdef USE_ITHREADS
if (p !MpHandlerPARSED(handler) !MpHandlerDYNAMIC(handler)) {
@@ -17,6 +17,7 @@
* locking, so just copy it
*/
handler = modperl_handler_dup(p, handler);
+duped = 1;
}
}
#endif
@@ -24,8 +25,17 @@
MP_TRACE_h_do(MpHandler_dump_flags(handler, handler-name));
if (!MpHandlerPARSED(handler)) {
+apr_pool_t *rp = duped ? p : s-process-pconf;
MpHandlerAUTOLOAD_On(handler);
-if (!modperl_mgv_resolve(aTHX_ handler, p, handler-name)) {
+
+MP_TRACE_h(MP_FUNC,
+ "handler %s was not compiled at startup, "
+ "attempting to resolve using %s pool 0x%lx\n",
+ handler-name,
+ duped ? "current" : "server conf",
+ (unsigned long)rp);
+
+if (!modperl_mgv_resolve(aTHX_ handler, rp, handler-name)) {
MP_TRACE_h(MP_FUNC, "failed to resolve handler `%s'\n",
handler-name);
return HTTP_INTERNAL_SERVER_ERROR;
