X-Git-Url: http://git.maemo.org/git/?p=dh-make-perl;a=blobdiff_plain;f=dev%2Farm%2Flibwww-perl%2Flibwww-perl-5.813%2Fdebian%2Flibwww-perl%2Fusr%2Fshare%2Fperl5%2FLWP%2FProtocol%2Fhttp10.pm;fp=dev%2Farm%2Flibwww-perl%2Flibwww-perl-5.813%2Fdebian%2Flibwww-perl%2Fusr%2Fshare%2Fperl5%2FLWP%2FProtocol%2Fhttp10.pm;h=e338f24047e40e16f91882a9ee7d242ae70ef6a4;hp=0000000000000000000000000000000000000000;hb=f477fa73365d491991707e7ed9217b48d6994551;hpb=da95c414033799c3a62606f299c3c00b5c77ca11

diff --git a/dev/arm/libwww-perl/libwww-perl-5.813/debian/libwww-perl/usr/share/perl5/LWP/Protocol/http10.pm b/dev/arm/libwww-perl/libwww-perl-5.813/debian/libwww-perl/usr/share/perl5/LWP/Protocol/http10.pm
new file mode 100644
index 0000000..e338f24
--- /dev/null
+++ b/dev/arm/libwww-perl/libwww-perl-5.813/debian/libwww-perl/usr/share/perl5/LWP/Protocol/http10.pm
@@ -0,0 +1,303 @@
+package LWP::Protocol::http10;
+
+use strict;
+
+require LWP::Debug;
+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) = @_;
+    LWP::Debug::trace('()');
+
+    $size ||= 4096;
+
+    # check method
+    my $method = $request->method;
+    unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
+	return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
+				  'Library does not allow method ' .
+				  "$method for 'http:' URLs";
+    }
+
+    my $url = $request->url;
+    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;
+    }
+    LWP::Debug::conns($buf);
+
+    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;
+	    }
+	    LWP::Debug::conns($buf);
+	}
+    }
+    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;
+	}
+	LWP::Debug::conns($$cont_ref);
+    }
+
+    # read response line from server
+    LWP::Debug::debug('reading response');
+
+    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;
+	LWP::Debug::conns($buf);
+
+	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$//;
+	    LWP::Debug::debug("$ver $code $msg");
+	    $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...
+		LWP::Debug::debug("need more header data");
+		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;
+		LWP::Debug::conns(substr($buf, $old_len));
+	    }
+
+	    # 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
+	    LWP::Debug::debug("HTTP/0.9 assume OK");
+	    $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+	    $response->protocol('HTTP/0.9');
+	    last;
+
+	}
+	else {
+	    # need more data
+	    LWP::Debug::debug("need more status line 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);
+	#LWP::Debug::conns($buf);
+	return \$buf;
+	} );
+
+    #$socket->close;
+
+    $response;
+}
+
+1;