File Coverage

blib/lib/Apache/TestRequest.pm
Criterion Covered Total %
statement 111 288 38.5
branch 39 140 27.9
condition 14 64 21.9
subroutine 25 53 47.2
pod 8 36 22.2
total 197 581 33.9


line stmt bran cond sub pod time code
1             # Licensed to the Apache Software Foundation (ASF) under one or more
2             # contributor license agreements. See the NOTICE file distributed with
3             # this work for additional information regarding copyright ownership.
4             # The ASF licenses this file to You under the Apache License, Version 2.0
5             # (the "License"); you may not use this file except in compliance with
6             # the License. You may obtain a copy of the License at
7             #
8             # http://www.apache.org/licenses/LICENSE-2.0
9             #
10             # Unless required by applicable law or agreed to in writing, software
11             # distributed under the License is distributed on an "AS IS" BASIS,
12             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13             # See the License for the specific language governing permissions and
14             # limitations under the License.
15             #
16             package Apache::TestRequest;
17              
18 6     6   80 use strict;
  6         54  
  6         110  
19 6     6   93 use warnings FATAL => 'all';
  6         58  
  6         85  
20              
21             BEGIN {
22 6     6   117     $ENV{PERL_LWP_USE_HTTP_10} = 1; # default to http/1.0
23 6   50     121     $ENV{APACHE_TEST_HTTP_09_OK} ||= 0; # 0.9 responses are ok
24             }
25              
26 6     6   91 use Apache::Test ();
  6         53  
  6         59  
27 6     6   93 use Apache::TestConfig ();
  6         55  
  6         57  
28              
29 6     6   85 use Carp;
  6         54  
  6         138  
30              
31 6     6   93 use constant TRY_TIMES => 200;
  6         423  
  6         192  
32 6     6   94 use constant INTERP_KEY => 'X-PerlInterpreter';
  6         55  
  6         75  
33 6     6   87 use constant UA_TIMEOUT => 60 * 10; #longer timeout for debugging
  6         52  
  6         77  
34              
35             my $have_lwp = 0;
36              
37             # APACHE_TEST_PRETEND_NO_LWP=1 pretends that LWP is not available so
38             # one can test whether the test suite survives if the user doesn't
39             # have lwp installed
40             unless ($ENV{APACHE_TEST_PRETEND_NO_LWP}) {
41                 $have_lwp = eval {
42                     require LWP::UserAgent;
43                     require HTTP::Request::Common;
44              
45                     unless (defined &HTTP::Request::Common::OPTIONS) {
46                         package HTTP::Request::Common;
47 6     6   121             no strict 'vars';
  6         57  
  6         140  
48 0     0   0             *OPTIONS = sub { _simple_req(OPTIONS => @_) };
49                         push @EXPORT, 'OPTIONS';
50                     }
51                     1;
52                 };
53             }
54              
55             unless ($have_lwp) {
56                 require Apache::TestClient;
57             }
58              
59 3     3 0 42 sub has_lwp { $have_lwp }
60              
61             unless ($have_lwp) {
62             #need to define the shortcuts even though the wont be used
63             #so Perl can parse test scripts
64                 @HTTP::Request::Common::EXPORT = qw(GET HEAD POST PUT OPTIONS);
65             }
66              
67             sub install_http11 {
68 0     0 0 0     eval {
69 0 0       0         die "no LWP" unless $have_lwp;
70 0         0         LWP->VERSION(5.60); #minimal version
71 0         0         require LWP::Protocol::http;
72             #LWP::Protocol::http10 is used by default
73 0         0         LWP::Protocol::implementor('http', 'LWP::Protocol::http');
74                 };
75             }
76              
77 6     6   125 use vars qw(@EXPORT @ISA $RedirectOK $DebugLWP);
  6         100  
  6         105  
