summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm289
1 files changed, 0 insertions, 289 deletions
diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm
deleted file mode 100644
index 08ce9cf15af..00000000000
--- a/Master/tlpkg/tlperl/lib/LWP/Protocol/http10.pm
+++ /dev/null
@@ -1,289 +0,0 @@
-package LWP::Protocol::http10;
-
-use strict;
-
-require HTTP::Response;
-require HTTP::Status;
-require IO::Socket;
-require IO::Select;
-
-use vars qw(@ISA @EXTRA_SOCK_OPTS);
-
-require LWP::Protocol;
-@ISA = qw(LWP::Protocol);
-
-my $CRLF = "\015\012"; # how lines should be terminated;
- # "\r\n" is not correct on all systems, for
- # instance MacPerl defines it to "\012\015"
-
-sub _new_socket
-{
- my($self, $host, $port, $timeout) = @_;
-
- local($^W) = 0; # IO::Socket::INET can be noisy
- my $sock = IO::Socket::INET->new(PeerAddr => $host,
- PeerPort => $port,
- Proto => 'tcp',
- Timeout => $timeout,
- $self->_extra_sock_opts($host, $port),
- );
- unless ($sock) {
- # IO::Socket::INET leaves additional error messages in $@
- $@ =~ s/^.*?: //;
- die "Can't connect to $host:$port ($@)";
- }
- $sock;
-}
-
-sub _extra_sock_opts # to be overridden by subclass
-{
- return @EXTRA_SOCK_OPTS;
-}
-
-
-sub _check_sock
-{
- #my($self, $req, $sock) = @_;
-}
-
-sub _get_sock_info
-{
- my($self, $res, $sock) = @_;
- if (defined(my $peerhost = $sock->peerhost)) {
- $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
- }
-}
-
-sub _fixup_header
-{
- my($self, $h, $url, $proxy) = @_;
-
- $h->remove_header('Connection'); # need support here to be useful
-
- # HTTP/1.1 will require us to send the 'Host' header, so we might
- # as well start now.
- my $hhost = $url->authority;
- if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@"
- # add authorization header if we need them. HTTP URLs do
- # not really support specification of user and password, but
- # we allow it.
- if (defined($1) && not $h->header('Authorization')) {
- require URI::Escape;
- $h->authorization_basic(map URI::Escape::uri_unescape($_),
- split(":", $1, 2));
- }
- }
- $h->init_header('Host' => $hhost);
-
- if ($proxy) {
- # Check the proxy URI's userinfo() for proxy credentials
- # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
- my $p_auth = $proxy->userinfo();
- if(defined $p_auth) {
- require URI::Escape;
- $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
- split(":", $p_auth, 2))
- }
- }
-}
-
-
-sub request
-{
- my($self, $request, $proxy, $arg, $size, $timeout) = @_;
-
- $size ||= 4096;
-
- # check method
- my $method = $request->method;
- unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
- return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' .
- "$method for 'http:' URLs");
- }
-
- my $url = $request->uri;
- my($host, $port, $fullpath);
-
- # Check if we're proxy'ing
- if (defined $proxy) {
- # $proxy is an URL to an HTTP server which will proxy this request
- $host = $proxy->host;
- $port = $proxy->port;
- $fullpath = $method eq "CONNECT" ?
- ($url->host . ":" . $url->port) :
- $url->as_string;
- }
- else {
- $host = $url->host;
- $port = $url->port;
- $fullpath = $url->path_query;
- $fullpath = "/" unless length $fullpath;
- }
-
- # connect to remote site
- my $socket = $self->_new_socket($host, $port, $timeout);
- $self->_check_sock($request, $socket);
-
- my $sel = IO::Select->new($socket) if $timeout;
-
- my $request_line = "$method $fullpath HTTP/1.0$CRLF";
-
- my $h = $request->headers->clone;
- my $cont_ref = $request->content_ref;
- $cont_ref = $$cont_ref if ref($$cont_ref);
- my $ctype = ref($cont_ref);
-
- # If we're sending content we *have* to specify a content length
- # otherwise the server won't know a messagebody is coming.
- if ($ctype eq 'CODE') {
- die 'No Content-Length header for request with dynamic content'
- unless defined($h->header('Content-Length')) ||
- $h->content_type =~ /^multipart\//;
- # For HTTP/1.1 we could have used chunked transfer encoding...
- }
- else {
- $h->header('Content-Length' => length $$cont_ref)
- if defined($$cont_ref) && length($$cont_ref);
- }
-
- $self->_fixup_header($h, $url, $proxy);
-
- my $buf = $request_line . $h->as_string($CRLF) . $CRLF;
- my $n; # used for return value from syswrite/sysread
- my $length;
- my $offset;
-
- # syswrite $buf
- $length = length($buf);
- $offset = 0;
- while ( $offset < $length ) {
- die "write timeout" if $timeout && !$sel->can_write($timeout);
- $n = $socket->syswrite($buf, $length-$offset, $offset );
- die $! unless defined($n);
- $offset += $n;
- }
-
- if ($ctype eq 'CODE') {
- while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) {
- # syswrite $buf
- $length = length($buf);
- $offset = 0;
- while ( $offset < $length ) {
- die "write timeout" if $timeout && !$sel->can_write($timeout);
- $n = $socket->syswrite($buf, $length-$offset, $offset );
- die $! unless defined($n);
- $offset += $n;
- }
- }
- }
- elsif (defined($$cont_ref) && length($$cont_ref)) {
- # syswrite $$cont_ref
- $length = length($$cont_ref);
- $offset = 0;
- while ( $offset < $length ) {
- die "write timeout" if $timeout && !$sel->can_write($timeout);
- $n = $socket->syswrite($$cont_ref, $length-$offset, $offset );
- die $! unless defined($n);
- $offset += $n;
- }
- }
-
- # read response line from server
- my $response;
- $buf = '';
-
- # Inside this loop we will read the response line and all headers
- # found in the response.
- while (1) {
- die "read timeout" if $timeout && !$sel->can_read($timeout);
- $n = $socket->sysread($buf, $size, length($buf));
- die $! unless defined($n);
- die "unexpected EOF before status line seen" unless $n;
-
- if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) {
- # HTTP/1.0 response or better
- my($ver,$code,$msg) = ($1, $2, $3);
- $msg =~ s/\015$//;
- $response = HTTP::Response->new($code, $msg);
- $response->protocol($ver);
-
- # ensure that we have read all headers. The headers will be
- # terminated by two blank lines
- until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) {
- # must read more if we can...
- die "read timeout" if $timeout && !$sel->can_read($timeout);
- my $old_len = length($buf);
- $n = $socket->sysread($buf, $size, $old_len);
- die $! unless defined($n);
- die "unexpected EOF before all headers seen" unless $n;
- }
-
- # now we start parsing the headers. The strategy is to
- # remove one line at a time from the beginning of the header
- # buffer ($res).
- my($key, $val);
- while ($buf =~ s/([^\012]*)\012//) {
- my $line = $1;
-
- # if we need to restore as content when illegal headers
- # are found.
- my $save = "$line\012";
-
- $line =~ s/\015$//;
- last unless length $line;
-
- if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) {
- $response->push_header($key, $val) if $key;
- ($key, $val) = ($1, $2);
- }
- elsif ($line =~ /^\s+(.*)/ && $key) {
- $val .= " $1";
- }
- else {
- $response->push_header("Client-Bad-Header-Line" => $line);
- }
- }
- $response->push_header($key, $val) if $key;
- last;
-
- }
- elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or
- $buf =~ /\012/ ) {
- # HTTP/0.9 or worse
- $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
- $response->protocol('HTTP/0.9');
- last;
-
- }
- else {
- # need more data
- }
- };
- $response->request($request);
- $self->_get_sock_info($response, $socket);
-
- if ($method eq "CONNECT") {
- $response->{client_socket} = $socket; # so it can be picked up
- $response->content($buf); # in case we read more than the headers
- return $response;
- }
-
- my $usebuf = length($buf) > 0;
- $response = $self->collect($arg, $response, sub {
- if ($usebuf) {
- $usebuf = 0;
- return \$buf;
- }
- die "read timeout" if $timeout && !$sel->can_read($timeout);
- my $n = $socket->sysread($buf, $size);
- die $! unless defined($n);
- return \$buf;
- } );
-
- #$socket->close;
-
- $response;
-}
-
-1;