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