diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm | 49 |
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 { |