File Coverage

blib/lib/LWP/Protocol/http/SocksChain10.pm
Criterion Covered Total %
statement 9 131 6.8
branch 0 74 0.0
condition 0 51 0.0
subroutine 3 10 30.0
pod 1 1 100.0
total 13 267 4.8


line stmt bran cond sub pod time code
1             ########################################################################
2             #
3             # $Id: SocksChain10.pm,v 1.7 2009-12-28 15:12:16 gosha Exp $
4             #
5             # Copyright (C) Igor V. Okunev goshaprv.mts-nn.ru 2005 - 2009
6             #
7             # All rights reserved. This library is free software;
8             # you can redistribute it and/or modify it under the
9             # same terms as Perl itself.
10             #
11             ########################################################################
12              
13             package LWP::Protocol::http::SocksChain10;
14              
15 1     1   24700 use strict;
  1         2  
  1         40  
16 1     1   6 use vars qw( @ISA $VERSION @EXTRA_SOCK_OPTS );
  1         2  
  1         70  
17              
18 1     1   1001 use Net::SC;
  1         61182  
  1         1976  
19              
20             require HTTP::Response;
21             require HTTP::Status;
22             require IO::Select;
23             require LWP::Protocol;
24              
25             ($VERSION='$Revision: 1.7 $')=~s/^\S+\s+(\S+)\s+.*/$1/;
26              
27             local $^W = 1;
28              
29             @ISA = qw(LWP::Protocol);
30              
31             my $CRLF = "\015\012";
32              
33             sub _new_socket
34             {
35 0     0     my($self, $host, $port, $timeout ) = @_;
36              
37              
38 0   0       my $sc = Net::SC->new( TimeOut => $timeout,
39             $self->_extra_sock_opts($host, $port),
40             ) || die $!;
41              
42 0 0         unless ( ( my $rc = $sc->connect( $host, $port ) ) == SOCKS_OKAY ) {
43 0           die socks_error($rc) . "\n";
44             }
45              
46 0   0       my $sock = $sc->sh || die $!;
47              
48 0 0         unless ($sock) {
49             # IO::Socket leaves additional error messages in $@
50 0           $@ =~ s/^.*?: //;
51 0           die "Can't connect to $host:$port ($@)";
52             }
53              
54             # perl 5.005's IO::Socket does not have the blocking method.
55 0           eval { $sock->blocking(0); };
  0            
56              
57 0           return $sock;
58             }
59              
60             sub _extra_sock_opts # to be overridden by subclass
61             {
62 0     0     return @EXTRA_SOCK_OPTS;
63             }
64              
65              
66             sub _check_sock
67 0     0     {
68             #my($self, $req, $sock) = @_;
69             }
70              
71             sub _get_sock_info
72             {
73 0     0     my($self, $res, $sock) = @_;
74              
75 0 0         if (defined(my $peerhost = $sock->peerhost)) {
76 0           $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
77             }
78             }
79              
80             sub _fixup_header
81             {
82 0     0     my($self, $h, $url) = @_;
83              
84 0           $h->remove_header('Connection'); # need support here to be useful
85              
86             # HTTP/1.1 will require us to send the 'Host' header, so we might
87             # as well start now.
88 0           my $hhost = $url->authority;
89            
90 0           $hhost =~ s/^([^\@]*)\@//; # get rid of potential "user:pass@"
91 0 0         $h->header('Host' => $hhost) unless defined $h->header('Host');
92              
93             # add authorization header if we need them. HTTP URLs do
94             # not really support specification of user and password, but
95             # we allow it.
96 0 0 0       if (defined($1) && not $h->header('Authorization')) {
97 0           require URI::Escape;
98 0           $h->authorization_basic(map URI::Escape::uri_unescape($_),
99             split(":", $1, 2));
100             }
101             }
102              
103              
104             sub request
105             {
106 0     0 1   my($self, $request, undef, $arg, $size, $timeout) = @_;
107              
108 0   0       $size ||= 4096;
109              
110             # check method
111 0           my $method = $request->method;
112              
113 0 0         unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
114 0           return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
115             'Library does not allow method ' .
116             "$method for 'http:' URLs";
117             }
118              
119 0           my $url = $request->url;
120              
121 0           my $host = $url->host;
122 0           my $port = $url->port;
123 0           my $fullpath = $url->path_query;
124              
125 0 0         $fullpath = "/" unless length $fullpath;
126              
127             # connect to remote site
128 0           my $socket = $self->_new_socket( $host, $port, $timeout );
129              
130 0           $self->_check_sock($request, $socket);
131              
132 0 0         my $sel = IO::Select->new($socket) if $timeout;
133              
134 0           my $request_line = "$method $fullpath HTTP/1.0$CRLF";
135              
136 0           my $h = $request->headers->clone;
137 0           my $cont_ref = $request->content_ref;
138              
139 0 0         $cont_ref = $$cont_ref if ref($$cont_ref);
140            
141 0           my $ctype = ref($cont_ref);
142              
143             # If we're sending content we *have* to specify a content length
144             # otherwise the server won't know a messagebody is coming.
145 0 0         if ($ctype eq 'CODE') {
146 0 0 0       die 'No Content-Length header for request with dynamic content'
147             unless defined($h->header('Content-Length')) ||
148             $h->content_type =~ /^multipart\//;
149             # For HTTP/1.1 we could have used chunked transfer encoding...
150             } else {
151 0 0 0       $h->header('Content-Length' => length $$cont_ref)
152             if defined($$cont_ref) && length($$cont_ref);
153             }
154              
155 0           $self->_fixup_header($h, $url);
156              
157 0           my $buf = $request_line . $h->as_string($CRLF) . $CRLF;
158 0           my $n; # used for return value from syswrite/sysread
159             my $length;
160 0           my $offset;
161              
162             # syswrite $buf
163 0           $length = length($buf);
164 0           $offset = 0;
165            
166 0           while ( $offset < $length ) {
167 0 0 0       die "write timeout" if $timeout && !$sel->can_write($timeout);
168 0           $n = $socket->syswrite($buf, $length-$offset, $offset );
169 0 0         die $! unless defined($n);
170 0           $offset += $n;
171             }
172            
173 0 0 0       if ($ctype eq 'CODE') {
    0          
174 0   0       while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) {
175             # syswrite $buf
176 0           $length = length($buf);
177 0           $offset = 0;
178 0           while ( $offset < $length ) {
179 0 0 0       die "write timeout" if $timeout && !$sel->can_write($timeout);
180 0           $n = $socket->syswrite($buf, $length-$offset, $offset );
181 0 0         die $! unless defined($n);
182 0           $offset += $n;
183             }
184             }
185             } elsif (defined($$cont_ref) && length($$cont_ref)) {
186             # syswrite $$cont_ref
187 0           $length = length($$cont_ref);
188 0           $offset = 0;
189 0           while ( $offset < $length ) {
190 0 0 0       die "write timeout" if $timeout && !$sel->can_write($timeout);
191 0           $n = $socket->syswrite($$cont_ref, $length-$offset, $offset );
192 0 0         die $! unless defined($n);
193 0           $offset += $n;
194             }
195             }
196              
197             # read response line from server
198              
199 0           my $response;
200 0           $buf = '';
201              
202             # Inside this loop we will read the response line and all headers
203             # found in the response.
204 0           while (1) {
205 0 0 0       die "read timeout" if $timeout && !$sel->can_read($timeout);
206 0           $n = $socket->sysread($buf, $size, length($buf));
207 0 0         die $! unless defined($n);
208 0 0         die "unexpected EOF before status line seen" unless $n;
209              
210 0 0 0       if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) {
    0 0        
211             # HTTP/1.0 response or better
212 0           my($ver,$code,$msg) = ($1, $2, $3);
213 0           $msg =~ s/\015$//;
214 0           $response = HTTP::Response->new($code, $msg);
215 0           $response->protocol($ver);
216              
217             # ensure that we have read all headers. The headers will be
218             # terminated by two blank lines
219 0   0       until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) {
220             # must read more if we can...
221 0 0 0       die "read timeout" if $timeout && !$sel->can_read($timeout);
222 0           my $old_len = length($buf);
223 0           $n = $socket->sysread($buf, $size, $old_len);
224 0 0         die $! unless defined($n);
225 0 0         die "unexpected EOF before all headers seen" unless $n;
226             }
227              
228             # now we start parsing the headers. The strategy is to
229             # remove one line at a time from the beginning of the header
230             # buffer ($res).
231 0           my($key, $val);
232 0           while ($buf =~ s/([^\012]*)\012//) {
233 0           my $line = $1;
234              
235             # if we need to restore as content when illegal headers
236             # are found.
237 0           my $save = "$line\012";
238            
239 0           $line =~ s/\015$//;
240 0 0         last unless length $line;
241              
242 0 0 0       if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) {
    0          
243 0 0         $response->push_header($key, $val) if $key;
244 0           ($key, $val) = ($1, $2);
245             } elsif ($line =~ /^\s+(.*)/ && $key) {
246 0           $val .= " $1";
247             } else {
248 0           $response->push_header("Client-Bad-Header-Line" => $line);
249             }
250             }
251 0 0         $response->push_header($key, $val) if $key;
252 0           last;
253            
254             } elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or
255             $buf =~ /\012/ ) {
256             # HTTP/0.9 or worse
257 0           $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
258 0           $response->protocol('HTTP/0.9');
259 0           last;
260              
261             } else {
262             # need more data
263             }
264             };
265 0           $response->request($request);
266 0           $self->_get_sock_info($response, $socket);
267              
268 0 0         if ($method eq "CONNECT") {
269 0           $response->{client_socket} = $socket; # so it can be picked up
270 0           $response->content($buf); # in case we read more than the headers
271 0           return $response;
272             }
273              
274 0           my $usebuf = length($buf) > 0;
275             $response = $self->collect($arg, $response, sub {
276 0 0   0     if ($usebuf) {
277 0           $usebuf = 0;
278 0           return \$buf;
279             }
280 0 0 0       die "read timeout" if $timeout && !$sel->can_read($timeout);
281 0           my $n = $socket->sysread($buf, $size);
282 0 0         die $! unless defined($n);
283 0           return \$buf;
284 0           } );
285              
286             # $socket->close;
287              
288 0           $response;
289             }
290              
291             1;
292              
293             __END__