This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Net::Ping: wrap long pod lines
[perl5.git] / dist / Net-Ping / lib / Net / Ping.pm
1 package Net::Ping;
2
3 require 5.002;
4 require Exporter;
5
6 use strict;
7 use vars qw(@ISA @EXPORT $VERSION
8             $def_timeout $def_proto $def_factor
9             $max_datasize $pingstring $hires $source_verify $syn_forking);
10 use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
11 use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR IPPROTO_IP IP_TOS IP_TTL
12                inet_aton getnameinfo NI_NUMERICHOST sockaddr_in );
13 use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
14 use FileHandle;
15 use Carp;
16 use Time::HiRes;
17
18 @ISA = qw(Exporter);
19 @EXPORT = qw(pingecho);
20 $VERSION = "2.41";
21
22 # Constants
23
24 $def_timeout = 5;           # Default timeout to wait for a reply
25 $def_proto = "tcp";         # Default protocol to use for pinging
26 $def_factor = 1.2;          # Default exponential backoff rate.
27 $max_datasize = 1024;       # Maximum data bytes in a packet
28 # The data we exchange with the server for the stream protocol
29 $pingstring = "pingschwingping!\n";
30 $source_verify = 1;         # Default is to verify source endpoint
31 $syn_forking = 0;
32
33 if ($^O =~ /Win32/i) {
34   # Hack to avoid this Win32 spewage:
35   # Your vendor has not defined POSIX macro ECONNREFUSED
36   my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response?
37                ENOTCONN     => 10057,
38                ECONNRESET   => 10054,
39                EINPROGRESS  => 10036,
40                EWOULDBLOCK  => 10035,
41           );
42   while (my $name = shift @pairs) {
43     my $value = shift @pairs;
44     # When defined, these all are non-zero
45     unless (eval $name) {
46       no strict 'refs';
47       *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value};
48     }
49   }
50 #  $syn_forking = 1;    # XXX possibly useful in < Win2K ?
51 };
52
53 # h2ph "asm/socket.h"
54 # require "asm/socket.ph";
55 sub SO_BINDTODEVICE {25;}
56
57 # Description:  The pingecho() subroutine is provided for backward
58 # compatibility with the original Net::Ping.  It accepts a host
59 # name/IP and an optional timeout in seconds.  Create a tcp ping
60 # object and try pinging the host.  The result of the ping is returned.
61
62 sub pingecho
63 {
64   my ($host,              # Name or IP number of host to ping
65       $timeout            # Optional timeout in seconds
66       ) = @_;
67   my ($p);                # A ping object
68
69   $p = Net::Ping->new("tcp", $timeout);
70   $p->ping($host);        # Going out of scope closes the connection
71 }
72
73 # Description:  The new() method creates a new ping object.  Optional
74 # parameters may be specified for the protocol to use, the timeout in
75 # seconds and the size in bytes of additional data which should be
76 # included in the packet.
77 #   After the optional parameters are checked, the data is constructed
78 # and a socket is opened if appropriate.  The object is returned.
79
80 sub new
81 {
82   my ($this,
83       $proto,             # Optional protocol to use for pinging
84       $timeout,           # Optional timeout in seconds
85       $data_size,         # Optional additional bytes of data
86       $device,            # Optional device to use
87       $tos,               # Optional ToS to set
88       $ttl,               # Optional TTL to set
89       ) = @_;
90   my  $class = ref($this) || $this;
91   my  $self = {};
92   my ($cnt,               # Count through data bytes
93       $min_datasize       # Minimum data bytes required
94       );
95
96   bless($self, $class);
97
98   $proto = $def_proto unless $proto;          # Determine the protocol
99   croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
100     unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
101   $self->{"proto"} = $proto;
102
103   $timeout = $def_timeout unless $timeout;    # Determine the timeout
104   croak("Default timeout for ping must be greater than 0 seconds")
105     if $timeout <= 0;
106   $self->{"timeout"} = $timeout;
107
108   $self->{"device"} = $device;
109
110   $self->{"tos"} = $tos;
111
112   if ($self->{"proto"} eq 'icmp') {
113     croak('TTL must be from 0 to 255')
114       if ($ttl && ($ttl < 0 || $ttl > 255));
115     $self->{"ttl"} = $ttl;
116   }
117
118   $min_datasize = ($proto eq "udp") ? 1 : 0;  # Determine data size
119   $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
120   croak("Data for ping must be from $min_datasize to $max_datasize bytes")
121     if ($data_size < $min_datasize) || ($data_size > $max_datasize);
122   $data_size-- if $self->{"proto"} eq "udp";  # We provide the first byte
123   $self->{"data_size"} = $data_size;
124
125   $self->{"data"} = "";                       # Construct data bytes
126   for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
127   {
128     $self->{"data"} .= chr($cnt % 256);
129   }
130
131   $self->{"local_addr"} = undef;              # Don't bind by default
132   $self->{"retrans"} = $def_factor;           # Default exponential backoff rate
133   $self->{"econnrefused"} = undef;            # Default Connection refused behavior
134
135   $self->{"seq"} = 0;                         # For counting packets
136   if ($self->{"proto"} eq "udp")              # Open a socket
137   {
138     $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
139       croak("Can't udp protocol by name");
140     $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
141       croak("Can't get udp echo port by name");
142     $self->{"fh"} = FileHandle->new();
143     socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
144            $self->{"proto_num"}) ||
145              croak("udp socket error - $!");
146     if ($self->{'device'}) {
147       setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
148         or croak "error binding to device $self->{'device'} $!";
149     }
150     if ($self->{'tos'}) {
151       setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
152         or croak "error configuring tos to $self->{'tos'} $!";
153     }
154   }
155   elsif ($self->{"proto"} eq "icmp")
156   {
157     croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
158     $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
159       croak("Can't get icmp protocol by name");
160     $self->{"pid"} = $$ & 0xffff;           # Save lower 16 bits of pid
161     $self->{"fh"} = FileHandle->new();
162     socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
163       croak("icmp socket error - $!");
164     if ($self->{'device'}) {
165       setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
166         or croak "error binding to device $self->{'device'} $!";
167     }
168     if ($self->{'tos'}) {
169       setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
170         or croak "error configuring tos to $self->{'tos'} $!";
171     }
172     if ($self->{'ttl'}) {
173       setsockopt($self->{"fh"}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'}))
174         or croak "error configuring ttl to $self->{'ttl'} $!";
175     }
176   }
177   elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
178   {
179     $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
180       croak("Can't get tcp protocol by name");
181     $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
182       croak("Can't get tcp echo port by name");
183     $self->{"fh"} = FileHandle->new();
184   }
185   elsif ($self->{"proto"} eq "syn")
186   {
187     $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
188       croak("Can't get tcp protocol by name");
189     $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
190       croak("Can't get tcp echo port by name");
191     if ($syn_forking) {
192       $self->{"fork_rd"} = FileHandle->new();
193       $self->{"fork_wr"} = FileHandle->new();
194       pipe($self->{"fork_rd"}, $self->{"fork_wr"});
195       $self->{"fh"} = FileHandle->new();
196       $self->{"good"} = {};
197       $self->{"bad"} = {};
198     } else {
199       $self->{"wbits"} = "";
200       $self->{"bad"} = {};
201     }
202     $self->{"syn"} = {};
203     $self->{"stop_time"} = 0;
204   }
205   elsif ($self->{"proto"} eq "external")
206   {
207     # No preliminary work needs to be done.
208   }
209
210   return($self);
211 }
212
213 # Description: Set the local IP address from which pings will be sent.
214 # For ICMP and UDP pings, this calls bind() on the already-opened socket;
215 # for TCP pings, just saves the address to be used when the socket is
216 # opened.  Returns non-zero if successful; croaks on error.
217 sub bind
218 {
219   my ($self,
220       $local_addr         # Name or IP number of local interface
221       ) = @_;
222   my ($ip                 # Packed IP number of $local_addr
223       );
224
225   croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
226   croak("already bound") if defined($self->{"local_addr"}) &&
227     ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
228
229   $ip = inet_aton($local_addr);
230   croak("nonexistent local address $local_addr") unless defined($ip);
231   $self->{"local_addr"} = $ip; # Only used if proto is tcp
232
233   if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
234   {
235   CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
236     croak("$self->{'proto'} bind error - $!");
237   }
238   elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
239   {
240     croak("Unknown protocol \"$self->{proto}\" in bind()");
241   }
242
243   return 1;
244 }
245
246 # Description: A select() wrapper that compensates for platform
247 # peculiarities.
248 sub mselect
249 {
250     if ($_[3] > 0 and $^O eq 'MSWin32') {
251         # On windows, select() doesn't process the message loop,
252         # but sleep() will, allowing alarm() to interrupt the latter.
253         # So we chop up the timeout into smaller pieces and interleave
254         # select() and sleep() calls.
255         my $t = $_[3];
256         my $gran = 0.5;  # polling granularity in seconds
257         my @args = @_;
258         while (1) {
259             $gran = $t if $gran > $t;
260             my $nfound = select($_[0], $_[1], $_[2], $gran);
261             undef $nfound if $nfound == -1;
262             $t -= $gran;
263             return $nfound if $nfound or !defined($nfound) or $t <= 0;
264
265             sleep(0);
266             ($_[0], $_[1], $_[2]) = @args;
267         }
268     }
269     else {
270         my $nfound = select($_[0], $_[1], $_[2], $_[3]);
271         undef $nfound if $nfound == -1;
272         return $nfound;
273     }
274 }
275
276 # Description: Allow UDP source endpoint comparison to be
277 #              skipped for those remote interfaces that do
278 #              not response from the same endpoint.
279
280 sub source_verify
281 {
282   my $self = shift;
283   $source_verify = 1 unless defined
284     ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
285 }
286
287 # Description: Set whether or not the connect
288 # behavior should enforce remote service
289 # availability as well as reachability.
290
291 sub service_check
292 {
293   my $self = shift;
294   $self->{"econnrefused"} = 1 unless defined
295     ($self->{"econnrefused"} = shift());
296 }
297
298 sub tcp_service_check
299 {
300   service_check(@_);
301 }
302
303 # Description: Set exponential backoff for retransmission.
304 # Should be > 1 to retain exponential properties.
305 # If set to 0, retransmissions are disabled.
306
307 sub retrans
308 {
309   my $self = shift;
310   $self->{"retrans"} = shift;
311 }
312
313 # Description: allows the module to use milliseconds as returned by
314 # the Time::HiRes module
315
316 $hires = 1;
317 sub hires
318 {
319   my $self = shift;
320   $hires = 1 unless defined
321     ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
322 }
323
324 sub time
325 {
326   return $hires ? Time::HiRes::time() : CORE::time();
327 }
328
329 # Description: Sets or clears the O_NONBLOCK flag on a file handle.
330 sub socket_blocking_mode
331 {
332   my ($self,
333       $fh,              # the file handle whose flags are to be modified
334       $block) = @_;     # if true then set the blocking
335                         # mode (clear O_NONBLOCK), otherwise
336                         # set the non-blocking mode (set O_NONBLOCK)
337
338   my $flags;
339   if ($^O eq 'MSWin32' || $^O eq 'VMS') {
340       # FIONBIO enables non-blocking sockets on windows and vms.
341       # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h
342       my $f = 0x8004667e;
343       my $v = pack("L", $block ? 0 : 1);
344       ioctl($fh, $f, $v) or croak("ioctl failed: $!");
345       return;
346   }
347   if ($flags = fcntl($fh, F_GETFL, 0)) {
348     $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
349     if (!fcntl($fh, F_SETFL, $flags)) {
350       croak("fcntl F_SETFL: $!");
351     }
352   } else {
353     croak("fcntl F_GETFL: $!");
354   }
355 }
356
357 # Description: Ping a host name or IP number with an optional timeout.
358 # First lookup the host, and return undef if it is not found.  Otherwise
359 # perform the specific ping method based on the protocol.  Return the
360 # result of the ping.
361
362 sub ping
363 {
364   my ($self,
365       $host,              # Name or IP number of host to ping
366       $timeout,           # Seconds after which ping times out
367       ) = @_;
368   my ($ip,                # Packed IP number of $host
369       $ret,               # The return value
370       $ping_time,         # When ping began
371       );
372
373   croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
374   $timeout = $self->{"timeout"} unless $timeout;
375   croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
376
377   $ip = inet_aton($host);
378   return () unless defined($ip);      # Does host exist?
379
380   # Dispatch to the appropriate routine.
381   $ping_time = &time();
382   if ($self->{"proto"} eq "external") {
383     $ret = $self->ping_external($ip, $timeout);
384   }
385   elsif ($self->{"proto"} eq "udp") {
386     $ret = $self->ping_udp($ip, $timeout);
387   }
388   elsif ($self->{"proto"} eq "icmp") {
389     $ret = $self->ping_icmp($ip, $timeout);
390   }
391   elsif ($self->{"proto"} eq "tcp") {
392     $ret = $self->ping_tcp($ip, $timeout);
393   }
394   elsif ($self->{"proto"} eq "stream") {
395     $ret = $self->ping_stream($ip, $timeout);
396   }
397   elsif ($self->{"proto"} eq "syn") {
398     $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
399   } else {
400     croak("Unknown protocol \"$self->{proto}\" in ping()");
401   }
402
403   return wantarray ? ($ret, &time() - $ping_time, $self->ntop($ip)) : $ret;
404 }
405
406 # Uses Net::Ping::External to do an external ping.
407 sub ping_external {
408   my ($self,
409       $ip,                # Packed IP number of the host
410       $timeout            # Seconds after which ping times out
411      ) = @_;
412
413   eval { require Net::Ping::External; }
414     or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
415   return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
416 }
417
418 use constant ICMP_ECHOREPLY   => 0; # ICMP packet types
419 use constant ICMP_UNREACHABLE => 3; # ICMP packet types
420 use constant ICMP_ECHO        => 8;
421 use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types
422 use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types
423 use constant ICMP_STRUCT      => "C2 n3 A"; # Structure of a minimal ICMP packet
424 use constant SUBCODE          => 0; # No ICMP subcode for ECHO and ECHOREPLY
425 use constant ICMP_FLAGS       => 0; # No special flags for send or recv
426 use constant ICMP_PORT        => 0; # No port with ICMP
427
428 sub ping_icmp
429 {
430   my ($self,
431       $ip,                # Packed IP number of the host
432       $timeout            # Seconds after which ping times out
433       ) = @_;
434
435   my ($saddr,             # sockaddr_in with port and ip
436       $checksum,          # Checksum of ICMP packet
437       $msg,               # ICMP packet to send
438       $len_msg,           # Length of $msg
439       $rbits,             # Read bits, filehandles for reading
440       $nfound,            # Number of ready filehandles found
441       $finish_time,       # Time ping should be finished
442       $done,              # set to 1 when we are done
443       $ret,               # Return value
444       $recv_msg,          # Received message including IP header
445       $from_saddr,        # sockaddr_in of sender
446       $from_port,         # Port packet was sent from
447       $from_ip,           # Packed IP of sender
448       $from_type,         # ICMP type
449       $from_subcode,      # ICMP subcode
450       $from_chk,          # ICMP packet checksum
451       $from_pid,          # ICMP packet id
452       $from_seq,          # ICMP packet sequence
453       $from_msg           # ICMP message
454       );
455
456   $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
457   $checksum = 0;                          # No checksum for starters
458   $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
459               $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
460   $checksum = Net::Ping->checksum($msg);
461   $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
462               $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
463   $len_msg = length($msg);
464   $saddr = sockaddr_in(ICMP_PORT, $ip);
465   $self->{"from_ip"} = undef;
466   $self->{"from_type"} = undef;
467   $self->{"from_subcode"} = undef;
468   send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
469
470   $rbits = "";
471   vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
472   $ret = 0;
473   $done = 0;
474   $finish_time = &time() + $timeout;      # Must be done by this time
475   while (!$done && $timeout > 0)          # Keep trying if we have time
476   {
477     $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
478     $timeout = $finish_time - &time();    # Get remaining time
479     if (!defined($nfound))                # Hmm, a strange error
480     {
481       $ret = undef;
482       $done = 1;
483     }
484     elsif ($nfound)                     # Got a packet from somewhere
485     {
486       $recv_msg = "";
487       $from_pid = -1;
488       $from_seq = -1;
489       $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
490       ($from_port, $from_ip) = sockaddr_in($from_saddr);
491       ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
492       if ($from_type == ICMP_ECHOREPLY) {
493         ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
494           if length $recv_msg >= 28;
495       } else {
496         ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
497           if length $recv_msg >= 56;
498       }
499       $self->{"from_ip"} = $from_ip;
500       $self->{"from_type"} = $from_type;
501       $self->{"from_subcode"} = $from_subcode;
502       next if ($from_pid != $self->{"pid"});
503       next if ($from_seq != $self->{"seq"});
504       if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out?
505         if ($from_type == ICMP_ECHOREPLY) {
506           $ret = 1;
507                 $done = 1;
508         } elsif ($from_type == ICMP_UNREACHABLE) {
509           $done = 1;
510         } elsif ($from_type == ICMP_TIME_EXCEEDED) {
511           $ret = 0;
512           $done = 1;
513         }
514       }
515     } else {     # Oops, timed out
516       $done = 1;
517     }
518   }
519   return $ret;
520 }
521
522 sub icmp_result {
523   my ($self) = @_;
524   my $ip = $self->{"from_ip"} || "";
525   $ip = "\0\0\0\0" unless 4 == length $ip;
526   return ($self->ntop($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
527 }
528
529 # Description:  Do a checksum on the message.  Basically sum all of
530 # the short words and fold the high order bits into the low order bits.
531
532 sub checksum
533 {
534   my ($class,
535       $msg            # The message to checksum
536       ) = @_;
537   my ($len_msg,       # Length of the message
538       $num_short,     # The number of short words in the message
539       $short,         # One short word
540       $chk            # The checksum
541       );
542
543   $len_msg = length($msg);
544   $num_short = int($len_msg / 2);
545   $chk = 0;
546   foreach $short (unpack("n$num_short", $msg))
547   {
548     $chk += $short;
549   }                                           # Add the odd byte in
550   $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
551   $chk = ($chk >> 16) + ($chk & 0xffff);      # Fold high into low
552   return(~(($chk >> 16) + $chk) & 0xffff);    # Again and complement
553 }
554
555
556 # Description:  Perform a tcp echo ping.  Since a tcp connection is
557 # host specific, we have to open and close each connection here.  We
558 # can't just leave a socket open.  Because of the robust nature of
559 # tcp, it will take a while before it gives up trying to establish a
560 # connection.  Therefore, we use select() on a non-blocking socket to
561 # check against our timeout.  No data bytes are actually
562 # sent since the successful establishment of a connection is proof
563 # enough of the reachability of the remote host.  Also, tcp is
564 # expensive and doesn't need our help to add to the overhead.
565
566 sub ping_tcp
567 {
568   my ($self,
569       $ip,                # Packed IP number of the host
570       $timeout            # Seconds after which ping times out
571       ) = @_;
572   my ($ret                # The return value
573       );
574
575   $! = 0;
576   $ret = $self -> tcp_connect( $ip, $timeout);
577   if (!$self->{"econnrefused"} &&
578       $! == ECONNREFUSED) {
579     $ret = 1;  # "Connection refused" means reachable
580   }
581   $self->{"fh"}->close();
582   return $ret;
583 }
584
585 sub tcp_connect
586 {
587   my ($self,
588       $ip,                # Packed IP number of the host
589       $timeout            # Seconds after which connect times out
590       ) = @_;
591   my ($saddr);            # Packed IP and Port
592
593   $saddr = sockaddr_in($self->{"port_num"}, $ip);
594
595   my $ret = 0;            # Default to unreachable
596
597   my $do_socket = sub {
598     socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
599       croak("tcp socket error - $!");
600     if (defined $self->{"local_addr"} &&
601         !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
602       croak("tcp bind error - $!");
603     }
604     if ($self->{'device'}) {
605       setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
606         or croak("error binding to device $self->{'device'} $!");
607     }
608     if ($self->{'tos'}) {
609       setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
610         or croak "error configuring tos to $self->{'tos'} $!";
611     }
612   };
613   my $do_connect = sub {
614     $self->{"ip"} = $ip;
615     # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
616     # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
617     return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
618   };
619   my $do_connect_nb = sub {
620     # Set O_NONBLOCK property on filehandle
621     $self->socket_blocking_mode($self->{"fh"}, 0);
622
623     # start the connection attempt
624     if (!connect($self->{"fh"}, $saddr)) {
625       if ($! == ECONNREFUSED) {
626         $ret = 1 unless $self->{"econnrefused"};
627       } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
628         # EINPROGRESS is the expected error code after a connect()
629         # on a non-blocking socket.  But if the kernel immediately
630         # determined that this connect() will never work,
631         # Simply respond with "unreachable" status.
632         # (This can occur on some platforms with errno
633         # EHOSTUNREACH or ENETUNREACH.)
634         return 0;
635       } else {
636         # Got the expected EINPROGRESS.
637         # Just wait for connection completion...
638         my ($wbits, $wout, $wexc);
639         $wout = $wexc = $wbits = "";
640         vec($wbits, $self->{"fh"}->fileno, 1) = 1;
641
642         my $nfound = mselect(undef,
643                             ($wout = $wbits),
644                             ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
645                             $timeout);
646         warn("select: $!") unless defined $nfound;
647
648         if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
649           # the socket is ready for writing so the connection
650           # attempt completed. test whether the connection
651           # attempt was successful or not
652
653           if (getpeername($self->{"fh"})) {
654             # Connection established to remote host
655             $ret = 1;
656           } else {
657             # TCP ACK will never come from this host
658             # because there was an error connecting.
659
660             # This should set $! to the correct error.
661             my $char;
662             sysread($self->{"fh"},$char,1);
663             $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
664
665             $ret = 1 if (!$self->{"econnrefused"}
666                          && $! == ECONNREFUSED);
667           }
668         } else {
669           # the connection attempt timed out (or there were connect
670           # errors on Windows)
671           if ($^O =~ 'MSWin32') {
672               # If the connect will fail on a non-blocking socket,
673               # winsock reports ECONNREFUSED as an exception, and we
674               # need to fetch the socket-level error code via getsockopt()
675               # instead of using the thread-level error code that is in $!.
676               if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
677                   $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
678                                               SO_ERROR));
679               }
680           }
681         }
682       }
683     } else {
684       # Connection established to remote host
685       $ret = 1;
686     }
687
688     # Unset O_NONBLOCK property on filehandle
689     $self->socket_blocking_mode($self->{"fh"}, 1);
690     $self->{"ip"} = $ip;
691     return $ret;
692   };
693
694   if ($syn_forking) {
695     # Buggy Winsock API doesn't allow nonblocking connect.
696     # Hence, if our OS is Windows, we need to create a separate
697     # process to do the blocking connect attempt.
698     # XXX Above comments are not true at least for Win2K, where
699     # nonblocking connect works.
700
701     $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
702     $self->{'tcp_chld'} = fork;
703     if (!$self->{'tcp_chld'}) {
704       if (!defined $self->{'tcp_chld'}) {
705         # Fork did not work
706         warn "Fork error: $!";
707         return 0;
708       }
709       &{ $do_socket }();
710
711       # Try a slow blocking connect() call
712       # and report the status to the parent.
713       if ( &{ $do_connect }() ) {
714         $self->{"fh"}->close();
715         # No error
716         exit 0;
717       } else {
718         # Pass the error status to the parent
719         # Make sure that $! <= 255
720         exit($! <= 255 ? $! : 255);
721       }
722     }
723
724     &{ $do_socket }();
725
726     my $patience = &time() + $timeout;
727
728     my ($child, $child_errno);
729     $? = 0; $child_errno = 0;
730     # Wait up to the timeout
731     # And clean off the zombie
732     do {
733       $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
734       $child_errno = $? >> 8;
735       select(undef, undef, undef, 0.1);
736     } while &time() < $patience && $child != $self->{'tcp_chld'};
737
738     if ($child == $self->{'tcp_chld'}) {
739       if ($self->{"proto"} eq "stream") {
740         # We need the socket connected here, in parent
741         # Should be safe to connect because the child finished
742         # within the timeout
743         &{ $do_connect }();
744       }
745       # $ret cannot be set by the child process
746       $ret = !$child_errno;
747     } else {
748       # Time must have run out.
749       # Put that choking client out of its misery
750       kill "KILL", $self->{'tcp_chld'};
751       # Clean off the zombie
752       waitpid($self->{'tcp_chld'}, 0);
753       $ret = 0;
754     }
755     delete $self->{'tcp_chld'};
756     $! = $child_errno;
757   } else {
758     # Otherwise don't waste the resources to fork
759
760     &{ $do_socket }();
761
762     &{ $do_connect_nb }();
763   }
764
765   return $ret;
766 }
767
768 sub DESTROY {
769   my $self = shift;
770   if ($self->{'proto'} eq 'tcp' &&
771       $self->{'tcp_chld'}) {
772     # Put that choking client out of its misery
773     kill "KILL", $self->{'tcp_chld'};
774     # Clean off the zombie
775     waitpid($self->{'tcp_chld'}, 0);
776   }
777 }
778
779 # This writes the given string to the socket and then reads it
780 # back.  It returns 1 on success, 0 on failure.
781 sub tcp_echo
782 {
783   my $self = shift;
784   my $timeout = shift;
785   my $pingstring = shift;
786
787   my $ret = undef;
788   my $time = &time();
789   my $wrstr = $pingstring;
790   my $rdstr = "";
791
792   eval <<'EOM';
793     do {
794       my $rin = "";
795       vec($rin, $self->{"fh"}->fileno(), 1) = 1;
796
797       my $rout = undef;
798       if($wrstr) {
799         $rout = "";
800         vec($rout, $self->{"fh"}->fileno(), 1) = 1;
801       }
802
803       if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
804
805         if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
806           my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
807           if($num) {
808             # If it was a partial write, update and try again.
809             $wrstr = substr($wrstr,$num);
810           } else {
811             # There was an error.
812             $ret = 0;
813           }
814         }
815
816         if(vec($rin,$self->{"fh"}->fileno(),1)) {
817           my $reply;
818           if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
819             $rdstr .= $reply;
820             $ret = 1 if $rdstr eq $pingstring;
821           } else {
822             # There was an error.
823             $ret = 0;
824           }
825         }
826
827       }
828     } until &time() > ($time + $timeout) || defined($ret);
829 EOM
830
831   return $ret;
832 }
833
834
835
836
837 # Description: Perform a stream ping.  If the tcp connection isn't
838 # already open, it opens it.  It then sends some data and waits for
839 # a reply.  It leaves the stream open on exit.
840
841 sub ping_stream
842 {
843   my ($self,
844       $ip,                # Packed IP number of the host
845       $timeout            # Seconds after which ping times out
846       ) = @_;
847
848   # Open the stream if it's not already open
849   if(!defined $self->{"fh"}->fileno()) {
850     $self->tcp_connect($ip, $timeout) or return 0;
851   }
852
853   croak "tried to switch servers while stream pinging"
854     if $self->{"ip"} ne $ip;
855
856   return $self->tcp_echo($timeout, $pingstring);
857 }
858
859 # Description: opens the stream.  You would do this if you want to
860 # separate the overhead of opening the stream from the first ping.
861
862 sub open
863 {
864   my ($self,
865       $host,              # Host or IP address
866       $timeout            # Seconds after which open times out
867       ) = @_;
868
869   my ($ip);               # Packed IP number of the host
870   $ip = inet_aton($host);
871   $timeout = $self->{"timeout"} unless $timeout;
872
873   if($self->{"proto"} eq "stream") {
874     if(defined($self->{"fh"}->fileno())) {
875       croak("socket is already open");
876     } else {
877       $self->tcp_connect($ip, $timeout);
878     }
879   }
880 }
881
882
883 # Description:  Perform a udp echo ping.  Construct a message of
884 # at least the one-byte sequence number and any additional data bytes.
885 # Send the message out and wait for a message to come back.  If we
886 # get a message, make sure all of its parts match.  If they do, we are
887 # done.  Otherwise go back and wait for the message until we run out
888 # of time.  Return the result of our efforts.
889
890 use constant UDP_FLAGS => 0; # Nothing special on send or recv
891 sub ping_udp
892 {
893   my ($self,
894       $ip,                # Packed IP number of the host
895       $timeout            # Seconds after which ping times out
896       ) = @_;
897
898   my ($saddr,             # sockaddr_in with port and ip
899       $ret,               # The return value
900       $msg,               # Message to be echoed
901       $finish_time,       # Time ping should be finished
902       $flush,             # Whether socket needs to be disconnected
903       $connect,           # Whether socket needs to be connected
904       $done,              # Set to 1 when we are done pinging
905       $rbits,             # Read bits, filehandles for reading
906       $nfound,            # Number of ready filehandles found
907       $from_saddr,        # sockaddr_in of sender
908       $from_msg,          # Characters echoed by $host
909       $from_port,         # Port message was echoed from
910       $from_ip            # Packed IP number of sender
911       );
912
913   $saddr = sockaddr_in($self->{"port_num"}, $ip);
914   $self->{"seq"} = ($self->{"seq"} + 1) % 256;    # Increment sequence
915   $msg = chr($self->{"seq"}) . $self->{"data"};   # Add data if any
916
917   if ($self->{"connected"}) {
918     if ($self->{"connected"} ne $saddr) {
919       # Still connected to wrong destination.
920       # Need to flush out the old one.
921       $flush = 1;
922     }
923   } else {
924     # Not connected yet.
925     # Need to connect() before send()
926     $connect = 1;
927   }
928
929   # Have to connect() and send() instead of sendto()
930   # in order to pick up on the ECONNREFUSED setting
931   # from recv() or double send() errno as utilized in
932   # the concept by rdw @ perlmonks.  See:
933   # http://perlmonks.thepen.com/42898.html
934   if ($flush) {
935     # Need to socket() again to flush the descriptor
936     # This will disconnect from the old saddr.
937     socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
938            $self->{"proto_num"});
939   }
940   # Connect the socket if it isn't already connected
941   # to the right destination.
942   if ($flush || $connect) {
943     connect($self->{"fh"}, $saddr);               # Tie destination to socket
944     $self->{"connected"} = $saddr;
945   }
946   send($self->{"fh"}, $msg, UDP_FLAGS);           # Send it
947
948   $rbits = "";
949   vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
950   $ret = 0;                   # Default to unreachable
951   $done = 0;
952   my $retrans = 0.01;
953   my $factor = $self->{"retrans"};
954   $finish_time = &time() + $timeout;       # Ping needs to be done by then
955   while (!$done && $timeout > 0)
956   {
957     if ($factor > 1)
958     {
959       $timeout = $retrans if $timeout > $retrans;
960       $retrans*= $factor; # Exponential backoff
961     }
962     $nfound  = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
963     my $why = $!;
964     $timeout = $finish_time - &time();   # Get remaining time
965
966     if (!defined($nfound))  # Hmm, a strange error
967     {
968       $ret = undef;
969       $done = 1;
970     }
971     elsif ($nfound)         # A packet is waiting
972     {
973       $from_msg = "";
974       $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS);
975       if (!$from_saddr) {
976         # For example an unreachable host will make recv() fail.
977         if (!$self->{"econnrefused"} &&
978             ($! == ECONNREFUSED ||
979              $! == ECONNRESET)) {
980           # "Connection refused" means reachable
981           # Good, continue
982           $ret = 1;
983         }
984         $done = 1;
985       } else {
986         ($from_port, $from_ip) = sockaddr_in($from_saddr);
987         if (!$source_verify ||
988             (($from_ip eq $ip) &&        # Does the packet check out?
989              ($from_port == $self->{"port_num"}) &&
990              ($from_msg eq $msg)))
991         {
992           $ret = 1;       # It's a winner
993           $done = 1;
994         }
995       }
996     }
997     elsif ($timeout <= 0)              # Oops, timed out
998     {
999       $done = 1;
1000     }
1001     else
1002     {
1003       # Send another in case the last one dropped
1004       if (send($self->{"fh"}, $msg, UDP_FLAGS)) {
1005         # Another send worked?  The previous udp packet
1006         # must have gotten lost or is still in transit.
1007         # Hopefully this new packet will arrive safely.
1008       } else {
1009         if (!$self->{"econnrefused"} &&
1010             $! == ECONNREFUSED) {
1011           # "Connection refused" means reachable
1012           # Good, continue
1013           $ret = 1;
1014         }
1015         $done = 1;
1016       }
1017     }
1018   }
1019   return $ret;
1020 }
1021
1022 # Description: Send a TCP SYN packet to host specified.
1023 sub ping_syn
1024 {
1025   my $self = shift;
1026   my $host = shift;
1027   my $ip = shift;
1028   my $start_time = shift;
1029   my $stop_time = shift;
1030
1031   if ($syn_forking) {
1032     return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
1033   }
1034
1035   my $fh = FileHandle->new();
1036   my $saddr = sockaddr_in($self->{"port_num"}, $ip);
1037
1038   # Create TCP socket
1039   if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
1040     croak("tcp socket error - $!");
1041   }
1042
1043   if (defined $self->{"local_addr"} &&
1044       !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
1045     croak("tcp bind error - $!");
1046   }
1047
1048   if ($self->{'device'}) {
1049     setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
1050       or croak("error binding to device $self->{'device'} $!");
1051   }
1052   if ($self->{'tos'}) {
1053     setsockopt($fh, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
1054       or croak "error configuring tos to $self->{'tos'} $!";
1055   }
1056   # Set O_NONBLOCK property on filehandle
1057   $self->socket_blocking_mode($fh, 0);
1058
1059   # Attempt the non-blocking connect
1060   # by just sending the TCP SYN packet
1061   if (connect($fh, $saddr)) {
1062     # Non-blocking, yet still connected?
1063     # Must have connected very quickly,
1064     # or else it wasn't very non-blocking.
1065     #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
1066   } else {
1067     # Error occurred connecting.
1068     if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
1069       # The connection is just still in progress.
1070       # This is the expected condition.
1071     } else {
1072       # Just save the error and continue on.
1073       # The ack() can check the status later.
1074       $self->{"bad"}->{$host} = $!;
1075     }
1076   }
1077
1078   my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
1079   $self->{"syn"}->{$fh->fileno} = $entry;
1080   if ($self->{"stop_time"} < $stop_time) {
1081     $self->{"stop_time"} = $stop_time;
1082   }
1083   vec($self->{"wbits"}, $fh->fileno, 1) = 1;
1084
1085   return 1;
1086 }
1087
1088 sub ping_syn_fork {
1089   my ($self, $host, $ip, $start_time, $stop_time) = @_;
1090
1091   # Buggy Winsock API doesn't allow nonblocking connect.
1092   # Hence, if our OS is Windows, we need to create a separate
1093   # process to do the blocking connect attempt.
1094   my $pid = fork();
1095   if (defined $pid) {
1096     if ($pid) {
1097       # Parent process
1098       my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
1099       $self->{"syn"}->{$pid} = $entry;
1100       if ($self->{"stop_time"} < $stop_time) {
1101         $self->{"stop_time"} = $stop_time;
1102       }
1103     } else {
1104       # Child process
1105       my $saddr = sockaddr_in($self->{"port_num"}, $ip);
1106
1107       # Create TCP socket
1108       if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
1109         croak("tcp socket error - $!");
1110       }
1111
1112       if (defined $self->{"local_addr"} &&
1113           !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
1114         croak("tcp bind error - $!");
1115       }
1116
1117       if ($self->{'device'}) {
1118         setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
1119           or croak("error binding to device $self->{'device'} $!");
1120       }
1121       if ($self->{'tos'}) {
1122         setsockopt($self->{"fh"}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
1123           or croak "error configuring tos to $self->{'tos'} $!";
1124       }
1125
1126       $!=0;
1127       # Try to connect (could take a long time)
1128       connect($self->{"fh"}, $saddr);
1129       # Notify parent of connect error status
1130       my $err = $!+0;
1131       my $wrstr = "$$ $err";
1132       # Force to 16 chars including \n
1133       $wrstr .= " "x(15 - length $wrstr). "\n";
1134       syswrite($self->{"fork_wr"}, $wrstr, length $wrstr);
1135       exit;
1136     }
1137   } else {
1138     # fork() failed?
1139     die "fork: $!";
1140   }
1141   return 1;
1142 }
1143
1144 # Description: Wait for TCP ACK from host specified
1145 # from ping_syn above.  If no host is specified, wait
1146 # for TCP ACK from any of the hosts in the SYN queue.
1147 sub ack
1148 {
1149   my $self = shift;
1150
1151   if ($self->{"proto"} eq "syn") {
1152     if ($syn_forking) {
1153       my @answer = $self->ack_unfork(shift);
1154       return wantarray ? @answer : $answer[0];
1155     }
1156     my $wbits = "";
1157     my $stop_time = 0;
1158     if (my $host = shift) {
1159       # Host passed as arg
1160       if (exists $self->{"bad"}->{$host}) {
1161         if (!$self->{"econnrefused"} &&
1162             $self->{"bad"}->{ $host } &&
1163             (($! = ECONNREFUSED)>0) &&
1164             $self->{"bad"}->{ $host } eq "$!") {
1165           # "Connection refused" means reachable
1166           # Good, continue
1167         } else {
1168           # ECONNREFUSED means no good
1169           return ();
1170         }
1171       }
1172       my $host_fd = undef;
1173       foreach my $fd (keys %{ $self->{"syn"} }) {
1174         my $entry = $self->{"syn"}->{$fd};
1175         if ($entry->[0] eq $host) {
1176           $host_fd = $fd;
1177           $stop_time = $entry->[4]
1178             || croak("Corrupted SYN entry for [$host]");
1179           last;
1180         }
1181       }
1182       croak("ack called on [$host] without calling ping first!")
1183         unless defined $host_fd;
1184       vec($wbits, $host_fd, 1) = 1;
1185     } else {
1186       # No $host passed so scan all hosts
1187       # Use the latest stop_time
1188       $stop_time = $self->{"stop_time"};
1189       # Use all the bits
1190       $wbits = $self->{"wbits"};
1191     }
1192
1193     while ($wbits !~ /^\0*\z/) {
1194       my $timeout = $stop_time - &time();
1195       # Force a minimum of 10 ms timeout.
1196       $timeout = 0.01 if $timeout <= 0.01;
1197
1198       my $winner_fd = undef;
1199       my $wout = $wbits;
1200       my $fd = 0;
1201       # Do "bad" fds from $wbits first
1202       while ($wout !~ /^\0*\z/) {
1203         if (vec($wout, $fd, 1)) {
1204           # Wipe it from future scanning.
1205           vec($wout, $fd, 1) = 0;
1206           if (my $entry = $self->{"syn"}->{$fd}) {
1207             if ($self->{"bad"}->{ $entry->[0] }) {
1208               $winner_fd = $fd;
1209               last;
1210             }
1211           }
1212         }
1213         $fd++;
1214       }
1215
1216       if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
1217         if (defined $winner_fd) {
1218           $fd = $winner_fd;
1219         } else {
1220           # Done waiting for one of the ACKs
1221           $fd = 0;
1222           # Determine which one
1223           while ($wout !~ /^\0*\z/ &&
1224                  !vec($wout, $fd, 1)) {
1225             $fd++;
1226           }
1227         }
1228         if (my $entry = $self->{"syn"}->{$fd}) {
1229           # Wipe it from future scanning.
1230           delete $self->{"syn"}->{$fd};
1231           vec($self->{"wbits"}, $fd, 1) = 0;
1232           vec($wbits, $fd, 1) = 0;
1233           if (!$self->{"econnrefused"} &&
1234               $self->{"bad"}->{ $entry->[0] } &&
1235               (($! = ECONNREFUSED)>0) &&
1236               $self->{"bad"}->{ $entry->[0] } eq "$!") {
1237             # "Connection refused" means reachable
1238             # Good, continue
1239           } elsif (getpeername($entry->[2])) {
1240             # Connection established to remote host
1241             # Good, continue
1242           } else {
1243             # TCP ACK will never come from this host
1244             # because there was an error connecting.
1245
1246             # This should set $! to the correct error.
1247             my $char;
1248             sysread($entry->[2],$char,1);
1249             # Store the excuse why the connection failed.
1250             $self->{"bad"}->{$entry->[0]} = $!;
1251             if (!$self->{"econnrefused"} &&
1252                 (($! == ECONNREFUSED) ||
1253                  ($! == EAGAIN && $^O =~ /cygwin/i))) {
1254               # "Connection refused" means reachable
1255               # Good, continue
1256             } else {
1257               # No good, try the next socket...
1258               next;
1259             }
1260           }
1261           # Everything passed okay, return the answer
1262           return wantarray ?
1263             ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]))
1264             : $entry->[0];
1265         } else {
1266           warn "Corrupted SYN entry: unknown fd [$fd] ready!";
1267           vec($wbits, $fd, 1) = 0;
1268           vec($self->{"wbits"}, $fd, 1) = 0;
1269         }
1270       } elsif (defined $nfound) {
1271         # Timed out waiting for ACK
1272         foreach my $fd (keys %{ $self->{"syn"} }) {
1273           if (vec($wbits, $fd, 1)) {
1274             my $entry = $self->{"syn"}->{$fd};
1275             $self->{"bad"}->{$entry->[0]} = "Timed out";
1276             vec($wbits, $fd, 1) = 0;
1277             vec($self->{"wbits"}, $fd, 1) = 0;
1278             delete $self->{"syn"}->{$fd};
1279           }
1280         }
1281       } else {
1282         # Weird error occurred with select()
1283         warn("select: $!");
1284         $self->{"syn"} = {};
1285         $wbits = "";
1286       }
1287     }
1288   }
1289   return ();
1290 }
1291
1292 sub ack_unfork {
1293   my ($self,$host) = @_;
1294   my $stop_time = $self->{"stop_time"};
1295   if ($host) {
1296     # Host passed as arg
1297     if (my $entry = $self->{"good"}->{$host}) {
1298       delete $self->{"good"}->{$host};
1299       return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]));
1300     }
1301   }
1302
1303   my $rbits = "";
1304   my $timeout;
1305
1306   if (keys %{ $self->{"syn"} }) {
1307     # Scan all hosts that are left
1308     vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
1309     $timeout = $stop_time - &time();
1310     # Force a minimum of 10 ms timeout.
1311     $timeout = 0.01 if $timeout < 0.01;
1312   } else {
1313     # No hosts left to wait for
1314     $timeout = 0;
1315   }
1316
1317   if ($timeout > 0) {
1318     my $nfound;
1319     while ( keys %{ $self->{"syn"} } and
1320            $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
1321       # Done waiting for one of the ACKs
1322       if (!sysread($self->{"fork_rd"}, $_, 16)) {
1323         # Socket closed, which means all children are done.
1324         return ();
1325       }
1326       my ($pid, $how) = split;
1327       if ($pid) {
1328         # Flush the zombie
1329         waitpid($pid, 0);
1330         if (my $entry = $self->{"syn"}->{$pid}) {
1331           # Connection attempt to remote host is done
1332           delete $self->{"syn"}->{$pid};
1333           if (!$how || # If there was no error connecting
1334               (!$self->{"econnrefused"} &&
1335                $how == ECONNREFUSED)) {  # "Connection refused" means reachable
1336             if ($host && $entry->[0] ne $host) {
1337               # A good connection, but not the host we need.
1338               # Move it from the "syn" hash to the "good" hash.
1339               $self->{"good"}->{$entry->[0]} = $entry;
1340               # And wait for the next winner
1341               next;
1342             }
1343             return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]));
1344           }
1345         } else {
1346           # Should never happen
1347           die "Unknown ping from pid [$pid]";
1348         }
1349       } else {
1350         die "Empty response from status socket?";
1351       }
1352     }
1353     if (defined $nfound) {
1354       # Timed out waiting for ACK status
1355     } else {
1356       # Weird error occurred with select()
1357       warn("select: $!");
1358     }
1359   }
1360   if (my @synners = keys %{ $self->{"syn"} }) {
1361     # Kill all the synners
1362     kill 9, @synners;
1363     foreach my $pid (@synners) {
1364       # Wait for the deaths to finish
1365       # Then flush off the zombie
1366       waitpid($pid, 0);
1367     }
1368   }
1369   $self->{"syn"} = {};
1370   return ();
1371 }
1372
1373 # Description:  Tell why the ack() failed
1374 sub nack {
1375   my $self = shift;
1376   my $host = shift || croak('Usage> nack($failed_ack_host)');
1377   return $self->{"bad"}->{$host} || undef;
1378 }
1379
1380 # Description:  Close the connection.
1381
1382 sub close
1383 {
1384   my ($self) = @_;
1385
1386   if ($self->{"proto"} eq "syn") {
1387     delete $self->{"syn"};
1388   } elsif ($self->{"proto"} eq "tcp") {
1389     # The connection will already be closed
1390   } elsif ($self->{"proto"} eq "external") {
1391     # Nothing to close
1392   } else {
1393     $self->{"fh"}->close();
1394   }
1395 }
1396
1397 sub port_number {
1398    my $self = shift;
1399    if(@_) {
1400        $self->{port_num} = shift @_;
1401        $self->service_check(1);
1402    }
1403    return $self->{port_num};
1404 }
1405
1406 sub ntop {
1407     my($self, $ip) = @_;
1408
1409     # Vista doesn't define a inet_ntop.  It has InetNtop instead.
1410     # Not following ANSI... priceless.  getnameinfo() is defined
1411     # for Windows 2000 and later, so that may be the choice.
1412
1413     # Any port will work, even undef, but this will work for now.
1414     # Socket warns when undef is passed in, but it still works.
1415     my $port = getservbyname('echo', 'udp');
1416     my $sockaddr = sockaddr_in $port, $ip;
1417     my ($error, $address) = getnameinfo($sockaddr, NI_NUMERICHOST);
1418     if($error) {
1419       croak $error;
1420     }
1421     return $address;
1422 }
1423
1424 1;
1425 __END__
1426
1427 =head1 NAME
1428
1429 Net::Ping - check a remote host for reachability
1430
1431 =head1 SYNOPSIS
1432
1433     use Net::Ping;
1434
1435     $p = Net::Ping->new();
1436     print "$host is alive.\n" if $p->ping($host);
1437     $p->close();
1438
1439     $p = Net::Ping->new("icmp");
1440     $p->bind($my_addr); # Specify source interface of pings
1441     foreach $host (@host_array)
1442     {
1443         print "$host is ";
1444         print "NOT " unless $p->ping($host, 2);
1445         print "reachable.\n";
1446         sleep(1);
1447     }
1448     $p->close();
1449
1450     $p = Net::Ping->new("tcp", 2);
1451     # Try connecting to the www port instead of the echo port
1452     $p->port_number(scalar(getservbyname("http", "tcp")));
1453     while ($stop_time > time())
1454     {
1455         print "$host not reachable ", scalar(localtime()), "\n"
1456             unless $p->ping($host);
1457         sleep(300);
1458     }
1459     undef($p);
1460
1461     # Like tcp protocol, but with many hosts
1462     $p = Net::Ping->new("syn");
1463     $p->port_number(getservbyname("http", "tcp"));
1464     foreach $host (@host_array) {
1465       $p->ping($host);
1466     }
1467     while (($host,$rtt,$ip) = $p->ack) {
1468       print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
1469     }
1470
1471     # High precision syntax (requires Time::HiRes)
1472     $p = Net::Ping->new();
1473     $p->hires();
1474     ($ret, $duration, $ip) = $p->ping($host, 5.5);
1475     printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n",
1476             1000 * $duration)
1477       if $ret;
1478     $p->close();
1479
1480     # For backward compatibility
1481     print "$host is alive.\n" if pingecho($host);
1482
1483 =head1 DESCRIPTION
1484
1485 This module contains methods to test the reachability of remote
1486 hosts on a network.  A ping object is first created with optional
1487 parameters, a variable number of hosts may be pinged multiple
1488 times and then the connection is closed.
1489
1490 You may choose one of six different protocols to use for the
1491 ping. The "tcp" protocol is the default. Note that a live remote host
1492 may still fail to be pingable by one or more of these protocols. For
1493 example, www.microsoft.com is generally alive but not "icmp" pingable.
1494
1495 With the "tcp" protocol the ping() method attempts to establish a
1496 connection to the remote host's echo port.  If the connection is
1497 successfully established, the remote host is considered reachable.  No
1498 data is actually echoed.  This protocol does not require any special
1499 privileges but has higher overhead than the "udp" and "icmp" protocols.
1500
1501 Specifying the "udp" protocol causes the ping() method to send a udp
1502 packet to the remote host's echo port.  If the echoed packet is
1503 received from the remote host and the received packet contains the
1504 same data as the packet that was sent, the remote host is considered
1505 reachable.  This protocol does not require any special privileges.
1506 It should be borne in mind that, for a udp ping, a host
1507 will be reported as unreachable if it is not running the
1508 appropriate echo service.  For Unix-like systems see L<inetd(8)>
1509 for more information.
1510
1511 If the "icmp" protocol is specified, the ping() method sends an icmp
1512 echo message to the remote host, which is what the UNIX ping program
1513 does.  If the echoed message is received from the remote host and
1514 the echoed information is correct, the remote host is considered
1515 reachable.  Specifying the "icmp" protocol requires that the program
1516 be run as root or that the program be setuid to root.
1517
1518 If the "external" protocol is specified, the ping() method attempts to
1519 use the C<Net::Ping::External> module to ping the remote host.
1520 C<Net::Ping::External> interfaces with your system's default C<ping>
1521 utility to perform the ping, and generally produces relatively
1522 accurate results. If C<Net::Ping::External> if not installed on your
1523 system, specifying the "external" protocol will result in an error.
1524
1525 If the "syn" protocol is specified, the ping() method will only
1526 send a TCP SYN packet to the remote host then immediately return.
1527 If the syn packet was sent successfully, it will return a true value,
1528 otherwise it will return false.  NOTE: Unlike the other protocols,
1529 the return value does NOT determine if the remote host is alive or
1530 not since the full TCP three-way handshake may not have completed
1531 yet.  The remote host is only considered reachable if it receives
1532 a TCP ACK within the timeout specified.  To begin waiting for the
1533 ACK packets, use the ack() method as explained below.  Use the
1534 "syn" protocol instead the "tcp" protocol to determine reachability
1535 of multiple destinations simultaneously by sending parallel TCP
1536 SYN packets.  It will not block while testing each remote host.
1537 demo/fping is provided in this distribution to demonstrate the
1538 "syn" protocol as an example.
1539 This protocol does not require any special privileges.
1540
1541 =head2 Functions
1542
1543 =over 4
1544
1545 =item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos [, $ttl ]]]]]]);
1546
1547 Create a new ping object.  All of the parameters are optional.  $proto
1548 specifies the protocol to use when doing a ping.  The current choices
1549 are "tcp", "udp", "icmp", "stream", "syn", or "external".
1550 The default is "tcp".
1551
1552 If a default timeout ($def_timeout) in seconds is provided, it is used
1553 when a timeout is not given to the ping() method (below).  The timeout
1554 must be greater than 0 and the default, if not specified, is 5 seconds.
1555
1556 If the number of data bytes ($bytes) is given, that many data bytes
1557 are included in the ping packet sent to the remote host. The number of
1558 data bytes is ignored if the protocol is "tcp".  The minimum (and
1559 default) number of data bytes is 1 if the protocol is "udp" and 0
1560 otherwise.  The maximum number of data bytes that can be specified is
1561 1024.
1562
1563 If $device is given, this device is used to bind the source endpoint
1564 before sending the ping packet.  I believe this only works with
1565 superuser privileges and with udp and icmp protocols at this time.
1566
1567 If $tos is given, this ToS is configured into the socket.
1568
1569 For icmp, $ttl can be specified to set the TTL of the outgoing packet.
1570
1571 =item $p->ping($host [, $timeout]);
1572
1573 Ping the remote host and wait for a response.  $host can be either the
1574 hostname or the IP number of the remote host.  The optional timeout
1575 must be greater than 0 seconds and defaults to whatever was specified
1576 when the ping object was created.  Returns a success flag.  If the
1577 hostname cannot be found or there is a problem with the IP number, the
1578 success flag returned will be undef.  Otherwise, the success flag will
1579 be 1 if the host is reachable and 0 if it is not.  For most practical
1580 purposes, undef and 0 and can be treated as the same case.  In array
1581 context, the elapsed time as well as the string form of the ip the
1582 host resolved to are also returned.  The elapsed time value will
1583 be a float, as returned by the Time::HiRes::time() function, if hires()
1584 has been previously called, otherwise it is returned as an integer.
1585
1586 =item $p->source_verify( { 0 | 1 } );
1587
1588 Allows source endpoint verification to be enabled or disabled.
1589 This is useful for those remote destinations with multiples
1590 interfaces where the response may not originate from the same
1591 endpoint that the original destination endpoint was sent to.
1592 This only affects udp and icmp protocol pings.
1593
1594 This is enabled by default.
1595
1596 =item $p->service_check( { 0 | 1 } );
1597
1598 Set whether or not the connect behavior should enforce
1599 remote service availability as well as reachability.  Normally,
1600 if the remote server reported ECONNREFUSED, it must have been
1601 reachable because of the status packet that it reported.
1602 With this option enabled, the full three-way tcp handshake
1603 must have been established successfully before it will
1604 claim it is reachable.  NOTE:  It still does nothing more
1605 than connect and disconnect.  It does not speak any protocol
1606 (i.e., HTTP or FTP) to ensure the remote server is sane in
1607 any way.  The remote server CPU could be grinding to a halt
1608 and unresponsive to any clients connecting, but if the kernel
1609 throws the ACK packet, it is considered alive anyway.  To
1610 really determine if the server is responding well would be
1611 application specific and is beyond the scope of Net::Ping.
1612 For udp protocol, enabling this option demands that the
1613 remote server replies with the same udp data that it was sent
1614 as defined by the udp echo service.
1615
1616 This affects the "udp", "tcp", and "syn" protocols.
1617
1618 This is disabled by default.
1619
1620 =item $p->tcp_service_check( { 0 | 1 } );
1621
1622 Deprecated method, but does the same as service_check() method.
1623
1624 =item $p->hires( { 0 | 1 } );
1625
1626 Causes this module to use Time::HiRes module, allowing milliseconds
1627 to be returned by subsequent calls to ping().
1628
1629 This is disabled by default.
1630
1631 =item $p->bind($local_addr);
1632
1633 Sets the source address from which pings will be sent.  This must be
1634 the address of one of the interfaces on the local host.  $local_addr
1635 may be specified as a hostname or as a text IP address such as
1636 "192.168.1.1".
1637
1638 If the protocol is set to "tcp", this method may be called any
1639 number of times, and each call to the ping() method (below) will use
1640 the most recent $local_addr.  If the protocol is "icmp" or "udp",
1641 then bind() must be called at most once per object, and (if it is
1642 called at all) must be called before the first call to ping() for that
1643 object.
1644
1645 =item $p->open($host);
1646
1647 When you are using the "stream" protocol, this call pre-opens the
1648 tcp socket.  It's only necessary to do this if you want to
1649 provide a different timeout when creating the connection, or
1650 remove the overhead of establishing the connection from the
1651 first ping.  If you don't call C<open()>, the connection is
1652 automatically opened the first time C<ping()> is called.
1653 This call simply does nothing if you are using any protocol other
1654 than stream.
1655
1656 =item $p->ack( [ $host ] );
1657
1658 When using the "syn" protocol, use this method to determine
1659 the reachability of the remote host.  This method is meant
1660 to be called up to as many times as ping() was called.  Each
1661 call returns the host (as passed to ping()) that came back
1662 with the TCP ACK.  The order in which the hosts are returned
1663 may not necessarily be the same order in which they were
1664 SYN queued using the ping() method.  If the timeout is
1665 reached before the TCP ACK is received, or if the remote
1666 host is not listening on the port attempted, then the TCP
1667 connection will not be established and ack() will return
1668 undef.  In list context, the host, the ack time, and the
1669 dotted ip string will be returned instead of just the host.
1670 If the optional $host argument is specified, the return
1671 value will be pertaining to that host only.
1672 This call simply does nothing if you are using any protocol
1673 other than syn.
1674
1675 =item $p->nack( $failed_ack_host );
1676
1677 The reason that host $failed_ack_host did not receive a
1678 valid ACK.  Useful to find out why when ack( $fail_ack_host )
1679 returns a false value.
1680
1681 =item $p->close();
1682
1683 Close the network connection for this ping object.  The network
1684 connection is also closed by "undef $p".  The network connection is
1685 automatically closed if the ping object goes out of scope (e.g. $p is
1686 local to a subroutine and you leave the subroutine).
1687
1688 =item $p->port_number([$port_number])
1689
1690 When called with a port number, the port number used to ping is set to
1691 $port_number rather than using the echo port.  It also has the effect
1692 of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful
1693 response only if that specific port is accessible.  This function returns
1694 the value of the port that C<ping()> will connect to.
1695
1696 =item pingecho($host [, $timeout]);
1697
1698 To provide backward compatibility with the previous version of
1699 Net::Ping, a pingecho() subroutine is available with the same
1700 functionality as before.  pingecho() uses the tcp protocol.  The
1701 return values and parameters are the same as described for the ping()
1702 method.  This subroutine is obsolete and may be removed in a future
1703 version of Net::Ping.
1704
1705 =back
1706
1707 =head1 NOTES
1708
1709 There will be less network overhead (and some efficiency in your
1710 program) if you specify either the udp or the icmp protocol.  The tcp
1711 protocol will generate 2.5 times or more traffic for each ping than
1712 either udp or icmp.  If many hosts are pinged frequently, you may wish
1713 to implement a small wait (e.g. 25ms or more) between each ping to
1714 avoid flooding your network with packets.
1715
1716 The icmp protocol requires that the program be run as root or that it
1717 be setuid to root.  The other protocols do not require special
1718 privileges, but not all network devices implement tcp or udp echo.
1719
1720 Local hosts should normally respond to pings within milliseconds.
1721 However, on a very congested network it may take up to 3 seconds or
1722 longer to receive an echo packet from the remote host.  If the timeout
1723 is set too low under these conditions, it will appear that the remote
1724 host is not reachable (which is almost the truth).
1725
1726 Reachability doesn't necessarily mean that the remote host is actually
1727 functioning beyond its ability to echo packets.  tcp is slightly better
1728 at indicating the health of a system than icmp because it uses more
1729 of the networking stack to respond.
1730
1731 Because of a lack of anything better, this module uses its own
1732 routines to pack and unpack ICMP packets.  It would be better for a
1733 separate module to be written which understands all of the different
1734 kinds of ICMP packets.
1735
1736 =head1 INSTALL
1737
1738 The latest source tree is available via cvs:
1739
1740   cvs -z3 -q -d \
1741     :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware \
1742     checkout Net-Ping
1743   cd Net-Ping
1744
1745 The tarball can be created as follows:
1746
1747   perl Makefile.PL ; make ; make dist
1748
1749 The latest Net::Ping release can be found at CPAN:
1750
1751   $CPAN/modules/by-module/Net/
1752
1753 1) Extract the tarball
1754
1755   gtar -zxvf Net-Ping-xxxx.tar.gz
1756   cd Net-Ping-xxxx
1757
1758 2) Build:
1759
1760   make realclean
1761   perl Makefile.PL
1762   make
1763   make test
1764
1765 3) Install
1766
1767   make install
1768
1769 Or install it RPM Style:
1770
1771   rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
1772
1773   rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
1774
1775 =head1 BUGS
1776
1777 For a list of known issues, visit:
1778
1779 https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping
1780
1781 To report a new bug, visit:
1782
1783 https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping
1784
1785 =head1 AUTHORS
1786
1787   Current maintainer:
1788     bbb@cpan.org (Rob Brown)
1789
1790   External protocol:
1791     colinm@cpan.org (Colin McMillen)
1792
1793   Stream protocol:
1794     bronson@trestle.com (Scott Bronson)
1795
1796   Original pingecho():
1797     karrer@bernina.ethz.ch (Andreas Karrer)
1798     pmarquess@bfsec.bt.co.uk (Paul Marquess)
1799
1800   Original Net::Ping author:
1801     mose@ns.ccsn.edu (Russell Mosemann)
1802
1803 =head1 COPYRIGHT
1804
1805 Copyright (c) 2002-2003, Rob Brown.  All rights reserved.
1806
1807 Copyright (c) 2001, Colin McMillen.  All rights reserved.
1808
1809 This program is free software; you may redistribute it and/or
1810 modify it under the same terms as Perl itself.
1811
1812 =cut