summaryrefslogtreecommitdiffstats
path: root/debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 15:01:31 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 15:01:31 +0000
commitc9cf025fadfe043f0f2f679e10d1207d8a158bb6 (patch)
tree3a94effe0bdc0a6814d8134f4ed840d7cc6b6f19 /debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm
parentAdding upstream version 2.4.57. (diff)
downloadapache2-debian.tar.xz
apache2-debian.zip
Adding debian version 2.4.57-2.debian/2.4.57-2debian
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm')
-rw-r--r--debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm1258
1 files changed, 1258 insertions, 0 deletions
diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm
new file mode 100644
index 0000000..55d32c8
--- /dev/null
+++ b/debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm
@@ -0,0 +1,1258 @@
+# Licensed to the Apache Software Foundation (ASF) under one or more
+# contributor license agreements. See the NOTICE file distributed with
+# this work for additional information regarding copyright ownership.
+# The ASF licenses this file to You under the Apache License, Version 2.0
+# (the "License"); you may not use this file except in compliance with
+# the License. You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+#
+package Apache::TestRequest;
+
+use strict;
+use warnings FATAL => 'all';
+
+BEGIN {
+ $ENV{PERL_LWP_USE_HTTP_10} = 1; # default to http/1.0
+ $ENV{APACHE_TEST_HTTP_09_OK} ||= 0; # 0.9 responses are ok
+}
+
+use Apache::Test ();
+use Apache::TestConfig ();
+
+use Carp;
+
+use constant TRY_TIMES => 200;
+use constant INTERP_KEY => 'X-PerlInterpreter';
+use constant UA_TIMEOUT => 60 * 10; #longer timeout for debugging
+
+my $have_lwp = 0;
+
+# APACHE_TEST_PRETEND_NO_LWP=1 pretends that LWP is not available so
+# one can test whether the test suite survives if the user doesn't
+# have lwp installed
+unless ($ENV{APACHE_TEST_PRETEND_NO_LWP}) {
+ $have_lwp = eval {
+ require LWP::UserAgent;
+ require HTTP::Request::Common;
+
+ unless (defined &HTTP::Request::Common::OPTIONS) {
+ package HTTP::Request::Common;
+ no strict 'vars';
+ *OPTIONS = sub { _simple_req(OPTIONS => @_) };
+ push @EXPORT, 'OPTIONS';
+ }
+ 1;
+ };
+}
+
+unless ($have_lwp) {
+ require Apache::TestClient;
+}
+
+sub has_lwp { $have_lwp }
+
+unless ($have_lwp) {
+ #need to define the shortcuts even though the wont be used
+ #so Perl can parse test scripts
+ @HTTP::Request::Common::EXPORT = qw(GET HEAD POST PUT OPTIONS);
+}
+
+sub install_http11 {
+ eval {
+ die "no LWP" unless $have_lwp;
+ LWP->VERSION(5.60); #minimal version
+ require LWP::Protocol::http;
+ #LWP::Protocol::http10 is used by default
+ LWP::Protocol::implementor('http', 'LWP::Protocol::http');
+ };
+}
+
+use vars qw(@EXPORT @ISA $RedirectOK $DebugLWP);
+
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT = @HTTP::Request::Common::EXPORT;
+
+@ISA = qw(LWP::UserAgent);
+
+my $UA;
+my $REDIR = $have_lwp ? undef : 1;
+my $conn_opts = {};
+
+sub module {
+ my $module = shift;
+ $Apache::TestRequest::Module = $module if $module;
+ $Apache::TestRequest::Module;
+}
+
+sub scheme {
+ my $scheme = shift;
+ $Apache::TestRequest::Scheme = $scheme if $scheme;
+ $Apache::TestRequest::Scheme;
+}
+
+sub module2path {
+ my $package = shift;
+
+ # httpd (1.3 && 2) / winFU have problems when the first path's
+ # segment includes ':' (security precaution which breaks the rfc)
+ # so we can't use /TestFoo::bar as path_info
+ (my $path = $package) =~ s/::/__/g;
+
+ return $path;
+}
+
+sub module2url {
+ my $module = shift;
+ my $opt = shift || {};
+ my $scheme = $opt->{scheme} || 'http';
+ my $path = exists $opt->{path} ? $opt->{path} : module2path($module);
+
+ module($module);
+
+ my $config = Apache::Test::config();
+ my $hostport = hostport($config);
+
+ $path =~ s|^/||;
+ return "$scheme://$hostport/$path";
+}
+
+sub user_agent {
+ my $args = {@_};
+
+ if (delete $args->{reset}) {
+ $UA = undef;
+ }
+
+ if (exists $args->{requests_redirectable}) {
+ my $redir = $args->{requests_redirectable};
+ if (ref $redir and (@$redir > 1 or $redir->[0] ne 'POST')) {
+ # Set our internal flag if there's no LWP.
+ $REDIR = $have_lwp ? undef : 1;
+ } elsif ($redir) {
+ if ($have_lwp) {
+ $args->{requests_redirectable} = [ qw/GET HEAD POST/ ];
+ $REDIR = undef;
+ } else {
+ # Set our internal flag.
+ $REDIR = 1;
+ }
+ } else {
+ # Make sure our internal flag is false if there's no LWP.
+ $REDIR = $have_lwp ? undef : 0;
+ }
+ }
+
+ $args->{keep_alive} ||= $ENV{APACHE_TEST_HTTP11};
+
+ if ($args->{keep_alive}) {
+ install_http11();
+ eval {
+ require LWP::Protocol::https; #https10 is the default
+ LWP::Protocol::implementor('https', 'LWP::Protocol::https');
+ };
+ }
+
+ # in LWP 6, verify_hostname defaults to on, so SSL_ca_file
+ # needs to be set accordingly
+ if ($have_lwp and $LWP::VERSION >= 6.0 and not exists $args->{ssl_opts}->{SSL_ca_file}) {
+ my $vars = Apache::Test::vars();
+ my $cafile = "$vars->{sslca}/$vars->{sslcaorg}/certs/ca.crt";
+ $args->{ssl_opts}->{SSL_ca_file} = $cafile;
+ # IO::Socket:SSL raw socket compatibility
+ $conn_opts->{SSL_ca_file} = $cafile;
+ }
+
+ eval { $UA ||= __PACKAGE__->new(%$args); };
+}
+
+sub user_agent_request_num {
+ my $res = shift;
+ $res->header('Client-Request-Num') || #lwp 5.60
+ $res->header('Client-Response-Num'); #lwp 5.62+
+}
+
+sub user_agent_keepalive {
+ $ENV{APACHE_TEST_HTTP11} = shift;
+}
+
+sub do_request {
+ my($ua, $method, $url, $callback) = @_;
+ my $r = HTTP::Request->new($method, resolve_url($url));
+ my $response = $ua->request($r, $callback);
+ lwp_trace($response);
+}
+
+sub hostport {
+ my $config = shift || Apache::Test::config();
+ my $vars = $config->{vars};
+ local $vars->{scheme} =
+ $Apache::TestRequest::Scheme || $vars->{scheme};
+ my $hostport = $config->hostport;
+
+ my $default_hostport = join ':', $vars->{servername}, $vars->{port};
+ if (my $module = $Apache::TestRequest::Module) {
+ $hostport = $module eq 'default'
+ ? $default_hostport
+ : $config->{vhosts}->{$module}->{hostport};
+ }
+
+ $hostport || $default_hostport;
+}
+
+sub resolve_url {
+ my $url = shift;
+ Carp::croak("no url passed") unless defined $url;
+
+ return $url if $url =~ m,^(\w+):/,;
+ $url = "/$url" unless $url =~ m,^/,;
+
+ my $vars = Apache::Test::vars();
+
+ local $vars->{scheme} =
+ $Apache::TestRequest::Scheme || $vars->{scheme} || 'http';
+
+ scheme_fixup($vars->{scheme});
+
+ my $hostport = hostport();
+
+ return "$vars->{scheme}://$hostport$url";
+}
+
+my %wanted_args = map {$_, 1} qw(username password realm content filename
+ redirect_ok cert);
+
+sub wanted_args {
+ \%wanted_args;
+}
+
+sub redirect_ok {
+ my $self = shift;
+ if ($have_lwp) {
+ # Return user setting or let LWP handle it.
+ return $RedirectOK if defined $RedirectOK;
+ return $self->SUPER::redirect_ok(@_);
+ }
+
+ # No LWP. We don't support redirect on POST.
+ return 0 if $self->method eq 'POST';
+ # Return user setting or our internal calculation.
+ return $RedirectOK if defined $RedirectOK;
+ return $REDIR;
+}
+
+my %credentials;
+
+#subclass LWP::UserAgent
+sub new {
+ my $self = shift->SUPER::new(@_);
+
+ lwp_debug(); #init from %ENV (set by Apache::TestRun)
+
+ my $config = Apache::Test::config();
+ if (my $proxy = $config->configure_proxy) {
+ #t/TEST -proxy
+ $self->proxy(http => "http://$proxy");
+ }
+
+ $self->timeout(UA_TIMEOUT);
+
+ $self;
+}
+
+sub credentials {
+ my $self = shift;
+ return $self->get_basic_credentials(@_);
+}
+
+sub get_basic_credentials {
+ my($self, $realm, $uri, $proxy) = @_;
+
+ for ($realm, '__ALL__') {
+ next unless $_ && $credentials{$_};
+ return @{ $credentials{$_} };
+ }
+
+ return (undef,undef);
+}
+
+sub vhost_socket {
+ my $module = shift;
+ local $Apache::TestRequest::Module = $module if $module;
+
+ my $hostport = hostport(Apache::Test::config());
+
+ my($host, $port) = split ':', $hostport;
+ my(%args) = (PeerAddr => $host, PeerPort => $port);
+
+ if ($module and ($module =~ /ssl/ || $module eq 'h2')) {
+ require IO::Socket::SSL;
+ # Add all conn_opts to args
+ map {$args{$_} = $conn_opts->{$_}} keys %{$conn_opts};
+ return IO::Socket::SSL->new(%args, Timeout => UA_TIMEOUT);
+ }
+ else {
+ require IO::Socket;
+ return IO::Socket::INET->new(%args);
+ }
+}
+
+#IO::Socket::SSL::getline does not correctly handle OpenSSL *_WANT_*.
+#Could care less about performance here, just need a getline()
+#that returns the same results with or without ssl.
+#Inspired from Net::SSLeay::ssl_read_all().
+my %getline = (
+ 'IO::Socket::SSL' => sub {
+ my $self = shift;
+ # _get_ssl_object in IO::Socket::SSL only meant for internal use!
+ # But we need to compensate for unsufficient getline impl there.
+ my $ssl = $self->_get_ssl_object;
+ my ($got, $rv, $errs);
+ my $reply = '';
+
+ while (1) {
+ ($got, $rv) = Net::SSLeay::read($ssl, 1);
+ if (! defined $got) {
+ my $err = Net::SSLeay::get_error($ssl, $rv);
+ if ($err != Net::SSLeay::ERROR_WANT_READ() and
+ $err != Net::SSLeay::ERROR_WANT_WRITE()) {
+ $errs = Net::SSLeay::print_errs('SSL_read');
+ last;
+ }
+ next;
+ }
+ last if $got eq ''; # EOF
+ $reply .= $got;
+ last if $got eq "\n";
+ }
+
+ wantarray ? ($reply, $errs) : $reply;
+ },
+);
+
+sub getline {
+ my $sock = shift;
+ my $class = ref $sock;
+ my $method = $getline{$class} || 'getline';
+ $sock->$method();
+}
+
+sub socket_trace {
+ my $sock = shift;
+ return unless $sock->can('get_peer_certificate');
+
+ #like having some -v info
+ my $cert = $sock->get_peer_certificate;
+ print "#Cipher: ", $sock->get_cipher, "\n";
+ print "#Peer DN: ", $cert->subject_name, "\n";
+}
+
+sub prepare {
+ my $url = shift;
+
+ if ($have_lwp) {
+ user_agent();
+ $url = resolve_url($url);
+ }
+ else {
+ lwp_debug() if $ENV{APACHE_TEST_DEBUG_LWP};
+ }
+
+ my($pass, $keep) = Apache::TestConfig::filter_args(\@_, \%wanted_args);
+
+ %credentials = ();
+ if (defined $keep->{username}) {
+ $credentials{$keep->{realm} || '__ALL__'} =
+ [$keep->{username}, $keep->{password}];
+ }
+ if (defined(my $content = $keep->{content})) {
+ if ($content eq '-') {
+ $content = join '', <STDIN>;
+ }
+ elsif ($content =~ /^x(\d+)$/) {
+ $content = 'a' x $1;
+ }
+ push @$pass, content => $content;
+ }
+ if (exists $keep->{cert}) {
+ set_client_cert($keep->{cert});
+ }
+
+ return ($url, $pass, $keep);
+}
+
+sub UPLOAD {
+ my($url, $pass, $keep) = prepare(@_);
+
+ local $RedirectOK = exists $keep->{redirect_ok}
+ ? $keep->{redirect_ok}
+ : $RedirectOK;
+
+ if ($keep->{filename}) {
+ return upload_file($url, $keep->{filename}, $pass);
+ }
+ else {
+ return upload_string($url, $keep->{content});
+ }
+}
+
+sub UPLOAD_BODY {
+ UPLOAD(@_)->content;
+}
+
+sub UPLOAD_BODY_ASSERT {
+ content_assert(UPLOAD(@_));
+}
+
+#lwp only supports files
+sub upload_string {
+ my($url, $data) = @_;
+
+ my $CRLF = "\015\012";
+ my $bound = 742617000027;
+ my $req = HTTP::Request->new(POST => $url);
+
+ my $content = join $CRLF,
+ "--$bound",
+ "Content-Disposition: form-data; name=\"HTTPUPLOAD\"; filename=\"b\"",
+ "Content-Type: text/plain", "",
+ $data, "--$bound--", "";
+
+ $req->header("Content-Length", length($content));
+ $req->content_type("multipart/form-data; boundary=$bound");
+ $req->content($content);
+
+ $UA->request($req);
+}
+
+sub upload_file {
+ my($url, $file, $args) = @_;
+
+ my $content = [@$args, filename => [$file]];
+
+ $UA->request(HTTP::Request::Common::POST($url,
+ Content_Type => 'form-data',
+ Content => $content,
+ ));
+}
+
+#useful for POST_HEAD and $DebugLWP (see below)
+sub lwp_as_string {
+ my($r, $want_body) = @_;
+ my $content = $r->content;
+
+ unless ($r->isa('HTTP::Request') or
+ $r->header('Content-Length') or
+ $r->header('Transfer-Encoding'))
+ {
+ $r->header('Content-Length' => length $content);
+ $r->header('X-Content-length-note' => 'added by Apache::TestRequest');
+ }
+
+ $r->content('') unless $want_body;
+
+ (my $string = $r->as_string) =~ s/^/\#/mg;
+ $r->content($content); #reset
+ $string;
+}
+
+$DebugLWP = 0; #1 == print METHOD URL and header response for all requests
+ #2 == #1 + response body
+ #other == passed to LWP::Debug->import
+
+sub lwp_debug {
+ package main; #wtf: else package in perldb changes
+ my $val = $_[0] || $ENV{APACHE_TEST_DEBUG_LWP};
+
+ return unless $val;
+
+ if ($val =~ /^\d+$/) {
+ $Apache::TestRequest::DebugLWP = $val;
+ return "\$Apache::TestRequest::DebugLWP = $val\n";
+ }
+ else {
+ my(@args) = @_ ? @_ : split /\s+/, $val;
+ require LWP::Debug;
+ LWP::Debug->import(@args);
+ return "LWP::Debug->import(@args)\n";
+ }
+}
+
+sub lwp_trace {
+ my $r = shift;
+
+ unless ($r->request->protocol) {
+ #lwp always sends a request, but never sets
+ #$r->request->protocol, happens deeper in the
+ #LWP::Protocol::http* modules
+ my $proto = user_agent_request_num($r) ? "1.1" : "1.0";
+ $r->request->protocol("HTTP/$proto");
+ }
+
+ my $want_body = $DebugLWP > 1;
+ print "#lwp request:\n",
+ lwp_as_string($r->request, $want_body);
+
+ print "#server response:\n",
+ lwp_as_string($r, $want_body);
+}
+
+sub lwp_call {
+ my($name, $shortcut) = (shift, shift);
+
+ my $r = (\&{$name})->(@_);
+
+ Carp::croak("$name(@_) didn't return a response object") unless $r;
+
+ my $error = "";
+ unless ($shortcut) {
+ #GET, HEAD, POST
+ if ($r->method eq "POST" && !defined($r->header("Content-Length"))) {
+ $r->header('Content-Length' => length($r->content));
+ }
+ $r = $UA ? $UA->request($r) : $r;
+ my $proto = $r->protocol;
+ if (defined($proto)) {
+ if ($proto !~ /^HTTP\/(\d\.\d)$/) {
+ $error = "response had no protocol (is LWP broken or something?)";
+ }
+ if ($1 ne "1.0" && $1 ne "1.1") {
+ $error = "response had protocol HTTP/$1 (headers not sent?)"
+ unless ($1 eq "0.9" && $ENV{APACHE_TEST_HTTP_09_OK});
+ }
+ }
+ }
+
+ if ($DebugLWP and not $shortcut) {
+ lwp_trace($r);
+ }
+
+ Carp::croak($error) if $error;
+
+ return $shortcut ? $r->$shortcut() : $r;
+}
+
+my %shortcuts = (RC => sub { shift->code },
+ OK => sub { shift->is_success },
+ STR => sub { shift->as_string },
+ HEAD => sub { lwp_as_string(shift, 0) },
+ BODY => sub { shift->content },
+ BODY_ASSERT => sub { content_assert(shift) },
+);
+
+for my $name (@EXPORT) {
+ my $package = $have_lwp ?
+ 'HTTP::Request::Common': 'Apache::TestClient';
+
+ my $method = join '::', $package, $name;
+ no strict 'refs';
+
+ next unless defined &$method;
+
+ *$name = sub {
+ my($url, $pass, $keep) = prepare(@_);
+ local $RedirectOK = exists $keep->{redirect_ok}
+ ? $keep->{redirect_ok}
+ : $RedirectOK;
+ return lwp_call($method, undef, $url, @$pass);
+ };
+
+ while (my($shortcut, $cv) = each %shortcuts) {
+ my $alias = join '_', $name, $shortcut;
+ *$alias = sub { lwp_call($name, $cv, @_) };
+ }
+}
+
+my @export_std = @EXPORT;
+for my $method (@export_std) {
+ push @EXPORT, map { join '_', $method, $_ } keys %shortcuts;
+}
+
+push @EXPORT, qw(UPLOAD UPLOAD_BODY UPLOAD_BODY_ASSERT);
+
+sub to_string {
+ my $obj = shift;
+ ref($obj) ? $obj->as_string : $obj;
+}
+
+# request an interpreter instance and use this interpreter id to
+# select the same interpreter in requests below
+sub same_interp_tie {
+ my($url) = @_;
+
+ my $res = GET($url, INTERP_KEY, 'tie');
+ unless ($res->code == 200) {
+ die sprintf "failed to init the same_handler data (url=%s). " .
+ "Failed with code=%s, response:\n%s",
+ $url, $res->code, $res->content;
+ }
+ my $same_interp = $res->header(INTERP_KEY);
+
+ return $same_interp;
+}
+
+# run the request though the selected perl interpreter, by polling
+# until we found it
+# currently supports only GET, HEAD, PUT, POST subs
+sub same_interp_do {
+ my($same_interp, $sub, $url, @args) = @_;
+
+ die "must pass an interpreter id, obtained via same_interp_tie()"
+ unless defined $same_interp and $same_interp;
+
+ push @args, (INTERP_KEY, $same_interp);
+
+ my $res = '';
+ my $times = 0;
+ my $found_same_interp = '';
+ do {
+ #loop until we get a response from our interpreter instance
+ $res = $sub->($url, @args);
+ die "no result" unless $res;
+ my $code = $res->code;
+ if ($code == 200) {
+ $found_same_interp = $res->header(INTERP_KEY) || '';
+ }
+ elsif ($code == 404) {
+ # try again
+ }
+ else {
+ die sprintf "failed to run the request (url=%s):\n" .
+ "code=%s, response:\n%s", $url, $code, $res->content;
+ }
+
+ unless ($found_same_interp eq $same_interp) {
+ $found_same_interp = '';
+ }
+
+ if ($times++ > TRY_TIMES) { #prevent endless loop
+ die "unable to find interp $same_interp\n";
+ }
+ } until ($found_same_interp);
+
+ return $found_same_interp ? $res : undef;
+}
+
+
+sub set_client_cert {
+ my $name = shift;
+ my $vars = Apache::Test::vars();
+ my $dir = join '/', $vars->{sslca}, $vars->{sslcaorg};
+
+ if ($name) {
+ my ($cert, $key) = ("$dir/certs/$name.crt", "$dir/keys/$name.pem");
+ # IO::Socket:SSL raw socket compatibility
+ $conn_opts->{SSL_cert_file} = $cert;
+ $conn_opts->{SSL_key_file} = $key;
+ if ($LWP::VERSION >= 6.0) {
+ # IO::Socket:SSL doesn't look at environment variables
+ if ($UA) {
+ $UA->ssl_opts(SSL_cert_file => $cert);
+ $UA->ssl_opts(SSL_key_file => $key);
+ } else {
+ user_agent(ssl_opts => { SSL_cert_file => $cert,
+ SSL_key_file => $key });
+ }
+ }
+ }
+ else {
+ # IO::Socket:SSL raw socket compatibility
+ $conn_opts->{SSL_cert_file} = undef;
+ $conn_opts->{SSL_key_file} = undef;
+ if ($LWP::VERSION >= 6.0 and $UA) {
+ $UA->ssl_opts(SSL_cert_file => undef);
+ $UA->ssl_opts(SSL_key_file => undef);
+ }
+ }
+}
+
+# Only for IO::Socket:SSL raw socket compatibility,
+# when using user_agent() already done in its
+# constructor.
+sub set_ca_cert {
+ my $vars = Apache::Test::vars();
+ my $cafile = "$vars->{sslca}/$vars->{sslcaorg}/certs/ca.crt";
+ $conn_opts->{SSL_ca_file} = $cafile;
+}
+
+#want news: urls to work with the LWP shortcuts
+#but cant find a clean way to override the default nntp port
+#by brute force we trick Net::NTTP into calling FixupNNTP::new
+#instead of IO::Socket::INET::new, we fixup the args then forward
+#to IO::Socket::INET::new
+
+#also want KeepAlive on for Net::HTTP
+#XXX libwww-perl 5.53_xx has: LWP::UserAgent->new(keep_alive => 1);
+
+sub install_net_socket_new {
+ my($module, $code) = @_;
+
+ return unless Apache::Test::have_module($module);
+
+ no strict 'refs';
+
+ my $new;
+ my $isa = \@{"$module\::ISA"};
+
+ for (@$isa) {
+ last if $new = $_->can('new');
+ }
+
+ my $fixup_class = "Apache::TestRequest::$module";
+ unshift @$isa, $fixup_class;
+
+ *{"$fixup_class\::new"} = sub {
+ my $class = shift;
+ my $args = {@_};
+ $code->($args);
+ return $new->($class, %$args);
+ };
+}
+
+my %scheme_fixups = (
+ 'news' => sub {
+ return if $INC{'Net/NNTP.pm'};
+ eval {
+ install_net_socket_new('Net::NNTP' => sub {
+ my $args = shift;
+ my($host, $port) = split ':',
+ Apache::TestRequest::hostport();
+ $args->{PeerPort} = $port;
+ $args->{PeerAddr} = $host;
+ });
+ };
+ },
+);
+
+sub scheme_fixup {
+ my $scheme = shift;
+ my $fixup = $scheme_fixups{$scheme};
+ return unless $fixup;
+ $fixup->();
+}
+
+# when the client side simply prints the response body which should
+# include the test's output, we need to make sure that the request
+# hasn't failed, or the test will be skipped instead of indicating the
+# error.
+sub content_assert {
+ my $res = shift;
+
+ return $res->content if $res->is_success;
+
+ die join "\n",
+ "request has failed (the response code was: " . $res->code . ")",
+ "see t/logs/error_log for more details\n";
+}
+
+1;
+
+=head1 NAME
+
+Apache::TestRequest - Send requests to your Apache test server
+
+=head1 SYNOPSIS
+
+ use Apache::Test qw(ok have_lwp);
+ use Apache::TestRequest qw(GET POST);
+ use Apache::Constants qw(HTTP_OK);
+
+ plan tests => 1, have_lwp;
+
+ my $res = GET '/test.html';
+ ok $res->code == HTTP_OK, "Request is ok";
+
+=head1 DESCRIPTION
+
+B<Apache::TestRequest> provides convenience functions to allow you to
+make requests to your Apache test server in your test scripts. It
+subclasses C<LWP::UserAgent>, so that you have access to all if its
+methods, but also exports a number of useful functions likely useful
+for majority of your test requests. Users of the old C<Apache::test>
+(or C<Apache::testold>) module, take note! Herein lie most of the
+functions you'll need to use to replace C<Apache::test> in your test
+suites.
+
+Each of the functions exported by C<Apache::TestRequest> uses an
+C<LWP::UserAgent> object to submit the request and retrieve its
+results. The return value for many of these functions is an
+HTTP::Response object. See L<HTTP::Response|HTTP::Response> for
+documentation of its methods, which you can use in your tests. For
+example, use the C<code()> and C<content()> methods to test the
+response code and content of your request. Using C<GET>, you can
+perform a couple of tests using these methods like this:
+
+ use Apache::Test qw(ok have_lwp);
+ use Apache::TestRequest qw(GET POST);
+ use Apache::Constants qw(HTTP_OK);
+
+ plan tests => 2, have_lwp;
+
+ my $uri = "/test.html?foo=1&bar=2";
+ my $res = GET $uri;
+ ok $res->code == HTTP_OK, "Check that the request was OK";
+ ok $res->content eq "foo => 1, bar => 2", "Check its content";
+
+Note that you can also use C<Apache::TestRequest> with
+C<Test::Builder> and its derivatives, including C<Test::More>:
+
+ use Test::More;
+ # ...
+ is $res->code, HTTP_OK, "Check that the request was OK";
+ is $res->content, "foo => 1, bar => 2", "Check its content";
+
+=head1 CONFIGURATION FUNCTION
+
+You can tell C<Apache::TestRequest> what kind of C<LWP::UserAgent>
+object to use for its convenience functions with C<user_agent()>. This
+function uses its arguments to construct an internal global
+C<LWP::UserAgent> object that will be used for all subsequent requests
+made by the convenience functions. The arguments it takes are the same
+as for the C<LWP::UserAgent> constructor. See the
+C<L<LWP::UserAgent|LWP::UserAgent>> documentation for a complete list.
+
+The C<user_agent()> function only creates the internal
+C<LWP::UserAgent> object the first time it is called. Since this
+function is called internally by C<Apache::TestRequest>, you should
+always use the C<reset> parameter to force it to create a new global
+C<LWP::UserAgent> Object:
+
+ Apache::TestRequest::user_agent(reset => 1, %params);
+
+C<user_agent()> differs from C<< LWP::UserAgent->new >> in two
+additional ways. First, it supports an additional parameter,
+C<keep_alive>, which enables connection persistence, where the same
+connection is used to process multiple requests (and, according to the
+C<L<LWP::UserAgent|LWP::UserAgent>> documentation, has the effect of
+loading and enabling the new experimental HTTP/1.1 protocol module).
+
+And finally, the semantics of the C<requests_redirectable> parameter is
+different than for C<LWP::UserAgent> in that you can pass it a boolean
+value as well as an array for C<LWP::UserAgent>. To force
+C<Apache::TestRequest> not to follow redirects in any of its convenience
+functions, pass a false value to C<requests_redirectable>:
+
+ Apache::TestRequest::user_agent(reset => 1,
+ requests_redirectable => 0);
+
+If LWP is not installed, then you can still pass in an array reference
+as C<LWP::UserAgent> expects. C<Apache::TestRequest> will examine the
+array and allow redirects if the array contains more than one value or
+if there is only one value and that value is not "POST":
+
+ # Always allow redirection.
+ my $redir = have_lwp() ? [qw(GET HEAD POST)] : 1;
+ Apache::TestRequest::user_agent(reset => 1,
+ requests_redirectable => $redir);
+
+But note that redirection will B<not> work with C<POST> unless LWP is
+installed. It's best, therefore, to check C<have_lwp> before running
+tests that rely on a redirection from C<POST>.
+
+Sometimes it is desireable to have C<Apache::TestRequest> remember
+cookies sent by the pages you are testing and send them back to the
+server on subsequent requests. This is especially necessary when
+testing pages whose functionality relies on sessions or the presence
+of preferences stored in cookies.
+
+By default, C<LWP::UserAgent> does B<not> remember cookies between
+requests. You can tell it to remember cookies between request by
+adding:
+
+ Apache::TestRequest::user_agent(cookie_jar => {});
+
+before issuing the requests.
+
+
+=head1 FUNCTIONS
+
+C<Apache::TestRequest> exports a number of functions that will likely
+prove convenient for use in the majority of your request tests.
+
+
+
+
+=head2 Optional Parameters
+
+Each function also takes a number of optional arguments.
+
+=over 4
+
+=item redirect_ok
+
+By default a request will follow redirects retrieved from the server. To
+prevent this behavior, pass a false value to a C<redirect_ok>
+parameter:
+
+ my $res = GET $uri, redirect_ok => 0;
+
+Alternately, if all of your tests need to disable redirects, tell
+C<Apache::TestRequest> to use an C<LWP::UserAgent> object that
+disables redirects:
+
+ Apache::TestRequest::user_agent( reset => 1,
+ requests_redirectable => 0 );
+
+=item cert
+
+If you need to force an SSL request to use a particular SSL
+certificate, pass the name of the certificate via the C<cert>
+parameter:
+
+ my $res = GET $uri, cert => 'my_cert';
+
+=item content
+
+If you need to add content to your request, use the C<content>
+parameter:
+
+ my $res = GET $uri, content => 'hello world!';
+
+=item filename
+
+The name of a local file on the file system to be sent to the Apache
+test server via C<UPLOAD()> and its friends.
+
+=back
+
+=head2 The Functions
+
+=head3 GET
+
+ my $res = GET $uri;
+
+Sends a simple GET request to the Apache test server. Returns an
+C<HTTP::Response> object.
+
+You can also supply additional headers to be sent with the request by
+adding their name/value pairs after the C<url> parameter, for example:
+
+ my $res = GET $url, 'Accept-Language' => 'de,en-us,en;q=0.5';
+
+=head3 GET_STR
+
+A shortcut function for C<GET($uri)-E<gt>as_string>.
+
+=head3 GET_BODY
+
+A shortcut function for C<GET($uri)-E<gt>content>.
+
+=head3 GET_BODY_ASSERT
+
+Use this function when your test is outputting content that you need
+to check, and you want to make sure that the request was successful
+before comparing the contents of the request. If the request was
+unsuccessful, C<GET_BODY_ASSERT> will return an error
+message. Otherwise it will simply return the content of the request
+just as C<GET_BODY> would.
+
+=head3 GET_OK
+
+A shortcut function for C<GET($uri)-E<gt>is_success>.
+
+=head3 GET_RC
+
+A shortcut function for C<GET($uri)-E<gt>code>.
+
+=head3 GET_HEAD
+
+Throws out the content of the request, and returns the string
+representation of the request. Since the body has been thrown out, the
+representation will consist solely of the headers. Furthermore,
+C<GET_HEAD> inserts a "#" at the beginning of each line of the return
+string, so that the contents are suitable for printing to STDERR
+during your tests without interfering with the workings of
+C<Test::Harness>.
+
+=head3 HEAD
+
+ my $res = HEAD $uri;
+
+Sends a HEAD request to the Apache test server. Returns an
+C<HTTP::Response> object.
+
+=head3 HEAD_STR
+
+A shortcut function for C<HEAD($uri)-E<gt>as_string>.
+
+=head3 HEAD_BODY
+
+A shortcut function for C<HEAD($uri)-E<gt>content>. Of course, this
+means that it will likely return nothing.
+
+=head3 HEAD_BODY_ASSERT
+
+Use this function when your test is outputting content that you need
+to check, and you want to make sure that the request was successful
+before comparing the contents of the request. If the request was
+unsuccessful, C<HEAD_BODY_ASSERT> will return an error
+message. Otherwise it will simply return the content of the request
+just as C<HEAD_BODY> would.
+
+=head3 HEAD_OK
+
+A shortcut function for C<GET($uri)-E<gt>is_success>.
+
+=head3 HEAD_RC
+
+A shortcut function for C<GET($uri)-E<gt>code>.
+
+=head3 HEAD_HEAD
+
+Throws out the content of the request, and returns the string
+representation of the request. Since the body has been thrown out, the
+representation will consist solely of the headers. Furthermore,
+C<GET_HEAD> inserts a "#" at the beginning of each line of the return
+string, so that the contents are suitable for printing to STDERR
+during your tests without interfering with the workings of
+C<Test::Harness>.
+
+=head3 PUT
+
+ my $res = PUT $uri;
+
+Sends a simple PUT request to the Apache test server. Returns an
+C<HTTP::Response> object.
+
+=head3 PUT_STR
+
+A shortcut function for C<PUT($uri)-E<gt>as_string>.
+
+=head3 PUT_BODY
+
+A shortcut function for C<PUT($uri)-E<gt>content>.
+
+=head3 PUT_BODY_ASSERT
+
+Use this function when your test is outputting content that you need
+to check, and you want to make sure that the request was successful
+before comparing the contents of the request. If the request was
+unsuccessful, C<PUT_BODY_ASSERT> will return an error
+message. Otherwise it will simply return the content of the request
+just as C<PUT_BODY> would.
+
+=head3 PUT_OK
+
+A shortcut function for C<PUT($uri)-E<gt>is_success>.
+
+=head3 PUT_RC
+
+A shortcut function for C<PUT($uri)-E<gt>code>.
+
+=head3 PUT_HEAD
+
+Throws out the content of the request, and returns the string
+representation of the request. Since the body has been thrown out, the
+representation will consist solely of the headers. Furthermore,
+C<PUT_HEAD> inserts a "#" at the beginning of each line of the return
+string, so that the contents are suitable for printing to STDERR
+during your tests without interfering with the workings of
+C<Test::Harness>.
+
+=head3 POST
+
+ my $res = POST $uri, [ arg => $val, arg2 => $val ];
+
+Sends a POST request to the Apache test server and returns an
+C<HTTP::Response> object. An array reference of parameters passed as
+the second argument will be submitted to the Apache test server as the
+POST content. Parameters corresponding to those documented in
+L<Optional Parameters|/Optional
+Parameters> can follow the optional array reference of parameters, or after
+C<$uri>.
+
+To upload a chunk of data, simply use:
+
+ my $res = POST $uri, content => $data;
+
+=head3 POST_STR
+
+A shortcut function for C<POST($uri, @args)-E<gt>content>.
+
+=head3 POST_BODY
+
+A shortcut function for C<POST($uri, @args)-E<gt>content>.
+
+=head3 POST_BODY_ASSERT
+
+Use this function when your test is outputting content that you need
+to check, and you want to make sure that the request was successful
+before comparing the contents of the request. If the request was
+unsuccessful, C<POST_BODY_ASSERT> will return an error
+message. Otherwise it will simply return the content of the request
+just as C<POST_BODY> would.
+
+=head3 POST_OK
+
+A shortcut function for C<POST($uri, @args)-E<gt>is_success>.
+
+=head3 POST_RC
+
+A shortcut function for C<POST($uri, @args)-E<gt>code>.
+
+=head3 POST_HEAD
+
+Throws out the content of the request, and returns the string
+representation of the request. Since the body has been thrown out, the
+representation will consist solely of the headers. Furthermore,
+C<POST_HEAD> inserts a "#" at the beginning of each line of the return
+string, so that the contents are suitable for printing to STDERR
+during your tests without interfering with the workings of
+C<Test::Harness>.
+
+=head3 UPLOAD
+
+ my $res = UPLOAD $uri, \@args, filename => $filename;
+
+Sends a request to the Apache test server that includes an uploaded
+file. Other POST parameters can be passed as a second argument as an
+array reference.
+
+C<Apache::TestRequest> will read in the contents of the file named via
+the C<filename> parameter for submission to the server. If you'd
+rather, you can submit use the C<content> parameter instead of
+C<filename>, and its value will be submitted to the Apache server as
+file contents:
+
+ my $res = UPLOAD $uri, undef, content => "This is file content";
+
+The name of the file sent to the server will simply be "b". Note that
+in this case, you cannot pass other POST arguments to C<UPLOAD()> --
+they would be ignored.
+
+=head3 UPLOAD_BODY
+
+A shortcut function for C<UPLOAD($uri, @params)-E<gt>content>.
+
+=head3 UPLOAD_BODY_ASSERT
+
+Use this function when your test is outputting content that you need
+to check, and you want to make sure that the request was successful
+before comparing the contents of the request. If the request was
+unsuccessful, C<UPLOAD_BODY_ASSERT> will return an error
+message. Otherwise it will simply return the content of the request
+just as C<UPLOAD_BODY> would.
+
+=head3 OPTIONS
+
+ my $res = OPTIONS $uri;
+
+Sends an C<OPTIONS> request to the Apache test server. Returns an
+C<HTTP::Response> object with the I<Allow> header, indicating which
+methods the server supports. Possible methods include C<OPTIONS>,
+C<GET>, C<HEAD> and C<POST>. This function thus can be useful for
+testing what options the Apache server supports. Consult the HTTPD 1.1
+specification, section 9.2, at
+I<http://www.faqs.org/rfcs/rfc2616.html> for more information.
+
+
+
+
+
+=head2 URL Manipulation Functions
+
+C<Apache::TestRequest> also includes a few helper functions to aid in
+the creation of urls used in the functions above.
+
+
+
+=head3 C<module2path>
+
+ $path = Apache::TestRequest::module2path($module_name);
+
+Convert a module name to a path, safe for use in the various request
+methods above. e.g. C<::> can't be used in URLs on win32. For example:
+
+ $path = Apache::TestRequest::module2path('Foo::Bar');
+
+returns:
+
+ /Foo__Bar
+
+
+
+
+=head3 C<module2url>
+
+ $url = Apache::TestRequest::module2url($module);
+ $url = Apache::TestRequest::module2url($module, \%options);
+
+Convert a module name to a full URL including the current
+configurations C<hostname:port> and sets C<module> accordingly.
+
+ $url = Apache::TestRequest::module2url('Foo::Bar');
+
+returns:
+
+ http://$hostname:$port/Foo__Bar
+
+The default scheme used is C<http>. You can override this by passing
+your preferred scheme into an optional second param. For example:
+
+ $module = 'MyTestModule::TestHandler';
+ $url = Apache::TestRequest::module2url($module, {scheme => 'https'});
+
+returns:
+
+ https://$hostname:$port/MyTestModule__TestHandler
+
+You may also override the default path with a path of your own:
+
+ $module = 'MyTestModule::TestHandler';
+ $url = Apache::TestRequest::module2url($module, {path => '/foo'});
+
+returns:
+
+ http://$hostname:$port/foo
+
+
+
+
+
+=head1 ENVIRONMENT VARIABLES
+
+The following environment variables can affect the behavior of
+C<Apache::TestRequest>:
+
+=over
+
+=item APACHE_TEST_PRETEND_NO_LWP
+
+If the environment variable C<APACHE_TEST_PRETEND_NO_LWP> is set to a
+true value, C<Apache::TestRequest> will pretend that LWP is not
+available so one can test whether the test suite will survive on a
+system which doesn't have libwww-perl installed.
+
+=item APACHE_TEST_HTTP_09_OK
+
+If the environment variable C<APACHE_TEST_HTTP_09_OK> is set to a
+true value, C<Apache::TestRequest> will allow HTTP/0.9 responses
+from the server to proceed. The default behavior is to die if
+the response protocol is not either HTTP/1.0 or HTTP/1.1.
+
+=back
+
+=head1 SEE ALSO
+
+L<Apache::Test|Apache::Test> is the main Apache testing module. Use it
+to set up your tests, create a plan, and to ensure that you have the
+Apache version and modules you need.
+
+Use L<Apache::TestMM|Apache::TestMM> in your I<Makefile.PL> to set up
+your distribution for testing.
+
+=head1 AUTHOR
+
+Doug MacEachern with contributions from Geoffrey Young, Philippe
+M. Chiasson, Stas Bekman and others. Documentation by David Wheeler.
+
+Questions can be asked at the test-dev <at> httpd.apache.org list. For
+more information see: I<http://httpd.apache.org/test/> and
+I<http://perl.apache.org/docs/general/testing/testing.html>.