| #!perl |
| use Apache (); |
| use Apache::Constants qw(:server :common :methods); |
| use Apache::testold; |
| 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::testold '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::testold qw($USE_THREAD); |
| if ($USE_THREAD) { |
| #under Solaris at least, according to Brian P Millett <bpm@ec-group.com> |
| warn "XXX: need to fix \$r->exit in t/net/api w/ threads\n"; |
| } |
| else { |
| $r->exit unless $is_xs; |
| } |
| |
| |
| |
| |