7 use vars qw(@ISA @EXPORT $VERSION
8 $def_timeout $def_proto $max_datasize $pingstring $hires $source_verify $syn_forking);
9 use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
10 use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET
11 inet_aton inet_ntoa sockaddr_in );
12 use POSIX qw( ECONNREFUSED EINPROGRESS EAGAIN WNOHANG );
17 @EXPORT = qw(pingecho);
22 $def_timeout = 5; # Default timeout to wait for a reply
23 $def_proto = "tcp"; # Default protocol to use for pinging
24 $max_datasize = 1024; # Maximum data bytes in a packet
25 # The data we exchange with the server for the stream protocol
26 $pingstring = "pingschwingping!\n";
27 $source_verify = 1; # Default is to verify source endpoint
30 if ($^O =~ /Win32/i) {
31 # Hack to avoid this Win32 spewage:
32 # Your vendor has not defined POSIX macro ECONNREFUSED
33 *ECONNREFUSED = sub {10061;}; # "Unknown Error" Special Win32 Response?
38 # require "asm/socket.ph";
39 sub SO_BINDTODEVICE {25;}
41 # Description: The pingecho() subroutine is provided for backward
42 # compatibility with the original Net::Ping. It accepts a host
43 # name/IP and an optional timeout in seconds. Create a tcp ping
44 # object and try pinging the host. The result of the ping is returned.
48 my ($host, # Name or IP number of host to ping
49 $timeout # Optional timeout in seconds
51 my ($p); # A ping object
53 $p = Net::Ping->new("tcp", $timeout);
54 $p->ping($host); # Going out of scope closes the connection
57 # Description: The new() method creates a new ping object. Optional
58 # parameters may be specified for the protocol to use, the timeout in
59 # seconds and the size in bytes of additional data which should be
60 # included in the packet.
61 # After the optional parameters are checked, the data is constructed
62 # and a socket is opened if appropriate. The object is returned.
67 $proto, # Optional protocol to use for pinging
68 $timeout, # Optional timeout in seconds
69 $data_size, # Optional additional bytes of data
70 $device, # Optional device to use
72 my $class = ref($this) || $this;
74 my ($cnt, # Count through data bytes
75 $min_datasize # Minimum data bytes required
80 $proto = $def_proto unless $proto; # Determine the protocol
81 croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
82 unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
83 $self->{"proto"} = $proto;
85 $timeout = $def_timeout unless $timeout; # Determine the timeout
86 croak("Default timeout for ping must be greater than 0 seconds")
88 $self->{"timeout"} = $timeout;
90 $self->{"device"} = $device;
92 $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
93 $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
94 croak("Data for ping must be from $min_datasize to $max_datasize bytes")
95 if ($data_size < $min_datasize) || ($data_size > $max_datasize);
96 $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
97 $self->{"data_size"} = $data_size;
99 $self->{"data"} = ""; # Construct data bytes
100 for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
102 $self->{"data"} .= chr($cnt % 256);
105 $self->{"local_addr"} = undef; # Don't bind by default
107 $self->{"tcp_econnrefused"} = undef; # Default Connection refused behavior
109 $self->{"seq"} = 0; # For counting packets
110 if ($self->{"proto"} eq "udp") # Open a socket
112 $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
113 croak("Can't udp protocol by name");
114 $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
115 croak("Can't get udp echo port by name");
116 $self->{"fh"} = FileHandle->new();
117 socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
118 $self->{"proto_num"}) ||
119 croak("udp socket error - $!");
120 if ($self->{'device'}) {
121 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
122 or croak "error binding to device $self->{'device'} $!";
125 elsif ($self->{"proto"} eq "icmp")
127 croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
128 $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
129 croak("Can't get icmp protocol by name");
130 $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
131 $self->{"fh"} = FileHandle->new();
132 socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
133 croak("icmp socket error - $!");
134 if ($self->{'device'}) {
135 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
136 or croak "error binding to device $self->{'device'} $!";
139 elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
141 $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
142 croak("Can't get tcp protocol by name");
143 $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
144 croak("Can't get tcp echo port by name");
145 $self->{"fh"} = FileHandle->new();
147 elsif ($self->{"proto"} eq "syn")
149 $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
150 croak("Can't get tcp protocol by name");
151 $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
152 croak("Can't get tcp echo port by name");
154 $self->{"fork_rd"} = FileHandle->new();
155 $self->{"fork_wr"} = FileHandle->new();
156 pipe($self->{"fork_rd"}, $self->{"fork_wr"});
157 $self->{"fh"} = FileHandle->new();
158 $self->{"good"} = {};
161 $self->{"wbits"} = "";
165 $self->{"stop_time"} = 0;
167 elsif ($self->{"proto"} eq "external")
169 # No preliminary work needs to be done.
175 # Description: Set the local IP address from which pings will be sent.
176 # For ICMP and UDP pings, this calls bind() on the already-opened socket;
177 # for TCP pings, just saves the address to be used when the socket is
178 # opened. Returns non-zero if successful; croaks on error.
182 $local_addr # Name or IP number of local interface
184 my ($ip # Packed IP number of $local_addr
187 croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
188 croak("already bound") if defined($self->{"local_addr"}) &&
189 ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
191 $ip = inet_aton($local_addr);
192 croak("nonexistent local address $local_addr") unless defined($ip);
193 $self->{"local_addr"} = $ip; # Only used if proto is tcp
195 if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
197 CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
198 croak("$self->{'proto'} bind error - $!");
200 elsif ($self->{"proto"} ne "tcp")
202 croak("Unknown protocol \"$self->{proto}\" in bind()");
209 # Description: Allow UDP source endpoint comparision to be
210 # skipped for those remote interfaces that do
211 # not response from the same endpoint.
216 $source_verify = 1 unless defined
217 ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
220 # Description: Set whether or not the tcp connect
221 # behavior should enforce remote service availability
222 # as well as reachability.
224 sub tcp_service_check
227 $self->{"tcp_econnrefused"} = 1 unless defined
228 ($self->{"tcp_econnrefused"} = shift());
231 # Description: allows the module to use milliseconds as returned by
232 # the Time::HiRes module
238 $hires = 1 unless defined
239 ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
240 require Time::HiRes if $hires;
245 return $hires ? Time::HiRes::time() : CORE::time();
248 # Description: Sets or clears the O_NONBLOCK flag on a file handle.
249 sub socket_blocking_mode
252 $fh, # the file handle whose flags are to be modified
253 $block) = @_; # if true then set the blocking
254 # mode (clear O_NONBLOCK), otherwise
255 # set the non-blocking mode (set O_NONBLOCK)
258 if ($flags = fcntl($fh, F_GETFL, 0)) {
259 $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
260 if (!fcntl($fh, F_SETFL, $flags)) {
261 croak("fcntl F_SETFL: $!");
264 croak("fcntl F_GETFL: $!");
268 # Description: Ping a host name or IP number with an optional timeout.
269 # First lookup the host, and return undef if it is not found. Otherwise
270 # perform the specific ping method based on the protocol. Return the
271 # result of the ping.
276 $host, # Name or IP number of host to ping
277 $timeout, # Seconds after which ping times out
279 my ($ip, # Packed IP number of $host
280 $ret, # The return value
281 $ping_time, # When ping began
284 croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
285 $timeout = $self->{"timeout"} unless $timeout;
286 croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
288 $ip = inet_aton($host);
289 return(undef) unless defined($ip); # Does host exist?
291 # Dispatch to the appropriate routine.
292 $ping_time = &time();
293 if ($self->{"proto"} eq "external") {
294 $ret = $self->ping_external($ip, $timeout);
296 elsif ($self->{"proto"} eq "udp") {
297 $ret = $self->ping_udp($ip, $timeout);
299 elsif ($self->{"proto"} eq "icmp") {
300 $ret = $self->ping_icmp($ip, $timeout);
302 elsif ($self->{"proto"} eq "tcp") {
303 $ret = $self->ping_tcp($ip, $timeout);
305 elsif ($self->{"proto"} eq "stream") {
306 $ret = $self->ping_stream($ip, $timeout);
308 elsif ($self->{"proto"} eq "syn") {
309 $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
311 croak("Unknown protocol \"$self->{proto}\" in ping()");
314 return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
317 # Uses Net::Ping::External to do an external ping.
320 $ip, # Packed IP number of the host
321 $timeout # Seconds after which ping times out
324 eval { require Net::Ping::External; }
325 or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
326 return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
329 use constant ICMP_ECHOREPLY => 0; # ICMP packet types
330 use constant ICMP_ECHO => 8;
331 use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
332 use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
333 use constant ICMP_FLAGS => 0; # No special flags for send or recv
334 use constant ICMP_PORT => 0; # No port with ICMP
339 $ip, # Packed IP number of the host
340 $timeout # Seconds after which ping times out
343 my ($saddr, # sockaddr_in with port and ip
344 $checksum, # Checksum of ICMP packet
345 $msg, # ICMP packet to send
346 $len_msg, # Length of $msg
347 $rbits, # Read bits, filehandles for reading
348 $nfound, # Number of ready filehandles found
349 $finish_time, # Time ping should be finished
350 $done, # set to 1 when we are done
352 $recv_msg, # Received message including IP header
353 $from_saddr, # sockaddr_in of sender
354 $from_port, # Port packet was sent from
355 $from_ip, # Packed IP of sender
356 $from_type, # ICMP type
357 $from_subcode, # ICMP subcode
358 $from_chk, # ICMP packet checksum
359 $from_pid, # ICMP packet id
360 $from_seq, # ICMP packet sequence
361 $from_msg # ICMP message
364 $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
365 $checksum = 0; # No checksum for starters
366 $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
367 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
368 $checksum = Net::Ping->checksum($msg);
369 $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
370 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
371 $len_msg = length($msg);
372 $saddr = sockaddr_in(ICMP_PORT, $ip);
373 $self->{"from_ip"} = undef;
374 $self->{"from_type"} = undef;
375 $self->{"from_subcode"} = undef;
376 send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
379 vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
382 $finish_time = &time() + $timeout; # Must be done by this time
383 while (!$done && $timeout > 0) # Keep trying if we have time
385 $nfound = select($rbits, undef, undef, $timeout); # Wait for packet
386 $timeout = $finish_time - &time(); # Get remaining time
387 if (!defined($nfound)) # Hmm, a strange error
392 elsif ($nfound) # Got a packet from somewhere
395 $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
396 ($from_port, $from_ip) = sockaddr_in($from_saddr);
397 ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
398 if ($from_type == ICMP_ECHOREPLY){
399 ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4));
401 ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4));
403 $self->{"from_ip"} = $from_ip;
404 $self->{"from_type"} = $from_type;
405 $self->{"from_subcode"} = $from_subcode;
406 if (($from_pid == $self->{"pid"}) && # Does the packet check out?
407 ($from_seq == $self->{"seq"})) {
408 if ($from_type == ICMP_ECHOREPLY){
413 } else { # Oops, timed out
422 my $ip = $self->{"from_ip"} || "";
423 $ip = "\0\0\0\0" unless 4 == length $ip;
424 return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
427 # Description: Do a checksum on the message. Basically sum all of
428 # the short words and fold the high order bits into the low order bits.
433 $msg # The message to checksum
435 my ($len_msg, # Length of the message
436 $num_short, # The number of short words in the message
437 $short, # One short word
441 $len_msg = length($msg);
442 $num_short = int($len_msg / 2);
444 foreach $short (unpack("n$num_short", $msg))
447 } # Add the odd byte in
448 $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
449 $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
450 return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
454 # Description: Perform a tcp echo ping. Since a tcp connection is
455 # host specific, we have to open and close each connection here. We
456 # can't just leave a socket open. Because of the robust nature of
457 # tcp, it will take a while before it gives up trying to establish a
458 # connection. Therefore, we use select() on a non-blocking socket to
459 # check against our timeout. No data bytes are actually
460 # sent since the successful establishment of a connection is proof
461 # enough of the reachability of the remote host. Also, tcp is
462 # expensive and doesn't need our help to add to the overhead.
467 $ip, # Packed IP number of the host
468 $timeout # Seconds after which ping times out
470 my ($ret # The return value
474 $ret = $self -> tcp_connect( $ip, $timeout);
475 if (!$self->{"tcp_econnrefused"} &&
476 $! == ECONNREFUSED) {
477 $ret = 1; # "Connection refused" means reachable
479 $self->{"fh"}->close();
486 $ip, # Packed IP number of the host
487 $timeout # Seconds after which connect times out
489 my ($saddr); # Packed IP and Port
491 $saddr = sockaddr_in($self->{"port_num"}, $ip);
493 my $ret = 0; # Default to unreachable
495 my $do_socket = sub {
496 socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
497 croak("tcp socket error - $!");
498 if (defined $self->{"local_addr"} &&
499 !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
500 croak("tcp bind error - $!");
502 if ($self->{'device'}) {
503 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
504 or croak("error binding to device $self->{'device'} $!");
507 my $do_connect = sub {
509 return ($ret = connect($self->{"fh"}, $saddr));
511 my $do_connect_nb = sub {
512 # Set O_NONBLOCK property on filehandle
513 $self->socket_blocking_mode($self->{"fh"}, 0);
515 # start the connection attempt
516 if (!connect($self->{"fh"}, $saddr)) {
517 if ($! == ECONNREFUSED) {
518 $ret = 1 unless $self->{"tcp_econnrefused"};
520 # EINPROGRESS is the expected error code after a connect()
521 # on a non-blocking socket
522 croak("tcp connect error - $!") if $! != EINPROGRESS;
524 # wait for connection completion
527 vec($wbits, $self->{"fh"}->fileno, 1) = 1;
529 my $nfound = select(undef, ($wout = $wbits), undef, $timeout);
530 warn("select: $!") unless defined $nfound;
532 if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
533 # the socket is ready for writing so the connection
534 # attempt completed. test whether the connection
535 # attempt was successful or not
537 if (getpeername($self->{"fh"})) {
538 # Connection established to remote host
541 # TCP ACK will never come from this host
542 # because there was an error connecting.
544 # This should set $! to the correct error.
546 sysread($self->{"fh"},$char,1);
547 $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
549 $ret = 1 if (!$self->{"tcp_econnrefused"}
550 && $! == ECONNREFUSED);
553 # the connection attempt timed out
557 # Connection established to remote host
561 # Unset O_NONBLOCK property on filehandle
562 $self->socket_blocking_mode($self->{"fh"}, 1);
568 # Buggy Winsock API doesn't allow nonblocking connect.
569 # Hence, if our OS is Windows, we need to create a separate
570 # process to do the blocking connect attempt.
572 $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
573 $self->{'tcp_chld'} = fork;
574 if (!$self->{'tcp_chld'}) {
575 if (!defined $self->{'tcp_chld'}) {
577 warn "Fork error: $!";
582 # Try a slow blocking connect() call
583 # and report the status to the parent.
584 if ( &{ $do_connect }() ) {
585 $self->{"fh"}->close();
589 # Pass the error status to the parent
596 my $patience = &time() + $timeout;
598 my ($child, $child_errno);
599 $? = 0; $child_errno = 0;
600 # Wait up to the timeout
601 # And clean off the zombie
603 $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
604 $child_errno = $? >> 8;
605 select(undef, undef, undef, 0.1);
606 } while &time() < $patience && $child != $self->{'tcp_chld'};
608 if ($child == $self->{'tcp_chld'}) {
609 if ($self->{"proto"} eq "stream") {
610 # We need the socket connected here, in parent
611 # Should be safe to connect because the child finished
616 # Time must have run out.
617 # Put that choking client out of its misery
618 kill "KILL", $self->{'tcp_chld'};
619 # Clean off the zombie
620 waitpid($self->{'tcp_chld'}, 0);
623 delete $self->{'tcp_chld'};
626 # Otherwise don't waste the resources to fork
630 &{ $do_connect_nb }();
638 if ($self->{'proto'} eq 'tcp' &&
639 $self->{'tcp_chld'}) {
640 # Put that choking client out of its misery
641 kill "KILL", $self->{'tcp_chld'};
642 # Clean off the zombie
643 waitpid($self->{'tcp_chld'}, 0);
647 # This writes the given string to the socket and then reads it
648 # back. It returns 1 on success, 0 on failure.
653 my $pingstring = shift;
657 my $wrstr = $pingstring;
663 vec($rin, $self->{"fh"}->fileno(), 1) = 1;
668 vec($rout, $self->{"fh"}->fileno(), 1) = 1;
671 if(select($rin, $rout, undef, ($time + $timeout) - &time())) {
673 if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
674 my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
676 # If it was a partial write, update and try again.
677 $wrstr = substr($wrstr,$num);
679 # There was an error.
684 if(vec($rin,$self->{"fh"}->fileno(),1)) {
686 if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
688 $ret = 1 if $rdstr eq $pingstring;
690 # There was an error.
696 } until &time() > ($time + $timeout) || defined($ret);
705 # Description: Perform a stream ping. If the tcp connection isn't
706 # already open, it opens it. It then sends some data and waits for
707 # a reply. It leaves the stream open on exit.
712 $ip, # Packed IP number of the host
713 $timeout # Seconds after which ping times out
716 # Open the stream if it's not already open
717 if(!defined $self->{"fh"}->fileno()) {
718 $self->tcp_connect($ip, $timeout) or return 0;
721 croak "tried to switch servers while stream pinging"
722 if $self->{"ip"} ne $ip;
724 return $self->tcp_echo($timeout, $pingstring);
727 # Description: opens the stream. You would do this if you want to
728 # separate the overhead of opening the stream from the first ping.
733 $host, # Host or IP address
734 $timeout # Seconds after which open times out
737 my ($ip); # Packed IP number of the host
738 $ip = inet_aton($host);
739 $timeout = $self->{"timeout"} unless $timeout;
741 if($self->{"proto"} eq "stream") {
742 if(defined($self->{"fh"}->fileno())) {
743 croak("socket is already open");
745 $self->tcp_connect($ip, $timeout);
751 # Description: Perform a udp echo ping. Construct a message of
752 # at least the one-byte sequence number and any additional data bytes.
753 # Send the message out and wait for a message to come back. If we
754 # get a message, make sure all of its parts match. If they do, we are
755 # done. Otherwise go back and wait for the message until we run out
756 # of time. Return the result of our efforts.
758 use constant UDP_FLAGS => 0; # Nothing special on send or recv
759 # XXX - Use concept by rdw @ perlmonks
760 # http://perlmonks.thepen.com/42898.html
764 $ip, # Packed IP number of the host
765 $timeout # Seconds after which ping times out
768 my ($saddr, # sockaddr_in with port and ip
769 $ret, # The return value
770 $msg, # Message to be echoed
771 $finish_time, # Time ping should be finished
772 $done, # Set to 1 when we are done pinging
773 $rbits, # Read bits, filehandles for reading
774 $nfound, # Number of ready filehandles found
775 $from_saddr, # sockaddr_in of sender
776 $from_msg, # Characters echoed by $host
777 $from_port, # Port message was echoed from
778 $from_ip # Packed IP number of sender
781 $saddr = sockaddr_in($self->{"port_num"}, $ip);
782 $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
783 $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
784 send($self->{"fh"}, $msg, UDP_FLAGS, $saddr); # Send it
787 vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
788 $ret = 0; # Default to unreachable
790 $finish_time = &time() + $timeout; # Ping needs to be done by then
791 while (!$done && $timeout > 0)
793 $nfound = select($rbits, undef, undef, $timeout); # Wait for response
794 $timeout = $finish_time - &time(); # Get remaining time
796 if (!defined($nfound)) # Hmm, a strange error
801 elsif ($nfound) # A packet is waiting
804 $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS)
805 or last; # For example an unreachable host will make recv() fail.
806 ($from_port, $from_ip) = sockaddr_in($from_saddr);
807 if (!$source_verify ||
808 (($from_ip eq $ip) && # Does the packet check out?
809 ($from_port == $self->{"port_num"}) &&
810 ($from_msg eq $msg)))
812 $ret = 1; # It's a winner
816 else # Oops, timed out
824 # Description: Send a TCP SYN packet to host specified.
830 my $start_time = shift;
831 my $stop_time = shift;
834 return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
837 my $fh = FileHandle->new();
838 my $saddr = sockaddr_in($self->{"port_num"}, $ip);
841 if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
842 croak("tcp socket error - $!");
845 if (defined $self->{"local_addr"} &&
846 !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
847 croak("tcp bind error - $!");
850 if ($self->{'device'}) {
851 setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
852 or croak("error binding to device $self->{'device'} $!");
855 # Set O_NONBLOCK property on filehandle
856 $self->socket_blocking_mode($fh, 0);
858 # Attempt the non-blocking connect
859 # by just sending the TCP SYN packet
860 if (connect($fh, $saddr)) {
861 # Non-blocking, yet still connected?
862 # Must have connected very quickly,
863 # or else it wasn't very non-blocking.
864 #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
866 # Error occurred connecting.
867 if ($! == EINPROGRESS) {
868 # The connection is just still in progress.
869 # This is the expected condition.
871 # Just save the error and continue on.
872 # The ack() can check the status later.
873 $self->{"bad"}->{$host} = $!;
877 my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
878 $self->{"syn"}->{$fh->fileno} = $entry;
879 if ($self->{"stop_time"} < $stop_time) {
880 $self->{"stop_time"} = $stop_time;
882 vec($self->{"wbits"}, $fh->fileno, 1) = 1;
888 my ($self, $host, $ip, $start_time, $stop_time) = @_;
890 # Buggy Winsock API doesn't allow nonblocking connect.
891 # Hence, if our OS is Windows, we need to create a separate
892 # process to do the blocking connect attempt.
897 my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
898 $self->{"syn"}->{$pid} = $entry;
899 if ($self->{"stop_time"} < $stop_time) {
900 $self->{"stop_time"} = $stop_time;
904 my $saddr = sockaddr_in($self->{"port_num"}, $ip);
907 if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
908 croak("tcp socket error - $!");
911 if (defined $self->{"local_addr"} &&
912 !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
913 croak("tcp bind error - $!");
916 if ($self->{'device'}) {
917 setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
918 or croak("error binding to device $self->{'device'} $!");
922 # Try to connect (could take a long time)
923 connect($self->{"fh"}, $saddr);
924 # Notify parent of connect error status
926 my $wrstr = "$$ $err";
927 # Force to 16 chars including \n
928 $wrstr .= " "x(15 - length $wrstr). "\n";
929 syswrite($self->{"fork_wr"}, $wrstr, length $wrstr);
939 # Description: Wait for TCP ACK from host specified
940 # from ping_syn above. If no host is specified, wait
941 # for TCP ACK from any of the hosts in the SYN queue.
946 if ($self->{"proto"} eq "syn") {
948 my @answer = $self->ack_unfork(shift);
949 return wantarray ? @answer : $answer[0];
953 if (my $host = shift) {
955 if (exists $self->{"bad"}->{$host}) {
956 if (!$self->{"tcp_econnrefused"} &&
957 $self->{"bad"}->{ $host } &&
958 (($! = ECONNREFUSED)>0) &&
959 $self->{"bad"}->{ $host } eq "$!") {
960 # "Connection refused" means reachable
963 # ECONNREFUSED means no good
968 foreach my $fd (keys %{ $self->{"syn"} }) {
969 my $entry = $self->{"syn"}->{$fd};
970 if ($entry->[0] eq $host) {
972 $stop_time = $entry->[4]
973 || croak("Corrupted SYN entry for [$host]");
977 croak("ack called on [$host] without calling ping first!")
978 unless defined $host_fd;
979 vec($wbits, $host_fd, 1) = 1;
981 # No $host passed so scan all hosts
982 # Use the latest stop_time
983 $stop_time = $self->{"stop_time"};
985 $wbits = $self->{"wbits"};
988 while ($wbits !~ /^\0*\z/) {
989 my $timeout = $stop_time - &time();
990 # Force a minimum of 10 ms timeout.
991 $timeout = 0.01 if $timeout <= 0.01;
993 my $winner_fd = undef;
996 # Do "bad" fds from $wbits first
997 while ($wout !~ /^\0*\z/) {
998 if (vec($wout, $fd, 1)) {
999 # Wipe it from future scanning.
1000 vec($wout, $fd, 1) = 0;
1001 if (my $entry = $self->{"syn"}->{$fd}) {
1002 if ($self->{"bad"}->{ $entry->[0] }) {
1011 if (defined($winner_fd) or my $nfound = select(undef, ($wout=$wbits), undef, $timeout)) {
1012 if (defined $winner_fd) {
1015 # Done waiting for one of the ACKs
1017 # Determine which one
1018 while ($wout !~ /^\0*\z/ &&
1019 !vec($wout, $fd, 1)) {
1023 if (my $entry = $self->{"syn"}->{$fd}) {
1024 # Wipe it from future scanning.
1025 delete $self->{"syn"}->{$fd};
1026 vec($self->{"wbits"}, $fd, 1) = 0;
1027 vec($wbits, $fd, 1) = 0;
1028 if (!$self->{"tcp_econnrefused"} &&
1029 $self->{"bad"}->{ $entry->[0] } &&
1030 (($! = ECONNREFUSED)>0) &&
1031 $self->{"bad"}->{ $entry->[0] } eq "$!") {
1032 # "Connection refused" means reachable
1034 } elsif (getpeername($entry->[2])) {
1035 # Connection established to remote host
1038 # TCP ACK will never come from this host
1039 # because there was an error connecting.
1041 # This should set $! to the correct error.
1043 sysread($entry->[2],$char,1);
1044 # Store the excuse why the connection failed.
1045 $self->{"bad"}->{$entry->[0]} = $!;
1046 if (!$self->{"tcp_econnrefused"} &&
1047 (($! == ECONNREFUSED) ||
1048 ($! == EAGAIN && $^O =~ /cygwin/i))) {
1049 # "Connection refused" means reachable
1052 # No good, try the next socket...
1056 # Everything passed okay, return the answer
1058 ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
1061 warn "Corrupted SYN entry: unknown fd [$fd] ready!";
1062 vec($wbits, $fd, 1) = 0;
1063 vec($self->{"wbits"}, $fd, 1) = 0;
1065 } elsif (defined $nfound) {
1066 # Timed out waiting for ACK
1067 foreach my $fd (keys %{ $self->{"syn"} }) {
1068 if (vec($wbits, $fd, 1)) {
1069 my $entry = $self->{"syn"}->{$fd};
1070 $self->{"bad"}->{$entry->[0]} = "Timed out";
1071 vec($wbits, $fd, 1) = 0;
1072 vec($self->{"wbits"}, $fd, 1) = 0;
1073 delete $self->{"syn"}->{$fd};
1077 # Weird error occurred with select()
1079 $self->{"syn"} = {};
1088 my ($self,$host) = @_;
1089 my $stop_time = $self->{"stop_time"};
1091 # Host passed as arg
1092 if (my $entry = $self->{"good"}->{$host}) {
1093 delete $self->{"good"}->{$host};
1094 return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
1101 if (keys %{ $self->{"syn"} }) {
1102 # Scan all hosts that are left
1103 vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
1104 $timeout = $stop_time - &time();
1105 # Force a minimum of 10 ms timeout.
1106 $timeout = 0.01 if $timeout < 0.01;
1108 # No hosts left to wait for
1114 while ( keys %{ $self->{"syn"} } and
1115 $nfound = select((my $rout=$rbits), undef, undef, $timeout)) {
1116 # Done waiting for one of the ACKs
1117 if (!sysread($self->{"fork_rd"}, $_, 16)) {
1118 # Socket closed, which means all children are done.
1121 my ($pid, $how) = split;
1125 if (my $entry = $self->{"syn"}->{$pid}) {
1126 # Connection attempt to remote host is done
1127 delete $self->{"syn"}->{$pid};
1128 if (!$how || # If there was no error connecting
1129 (!$self->{"tcp_econnrefused"} &&
1130 $how == ECONNREFUSED)) { # "Connection refused" means reachable
1131 if ($host && $entry->[0] ne $host) {
1132 # A good connection, but not the host we need.
1133 # Move it from the "syn" hash to the "good" hash.
1134 $self->{"good"}->{$entry->[0]} = $entry;
1135 # And wait for the next winner
1138 return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
1141 # Should never happen
1142 die "Unknown ping from pid [$pid]";
1145 die "Empty response from status socket?";
1148 if (defined $nfound) {
1149 # Timed out waiting for ACK status
1151 # Weird error occurred with select()
1155 if (my @synners = keys %{ $self->{"syn"} }) {
1156 # Kill all the synners
1158 foreach my $pid (@synners) {
1159 # Wait for the deaths to finish
1160 # Then flush off the zombie
1164 $self->{"syn"} = {};
1168 # Description: Tell why the ack() failed
1171 my $host = shift || croak('Usage> nack($failed_ack_host)');
1172 return $self->{"bad"}->{$host} || undef;
1175 # Description: Close the connection.
1181 if ($self->{"proto"} eq "syn") {
1182 delete $self->{"syn"};
1183 } elsif ($self->{"proto"} eq "tcp") {
1184 # The connection will already be closed
1186 $self->{"fh"}->close();
1196 Net::Ping - check a remote host for reachability
1198 $Id: Ping.pm,v 1.69 2003/01/23 17:21:29 rob Exp $
1204 $p = Net::Ping->new();
1205 print "$host is alive.\n" if $p->ping($host);
1208 $p = Net::Ping->new("icmp");
1209 $p->bind($my_addr); # Specify source interface of pings
1210 foreach $host (@host_array)
1213 print "NOT " unless $p->ping($host, 2);
1214 print "reachable.\n";
1219 $p = Net::Ping->new("tcp", 2);
1220 # Try connecting to the www port instead of the echo port
1221 $p->{port_num} = getservbyname("http", "tcp");
1222 while ($stop_time > time())
1224 print "$host not reachable ", scalar(localtime()), "\n"
1225 unless $p->ping($host);
1230 # Like tcp protocol, but with many hosts
1231 $p = Net::Ping->new("syn");
1232 $p->{port_num} = getservbyname("http", "tcp");
1233 foreach $host (@host_array) {
1236 while (($host,$rtt,$ip) = $p->ack) {
1237 print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
1240 # High precision syntax (requires Time::HiRes)
1241 $p = Net::Ping->new();
1243 ($ret, $duration, $ip) = $p->ping($host, 5.5);
1244 printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration)
1248 # For backward compatibility
1249 print "$host is alive.\n" if pingecho($host);
1253 This module contains methods to test the reachability of remote
1254 hosts on a network. A ping object is first created with optional
1255 parameters, a variable number of hosts may be pinged multiple
1256 times and then the connection is closed.
1258 You may choose one of six different protocols to use for the
1259 ping. The "tcp" protocol is the default. Note that a live remote host
1260 may still fail to be pingable by one or more of these protocols. For
1261 example, www.microsoft.com is generally alive but not "icmp" pingable.
1263 With the "tcp" protocol the ping() method attempts to establish a
1264 connection to the remote host's echo port. If the connection is
1265 successfully established, the remote host is considered reachable. No
1266 data is actually echoed. This protocol does not require any special
1267 privileges but has higher overhead than the "udp" and "icmp" protocols.
1269 Specifying the "udp" protocol causes the ping() method to send a udp
1270 packet to the remote host's echo port. If the echoed packet is
1271 received from the remote host and the received packet contains the
1272 same data as the packet that was sent, the remote host is considered
1273 reachable. This protocol does not require any special privileges.
1274 It should be borne in mind that, for a udp ping, a host
1275 will be reported as unreachable if it is not running the
1276 appropriate echo service. For Unix-like systems see L<inetd(8)>
1277 for more information.
1279 If the "icmp" protocol is specified, the ping() method sends an icmp
1280 echo message to the remote host, which is what the UNIX ping program
1281 does. If the echoed message is received from the remote host and
1282 the echoed information is correct, the remote host is considered
1283 reachable. Specifying the "icmp" protocol requires that the program
1284 be run as root or that the program be setuid to root.
1286 If the "external" protocol is specified, the ping() method attempts to
1287 use the C<Net::Ping::External> module to ping the remote host.
1288 C<Net::Ping::External> interfaces with your system's default C<ping>
1289 utility to perform the ping, and generally produces relatively
1290 accurate results. If C<Net::Ping::External> if not installed on your
1291 system, specifying the "external" protocol will result in an error.
1293 If the "syn" protocol is specified, the ping() method will only
1294 send a TCP SYN packet to the remote host then immediately return.
1295 If the syn packet was sent successfully, it will return a true value,
1296 otherwise it will return false. NOTE: Unlike the other protocols,
1297 the return value does NOT determine if the remote host is alive or
1298 not since the full TCP three-way handshake may not have completed
1299 yet. The remote host is only considered reachable if it receives
1300 a TCP ACK within the timeout specifed. To begin waiting for the
1301 ACK packets, use the ack() method as explained below. Use the
1302 "syn" protocol instead the "tcp" protocol to determine reachability
1303 of multiple destinations simultaneously by sending parallel TCP
1304 SYN packets. It will not block while testing each remote host.
1305 demo/fping is provided in this distribution to demonstrate the
1306 "syn" protocol as an example.
1307 This protocol does not require any special privileges.
1313 =item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device ]]]]);
1315 Create a new ping object. All of the parameters are optional. $proto
1316 specifies the protocol to use when doing a ping. The current choices
1317 are "tcp", "udp", "icmp", "stream", "syn", or "external".
1318 The default is "tcp".
1320 If a default timeout ($def_timeout) in seconds is provided, it is used
1321 when a timeout is not given to the ping() method (below). The timeout
1322 must be greater than 0 and the default, if not specified, is 5 seconds.
1324 If the number of data bytes ($bytes) is given, that many data bytes
1325 are included in the ping packet sent to the remote host. The number of
1326 data bytes is ignored if the protocol is "tcp". The minimum (and
1327 default) number of data bytes is 1 if the protocol is "udp" and 0
1328 otherwise. The maximum number of data bytes that can be specified is
1331 If $device is given, this device is used to bind the source endpoint
1332 before sending the ping packet. I beleive this only works with
1333 superuser privileges and with udp and icmp protocols at this time.
1335 =item $p->ping($host [, $timeout]);
1337 Ping the remote host and wait for a response. $host can be either the
1338 hostname or the IP number of the remote host. The optional timeout
1339 must be greater than 0 seconds and defaults to whatever was specified
1340 when the ping object was created. Returns a success flag. If the
1341 hostname cannot be found or there is a problem with the IP number, the
1342 success flag returned will be undef. Otherwise, the success flag will
1343 be 1 if the host is reachable and 0 if it is not. For most practical
1344 purposes, undef and 0 and can be treated as the same case. In array
1345 context, the elapsed time as well as the string form of the ip the
1346 host resolved to are also returned. The elapsed time value will
1347 be a float, as retuned by the Time::HiRes::time() function, if hires()
1348 has been previously called, otherwise it is returned as an integer.
1350 =item $p->source_verify( { 0 | 1 } );
1352 Allows source endpoint verification to be enabled or disabled.
1353 This is useful for those remote destinations with multiples
1354 interfaces where the response may not originate from the same
1355 endpoint that the original destination endpoint was sent to.
1356 This only affects udp and icmp protocol pings.
1358 This is enabled by default.
1360 =item $p->tcp_service_check( { 0 | 1 } );
1362 Set whether or not the tcp connect behavior should enforce
1363 remote service availability as well as reachability. Normally,
1364 if the remote server reported ECONNREFUSED, it must have been
1365 reachable because of the status packet that it reported.
1366 With this option enabled, the full three-way tcp handshake
1367 must have been established successfully before it will
1368 claim it is reachable. NOTE: It still does nothing more
1369 than connect and disconnect. It does not speak any protocol
1370 (i.e., HTTP or FTP) to ensure the remote server is sane in
1371 any way. The remote server CPU could be grinding to a halt
1372 and unresponsive to any clients connecting, but if the kernel
1373 throws the ACK packet, it is considered alive anyway. To
1374 really determine if the server is responding well would be
1375 application specific and is beyond the scope of Net::Ping.
1377 This only affects "tcp" and "syn" protocols.
1379 This is disabled by default.
1381 =item $p->hires( { 0 | 1 } );
1383 Causes this module to use Time::HiRes module, allowing milliseconds
1384 to be returned by subsequent calls to ping().
1386 This is disabled by default.
1388 =item $p->bind($local_addr);
1390 Sets the source address from which pings will be sent. This must be
1391 the address of one of the interfaces on the local host. $local_addr
1392 may be specified as a hostname or as a text IP address such as
1395 If the protocol is set to "tcp", this method may be called any
1396 number of times, and each call to the ping() method (below) will use
1397 the most recent $local_addr. If the protocol is "icmp" or "udp",
1398 then bind() must be called at most once per object, and (if it is
1399 called at all) must be called before the first call to ping() for that
1402 =item $p->open($host);
1404 When you are using the "stream" protocol, this call pre-opens the
1405 tcp socket. It's only necessary to do this if you want to
1406 provide a different timeout when creating the connection, or
1407 remove the overhead of establishing the connection from the
1408 first ping. If you don't call C<open()>, the connection is
1409 automatically opened the first time C<ping()> is called.
1410 This call simply does nothing if you are using any protocol other
1413 =item $p->ack( [ $host ] );
1415 When using the "syn" protocol, use this method to determine
1416 the reachability of the remote host. This method is meant
1417 to be called up to as many times as ping() was called. Each
1418 call returns the host (as passed to ping()) that came back
1419 with the TCP ACK. The order in which the hosts are returned
1420 may not necessarily be the same order in which they were
1421 SYN queued using the ping() method. If the timeout is
1422 reached before the TCP ACK is received, or if the remote
1423 host is not listening on the port attempted, then the TCP
1424 connection will not be established and ack() will return
1425 undef. In list context, the host, the ack time, and the
1426 dotted ip string will be returned instead of just the host.
1427 If the optional $host argument is specified, the return
1428 value will be partaining to that host only.
1429 This call simply does nothing if you are using any protocol
1432 =item $p->nack( $failed_ack_host );
1434 The reason that host $failed_ack_host did not receive a
1435 valid ACK. Useful to find out why when ack( $fail_ack_host )
1436 returns a false value.
1440 Close the network connection for this ping object. The network
1441 connection is also closed by "undef $p". The network connection is
1442 automatically closed if the ping object goes out of scope (e.g. $p is
1443 local to a subroutine and you leave the subroutine).
1445 =item pingecho($host [, $timeout]);
1447 To provide backward compatibility with the previous version of
1448 Net::Ping, a pingecho() subroutine is available with the same
1449 functionality as before. pingecho() uses the tcp protocol. The
1450 return values and parameters are the same as described for the ping()
1451 method. This subroutine is obsolete and may be removed in a future
1452 version of Net::Ping.
1458 There will be less network overhead (and some efficiency in your
1459 program) if you specify either the udp or the icmp protocol. The tcp
1460 protocol will generate 2.5 times or more traffic for each ping than
1461 either udp or icmp. If many hosts are pinged frequently, you may wish
1462 to implement a small wait (e.g. 25ms or more) between each ping to
1463 avoid flooding your network with packets.
1465 The icmp protocol requires that the program be run as root or that it
1466 be setuid to root. The other protocols do not require special
1467 privileges, but not all network devices implement tcp or udp echo.
1469 Local hosts should normally respond to pings within milliseconds.
1470 However, on a very congested network it may take up to 3 seconds or
1471 longer to receive an echo packet from the remote host. If the timeout
1472 is set too low under these conditions, it will appear that the remote
1473 host is not reachable (which is almost the truth).
1475 Reachability doesn't necessarily mean that the remote host is actually
1476 functioning beyond its ability to echo packets. tcp is slightly better
1477 at indicating the health of a system than icmp because it uses more
1478 of the networking stack to respond.
1480 Because of a lack of anything better, this module uses its own
1481 routines to pack and unpack ICMP packets. It would be better for a
1482 separate module to be written which understands all of the different
1483 kinds of ICMP packets.
1487 The latest source tree is available via cvs:
1489 cvs -z3 -q -d :pserver:anonymous@cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping
1492 The tarball can be created as follows:
1494 perl Makefile.PL ; make ; make dist
1496 The latest Net::Ping release can be found at CPAN:
1498 $CPAN/modules/by-module/Net/
1500 1) Extract the tarball
1502 gtar -zxvf Net-Ping-xxxx.tar.gz
1516 Or install it RPM Style:
1518 rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
1520 rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
1525 bbb@cpan.org (Rob Brown)
1528 colinm@cpan.org (Colin McMillen)
1531 bronson@trestle.com (Scott Bronson)
1533 Original pingecho():
1534 karrer@bernina.ethz.ch (Andreas Karrer)
1535 pmarquess@bfsec.bt.co.uk (Paul Marquess)
1537 Original Net::Ping author:
1538 mose@ns.ccsn.edu (Russell Mosemann)
1542 Copyright (c) 2002-2003, Rob Brown. All rights reserved.
1544 Copyright (c) 2001, Colin McMillen. All rights reserved.
1546 This program is free software; you may redistribute it and/or
1547 modify it under the same terms as Perl itself.