1258 lines
36 KiB
Perl
1258 lines
36 KiB
Perl
# 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>.
|