3 # $Id: Ping.pm,v 1.46 2002/12/02 19:17:09 rob Exp $
9 use vars qw(@ISA @EXPORT $VERSION
10 $def_timeout $def_proto $max_datasize $pingstring $hires $source_verify $syn_forking);
11 use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
12 use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET
13 inet_aton inet_ntoa sockaddr_in );
14 use POSIX qw( ECONNREFUSED EINPROGRESS EAGAIN WNOHANG );
19 @EXPORT = qw(pingecho);
24 $def_timeout = 5; # Default timeout to wait for a reply
25 $def_proto = "tcp"; # Default protocol to use for pinging
26 $max_datasize = 1024; # Maximum data bytes in a packet
27 # The data we exchange with the server for the stream protocol
28 $pingstring = "pingschwingping!\n";
29 $source_verify = 1; # Default is to verify source endpoint
32 if ($^O =~ /Win32/i) {
33 # Hack to avoid this Win32 spewage:
34 # Your vendor has not defined POSIX macro ECONNREFUSED
35 *ECONNREFUSED = sub {10061;}; # "Unknown Error" Special Win32 Response?
40 # require "asm/socket.ph";
41 sub SO_BINDTODEVICE {25;}
43 # Description: The pingecho() subroutine is provided for backward
44 # compatibility with the original Net::Ping. It accepts a host
45 # name/IP and an optional timeout in seconds. Create a tcp ping
46 # object and try pinging the host. The result of the ping is returned.
50 my ($host, # Name or IP number of host to ping
51 $timeout # Optional timeout in seconds
53 my ($p); # A ping object
55 $p = Net::Ping->new("tcp", $timeout);
56 $p->ping($host); # Going out of scope closes the connection
59 # Description: The new() method creates a new ping object. Optional
60 # parameters may be specified for the protocol to use, the timeout in
61 # seconds and the size in bytes of additional data which should be
62 # included in the packet.
63 # After the optional parameters are checked, the data is constructed
64 # and a socket is opened if appropriate. The object is returned.
69 $proto, # Optional protocol to use for pinging
70 $timeout, # Optional timeout in seconds
71 $data_size, # Optional additional bytes of data
72 $device, # Optional device to use
74 my $class = ref($this) || $this;
76 my ($cnt, # Count through data bytes
77 $min_datasize # Minimum data bytes required
82 $proto = $def_proto unless $proto; # Determine the protocol
83 croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
84 unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
85 $self->{"proto"} = $proto;
87 $timeout = $def_timeout unless $timeout; # Determine the timeout
88 croak("Default timeout for ping must be greater than 0 seconds")
90 $self->{"timeout"} = $timeout;
92 $self->{"device"} = $device;
94 $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
95 $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
96 croak("Data for ping must be from $min_datasize to $max_datasize bytes")
97 if ($data_size < $min_datasize) || ($data_size > $max_datasize);
98 $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
99 $self->{"data_size"} = $data_size;
101 $self->{"data"} = ""; # Construct data bytes
102 for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
104 $self->{"data"} .= chr($cnt % 256);
107 $self->{"local_addr"} = undef; # Don't bind by default
109 $self->{"tcp_econnrefused"} = undef; # Default Connection refused behavior
111 $self->{"seq"} = 0; # For counting packets
112 if ($self->{"proto"} eq "udp") # Open a socket
114 $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
115 croak("Can't udp protocol by name");
116 $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
117 croak("Can't get udp echo port by name");
118 $self->{"fh"} = FileHandle->new();
119 socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
120 $self->{"proto_num"}) ||
121 croak("udp socket error - $!");
122 if ($self->{'device'}) {
123 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
124 or croak "error binding to device $self->{'device'} $!";
127 elsif ($self->{"proto"} eq "icmp")
129 croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
130 $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
131 croak("Can't get icmp protocol by name");
132 $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
133 $self->{"fh"} = FileHandle->new();
134 socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
135 croak("icmp socket error - $!");
136 if ($self->{'device'}) {
137 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
138 or croak "error binding to device $self->{'device'} $!";
141 elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
143 $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
144 croak("Can't get tcp protocol by name");
145 $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
146 croak("Can't get tcp echo port by name");
147 $self->{"fh"} = FileHandle->new();
149 elsif ($self->{"proto"} eq "syn")
151 $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
152 croak("Can't get tcp protocol by name");
153 $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
154 croak("Can't get tcp echo port by name");
156 $self->{"fork_rd"} = FileHandle->new();
157 $self->{"fork_wr"} = FileHandle->new();
158 pipe($self->{"fork_rd"}, $self->{"fork_wr"});
159 $self->{"fh"} = FileHandle->new();
160 $self->{"good"} = {};
163 $self->{"wbits"} = "";
167 $self->{"stop_time"} = 0;
169 elsif ($self->{"proto"} eq "external")
171 # No preliminary work needs to be done.
177 # Description: Set the local IP address from which pings will be sent.
178 # For ICMP and UDP pings, this calls bind() on the already-opened socket;
179 # for TCP pings, just saves the address to be used when the socket is
180 # opened. Returns non-zero if successful; croaks on error.
184 $local_addr # Name or IP number of local interface
186 my ($ip # Packed IP number of $local_addr
189 croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
190 croak("already bound") if defined($self->{"local_addr"}) &&
191 ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
193 $ip = inet_aton($local_addr);
194 croak("nonexistent local address $local_addr") unless defined($ip);
195 $self->{"local_addr"} = $ip; # Only used if proto is tcp
197 if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
199 CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
200 croak("$self->{'proto'} bind error - $!");
202 elsif ($self->{"proto"} ne "tcp")
204 croak("Unknown protocol \"$self->{proto}\" in bind()");
211 # Description: Allow UDP source endpoint comparision to be
212 # skipped for those remote interfaces that do
213 # not response from the same endpoint.
218 $source_verify = 1 unless defined
219 ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
222 # Description: Set whether or not the tcp connect
223 # behavior should enforce remote service availability
224 # as well as reachability.
226 sub tcp_service_check
229 $self->{"tcp_econnrefused"} = 1 unless defined
230 ($self->{"tcp_econnrefused"} = shift());
233 # Description: allows the module to use milliseconds as returned by
234 # the Time::HiRes module
240 $hires = 1 unless defined
241 ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
242 require Time::HiRes if $hires;
247 return $hires ? Time::HiRes::time() : CORE::time();
250 # Description: Ping a host name or IP number with an optional timeout.
251 # First lookup the host, and return undef if it is not found. Otherwise
252 # perform the specific ping method based on the protocol. Return the
253 # result of the ping.
258 $host, # Name or IP number of host to ping
259 $timeout, # Seconds after which ping times out
261 my ($ip, # Packed IP number of $host
262 $ret, # The return value
263 $ping_time, # When ping began
266 croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
267 $timeout = $self->{"timeout"} unless $timeout;
268 croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
270 $ip = inet_aton($host);
271 return(undef) unless defined($ip); # Does host exist?
273 # Dispatch to the appropriate routine.
274 $ping_time = &time();
275 if ($self->{"proto"} eq "external") {
276 $ret = $self->ping_external($ip, $timeout);
278 elsif ($self->{"proto"} eq "udp") {
279 $ret = $self->ping_udp($ip, $timeout);
281 elsif ($self->{"proto"} eq "icmp") {
282 $ret = $self->ping_icmp($ip, $timeout);
284 elsif ($self->{"proto"} eq "tcp") {
285 $ret = $self->ping_tcp($ip, $timeout);
287 elsif ($self->{"proto"} eq "stream") {
288 $ret = $self->ping_stream($ip, $timeout);
290 elsif ($self->{"proto"} eq "syn") {
291 $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
293 croak("Unknown protocol \"$self->{proto}\" in ping()");
296 return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
299 # Uses Net::Ping::External to do an external ping.
302 $ip, # Packed IP number of the host
303 $timeout # Seconds after which ping times out
306 eval { require Net::Ping::External; }
307 or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
308 return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
311 use constant ICMP_ECHOREPLY => 0; # ICMP packet types
312 use constant ICMP_ECHO => 8;
313 use constant ICMP_STRUCT => "C2 S3 A"; # Structure of a minimal ICMP packet
314 use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
315 use constant ICMP_FLAGS => 0; # No special flags for send or recv
316 use constant ICMP_PORT => 0; # No port with ICMP
321 $ip, # Packed IP number of the host
322 $timeout # Seconds after which ping times out
325 my ($saddr, # sockaddr_in with port and ip
326 $checksum, # Checksum of ICMP packet
327 $msg, # ICMP packet to send
328 $len_msg, # Length of $msg
329 $rbits, # Read bits, filehandles for reading
330 $nfound, # Number of ready filehandles found
331 $finish_time, # Time ping should be finished
332 $done, # set to 1 when we are done
334 $recv_msg, # Received message including IP header
335 $from_saddr, # sockaddr_in of sender
336 $from_port, # Port packet was sent from
337 $from_ip, # Packed IP of sender
338 $from_type, # ICMP type
339 $from_subcode, # ICMP subcode
340 $from_chk, # ICMP packet checksum
341 $from_pid, # ICMP packet id
342 $from_seq, # ICMP packet sequence
343 $from_msg # ICMP message
346 $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
347 $checksum = 0; # No checksum for starters
348 $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
349 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
350 $checksum = Net::Ping->checksum($msg);
351 $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
352 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
353 $len_msg = length($msg);
354 $saddr = sockaddr_in(ICMP_PORT, $ip);
355 send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
358 vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
361 $finish_time = &time() + $timeout; # Must be done by this time
362 while (!$done && $timeout > 0) # Keep trying if we have time
364 $nfound = select($rbits, undef, undef, $timeout); # Wait for packet
365 $timeout = $finish_time - &time(); # Get remaining time
366 if (!defined($nfound)) # Hmm, a strange error
371 elsif ($nfound) # Got a packet from somewhere
374 $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
375 ($from_port, $from_ip) = sockaddr_in($from_saddr);
376 ($from_type, $from_subcode, $from_chk,
377 $from_pid, $from_seq, $from_msg) =
378 unpack(ICMP_STRUCT . $self->{"data_size"},
379 substr($recv_msg, length($recv_msg) - $len_msg,
381 if (($from_type == ICMP_ECHOREPLY) &&
382 (!$source_verify || $from_ip eq $ip) &&
383 ($from_pid == $self->{"pid"}) && # Does the packet check out?
384 ($from_seq == $self->{"seq"}))
386 $ret = 1; # It's a winner
390 else # Oops, timed out
398 # Description: Do a checksum on the message. Basically sum all of
399 # the short words and fold the high order bits into the low order bits.
404 $msg # The message to checksum
406 my ($len_msg, # Length of the message
407 $num_short, # The number of short words in the message
408 $short, # One short word
412 $len_msg = length($msg);
413 $num_short = int($len_msg / 2);
415 foreach $short (unpack("S$num_short", $msg))
418 } # Add the odd byte in
419 $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
420 $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
421 return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
425 # Description: Perform a tcp echo ping. Since a tcp connection is
426 # host specific, we have to open and close each connection here. We
427 # can't just leave a socket open. Because of the robust nature of
428 # tcp, it will take a while before it gives up trying to establish a
429 # connection. Therefore, we use select() on a non-blocking socket to
430 # check against our timeout. No data bytes are actually
431 # sent since the successful establishment of a connection is proof
432 # enough of the reachability of the remote host. Also, tcp is
433 # expensive and doesn't need our help to add to the overhead.
438 $ip, # Packed IP number of the host
439 $timeout # Seconds after which ping times out
441 my ($ret # The return value
445 $ret = $self -> tcp_connect( $ip, $timeout);
446 if (!$self->{"tcp_econnrefused"} &&
447 $! == ECONNREFUSED) {
448 $ret = 1; # "Connection refused" means reachable
450 $self->{"fh"}->close();
457 $ip, # Packed IP number of the host
458 $timeout # Seconds after which connect times out
460 my ($saddr); # Packed IP and Port
462 $saddr = sockaddr_in($self->{"port_num"}, $ip);
464 my $ret = 0; # Default to unreachable
466 my $do_socket = sub {
467 socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
468 croak("tcp socket error - $!");
469 if (defined $self->{"local_addr"} &&
470 !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
471 croak("tcp bind error - $!");
473 if ($self->{'device'}) {
474 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
475 or croak("error binding to device $self->{'device'} $!");
478 my $do_connect = sub {
480 die $! unless connect($self->{"fh"}, $saddr);
487 if ($^O =~ /Win32/i) {
489 # Buggy Winsock API doesn't allow us to use alarm() calls.
490 # Hence, if our OS is Windows, we need to create a separate
491 # process to do the blocking connect attempt.
493 $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
498 warn "Win32 Fork error: $!";
503 # Try a slow blocking connect() call
504 # and report the status to the pipe.
505 if ( &{ $do_connect }() ) {
506 $self->{"fh"}->close();
510 # Pass the error status to the parent
517 my $patience = &time() + $timeout;
521 # Wait up to the timeout
522 # And clean off the zombie
524 $child = waitpid($pid, &WNOHANG());
527 select(undef, undef, undef, 0.1);
528 } while &time() < $patience && $child != $pid;
530 if ($child == $pid) {
531 # Since she finished within the timeout,
532 # it is probably safe for me to try it too
535 # Time must have run out.
537 # Put that choking client out of its misery
539 # Clean off the zombie
544 # Otherwise don't waste the resources to fork
548 local $SIG{'ALRM'} = sub { die "Timed out!"; };
549 my $old = alarm($timeout); # Interrupt connect() if we have to
558 # This writes the given string to the socket and then reads it
559 # back. It returns 1 on success, 0 on failure.
564 my $pingstring = shift;
568 my $wrstr = $pingstring;
574 vec($rin, $self->{"fh"}->fileno(), 1) = 1;
579 vec($rout, $self->{"fh"}->fileno(), 1) = 1;
582 if(select($rin, $rout, undef, ($time + $timeout) - &time())) {
584 if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
585 my $num = syswrite($self->{"fh"}, $wrstr);
587 # If it was a partial write, update and try again.
588 $wrstr = substr($wrstr,$num);
590 # There was an error.
595 if(vec($rin,$self->{"fh"}->fileno(),1)) {
597 if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
599 $ret = 1 if $rdstr eq $pingstring;
601 # There was an error.
607 } until &time() > ($time + $timeout) || defined($ret);
616 # Description: Perform a stream ping. If the tcp connection isn't
617 # already open, it opens it. It then sends some data and waits for
618 # a reply. It leaves the stream open on exit.
623 $ip, # Packed IP number of the host
624 $timeout # Seconds after which ping times out
627 # Open the stream if it's not already open
628 if(!defined $self->{"fh"}->fileno()) {
629 $self->tcp_connect($ip, $timeout) or return 0;
632 croak "tried to switch servers while stream pinging"
633 if $self->{"ip"} ne $ip;
635 return $self->tcp_echo($timeout, $pingstring);
638 # Description: opens the stream. You would do this if you want to
639 # separate the overhead of opening the stream from the first ping.
644 $host, # Host or IP address
645 $timeout # Seconds after which open times out
648 my ($ip); # Packed IP number of the host
649 $ip = inet_aton($host);
650 $timeout = $self->{"timeout"} unless $timeout;
652 if($self->{"proto"} eq "stream") {
653 if(defined($self->{"fh"}->fileno())) {
654 croak("socket is already open");
656 $self->tcp_connect($ip, $timeout);
662 # Description: Perform a udp echo ping. Construct a message of
663 # at least the one-byte sequence number and any additional data bytes.
664 # Send the message out and wait for a message to come back. If we
665 # get a message, make sure all of its parts match. If they do, we are
666 # done. Otherwise go back and wait for the message until we run out
667 # of time. Return the result of our efforts.
669 use constant UDP_FLAGS => 0; # Nothing special on send or recv
670 # XXX - Use concept by rdw @ perlmonks
671 # http://perlmonks.thepen.com/42898.html
675 $ip, # Packed IP number of the host
676 $timeout # Seconds after which ping times out
679 my ($saddr, # sockaddr_in with port and ip
680 $ret, # The return value
681 $msg, # Message to be echoed
682 $finish_time, # Time ping should be finished
683 $done, # Set to 1 when we are done pinging
684 $rbits, # Read bits, filehandles for reading
685 $nfound, # Number of ready filehandles found
686 $from_saddr, # sockaddr_in of sender
687 $from_msg, # Characters echoed by $host
688 $from_port, # Port message was echoed from
689 $from_ip # Packed IP number of sender
692 $saddr = sockaddr_in($self->{"port_num"}, $ip);
693 $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
694 $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
695 send($self->{"fh"}, $msg, UDP_FLAGS, $saddr); # Send it
698 vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
699 $ret = 0; # Default to unreachable
701 $finish_time = &time() + $timeout; # Ping needs to be done by then
702 while (!$done && $timeout > 0)
704 $nfound = select($rbits, undef, undef, $timeout); # Wait for response
705 $timeout = $finish_time - &time(); # Get remaining time
707 if (!defined($nfound)) # Hmm, a strange error
712 elsif ($nfound) # A packet is waiting
715 $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS)
716 or last; # For example an unreachable host will make recv() fail.
717 ($from_port, $from_ip) = sockaddr_in($from_saddr);
718 if (!$source_verify ||
719 (($from_ip eq $ip) && # Does the packet check out?
720 ($from_port == $self->{"port_num"}) &&
721 ($from_msg eq $msg)))
723 $ret = 1; # It's a winner
727 else # Oops, timed out
735 # Description: Send a TCP SYN packet to host specified.
741 my $start_time = shift;
742 my $stop_time = shift;
745 return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
748 my $fh = FileHandle->new();
749 my $saddr = sockaddr_in($self->{"port_num"}, $ip);
752 if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
753 croak("tcp socket error - $!");
756 if (defined $self->{"local_addr"} &&
757 !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
758 croak("tcp bind error - $!");
761 if ($self->{'device'}) {
762 setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
763 or croak("error binding to device $self->{'device'} $!");
766 # Set O_NONBLOCK property on filehandle
768 if (fcntl($fh, F_GETFL, $flags)) {
769 if (!fcntl($fh, F_SETFL, $flags | O_NONBLOCK)) {
770 croak("fcntl F_SETFL: $!");
773 croak("fcntl F_GETFL: $!");
776 # Attempt the non-blocking connect
777 # by just sending the TCP SYN packet
778 if (connect($fh, $saddr)) {
779 # Non-blocking, yet still connected?
780 # Must have connected very quickly,
781 # or else it wasn't very non-blocking.
782 #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
784 # Error occurred connecting.
785 if ($! == EINPROGRESS) {
786 # The connection is just still in progress.
787 # This is the expected condition.
789 # Just save the error and continue on.
790 # The ack() can check the status later.
791 $self->{"bad"}->{$host} = $!;
795 my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
796 $self->{"syn"}->{$fh->fileno} = $entry;
797 if ($self->{"stop_time"} < $stop_time) {
798 $self->{"stop_time"} = $stop_time;
800 vec($self->{"wbits"}, $fh->fileno, 1) = 1;
806 my ($self, $host, $ip, $start_time, $stop_time) = @_;
808 # Buggy Winsock API doesn't allow nonblocking connect.
809 # Hence, if our OS is Windows, we need to create a separate
810 # process to do the blocking connect attempt.
815 my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
816 $self->{"syn"}->{$pid} = $entry;
817 if ($self->{"stop_time"} < $stop_time) {
818 $self->{"stop_time"} = $stop_time;
822 my $saddr = sockaddr_in($self->{"port_num"}, $ip);
825 if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
826 croak("tcp socket error - $!");
829 if (defined $self->{"local_addr"} &&
830 !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
831 croak("tcp bind error - $!");
834 if ($self->{'device'}) {
835 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
836 or croak("error binding to device $self->{'device'} $!");
840 # Try to connect (could take a long time)
841 connect($self->{"fh"}, $saddr);
842 # Notify parent of connect error status
844 my $wrstr = "$$ $err";
845 # Force to 10 chars including \n
846 $wrstr .= " "x(9 - length $wrstr). "\n";
847 syswrite($self->{"fork_wr"}, $wrstr);
857 # Description: Wait for TCP ACK from host specified
858 # from ping_syn above. If no host is specified, wait
859 # for TCP ACK from any of the hosts in the SYN queue.
864 if ($self->{"proto"} eq "syn") {
866 my @answer = $self->ack_unfork(shift);
867 return wantarray ? @answer : $answer[0];
871 if (my $host = shift) {
873 if (exists $self->{"bad"}->{$host}) {
874 if (!$self->{"tcp_econnrefused"} &&
875 $self->{"bad"}->{ $host } &&
876 (($! = ECONNREFUSED)>0) &&
877 $self->{"bad"}->{ $host } eq "$!") {
878 # "Connection refused" means reachable
881 # ECONNREFUSED means no good
886 foreach my $fd (keys %{ $self->{"syn"} }) {
887 my $entry = $self->{"syn"}->{$fd};
888 if ($entry->[0] eq $host) {
890 $stop_time = $entry->[4]
891 || croak("Corrupted SYN entry for [$host]");
895 croak("ack called on [$host] without calling ping first!")
896 unless defined $host_fd;
897 vec($wbits, $host_fd, 1) = 1;
899 # No $host passed so scan all hosts
900 # Use the latest stop_time
901 $stop_time = $self->{"stop_time"};
903 $wbits = $self->{"wbits"};
906 while ($wbits !~ /^\0*$/) {
907 my $timeout = $stop_time - &time();
908 # Force a minimum of 10 ms timeout.
909 $timeout = 0.01 if $timeout <= 0.01;
911 my $winner_fd = undef;
914 # Do "bad" fds from $wbits first
915 while ($wout !~ /^\0*$/) {
916 if (vec($wout, $fd, 1)) {
917 # Wipe it from future scanning.
918 vec($wout, $fd, 1) = 0;
919 if (my $entry = $self->{"syn"}->{$fd}) {
920 if ($self->{"bad"}->{ $entry->[0] }) {
929 if (defined($winner_fd) or my $nfound = select(undef, ($wout=$wbits), undef, $timeout)) {
930 if (defined $winner_fd) {
933 # Done waiting for one of the ACKs
935 # Determine which one
936 while ($wout !~ /^\0*$/ &&
937 !vec($wout, $fd, 1)) {
941 if (my $entry = $self->{"syn"}->{$fd}) {
942 # Wipe it from future scanning.
943 delete $self->{"syn"}->{$fd};
944 vec($self->{"wbits"}, $fd, 1) = 0;
945 vec($wbits, $fd, 1) = 0;
946 if (!$self->{"tcp_econnrefused"} &&
947 $self->{"bad"}->{ $entry->[0] } &&
948 (($! = ECONNREFUSED)>0) &&
949 $self->{"bad"}->{ $entry->[0] } eq "$!") {
950 # "Connection refused" means reachable
952 } elsif (getpeername($entry->[2])) {
953 # Connection established to remote host
956 # TCP ACK will never come from this host
957 # because there was an error connecting.
959 # This should set $! to the correct error.
961 read($entry->[2],$char,1);
962 # Store the excuse why the connection failed.
963 $self->{"bad"}->{$entry->[0]} = $!;
964 if (!$self->{"tcp_econnrefused"} &&
965 (($! == ECONNREFUSED) ||
966 ($! == EAGAIN && $^O =~ /cygwin/i))) {
967 # "Connection refused" means reachable
970 # No good, try the next socket...
974 # Everything passed okay, return the answer
976 ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
979 warn "Corrupted SYN entry: unknown fd [$fd] ready!";
980 vec($wbits, $fd, 1) = 0;
981 vec($self->{"wbits"}, $fd, 1) = 0;
983 } elsif (defined $nfound) {
984 # Timed out waiting for ACK
985 foreach my $fd (keys %{ $self->{"syn"} }) {
986 if (vec($wbits, $fd, 1)) {
987 my $entry = $self->{"syn"}->{$fd};
988 $self->{"bad"}->{$entry->[0]} = "Timed out";
989 vec($wbits, $fd, 1) = 0;
990 vec($self->{"wbits"}, $fd, 1) = 0;
991 delete $self->{"syn"}->{$fd};
995 # Weird error occurred with select()
1006 my ($self,$host) = @_;
1007 my $stop_time = $self->{"stop_time"};
1009 # Host passed as arg
1010 if (my $entry = $self->{"good"}->{$host}) {
1011 delete $self->{"good"}->{$host};
1012 return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
1019 if (keys %{ $self->{"syn"} }) {
1020 # Scan all hosts that are left
1021 vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
1022 $timeout = $stop_time - &time();
1023 # Force a minimum of 10 ms timeout.
1024 $timeout = 0.01 if $timeout < 0.01;
1026 # No hosts left to wait for
1032 while ( keys %{ $self->{"syn"} } and
1033 $nfound = select((my $rout=$rbits), undef, undef, $timeout)) {
1034 # Done waiting for one of the ACKs
1035 if (!sysread($self->{"fork_rd"}, $_, 10)) {
1036 # Socket closed, which means all children are done.
1039 my ($pid, $how) = split;
1043 if (my $entry = $self->{"syn"}->{$pid}) {
1044 # Connection attempt to remote host is done
1045 delete $self->{"syn"}->{$pid};
1046 if (!$how || # If there was no error connecting
1047 (!$self->{"tcp_econnrefused"} &&
1048 $how == ECONNREFUSED)) { # "Connection refused" means reachable
1049 if ($host && $entry->[0] ne $host) {
1050 # A good connection, but not the host we need.
1051 # Move it from the "syn" hash to the "good" hash.
1052 $self->{"good"}->{$entry->[0]} = $entry;
1053 # And wait for the next winner
1056 return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
1059 # Should never happen
1060 die "Unknown ping from pid [$pid]";
1063 die "Empty response from status socket?";
1066 if (defined $nfound) {
1067 # Timed out waiting for ACK status
1069 # Weird error occurred with select()
1073 if (my @synners = keys %{ $self->{"syn"} }) {
1074 # Kill all the synners
1076 foreach my $pid (@synners) {
1077 # Wait for the deaths to finish
1078 # Then flush off the zombie
1082 $self->{"syn"} = {};
1086 # Description: Tell why the ack() failed
1089 my $host = shift || croak('Usage> nack($failed_ack_host)');
1090 return $self->{"bad"}->{$host} || undef;
1093 # Description: Close the connection.
1099 if ($self->{"proto"} eq "syn") {
1100 delete $self->{"syn"};
1101 } elsif ($self->{"proto"} eq "tcp") {
1102 # The connection will already be closed
1104 $self->{"fh"}->close();
1114 Net::Ping - check a remote host for reachability
1116 $Id: Ping.pm,v 1.46 2002/12/02 19:17:09 rob Exp $
1122 $p = Net::Ping->new();
1123 print "$host is alive.\n" if $p->ping($host);
1126 $p = Net::Ping->new("icmp");
1127 $p->bind($my_addr); # Specify source interface of pings
1128 foreach $host (@host_array)
1131 print "NOT " unless $p->ping($host, 2);
1132 print "reachable.\n";
1137 $p = Net::Ping->new("tcp", 2);
1138 # Try connecting to the www port instead of the echo port
1139 $p->{port_num} = getservbyname("http", "tcp");
1140 while ($stop_time > time())
1142 print "$host not reachable ", scalar(localtime()), "\n"
1143 unless $p->ping($host);
1148 # Like tcp protocol, but with many hosts
1149 $p = Net::Ping->new("syn");
1150 $p->{port_num} = getservbyname("http", "tcp");
1151 foreach $host (@host_array) {
1154 while (($host,$rtt,$ip) = $p->ack) {
1155 print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
1158 # High precision syntax (requires Time::HiRes)
1159 $p = Net::Ping->new();
1161 ($ret, $duration, $ip) = $p->ping($host, 5.5);
1162 printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration)
1166 # For backward compatibility
1167 print "$host is alive.\n" if pingecho($host);
1171 This module contains methods to test the reachability of remote
1172 hosts on a network. A ping object is first created with optional
1173 parameters, a variable number of hosts may be pinged multiple
1174 times and then the connection is closed.
1176 You may choose one of six different protocols to use for the
1177 ping. The "tcp" protocol is the default. Note that a live remote host
1178 may still fail to be pingable by one or more of these protocols. For
1179 example, www.microsoft.com is generally alive but not "icmp" pingable.
1181 With the "tcp" protocol the ping() method attempts to establish a
1182 connection to the remote host's echo port. If the connection is
1183 successfully established, the remote host is considered reachable. No
1184 data is actually echoed. This protocol does not require any special
1185 privileges but has higher overhead than the other two protocols.
1187 Specifying the "udp" protocol causes the ping() method to send a udp
1188 packet to the remote host's echo port. If the echoed packet is
1189 received from the remote host and the received packet contains the
1190 same data as the packet that was sent, the remote host is considered
1191 reachable. This protocol does not require any special privileges.
1192 It should be borne in mind that, for a udp ping, a host
1193 will be reported as unreachable if it is not running the
1194 appropriate echo service. For Unix-like systems see L<inetd(8)>
1195 for more information.
1197 If the "icmp" protocol is specified, the ping() method sends an icmp
1198 echo message to the remote host, which is what the UNIX ping program
1199 does. If the echoed message is received from the remote host and
1200 the echoed information is correct, the remote host is considered
1201 reachable. Specifying the "icmp" protocol requires that the program
1202 be run as root or that the program be setuid to root.
1204 If the "external" protocol is specified, the ping() method attempts to
1205 use the C<Net::Ping::External> module to ping the remote host.
1206 C<Net::Ping::External> interfaces with your system's default C<ping>
1207 utility to perform the ping, and generally produces relatively
1208 accurate results. If C<Net::Ping::External> if not installed on your
1209 system, specifying the "external" protocol will result in an error.
1211 If the "syn" protocol is specified, the ping() method will only
1212 send a TCP SYN packet to the remote host then immediately return.
1213 If the syn packet was sent successfully, it will return a true value,
1214 otherwise it will return false. NOTE: Unlike the other protocols,
1215 the return value does NOT determine if the remote host is alive or
1216 not since the full TCP three-way handshake may not have completed
1217 yet. The remote host is only considered reachable if it receives
1218 a TCP ACK within the timeout specifed. To begin waiting for the
1219 ACK packets, use the ack() method as explained below. Use the
1220 "syn" protocol instead the "tcp" protocol to determine reachability
1221 of multiple destinations simultaneously by sending parallel TCP
1222 SYN packets. It will not block while testing each remote host.
1223 demo/fping is provided in this distribution to demonstrate the
1224 "syn" protocol as an example.
1225 This protocol does not require any special privileges.
1231 =item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device ]]]]);
1233 Create a new ping object. All of the parameters are optional. $proto
1234 specifies the protocol to use when doing a ping. The current choices
1235 are "tcp", "udp", "icmp", "stream", "syn", or "external".
1236 The default is "tcp".
1238 If a default timeout ($def_timeout) in seconds is provided, it is used
1239 when a timeout is not given to the ping() method (below). The timeout
1240 must be greater than 0 and the default, if not specified, is 5 seconds.
1242 If the number of data bytes ($bytes) is given, that many data bytes
1243 are included in the ping packet sent to the remote host. The number of
1244 data bytes is ignored if the protocol is "tcp". The minimum (and
1245 default) number of data bytes is 1 if the protocol is "udp" and 0
1246 otherwise. The maximum number of data bytes that can be specified is
1249 If $device is given, this device is used to bind the source endpoint
1250 before sending the ping packet. I beleive this only works with
1251 superuser privileges and with udp and icmp protocols at this time.
1253 =item $p->ping($host [, $timeout]);
1255 Ping the remote host and wait for a response. $host can be either the
1256 hostname or the IP number of the remote host. The optional timeout
1257 must be greater than 0 seconds and defaults to whatever was specified
1258 when the ping object was created. Returns a success flag. If the
1259 hostname cannot be found or there is a problem with the IP number, the
1260 success flag returned will be undef. Otherwise, the success flag will
1261 be 1 if the host is reachable and 0 if it is not. For most practical
1262 purposes, undef and 0 and can be treated as the same case. In array
1263 context, the elapsed time as well as the string form of the ip the
1264 host resolved to are also returned. The elapsed time value will
1265 be a float, as retuned by the Time::HiRes::time() function, if hires()
1266 has been previously called, otherwise it is returned as an integer.
1268 =item $p->source_verify( { 0 | 1 } );
1270 Allows source endpoint verification to be enabled or disabled.
1271 This is useful for those remote destinations with multiples
1272 interfaces where the response may not originate from the same
1273 endpoint that the original destination endpoint was sent to.
1274 This only affects udp and icmp protocol pings.
1276 This is enabled by default.
1278 =item $p->tcp_service_check( { 0 | 1 } );
1280 Set whether or not the tcp connect behavior should enforce
1281 remote service availability as well as reachability. Normally,
1282 if the remote server reported ECONNREFUSED, it must have been
1283 reachable because of the status packet that it reported.
1284 With this option enabled, the full three-way tcp handshake
1285 must have been established successfully before it will
1286 claim it is reachable. NOTE: It still does nothing more
1287 than connect and disconnect. It does not speak any protocol
1288 (i.e., HTTP or FTP) to ensure the remote server is sane in
1289 any way. The remote server CPU could be grinding to a halt
1290 and unresponsive to any clients connecting, but if the kernel
1291 throws the ACK packet, it is considered alive anyway. To
1292 really determine if the server is responding well would be
1293 application specific and is beyond the scope of Net::Ping.
1295 This only affects "tcp" and "syn" protocols.
1297 This is disabled by default.
1299 =item $p->hires( { 0 | 1 } );
1301 Causes this module to use Time::HiRes module, allowing milliseconds
1302 to be returned by subsequent calls to ping().
1304 This is disabled by default.
1306 =item $p->bind($local_addr);
1308 Sets the source address from which pings will be sent. This must be
1309 the address of one of the interfaces on the local host. $local_addr
1310 may be specified as a hostname or as a text IP address such as
1313 If the protocol is set to "tcp", this method may be called any
1314 number of times, and each call to the ping() method (below) will use
1315 the most recent $local_addr. If the protocol is "icmp" or "udp",
1316 then bind() must be called at most once per object, and (if it is
1317 called at all) must be called before the first call to ping() for that
1320 =item $p->open($host);
1322 When you are using the "stream" protocol, this call pre-opens the
1323 tcp socket. It's only necessary to do this if you want to
1324 provide a different timeout when creating the connection, or
1325 remove the overhead of establishing the connection from the
1326 first ping. If you don't call C<open()>, the connection is
1327 automatically opened the first time C<ping()> is called.
1328 This call simply does nothing if you are using any protocol other
1331 =item $p->ack( [ $host ] );
1333 When using the "syn" protocol, use this method to determine
1334 the reachability of the remote host. This method is meant
1335 to be called up to as many times as ping() was called. Each
1336 call returns the host (as passed to ping()) that came back
1337 with the TCP ACK. The order in which the hosts are returned
1338 may not necessarily be the same order in which they were
1339 SYN queued using the ping() method. If the timeout is
1340 reached before the TCP ACK is received, or if the remote
1341 host is not listening on the port attempted, then the TCP
1342 connection will not be established and ack() will return
1343 undef. In list context, the host, the ack time, and the
1344 dotted ip string will be returned instead of just the host.
1345 If the optional $host argument is specified, the return
1346 value will be partaining to that host only.
1347 This call simply does nothing if you are using any protocol
1350 =item $p->nack( $failed_ack_host );
1352 The reason that host $failed_ack_host did not receive a
1353 valid ACK. Useful to find out why when ack( $fail_ack_host )
1354 returns a false value.
1358 Close the network connection for this ping object. The network
1359 connection is also closed by "undef $p". The network connection is
1360 automatically closed if the ping object goes out of scope (e.g. $p is
1361 local to a subroutine and you leave the subroutine).
1363 =item pingecho($host [, $timeout]);
1365 To provide backward compatibility with the previous version of
1366 Net::Ping, a pingecho() subroutine is available with the same
1367 functionality as before. pingecho() uses the tcp protocol. The
1368 return values and parameters are the same as described for the ping()
1369 method. This subroutine is obsolete and may be removed in a future
1370 version of Net::Ping.
1376 pingecho() or a ping object with the tcp protocol use alarm() to
1377 implement the timeout. So, don't use alarm() in your program while
1378 you are using pingecho() or a ping object with the tcp protocol. The
1379 udp and icmp protocols do not use alarm() to implement the timeout.
1383 There will be less network overhead (and some efficiency in your
1384 program) if you specify either the udp or the icmp protocol. The tcp
1385 protocol will generate 2.5 times or more traffic for each ping than
1386 either udp or icmp. If many hosts are pinged frequently, you may wish
1387 to implement a small wait (e.g. 25ms or more) between each ping to
1388 avoid flooding your network with packets.
1390 The icmp protocol requires that the program be run as root or that it
1391 be setuid to root. The other protocols do not require special
1392 privileges, but not all network devices implement tcp or udp echo.
1394 Local hosts should normally respond to pings within milliseconds.
1395 However, on a very congested network it may take up to 3 seconds or
1396 longer to receive an echo packet from the remote host. If the timeout
1397 is set too low under these conditions, it will appear that the remote
1398 host is not reachable (which is almost the truth).
1400 Reachability doesn't necessarily mean that the remote host is actually
1401 functioning beyond its ability to echo packets. tcp is slightly better
1402 at indicating the health of a system than icmp because it uses more
1403 of the networking stack to respond.
1405 Because of a lack of anything better, this module uses its own
1406 routines to pack and unpack ICMP packets. It would be better for a
1407 separate module to be written which understands all of the different
1408 kinds of ICMP packets.
1412 The latest source tree is available via cvs:
1414 cvs -z3 -q -d :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping
1417 The tarball can be created as follows:
1419 perl Makefile.PL ; make ; make dist
1421 The latest Net::Ping release can be found at CPAN:
1423 $CPAN/modules/by-module/Net/
1425 1) Extract the tarball
1427 gtar -zxvf Net-Ping-xxxx.tar.gz
1441 Or install it RPM Style:
1443 rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
1445 rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
1450 bbb@cpan.org (Rob Brown)
1453 colinm@cpan.org (Colin McMillen)
1456 bronson@trestle.com (Scott Bronson)
1458 Original pingecho():
1459 karrer@bernina.ethz.ch (Andreas Karrer)
1460 pmarquess@bfsec.bt.co.uk (Paul Marquess)
1462 Original Net::Ping author:
1463 mose@ns.ccsn.edu (Russell Mosemann)
1467 Copyright (c) 2002, Rob Brown. All rights reserved.
1469 Copyright (c) 2001, Colin McMillen. All rights reserved.
1471 This program is free software; you may redistribute it and/or
1472 modify it under the same terms as Perl itself.