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