78              
79             require Exporter;
80             *import = \&Exporter::import;
81             @EXPORT = @HTTP::Request::Common::EXPORT;
82              
83             @ISA = qw(LWP::UserAgent);
84              
85             my $UA;
86             my $REDIR = $have_lwp ? undef : 1;
87              
88             sub module {
89 0     0 0 0     my $module = shift;
90 0 0       0     $Apache::TestRequest::Module = $module if $module;
91 0         0     $Apache::TestRequest::Module;
92             }
93              
94             sub scheme {
95 0     0 0 0     my $scheme = shift;
96 0 0       0     $Apache::TestRequest::Scheme = $scheme if $scheme;
97 0         0     $Apache::TestRequest::Scheme;
98             }
99              
100             sub module2path {
101 0     0 1 0     my $package = shift;
102              
103             # httpd (1.3 && 2) / winFU have problems when the first path's
104             # segment includes ':' (security precaution which breaks the rfc)
105             # so we can't use /TestFoo::bar as path_info
106 0         0     (my $path = $package) =~ s/::/__/g;
107              
108 0         0     return $path;
109             }
110              
111             sub module2url {
112 0     0 1 0     my $module = shift;
113 0   0     0     my $opt = shift || {};
114 0   0     0     my $scheme = $opt->{scheme} || 'http';
115 0 0       0     my $path = exists $opt->{path} ? $opt->{path} : module2path($module);
116              
117 0         0     module($module);
118              
119 0         0     my $config = Apache::Test::config();
120 0         0     my $hostport = hostport($config);
121              
122 0         0     $path =~ s|^/||;
123 0         0     return "$scheme://$hostport/$path";
124             }
125              
126             sub user_agent {
127 17     17 0 333     my $args = {@_};
128              
129 17 100       3417     if (delete $args->{reset}) {
130 1         11         $UA = undef;
131                 }
132              
133 17 100       246     if (exists $args->{requests_redirectable}) {
134 1         12         my $redir = $args->{requests_redirectable};
135 1 50 0     17         if (ref $redir and (@$redir > 1 or $redir->[0] ne 'POST')) {
    50 33        
136             # Set our internal flag if there's no LWP.
137 0 0       0             $REDIR = $have_lwp ? undef : 1;
138                     } elsif ($redir) {
139 0 0       0             if ($have_lwp) {
140 0         0                 $args->{requests_redirectable} = [ qw/GET HEAD POST/ ];
141 0         0                 $REDIR = undef;
142                         } else {
143             # Set our internal flag.
144 0         0                 $REDIR = 1;
145                         }
146                     } else {
147             # Make sure our internal flag is false if there's no LWP.
148 1 50       12             $REDIR = $have_lwp ? undef : 0;
149                     }
150                 }
151              
152 17   33     331     $args->{keep_alive} ||= $ENV{APACHE_TEST_HTTP11};
153              
154 17 50       210     if ($args->{keep_alive}) {
155 0         0         install_http11();
156 0         0         eval {
157 0         0             require LWP::Protocol::https; #https10 is the default
158 0         0             LWP::Protocol::implementor('https', 'LWP::Protocol::https');
159                     };
160                 }
161              
162 17   66     450     eval { $UA ||= __PACKAGE__->new(%$args); };
  17         730  
163             }
164              
165             sub user_agent_request_num {
166 0     0 0 0     my $res = shift;
167 0 0       0     $res->header('Client-Request-Num') || #lwp 5.60
168                     $res->header('Client-Response-Num'); #lwp 5.62+
169             }
170              
171             sub user_agent_keepalive {
172 0     0 0 0     $ENV{APACHE_TEST_HTTP11} = shift;
173             }
174              
175             sub do_request {
176 0     0 0 0     my($ua, $method, $url, $callback) = @_;
177 0         0     my $r = HTTP::Request->new($method, resolve_url($url));
178 0         0     my $response = $ua->request($r, $callback);
179 0         0     lwp_trace($response);
180             }
181              
182             sub hostport {
183 15   33 15 0 331     my $config = shift || Apache::Test::config();
184 15         1731     my $vars = $config->{vars};
185 15   33     230     local $vars->{scheme} =
186                     $Apache::TestRequest::Scheme || $vars->{scheme};
187 15         454     my $hostport = $config->hostport;
188              
189 15         227     my $default_hostport = join ':', $vars->{servername}, $vars->{port};
190 15 50       159     if (my $module = $Apache::TestRequest::Module) {
191 0 0       0         $hostport = $module eq 'default'
192                         ? $default_hostport
193                         : $config->{vhosts}->{$module}->{hostport};
194                 }
195              
196 15 50       200     $hostport || $default_hostport;
197             }
198              
199             sub resolve_url {
200 15     15 0 254     my $url = shift;
201 15 50       163     Carp::croak("no url passed") unless defined $url;
202              
203 15 50       262     return $url if $url =~ m,^(\w+):/,;
204 15 50       189     $url = "/$url" unless $url =~ m,^/,;
205              
206 15         239     my $vars = Apache::Test::vars();
207              
208 15   33     1181     local $vars->{scheme} =
      50        
209                   $Apache::TestRequest::Scheme || $vars->{scheme} || 'http';
210              
211 15         324     scheme_fixup($vars->{scheme});
212              
213 15         247     my $hostport = hostport();
214              
215 15         1924     return "$vars->{scheme}://$hostport$url";
216             }
217              
218             my %wanted_args = map {$_, 1} qw(username password realm content filename
219             redirect_ok cert);
220              
221             sub wanted_args {
222 0     0 0 0     \%wanted_args;
223             }
224              
225             sub redirect_ok {
226 3     3 1 424     my $self = shift;
227 3 50       36     if ($have_lwp) {
228             # Return user setting or let LWP handle it.
229 3 100       32         return $RedirectOK if defined $RedirectOK;
230 2         81         return $self->SUPER::redirect_ok(@_);
231                 }
232              
233             # No LWP. We don't support redirect on POST.
234 0 0       0     return 0 if $self->method eq 'POST';
235             # Return user setting or our internal calculation.
236 0 0       0     return $RedirectOK if defined $RedirectOK;
237 0         0     return $REDIR;
238             }
239              
240             my %credentials;
241              
242             #subclass LWP::UserAgent
243             sub new {
244 5     5 1 740     my $self = shift->SUPER::new(@_);
245              
246 5         1756     lwp_debug(); #init from %ENV (set by Apache::TestRun)
247              
248 5         69     my $config = Apache::Test::config();
249 5 50       2194     if (my $proxy = $config->configure_proxy) {
250             #t/TEST -proxy
251 0         0         $self->proxy(http => "http://$proxy");
252                 }
253              
254 5         348     $self->timeout(UA_TIMEOUT);
255              
256 5         753     $self;
257             }
258              
259             sub get_basic_credentials {
260 0     0 1 0     my($self, $realm, $uri, $proxy) = @_;
261              
262 0         0     for ($realm, '__ALL__') {
263 0 0       0         next unless $credentials{$_};
264 0         0         return @{ $credentials{$_} };
  0         0  
265                 }
266              
267 0         0     return (undef,undef);
268             }
269              
270             sub vhost_socket {
271 0     0 0 0     my $module = shift;
272 0 0       0     local $Apache::TestRequest::Module = $module if $module;
273              
274 0         0     my $hostport = hostport(Apache::Test::config());
275              
276 0         0     my($host, $port) = split ':', $hostport;
277 0         0     my(%args) = (PeerAddr => $host, PeerPort => $port);
278              
279 0 0 0     0     if ($module and $module =~ /ssl/) {
280 0         0         require Net::SSL;
281 0   0     0         local $ENV{https_proxy} ||= ""; #else uninitialized value in Net/SSL.pm
282 0         0         return Net::SSL->new(%args, Timeout => UA_TIMEOUT);
283                 }
284                 else {
285 0         0         require IO::Socket;
286 0         0         return IO::Socket::INET->new(%args);
287                 }
288             }
289              
290             #Net::SSL::getline is nothing like IO::Handle::getline
291             #could care less about performance here, just need a getline()
292             #that returns the same results with or without ssl
293             my %getline = (
294                 'Net::SSL' => sub {
295                     my $self = shift;
296                     my $buf = '';
297                     my $c = '';
298                     do {
299                         $self->read($c, 1);
300                         $buf .= $c;
301                     } until ($c eq "\n");
302                     $buf;
303                 },
304             );
305              
306             sub getline {
307 0     0 0 0     my $sock = shift;
308 0         0     my $class = ref $sock;
309 0   0     0     my $method = $getline{$class} || 'getline';
310 0         0     $sock->$method();
311             }
312              
313             sub socket_trace {
314 0     0 0 0     my $sock = shift;
315 0 0       0     return unless $sock->can('get_peer_certificate');
316              
317             #like having some -v info
318 0         0     my $cert = $sock->get_peer_certificate;
319 0         0     print "#Cipher: ", $sock->get_cipher, "\n";
320 0         0     print "#Peer DN: ", $cert->subject_name, "\n";
321             }
322              
323             sub prepare {
324 15     15 0 190     my $url = shift;
325              
326 15 50       4391     if ($have_lwp) {
327 15         2101         user_agent();
328 15         1584         $url = resolve_url($url);
329                 }
330                 else {
331 0 0       0         lwp_debug() if $ENV{APACHE_TEST_DEBUG_LWP};
332                 }
333              
334 15         336     my($pass, $keep) = Apache::TestConfig::filter_args(\@_, \%wanted_args);
335              
336 15         150     %credentials = ();
337 15 100       166     if (defined $keep->{username}) {
338 1   50     19         $credentials{$keep->{realm} || '__ALL__'} =
339                       [$keep->{username}, $keep->{password}];
340                 }
341 15 50       162     if (defined(my $content = $keep->{content})) {
342 0 0       0         if ($content eq '-') {
    0          
343 0         0             $content = join '', <STDIN>;
344                     }
345                     elsif ($content =~ /^x(\d+)$/) {
346 0         0             $content = 'a' x $1;
347                     }
348 0         0         push @$pass, content => $content;
349                 }
350 15 50       221     if ($keep->{cert}) {
351 0         0         set_client_cert($keep->{cert});
352                 }
353              
354 15         288     return ($url, $pass, $keep);
355             }
356              
357             sub UPLOAD {
358 0     0 1 0     my($url, $pass, $keep) = prepare(@_);
359              
360 0 0       0     local $RedirectOK = exists $keep->{redirect_ok}
361                     ? $keep->{redirect_ok}
362                     : $RedirectOK;
363              
364 0 0       0     if ($keep->{filename}) {
365 0         0         return upload_file($url, $keep->{filename}, $pass);
366                 }
367                 else {
368 0         0         return upload_string($url, $keep->{content});
369                 }
370             }
371              
372             sub UPLOAD_BODY {
373 0     0 1 0     UPLOAD(@_)->content;
374             }
375              
376             sub UPLOAD_BODY_ASSERT {
377 0     0 1 0     content_assert(UPLOAD(@_));
378             }
379              
380             #lwp only supports files
381             sub upload_string {
382 0     0 0 0     my($url, $data) = @_;
383              
384 0         0     my $CRLF = "\015\012";
385 0         0     my $bound = 742617000027;
386 0         0     my $req = HTTP::Request->new(POST => $url);
387              
388 0         0     my $content = join $CRLF,
389                   "--$bound",
390                   "Content-Disposition: form-data; name=\"HTTPUPLOAD\"; filename=\"b\"",
391                   "Content-Type: text/plain", "",
392                   $data, "--$bound--", "";
393              
394 0         0     $req->header("Content-Length", length($content));
395 0         0     $req->content_type("multipart/form-data; boundary=$bound");
396 0         0     $req->content($content);
397              
398 0         0     $UA->request($req);
399             }
400              
401             sub upload_file {
402 0     0 0 0     my($url, $file, $args) = @_;
403              
404 0         0     my $content = [@$args, filename => [$file]];
405              
406 0         0     $UA->request(HTTP::Request::Common::POST($url,
407                              Content_Type => 'form-data',
408                              Content => $content,
409                 ));
410             }
411              
412             #useful for POST_HEAD and $DebugLWP (see below)
413             sub lwp_as_string {
414 0     0 0 0     my($r, $want_body) = @_;
415 0         0     my $content = $r->content;
416              
417 0 0 0     0     unless ($r->isa('HTTP::Request') or
      0        
418                         $r->header('Content-Length') or
419                         $r->header('Transfer-Encoding'))
420                 {
421 0         0         $r->header('Content-Length' => length $content);
422 0         0         $r->header('X-Content-length-note' => 'added by Apache::TestRequest');
423                 }
424              
425 0 0       0     $r->content('') unless $want_body;
426              
427 0         0     (my $string = $r->as_string) =~ s/^/\#/mg;
428 0         0     $r->content($content); #reset
429 0         0     $string;
430             }
431              
432             $DebugLWP = 0; #1 == print METHOD URL and header response for all requests
433             #2 == #1 + response body
434             #other == passed to LWP::Debug->import
435              
436             sub lwp_debug {
437                 package main; #wtf: else package in perldb changes
438 5   33 5 0 154     my $val = $_[0] || $ENV{APACHE_TEST_DEBUG_LWP};
439              
440 5 50       61     return unless $val;
441              
442 0 0       0     if ($val =~ /^\d+$/) {
443 0         0         $Apache::TestRequest::DebugLWP = $val;
444 0         0         return "\$Apache::TestRequest::DebugLWP = $val\n";
445                 }
446                 else {
447 0 0       0         my(@args) = @_ ? @_ : split /\s+/, $val;
448 0         0         require LWP::Debug;
449 0         0         LWP::Debug->import(@args);
450 0         0         return "LWP::Debug->import(@args)\n";
451                 }
452             }
453              
454             sub lwp_trace {
455 0     0 0 0     my $r = shift;
456              
457 0 0       0     unless ($r->request->protocol) {
458             #lwp always sends a request, but never sets
459             #$r->request->protocol, happens deeper in the
460             #LWP::Protocol::http* modules
461 0 0       0         my $proto = user_agent_request_num($r) ? "1.1" : "1.0";
462 0         0         $r->request->protocol("HTTP/$proto");
463                 }
464              
465 0         0     my $want_body = $DebugLWP > 1;
466 0         0     print "#lwp request:\n",
467                   lwp_as_string($r->request, $want_body);
468              
469 0         0     print "#server response:\n",
470                   lwp_as_string($r, $want_body);
471             }
472              
473             sub lwp_call {
474 27     27 0 364     my($name, $shortcut) = (shift, shift);
475              
476 27         269     my $r = (\&{$name})->(@_);
  27         891  
477              
478 27 50       8285     Carp::croak("$name(@_) didn't return a response object") unless $r;
479              
480 27         265     my $error = "";
481 27 100       1847     unless ($shortcut) {
482             #GET, HEAD, POST
483 15 50 33     209         if ($r->method eq "POST" && !defined($r->header("Content-Length"))) {
484 0         0             $r->header('Content-Length' => length($r->content));
485                     }
486 15 50       1072         $r = $UA ? $UA->request($r) : $r;
487 15         3624         my $proto = $r->protocol;
488 15 100       509         if (defined($proto)) {
489 14 50       284             if ($proto !~ /^HTTP\/(\d\.\d)$/) {
490 0         0                 $error = "response had no protocol (is LWP broken or something?)";
491                         }
492 14 50 33     2926             if ($1 ne "1.0" && $1 ne "1.1") {
493 0 0 0     0                 $error = "response had protocol HTTP/$1 (headers not sent?)"
494                                 unless ($1 eq "0.9" && $ENV{APACHE_TEST_HTTP_09_OK});
495                         }
496                     }
497                 }
498              
499 27 50 33     319     if ($DebugLWP and not $shortcut) {
500 0         0         lwp_trace($r);
501                 }
502              
503 27 50       263     Carp::croak($error) if $error;
504              
505 27 100       654     return $shortcut ? $r->$shortcut() : $r;
506             }
507              
508             my %shortcuts = (RC => sub { shift->code },
509                              OK => sub { shift->is_success },
510                              STR => sub { shift->as_string },
511                              HEAD => sub { lwp_as_string(shift, 0) },
512                              BODY => sub { shift->content },
513                              BODY_ASSERT => sub { content_assert(shift) },
514             );
515              
516             for my $name (@EXPORT) {
517                 my $package = $have_lwp ?
518                   'HTTP::Request::Common': 'Apache::TestClient';
519              
520                 my $method = join '::', $package, $name;
521 6     6   140     no strict 'refs';
  6         62  
  6         97  
522              
523                 next unless defined &$method;
524              
525                 *$name = sub {
526 15     15   333         my($url, $pass, $keep) = prepare(@_);
527 15 100       303         local $RedirectOK = exists $keep->{redirect_ok}
528                         ? $keep->{redirect_ok}
529                         : $RedirectOK;
530 15         414         return lwp_call($method, undef, $url, @$pass);
531                 };
532              
533                 while (my($shortcut, $cv) = each %shortcuts) {
534                     my $alias = join '_', $name, $shortcut;
535 12     12   255         *$alias = sub { lwp_call($name, $cv, @_) };
536                 }
537             }
538              
539             my @export_std = @EXPORT;
540             for my $method (@export_std) {
541                 push @EXPORT, map { join '_', $method, $_ } keys %shortcuts;
542             }
543              
544             push @EXPORT, qw(UPLOAD UPLOAD_BODY UPLOAD_BODY_ASSERT);
545              
546             sub to_string {
547 0     0 0 0     my $obj = shift;
548 0 0       0     ref($obj) ? $obj->as_string : $obj;
549             }
550              
551             # request an interpreter instance and use this interpreter id to
552             # select the same interpreter in requests below
553             sub same_interp_tie {
554 0     0 0 0     my($url) = @_;
555              
556 0         0     my $res = GET($url, INTERP_KEY, 'tie');
557 0 0       0     unless ($res->code == 200) {
558 0         0         die sprintf "failed to init the same_handler data (url=%s). " .
559                         "Failed with code=%s, response:\n%s",
560                             $url, $res->code, $res->content;
561                 }
562 0         0     my $same_interp = $res->header(INTERP_KEY);
563              
564 0         0     return $same_interp;
565             }
566              
567             # run the request though the selected perl interpreter, by polling
568             # until we found it
569             # currently supports only GET, HEAD, PUT, POST subs
570             sub same_interp_do {
571 0     0 0 0     my($same_interp, $sub, $url, @args) = @_;
572              
573 0 0 0     0     die "must pass an interpreter id, obtained via same_interp_tie()"
574                     unless defined $same_interp and $same_interp;
575              
576 0         0     push @args, (INTERP_KEY, $same_interp);
577              
578 0         0     my $res = '';
579 0         0     my $times = 0;
580 0         0     my $found_same_interp = '';
581 0         0     do {
582             #loop until we get a response from our interpreter instance
583 0         0         $res = $sub->($url, @args);
584 0 0       0         die "no result" unless $res;
585 0         0         my $code = $res->code;
586 0 0       0         if ($code == 200) {
    0          
587 0   0     0             $found_same_interp = $res->header(INTERP_KEY) || '';
588                     }
589                     elsif ($code == 404) {
590             # try again
591                     }
592                     else {
593 0         0             die sprintf "failed to run the request (url=%s):\n" .
594                             "code=%s, response:\n%s", $url, $code, $res->content;
595                     }
596              
597 0 0       0         unless ($found_same_interp eq $same_interp) {
598 0         0             $found_same_interp = '';
599                     }
600              
601 0 0       0         if ($times++ > TRY_TIMES) { #prevent endless loop
602 0         0             die "unable to find interp $same_interp\n";
603                     }
604                 } until ($found_same_interp);
605              
606 0 0       0     return $found_same_interp ? $res : undef;
607             }
608              
609              
610             sub set_client_cert {
611 0     0 0 0     my $name = shift;
612 0         0     my $vars = Apache::Test::vars();
613 0         0     my $dir = join '/', $vars->{sslca}, $vars->{sslcaorg};
614              
615 0 0       0     if ($name) {
616 0         0         $ENV{HTTPS_CERT_FILE} = "$dir/certs/$name.crt";
617 0         0         $ENV{HTTPS_KEY_FILE} = "$dir/keys/$name.pem";
618                 }
619                 else {
620 0         0         for (qw(CERT KEY)) {
621 0         0             delete $ENV{"HTTPS_${_}_FILE"};
622                     }
623                 }
624             }
625              
626             #want news: urls to work with the LWP shortcuts
627             #but cant find a clean way to override the default nntp port
628             #by brute force we trick Net::NTTP into calling FixupNNTP::new
629             #instead of IO::Socket::INET::new, we fixup the args then forward
630             #to IO::Socket::INET::new
631              
632             #also want KeepAlive on for Net::HTTP
633             #XXX libwww-perl 5.53_xx has: LWP::UserAgent->new(keep_alive => 1);
634              
635             sub install_net_socket_new {
636 0     0 0 0     my($module, $code) = @_;
637              
638 0 0       0     return unless Apache::Test::have_module($module);
639              
640 6     6   115     no strict 'refs';
  6         59  
  6         87  
641              
642 0         0     my $new;
643 0         0     my $isa = \@{"$module\::ISA"};
  0         0  
644              
645 0         0     for (@$isa) {
646 0 0       0         last if $new = $_->can('new');
647                 }
648              
649 0         0     my $fixup_class = "Apache::TestRequest::$module";
650 0         0     unshift @$isa, $fixup_class;
651              
652 0         0     *{"$fixup_class\::new"} = sub {
653 0     0   0         my $class = shift;
654 0         0         my $args = {@_};
655 0         0         $code->($args);
656 0         0         return $new->($class, %$args);
657 0         0     };
658             }
659              
660             my %scheme_fixups = (
661                 'news' => sub {
662                     return if $INC{'Net/NNTP.pm'};
663                     eval {
664                         install_net_socket_new('Net::NNTP' => sub {
665                             my $args = shift;
666                             my($host, $port) = split ':',
667                               Apache::TestRequest::hostport();
668                             $args->{PeerPort} = $port;
669                             $args->{PeerAddr} = $host;
670                         });
671                     };
672                 },
673             );
674              
675             sub scheme_fixup {
676 15     15 0 134     my $scheme = shift;
677 15         137     my $fixup = $scheme_fixups{$scheme};
678 15 50       182     return unless $fixup;
679 0               $fixup->();
680             }
681              
682             # when the client side simply prints the response body which should
683             # include the test's output, we need to make sure that the request
684             # hasn't failed, or the test will be skipped instead of indicating the
685             # error.
686             sub content_assert {
687 0     0 0       my $res = shift;
688              
689 0 0             return $res->content if $res->is_success;
690              
691 0               die join "\n",
692                     "request has failed (the response code was: " . $res->code . ")",
693                     "see t/logs/error_log for more details\n";
694             }
695              
696             1;
697              
698             =head1 NAME
699            
700             Apache::TestRequest - Send requests to your Apache test server
701            
702             =head1 SYNOPSIS
703            
704             use Apache::Test qw(ok have_lwp);
705             use Apache::TestRequest qw(GET POST);
706             use Apache::Constants qw(HTTP_OK);
707            
708             plan tests => 1, have_lwp;
709            
710             my $res = GET '/test.html';
711             ok $res->code == HTTP_OK, "Request is ok";
712            
713             =head1 DESCRIPTION
714            
715             B<Apache::TestRequest> provides convenience functions to allow you to
716             make requests to your Apache test server in your test scripts. It
717             subclasses C<LWP::UserAgent>, so that you have access to all if its
718             methods, but also exports a number of useful functions likely useful
719             for majority of your test requests. Users of the old C<Apache::test>
720             (or C<Apache::testold>) module, take note! Herein lie most of the
721             functions you'll need to use to replace C<Apache::test> in your test
722             suites.
723            
724             Each of the functions exported by C<Apache::TestRequest> uses an
725             C<LWP::UserAgent> object to submit the request and retrieve its
726             results. The return value for many of these functions is an
727             HTTP::Response object. See L<HTTP::Response|HTTP::Response> for
728             documentation of its methods, which you can use in your tests. For
729             example, use the C<code()> and C<content()> methods to test the
730             response code and content of your request. Using C<GET>, you can
731             perform a couple of tests using these methods like this:
732            
733             use Apache::Test qw(ok have_lwp);
734             use Apache::TestRequest qw(GET POST);
735             use Apache::Constants qw(HTTP_OK);
736            
737             plan tests => 2, have_lwp;
738            
739             my $uri = "/test.html?foo=1&bar=2";
740             my $res = GET $uri;
741             ok $res->code == HTTP_OK, "Check that the request was OK";
742             ok $res->content eq "foo => 1, bar => 2", "Check its content";
743            
744             Note that you can also use C<Apache::TestRequest> with
745             C<Test::Builder> and its derivatives, including C<Test::More>:
746            
747             use Test::More;
748             # ...
749             is $res->code, HTTP_OK, "Check that the request was OK";
750             is $res->content, "foo => 1, bar => 2", "Check its content";
751            
752             =head1 CONFIGURATION FUNCTION
753            
754             You can tell C<Apache::TestRequest> what kind of C<LWP::UserAgent>
755             object to use for its convenience functions with C<user_agent()>. This
756             function uses its arguments to construct an internal global
757             C<LWP::UserAgent> object that will be used for all subsequent requests
758             made by the convenience functions. The arguments it takes are the same
759             as for the C<LWP::UserAgent> constructor. See the
760             C<L<LWP::UserAgent|LWP::UserAgent>> documentation for a complete list.
761            
762             The C<user_agent()> function only creates the internal
763             C<LWP::UserAgent> object the first time it is called. Since this
764             function is called internally by C<Apache::TestRequest>, you should
765             always use the C<reset> parameter to force it to create a new global
766             C<LWP::UserAgent> Object:
767            
768             Apache::TestRequest::user_agent(reset => 1, %params);
769            
770             C<user_agent()> differs from C<< LWP::UserAgent->new >> in two
771             additional ways. First, it supports an additional parameter,
772             C<keep_alive>, which enables connection persistence, where the same
773             connection is used to process multiple requests (and, according to the
774             C<L<LWP::UserAgent|LWP::UserAgent>> documentation, has the effect of
775             loading and enabling the new experimental HTTP/1.1 protocol module).
776            
777             And finally, the semantics of the C<requests_redirectable> parameter is
778             different than for C<LWP::UserAgent> in that you can pass it a boolean
779             value as well as an array for C<LWP::UserAgent>. To force
780             C<Apache::TestRequest> not to follow redirects in any of its convenience
781             functions, pass a false value to C<requests_redirectable>:
782            
783             Apache::TestRequest::user_agent(reset => 1,
784             requests_redirectable => 0);
785            
786             If LWP is not installed, then you can still pass in an array reference
787             as C<LWP::UserAgent> expects. C<Apache::TestRequest> will examine the
788             array and allow redirects if the array contains more than one value or
789             if there is only one value and that value is not "POST":
790            
791             # Always allow redirection.
792             my $redir = have_lwp() ? [qw(GET HEAD POST)] : 1;
793             Apache::TestRequest::user_agent(reset => 1,
794             requests_redirectable => $redir);
795            
796             But note that redirection will B<not> work with C<POST> unless LWP is
797             installed. It's best, therefore, to check C<have_lwp> before running
798             tests that rely on a redirection from C<POST>.
799            
800             Sometimes it is desireable to have C<Apache::TestRequest> remember
801             cookies sent by the pages you are testing and send them back to the
802             server on subsequent requests. This is especially necessary when
803             testing pages whose functionality relies on sessions or the presence
804             of preferences stored in cookies.
805            
806             By default, C<LWP::UserAgent> does B<not> remember cookies between
807             requests. You can tell it to remember cookies between request by
808             adding:
809            
810             Apache::TestRequest::user_agent(cookie_jar => {});
811            
812             before issuing the requests.
813            
814            
815             =head1 FUNCTIONS
816            
817             C<Apache::TestRequest> exports a number of functions that will likely
818             prove convenient for use in the majority of your request tests.
819            
820            
821            
822            
823             =head2 Optional Parameters
824            
825             Each function also takes a number of optional arguments.
826            
827             =over 4
828            
829             =item redirect_ok
830            
831             By default a request will follow redirects retrieved from the server. To
832             prevent this behavior, pass a false value to a C<redirect_ok>
833             parameter:
834            
835             my $res = GET $uri, redirect_ok => 0;
836            
837             Alternately, if all of your tests need to disable redirects, tell
838             C<Apache::TestRequest> to use an C<LWP::UserAgent> object that
839             disables redirects:
840            
841             Apache::TestRequest::user_agent( reset => 1,
842             requests_redirectable => 0 );
843            
844             =item cert
845            
846             If you need to force an SSL request to use a particular SSL
847             certificate, pass the name of the certificate via the C<cert>
848             parameter:
849            
850             my $res = GET $uri, cert => 'my_cert';
851            
852             =item content
853            
854             If you need to add content to your request, use the C<content>
855             parameter:
856            
857             my $res = GET $uri, content => 'hello world!';
858            
859             =item filename
860            
861             The name of a local file on the file system to be sent to the Apache
862             test server via C<UPLOAD()> and its friends.
863            
864             =back
865            
866             =head2 The Functions
867            
868             =head3 GET
869            
870             my $res = GET $uri;
871            
872             Sends a simple GET request to the Apache test server. Returns an
873             C<HTTP::Response> object.
874            
875             You can also supply additional headers to be sent with the request by
876             adding their name/value pairs after the C<url> parameter, for example:
877            
878             my $res = GET $url, 'Accept-Language' => 'de,en-us,en;q=0.5';
879            
880             =head3 GET_STR
881            
882             A shortcut function for C<GET($uri)-E<gt>as_string>.
883            
884             =head3 GET_BODY
885            
886             A shortcut function for C<GET($uri)-E<gt>content>.
887            
888             =head3 GET_BODY_ASSERT
889            
890             Use this function when your test is outputting content that you need
891             to check, and you want to make sure that the request was successful
892             before comparing the contents of the request. If the request was
893             unsuccessful, C<GET_BODY_ASSERT> will return an error
894             message. Otherwise it will simply return the content of the request
895             just as C<GET_BODY> would.
896            
897             =head3 GET_OK
898            
899             A shortcut function for C<GET($uri)-E<gt>is_success>.
900            
901             =head3 GET_RC
902            
903             A shortcut function for C<GET($uri)-E<gt>code>.
904            
905             =head3 GET_HEAD
906            
907             Throws out the content of the request, and returns the string
908             representation of the request. Since the body has been thrown out, the
909             representation will consist solely of the headers. Furthermore,
910             C<GET_HEAD> inserts a "#" at the beginning of each line of the return
911             string, so that the contents are suitable for printing to STDERR
912             during your tests without interfering with the workings of
913             C<Test::Harness>.
914            
915             =head3 HEAD
916            
917             my $res = HEAD $uri;
918            
919             Sends a HEAD request to the Apache test server. Returns an
920             C<HTTP::Response> object.
921            
922             =head3 HEAD_STR
923            
924             A shortcut function for C<HEAD($uri)-E<gt>as_string>.
925            
926             =head3 HEAD_BODY
927            
928             A shortcut function for C<HEAD($uri)-E<gt>content>. Of course, this
929             means that it will likely return nothing.
930            
931             =head3 HEAD_BODY_ASSERT
932            
933             Use this function when your test is outputting content that you need
934             to check, and you want to make sure that the request was successful
935             before comparing the contents of the request. If the request was
936             unsuccessful, C<HEAD_BODY_ASSERT> will return an error
937             message. Otherwise it will simply return the content of the request
938             just as C<HEAD_BODY> would.
939            
940             =head3 HEAD_OK
941            
942             A shortcut function for C<GET($uri)-E<gt>is_success>.
943            
944             =head3 HEAD_RC
945            
946             A shortcut function for C<GET($uri)-E<gt>code>.
947            
948             =head3 HEAD_HEAD
949            
950             Throws out the content of the request, and returns the string
951             representation of the request. Since the body has been thrown out, the
952             representation will consist solely of the headers. Furthermore,
953             C<GET_HEAD> inserts a "#" at the beginning of each line of the return
954             string, so that the contents are suitable for printing to STDERR
955             during your tests without interfering with the workings of
956             C<Test::Harness>.
957            
958             =head3 PUT
959            
960             my $res = PUT $uri;
961            
962             Sends a simple PUT request to the Apache test server. Returns an
963             C<HTTP::Response> object.
964            
965             =head3 PUT_STR
966            
967             A shortcut function for C<PUT($uri)-E<gt>as_string>.
968            
969             =head3 PUT_BODY
970            
971             A shortcut function for C<PUT($uri)-E<gt>content>.
972            
973             =head3 PUT_BODY_ASSERT
974            
975             Use this function when your test is outputting content that you need
976             to check, and you want to make sure that the request was successful
977             before comparing the contents of the request. If the request was
978             unsuccessful, C<PUT_BODY_ASSERT> will return an error
979             message. Otherwise it will simply return the content of the request
980             just as C<PUT_BODY> would.
981            
982             =head3 PUT_OK
983            
984             A shortcut function for C<PUT($uri)-E<gt>is_success>.
985            
986             =head3 PUT_RC
987            
988             A shortcut function for C<PUT($uri)-E<gt>code>.
989            
990             =head3 PUT_HEAD
991            
992             Throws out the content of the request, and returns the string
993             representation of the request. Since the body has been thrown out, the
994             representation will consist solely of the headers. Furthermore,
995             C<PUT_HEAD> inserts a "#" at the beginning of each line of the return
996             string, so that the contents are suitable for printing to STDERR
997             during your tests without interfering with the workings of
998             C<Test::Harness>.
999            
1000             =head3 POST
1001            
1002             my $res = POST $uri, [ arg => $val, arg2 => $val ];
1003            
1004             Sends a POST request to the Apache test server and returns an
1005             C<HTTP::Response> object. An array reference of parameters passed as
1006             the second argument will be submitted to the Apache test server as the
1007             POST content. Parameters corresponding to those documented in
1008             L<Optional Parameters|/Optional
1009             Parameters> can follow the optional array reference of parameters, or after
1010             C<$uri>.
1011            
1012             To upload a chunk of data, simply use:
1013            
1014             my $res = POST $uri, content => $data;
1015            
1016             =head3 POST_STR
1017            
1018             A shortcut function for C<POST($uri, @args)-E<gt>content>.
1019            
1020             =head3 POST_BODY
1021            
1022             A shortcut function for C<POST($uri, @args)-E<gt>content>.
1023            
1024             =head3 POST_BODY_ASSERT
1025            
1026             Use this function when your test is outputting content that you need
1027             to check, and you want to make sure that the request was successful
1028             before comparing the contents of the request. If the request was
1029             unsuccessful, C<POST_BODY_ASSERT> will return an error
1030             message. Otherwise it will simply return the content of the request
1031             just as C<POST_BODY> would.
1032            
1033             =head3 POST_OK
1034            
1035             A shortcut function for C<POST($uri, @args)-E<gt>is_success>.
1036            
1037             =head3 POST_RC
1038            
1039             A shortcut function for C<POST($uri, @args)-E<gt>code>.
1040            
1041             =head3 POST_HEAD
1042            
1043             Throws out the content of the request, and returns the string
1044             representation of the request. Since the body has been thrown out, the
1045             representation will consist solely of the headers. Furthermore,
1046             C<POST_HEAD> inserts a "#" at the beginning of each line of the return
1047             string, so that the contents are suitable for printing to STDERR
1048             during your tests without interfering with the workings of
1049             C<Test::Harness>.
1050            
1051             =head3 UPLOAD
1052            
1053             my $res = UPLOAD $uri, \@args, filename => $filename;
1054            
1055             Sends a request to the Apache test server that includes an uploaded
1056             file. Other POST parameters can be passed as a second argument as an
1057             array reference.
1058            
1059             C<Apache::TestRequest> will read in the contents of the file named via
1060             the C<filename> parameter for submission to the server. If you'd
1061             rather, you can submit use the C<content> parameter instead of
1062             C<filename>, and its value will be submitted to the Apache server as
1063             file contents:
1064            
1065             my $res = UPLOAD $uri, undef, content => "This is file content";
1066            
1067             The name of the file sent to the server will simply be "b". Note that
1068             in this case, you cannot pass other POST arguments to C<UPLOAD()> --
1069             they would be ignored.
1070            
1071             =head3 UPLOAD_BODY
1072            
1073             A shortcut function for C<UPLOAD($uri, @params)-E<gt>content>.
1074            
1075             =head3 UPLOAD_BODY_ASSERT
1076            
1077             Use this function when your test is outputting content that you need
1078             to check, and you want to make sure that the request was successful
1079             before comparing the contents of the request. If the request was
1080             unsuccessful, C<UPLOAD_BODY_ASSERT> will return an error
1081             message. Otherwise it will simply return the content of the request
1082             just as C<UPLOAD_BODY> would.
1083            
1084             =head3 OPTIONS
1085            
1086             my $res = OPTIONS $uri;
1087            
1088             Sends an C<OPTIONS> request to the Apache test server. Returns an
1089             C<HTTP::Response> object with the I<Allow> header, indicating which
1090             methods the server supports. Possible methods include C<OPTIONS>,
1091             C<GET>, C<HEAD> and C<POST>. This function thus can be useful for
1092             testing what options the Apache server supports. Consult the HTTPD 1.1
1093             specification, section 9.2, at
1094             I<http://www.faqs.org/rfcs/rfc2616.html> for more information.
1095            
1096            
1097            
1098            
1099            
1100             =head2 URL Manipulation Functions
1101            
1102             C<Apache::TestRequest> also includes a few helper functions to aid in
1103             the creation of urls used in the functions above.
1104            
1105            
1106            
1107             =head3 C<module2path>
1108            
1109             $path = Apache::TestRequest::module2path($module_name);
1110            
1111             Convert a module name to a path, safe for use in the various request
1112             methods above. e.g. C<::> can't be used in URLs on win32. For example:
1113            
1114             $path = Apache::TestRequest::module2path('Foo::Bar');
1115            
1116             returns:
1117            
1118             /Foo__Bar
1119            
1120            
1121            
1122            
1123             =head3 C<module2url>
1124            
1125             $url = Apache::TestRequest::module2url($module);
1126             $url = Apache::TestRequest::module2url($module, \%options);
1127            
1128             Convert a module name to a full URL including the current
1129             configurations C<hostname:port> and sets C<module> accordingly.
1130            
1131             $url = Apache::TestRequest::module2url('Foo::Bar');
1132            
1133             returns:
1134            
1135             http://$hostname:$port/Foo__Bar
1136            
1137             The default scheme used is C<http>. You can override this by passing
1138             your preferred scheme into an optional second param. For example:
1139            
1140             $module = 'MyTestModule::TestHandler';
1141             $url = Apache::TestRequest::module2url($module, {scheme => 'https'});
1142            
1143             returns:
1144            
1145             https://$hostname:$port/MyTestModule__TestHandler
1146            
1147             You may also override the default path with a path of your own:
1148            
1149             $module = 'MyTestModule::TestHandler';
1150             $url = Apache::TestRequest::module2url($module, {path => '/foo'});
1151            
1152             returns:
1153            
1154             http://$hostname:$port/foo
1155            
1156            
1157            
1158            
1159            
1160             =head1 ENVIRONMENT VARIABLES
1161            
1162             The following environment variables can affect the behavior of
1163             C<Apache::TestRequest>:
1164            
1165             =over
1166            
1167             =item APACHE_TEST_PRETEND_NO_LWP
1168            
1169             If the environment variable C<APACHE_TEST_PRETEND_NO_LWP> is set to a
1170             true value, C<Apache::TestRequest> will pretend that LWP is not
1171             available so one can test whether the test suite will survive on a
1172             system which doesn't have libwww-perl installed.
1173            
1174             =item APACHE_TEST_HTTP_09_OK
1175            
1176             If the environment variable C<APACHE_TEST_HTTP_09_OK> is set to a
1177             true value, C<Apache::TestRequest> will allow HTTP/0.9 responses
1178             from the server to proceed. The default behavior is to die if
1179             the response protocol is not either HTTP/1.0 or HTTP/1.1.
1180            
1181             =back
1182            
1183             =head1 SEE ALSO
1184            
1185             L<Apache::Test|Apache::Test> is the main Apache testing module. Use it
1186             to set up your tests, create a plan, and to ensure that you have the
1187             Apache version and modules you need.
1188            
1189             Use L<Apache::TestMM|Apache::TestMM> in your I<Makefile.PL> to set up
1190             your distribution for testing.
1191            
1192             =head1 AUTHOR
1193            
1194             Doug MacEachern with contributions from Geoffrey Young, Philippe
1195             M. Chiasson, Stas Bekman and others. Documentation by David Wheeler.
1196            
1197             Questions can be asked at the test-dev <at> httpd.apache.org list. For
1198             more information see: I<http://httpd.apache.org/test/> and
1199             I<http://perl.apache.org/docs/general/testing/testing.html>.
1200