summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Net
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Net')
-rw-r--r--Master/tlpkg/tlperl/lib/Net/HTTP.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Net/HTTP/Methods.pm49
-rw-r--r--Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm6
-rw-r--r--Master/tlpkg/tlperl/lib/Net/HTTPS.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Net/Ping.pm82
5 files changed, 104 insertions, 37 deletions
diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP.pm b/Master/tlpkg/tlperl/lib/Net/HTTP.pm
index 1ee6db82a30..919e591e16c 100644
--- a/Master/tlpkg/tlperl/lib/Net/HTTP.pm
+++ b/Master/tlpkg/tlperl/lib/Net/HTTP.pm
@@ -3,7 +3,7 @@ package Net::HTTP;
use strict;
use vars qw($VERSION @ISA $SOCKET_CLASS);
-$VERSION = "6.03";
+$VERSION = "6.06";
unless ($SOCKET_CLASS) {
eval { require IO::Socket::INET } || require IO::Socket;
$SOCKET_CLASS = "IO::Socket::INET";
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 {
diff --git a/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm b/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm
index 78871116338..6049e054914 100644
--- a/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm
+++ b/Master/tlpkg/tlperl/lib/Net/HTTP/NB.pm
@@ -3,11 +3,15 @@ package Net::HTTP::NB;
use strict;
use vars qw($VERSION @ISA);
-$VERSION = "6.00";
+$VERSION = "6.04";
require Net::HTTP;
@ISA=qw(Net::HTTP);
+sub can_read {
+ return 1;
+}
+
sub sysread {
my $self = $_[0];
if (${*$self}{'httpnb_read_count'}++) {
diff --git a/Master/tlpkg/tlperl/lib/Net/HTTPS.pm b/Master/tlpkg/tlperl/lib/Net/HTTPS.pm
index 5ab56a7d43e..87ecf485f63 100644
--- a/Master/tlpkg/tlperl/lib/Net/HTTPS.pm
+++ b/Master/tlpkg/tlperl/lib/Net/HTTPS.pm
@@ -3,7 +3,7 @@ package Net::HTTPS;
use strict;
use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
-$VERSION = "6.02";
+$VERSION = "6.04";
# Figure out which SSL implementation to use
if ($SSL_SOCKET_CLASS) {
diff --git a/Master/tlpkg/tlperl/lib/Net/Ping.pm b/Master/tlpkg/tlperl/lib/Net/Ping.pm
index a7adf21bedf..1523af91dd3 100644
--- a/Master/tlpkg/tlperl/lib/Net/Ping.pm
+++ b/Master/tlpkg/tlperl/lib/Net/Ping.pm
@@ -8,18 +8,16 @@ use vars qw(@ISA @EXPORT $VERSION
$def_timeout $def_proto $def_factor
$max_datasize $pingstring $hires $source_verify $syn_forking);
use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
-use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
- inet_aton inet_ntoa sockaddr_in );
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR IPPROTO_IP IP_TOS IP_TTL
+ inet_aton getnameinfo NI_NUMERICHOST sockaddr_in );
use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
use FileHandle;
use Carp;
+use Time::HiRes;
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.38";
-
-sub SOL_IP { 0; };
-sub IP_TOS { 1; };
+$VERSION = "2.41";
# Constants
@@ -87,6 +85,7 @@ sub new
$data_size, # Optional additional bytes of data
$device, # Optional device to use
$tos, # Optional ToS to set
+ $ttl, # Optional TTL to set
) = @_;
my $class = ref($this) || $this;
my $self = {};
@@ -110,6 +109,12 @@ sub new
$self->{"tos"} = $tos;
+ if ($self->{"proto"} eq 'icmp') {
+ croak('TTL must be from 0 to 255')
+ if ($ttl && ($ttl < 0 || $ttl > 255));
+ $self->{"ttl"} = $ttl;
+ }
+
$min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
$data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
croak("Data for ping must be from $min_datasize to $max_datasize bytes")
@@ -143,7 +148,7 @@ sub new
or croak "error binding to device $self->{'device'} $!";
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
}
@@ -161,9 +166,13 @@ sub new
or croak "error binding to device $self->{'device'} $!";
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
+ if ($self->{'ttl'}) {
+ setsockopt($self->{"fh"}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'}))
+ or croak "error configuring ttl to $self->{'ttl'} $!";
+ }
}
elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
{
@@ -304,13 +313,12 @@ sub retrans
# Description: allows the module to use milliseconds as returned by
# the Time::HiRes module
-$hires = 0;
+$hires = 1;
sub hires
{
my $self = shift;
$hires = 1 unless defined
($hires = ((defined $self) && (ref $self)) ? shift() : $self);
- require Time::HiRes if $hires;
}
sub time
@@ -392,7 +400,7 @@ sub ping
croak("Unknown protocol \"$self->{proto}\" in ping()");
}
- return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
+ return wantarray ? ($ret, &time() - $ping_time, $self->ntop($ip)) : $ret;
}
# Uses Net::Ping::External to do an external ping.
@@ -410,6 +418,8 @@ sub ping_external {
use constant ICMP_ECHOREPLY => 0; # ICMP packet types
use constant ICMP_UNREACHABLE => 3; # ICMP packet types
use constant ICMP_ECHO => 8;
+use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types
+use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types
use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
use constant ICMP_FLAGS => 0; # No special flags for send or recv
@@ -489,14 +499,17 @@ sub ping_icmp
$self->{"from_ip"} = $from_ip;
$self->{"from_type"} = $from_type;
$self->{"from_subcode"} = $from_subcode;
- if (($from_pid == $self->{"pid"}) && # Does the packet check out?
- (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) &&
- ($from_seq == $self->{"seq"})) {
+ next if ($from_pid != $self->{"pid"});
+ next if ($from_seq != $self->{"seq"});
+ if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out?
if ($from_type == ICMP_ECHOREPLY) {
$ret = 1;
- $done = 1;
+ $done = 1;
} elsif ($from_type == ICMP_UNREACHABLE) {
$done = 1;
+ } elsif ($from_type == ICMP_TIME_EXCEEDED) {
+ $ret = 0;
+ $done = 1;
}
}
} else { # Oops, timed out
@@ -510,7 +523,7 @@ sub icmp_result {
my ($self) = @_;
my $ip = $self->{"from_ip"} || "";
$ip = "\0\0\0\0" unless 4 == length $ip;
- return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
+ return ($self->ntop($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
}
# Description: Do a checksum on the message. Basically sum all of
@@ -593,7 +606,7 @@ sub tcp_connect
or croak("error binding to device $self->{'device'} $!");
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
};
@@ -1037,7 +1050,7 @@ sub ping_syn
or croak("error binding to device $self->{'device'} $!");
}
if ($self->{'tos'}) {
- setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ setsockopt($fh, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
# Set O_NONBLOCK property on filehandle
@@ -1106,7 +1119,7 @@ sub ping_syn_fork {
or croak("error binding to device $self->{'device'} $!");
}
if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
or croak "error configuring tos to $self->{'tos'} $!";
}
@@ -1247,7 +1260,7 @@ sub ack
}
# Everything passed okay, return the answer
return wantarray ?
- ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
+ ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]))
: $entry->[0];
} else {
warn "Corrupted SYN entry: unknown fd [$fd] ready!";
@@ -1283,7 +1296,7 @@ sub ack_unfork {
# Host passed as arg
if (my $entry = $self->{"good"}->{$host}) {
delete $self->{"good"}->{$host};
- return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
+ return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]));
}
}
@@ -1327,7 +1340,7 @@ sub ack_unfork {
# And wait for the next winner
next;
}
- return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
+ return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]));
}
} else {
# Should never happen
@@ -1374,6 +1387,8 @@ sub close
delete $self->{"syn"};
} elsif ($self->{"proto"} eq "tcp") {
# The connection will already be closed
+ } elsif ($self->{"proto"} eq "external") {
+ # Nothing to close
} else {
$self->{"fh"}->close();
}
@@ -1388,6 +1403,23 @@ sub port_number {
return $self->{port_num};
}
+sub ntop {
+ my($self, $ip) = @_;
+
+ # Vista doesn't define a inet_ntop. It has InetNtop instead.
+ # Not following ANSI... priceless. getnameinfo() is defined
+ # for Windows 2000 and later, so that may be the choice.
+
+ # Any port will work, even undef, but this will work for now.
+ # Socket warns when undef is passed in, but it still works.
+ my $port = getservbyname('echo', 'udp');
+ my $sockaddr = sockaddr_in $port, $ip;
+ my ($error, $address) = getnameinfo($sockaddr, NI_NUMERICHOST);
+ if($error) {
+ croak $error;
+ }
+ return $address;
+}
1;
__END__
@@ -1417,7 +1449,7 @@ Net::Ping - check a remote host for reachability
$p = Net::Ping->new("tcp", 2);
# Try connecting to the www port instead of the echo port
- $p->port_number(getservbyname("http", "tcp"));
+ $p->port_number(scalar(getservbyname("http", "tcp")));
while ($stop_time > time())
{
print "$host not reachable ", scalar(localtime()), "\n"
@@ -1509,7 +1541,7 @@ This protocol does not require any special privileges.
=over 4
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos [, $ttl ]]]]]]);
Create a new ping object. All of the parameters are optional. $proto
specifies the protocol to use when doing a ping. The current choices
@@ -1533,6 +1565,8 @@ superuser privileges and with udp and icmp protocols at this time.
If $tos is given, this ToS is configured into the socket.
+For icmp, $ttl can be specified to set the TTL of the outgoing packet.
+
=item $p->ping($host [, $timeout]);
Ping the remote host and wait for a response. $host can be either the