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