| #!perl |
| |
| unless (defined $ENV{MOD_PERL}) { |
| die "\$ENV{MOD_PERL} not set!"; |
| } |
| |
| BEGIN { |
| use lib map { "$Apache::Server::CWD/$_" } qw(t/docs blib/lib blib/arch); |
| require "blib.pl" if -e "./t/docs/blib.pl"; |
| #Perl ignores w/ -T |
| if ($ENV{PERL5LIB} and $ENV{PASS_PERL5LIB}) { |
| unshift @INC, map { Apache->untaint($_) } split ":", $ENV{PERL5LIB}; |
| } |
| |
| $Apache::Server::Starting or warn "Server is not starting !?\n"; |
| \$Apache::Server::Starting == \$Apache::ServerStarting or |
| warn "GV alias broken\n"; |
| \$Apache::Server::ReStarting == \$Apache::ServerReStarting or |
| warn "GV alias broken\n"; |
| } |
| |
| if ($] >= 5.005 and -e "t/docs/local.pl") { |
| eval { |
| require "local.pl"; |
| }; $@='' if $@; |
| } |
| |
| use Socket (); #test DynaLoader vs. XSLoader workaroud |
| use Apache (); |
| use Apache::Registry (); |
| unless ($INC{'Apache.pm'} =~ /blib/) { |
| die "Wrong Apache.pm loaded: $INC{'Apache.pm'}"; |
| } |
| |
| my $version = defined $^V ? sprintf("v%vd", $^V) : $]; |
| Apache::add_version_component("Perl/$version"); |
| |
| # BSD/OS 3.1 gets confused with some dynamically loaded code inside evals, |
| # so make sure IO::File is loaded here, rather than later within an eval. |
| # this should not harm any other platforms, since IO::File will be used |
| # by them anyhow. |
| use IO::File (); |
| |
| Apache::Constants->export(qw(HTTP_MULTIPLE_CHOICES)); |
| |
| eval { |
| require Apache::PerlRunXS; |
| }; $@ = '' if $@; |
| |
| |
| { |
| last; |
| Apache::warn("use Apache 'warn' is ok\n"); |
| |
| my $s = Apache->server; |
| |
| my($host,$port) = map { $s->$_() } qw(server_hostname port); |
| $s->log_error("starting server $host on port $port"); |
| |
| my $admin = $s->server_admin; |
| $s->warn("report any problems to server_admin $admin"); |
| } |
| |
| #use HTTP::Status (); |
| #use Apache::Symbol (); |
| #Apache::Symbol->make_universal; |
| |
| $Apache::DoInternalRedirect = 1; |
| $Apache::ERRSV_CAN_BE_HTTP = 1; |
| #$Apache::Server::AddPerlVersion = 1; |
| #warn "ServerStarting=$Apache::ServerStarting\n"; |
| #warn "ServerReStarting=$Apache::ServerReStarting\n"; |
| |
| #use Apache::Debug level => 4; |
| use mod_perl 1.03_01; |
| |
| if(defined &main::subversion) { |
| die "mod_perl.pm is broken\n"; |
| } |
| |
| if($ENV{PERL_TEST_NEW_READ}) { |
| *Apache::READ = \&Apache::new_read; |
| } |
| |
| unless($ENV{KeyForPerlSetEnv} and |
| $ENV{KeyForPerlSetEnv} eq "OK") { |
| warn "PerlSetEnv is broken\n"; |
| } |
| |
| %net::callback_hooks = (); |
| require "net/config.pl"; |
| if($net::callback_hooks{PERL_SAFE_STARTUP}) { |
| eval "open \$0"; |
| unless ($@ =~ /open trapped by operation mask/) { |
| die "opmask not set"; |
| } |
| } |
| else { |
| require "docs/rl.pl"; |
| } |
| #for testing perl mod_include's |
| |
| $Access::Cnt = 0; |
| sub main::pid { print $$ } |
| sub main::access { print ++$Access::Cnt } |
| |
| $ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl/ or die "GATEWAY_INTERFACE not set!"; |
| |
| sub Outside::code {4} |
| %Outside::hash = (one => 1); |
| @Outside::array = qw(one); |
| $Outside::scalar = 'one'; |
| |
| #will be redef'd during tests |
| sub PerlTransHandler::handler {-1} |
| |
| #for testing PERL_HANDLER_METHODS |
| #see httpd.conf and t/docs/LoadClass.pm |
| |
| require "docs/LoadClass.pm"; |
| |
| sub MyClass::method ($$) { |
| my($class, $r) = @_; |
| #warn "$class->method called\n"; |
| 0; |
| } |
| |
| sub BaseClass::handler ($$) { |
| my($class, $r) = @_; |
| #warn "$class->handler called\n"; |
| 0; |
| } |
| |
| { |
| package BaseClass; |
| #so 5.005-tobe doesn't complain: |
| #No such package "BaseClass" in @ISA assignment at ... |
| } |
| |
| |
| $MyClass::Object = bless {}, "MyClass"; |
| @MyClass::ISA = qw(BaseClass); |
| |
| #testing child init/exit hooks |
| |
| sub My::child_init { |
| my $r = shift; |
| eval { |
| my $s = $r->server; |
| my $sa = $s->server_admin; |
| $s->warn("[notice] child_init for process $$, report any problems to $sa\n"); |
| }; $@='' if $@; |
| 0; |
| } |
| |
| sub My::child_exit { |
| warn "[notice] child process $$ terminating\n"; |
| } |
| |
| sub My::restart { |
| my $r = shift; |
| my $s = $r->server; |
| my $sa = $s->server_admin; |
| push @HTTP::Status::ISA, "Apache::Symbol"; |
| HTTP::Status->undef_functions; |
| } |
| |
| sub Apache::AuthenTest::handler { |
| use Apache::Constants ':common'; |
| my $r = shift; |
| |
| $r->custom_response(AUTH_REQUIRED, "/error.txt"); |
| |
| my($res, $sent_pwd) = $r->get_basic_auth_pw; |
| return $res if $res; #decline if not Basic |
| |
| my $user = lc $r->user; |
| $r->notes("DoAuthenTest", 1); |
| |
| unless($user eq "dougm" and $sent_pwd eq "mod_perl") { |
| $r->note_basic_auth_failure; |
| return AUTH_REQUIRED; |
| } |
| |
| return OK; |
| } |
| |
| use Apache::Constants qw(DECLINED DIR_MAGIC_TYPE); |
| |
| sub My::DirIndex::handler { |
| my $r = shift; |
| return DECLINED unless $r->content_type and |
| $r->content_type eq DIR_MAGIC_TYPE; |
| require DirHandle; |
| my $dh = DirHandle->new($r->filename) or die $!; |
| my @entries = $dh->read; |
| my $x = @entries; |
| $r->send_http_header('text/plain'); |
| print "1..$x\n"; |
| my $i = 1; |
| for my $e (@entries) { |
| print "ok $i #($e)\n"; |
| ++$i; |
| } |
| 1; |
| } |
| |
| sub My::ProxyTest::handler { |
| my $r = shift; |
| unless ($r->proxyreq and $r->uri =~ /proxytest/) { |
| #warn sprintf "ProxyTest: proxyreq=%d, uri=%s\n", |
| $r->proxyreq, $r->uri; |
| } |
| return -1 unless $r->proxyreq; |
| return -1 unless $r->uri =~ /proxytest/; |
| $r->handler("perl-script"); |
| $r->push_handlers(PerlHandler => sub { |
| my $r = shift; |
| $r->send_http_header("text/plain"); |
| $r->print("1..1\n"); |
| $r->print("ok 1\n"); |
| $r->print("URI=`", $r->uri, "'\n"); |
| }); |
| return 0; |
| } |
| |
| if(Apache->can_stack_handlers) { |
| Apache->push_handlers(PerlChildExitHandler => sub { |
| warn "[notice] push'd PerlChildExitHandler called, pid=$$\n"; |
| }); |
| } |
| |
| END { |
| warn "[notice] END block called for startup.pl\n"; |
| } |
| |
| package Apache::Death; |
| my $say_ok = <<EOF; |
| *** The following [error] is expected, no cause for alarm *** |
| EOF |
| |
| sub handler { |
| my $r = shift; |
| |
| my $args = $r->args || ""; |
| if ($args =~ /die/) { |
| warn $say_ok; |
| delete $INC{"badsyntax.pl"}; |
| require "badsyntax.pl"; # contains syntax error |
| } |
| if($args =~ /croak/) { |
| warn $say_ok; |
| Carp::croak("Apache::Death"); |
| } |
| |
| $r->content_type('text/html'); |
| $r->send_http_header(); |
| print "<h1>Script completed</h1>\n"; |
| return 0; |
| } |
| |
| package Destruction; |
| |
| sub new { bless {} } |
| |
| sub DESTROY { |
| warn "[notice] Destruction->DESTROY called for \$global_object\n" |
| } |
| |
| #prior to 1.3b1 (and the child_exit hook), this object's DESTROY method would not be invoked |
| $global_object = Destruction->new; |
| |
| 1; |