summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm49
1 files changed, 39 insertions, 10 deletions
diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm b/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm
index 738e95f3347..98b58c54907 100644
--- a/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm
+++ b/Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm
@@ -5,7 +5,7 @@ require 5.005; # 4-arg substr
use strict;
use vars qw($VERSION);
-$VERSION = "6.00";
+$VERSION = "6.06";
my $CRLF = "\015\012"; # "\r\n" is not portable
@@ -233,6 +233,7 @@ sub my_read {
return length($_[0]);
}
else {
+ die "read timeout" unless $self->can_read;
return $self->sysread($_[0], $len);
}
}
@@ -255,15 +256,10 @@ sub my_readline {
# need to read more data to find a line ending
READ:
{
+ die "read timeout" unless $self->can_read;
my $n = $self->sysread($_, 1024, length);
unless (defined $n) {
- redo READ if $!{EINTR};
- if ($!{EAGAIN}) {
- # Hmm, we must be reading from a non-blocking socket
- # XXX Should really wait until this socket is readable,...
- select(undef, undef, undef, 0.1); # but this will do for now
- redo READ;
- }
+ redo READ if $!{EINTR} || $!{EAGAIN};
# if we have already accumulated some data let's at least
# return that as a line
die "$what read failed: $!" unless length;
@@ -284,6 +280,38 @@ sub my_readline {
}
+sub can_read {
+ my $self = shift;
+ return 1 unless defined(fileno($self));
+ return 1 if $self->isa('IO::Socket::SSL') && $self->pending;
+
+ # With no timeout, wait forever. An explict timeout of 0 can be
+ # used to just check if the socket is readable without waiting.
+ my $timeout = @_ ? shift : (${*$self}{io_socket_timeout} || undef);
+
+ my $fbits = '';
+ vec($fbits, fileno($self), 1) = 1;
+ SELECT:
+ {
+ my $before;
+ $before = time if $timeout;
+ my $nfound = select($fbits, undef, undef, $timeout);
+ if ($nfound < 0) {
+ if ($!{EINTR} || $!{EAGAIN}) {
+ # don't really think EAGAIN can happen here
+ if ($timeout) {
+ $timeout -= time - $before;
+ $timeout = 0 if $timeout < 0;
+ }
+ redo SELECT;
+ }
+ die "select failed: $!";
+ }
+ return $nfound > 0;
+ }
+}
+
+
sub _rbuf {
my $self = shift;
if (@_) {
@@ -415,6 +443,7 @@ sub read_entity_body {
my @te = split(/\s*,\s*/, lc($te));
die "Chunked must be last Transfer-Encoding '$te'"
unless pop(@te) eq "chunked";
+ pop(@te) while @te && $te[-1] eq "chunked"; # ignore repeated chunked spec
for (@te) {
if ($_ eq "deflate" && inflate_ok()) {
@@ -489,6 +518,7 @@ sub read_entity_body {
die "Bad chunk-size in HTTP response: $line";
}
$chunked = hex($1);
+ ${*$self}{'http_chunked'} = $chunked;
if ($chunked == 0) {
${*$self}{'http_trailers'} = [$self->_read_header_lines];
$$buf_ref = "";
@@ -536,8 +566,7 @@ sub read_entity_body {
my $n = $bytes;
$n = $size if $size && $size < $n;
$n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
- ${*$self}{'http_bytes'} = $bytes - $n;
+ ${*$self}{'http_bytes'} = defined $n ? $bytes - $n : $bytes;
return $n;
}
else {