This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
DJGPP was broken by #17270. Because of the time crunch
[perl5.git] / lib / Net / Ping.pm
CommitLineData
a0d0e21e
LW
1package Net::Ping;
2
15d96390 3# $Id: Ping.pm,v 1.1 2002/06/04 00:41:52 rob Exp $
b124990b
JH
4
5require 5.002;
a0d0e21e
LW
6require Exporter;
7
a3b93737 8use strict;
b124990b 9use vars qw(@ISA @EXPORT $VERSION
15d96390 10 $def_timeout $def_proto $max_datasize $pingstring $hires $udp_source_verify);
a3b93737
RM
11use FileHandle;
12use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
e82f584b 13 inet_aton inet_ntoa sockaddr_in );
a3b93737 14use Carp;
ef73e1db 15use POSIX qw(ECONNREFUSED);
a79c1648 16
a0d0e21e 17@ISA = qw(Exporter);
a3b93737 18@EXPORT = qw(pingecho);
15d96390 19$VERSION = "2.19";
a0d0e21e 20
a3b93737 21# Constants
a0d0e21e 22
a3b93737 23$def_timeout = 5; # Default timeout to wait for a reply
a5a165b1 24$def_proto = "tcp"; # Default protocol to use for pinging
a3b93737 25$max_datasize = 1024; # Maximum data bytes in a packet
b124990b
JH
26# The data we exchange with the server for the stream protocol
27$pingstring = "pingschwingping!\n";
15d96390 28$udp_source_verify = 1; # Default is to verify source endpoint
a0d0e21e 29
ef73e1db
JH
30if ($^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?
34};
35
a3b93737
RM
36# Description: The pingecho() subroutine is provided for backward
37# compatibility with the original Net::Ping. It accepts a host
38# name/IP and an optional timeout in seconds. Create a tcp ping
39# object and try pinging the host. The result of the ping is returned.
a0d0e21e 40
a3b93737
RM
41sub pingecho
42{
e82f584b
JH
43 my ($host, # Name or IP number of host to ping
44 $timeout # Optional timeout in seconds
45 ) = @_;
46 my ($p); # A ping object
a0d0e21e 47
e82f584b
JH
48 $p = Net::Ping->new("tcp", $timeout);
49 $p->ping($host); # Going out of scope closes the connection
a3b93737 50}
a0d0e21e 51
a3b93737
RM
52# Description: The new() method creates a new ping object. Optional
53# parameters may be specified for the protocol to use, the timeout in
54# seconds and the size in bytes of additional data which should be
55# included in the packet.
56# After the optional parameters are checked, the data is constructed
57# and a socket is opened if appropriate. The object is returned.
58
59sub new
60{
e82f584b
JH
61 my ($this,
62 $proto, # Optional protocol to use for pinging
63 $timeout, # Optional timeout in seconds
64 $data_size # Optional additional bytes of data
65 ) = @_;
66 my $class = ref($this) || $this;
67 my $self = {};
68 my ($cnt, # Count through data bytes
69 $min_datasize # Minimum data bytes required
70 );
71
72 bless($self, $class);
73
74 $proto = $def_proto unless $proto; # Determine the protocol
75 croak('Protocol for ping must be "icmp", "udp", "tcp", "stream", or "external"')
76 unless $proto =~ m/^(icmp|udp|tcp|stream|external)$/;
77 $self->{"proto"} = $proto;
78
79 $timeout = $def_timeout unless $timeout; # Determine the timeout
80 croak("Default timeout for ping must be greater than 0 seconds")
81 if $timeout <= 0;
82 $self->{"timeout"} = $timeout;
83
84 $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
85 $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
86 croak("Data for ping must be from $min_datasize to $max_datasize bytes")
87 if ($data_size < $min_datasize) || ($data_size > $max_datasize);
88 $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
89 $self->{"data_size"} = $data_size;
90
91 $self->{"data"} = ""; # Construct data bytes
92 for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
93 {
94 $self->{"data"} .= chr($cnt % 256);
95 }
96
97 $self->{"local_addr"} = undef; # Don't bind by default
98
99 $self->{"seq"} = 0; # For counting packets
100 if ($self->{"proto"} eq "udp") # Open a socket
101 {
102 $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
103 croak("Can't udp protocol by name");
104 $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
105 croak("Can't get udp echo port by name");
106 $self->{"fh"} = FileHandle->new();
107 socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
108 $self->{"proto_num"}) ||
109 croak("udp socket error - $!");
110 }
111 elsif ($self->{"proto"} eq "icmp")
112 {
113 croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS');
114 $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
115 croak("Can't get icmp protocol by name");
116 $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
117 $self->{"fh"} = FileHandle->new();
118 socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
119 croak("icmp socket error - $!");
120 }
121 elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
122 {
123 $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
124 croak("Can't get tcp protocol by name");
125 $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
126 croak("Can't get tcp echo port by name");
127 $self->{"fh"} = FileHandle->new();
128 }
129
130 return($self);
a3b93737 131}
a0d0e21e 132
49afa5f6
JH
133# Description: Set the local IP address from which pings will be sent.
134# For ICMP and UDP pings, this calls bind() on the already-opened socket;
135# for TCP pings, just saves the address to be used when the socket is
136# opened. Returns non-zero if successful; croaks on error.
137sub bind
138{
e82f584b
JH
139 my ($self,
140 $local_addr # Name or IP number of local interface
141 ) = @_;
142 my ($ip # Packed IP number of $local_addr
143 );
144
145 croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
146 croak("already bound") if defined($self->{"local_addr"}) &&
147 ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
148
149 $ip = inet_aton($local_addr);
150 croak("nonexistent local address $local_addr") unless defined($ip);
151 $self->{"local_addr"} = $ip; # Only used if proto is tcp
152
153 if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
154 {
155 CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
156 croak("$self->{'proto'} bind error - $!");
157 }
158 elsif ($self->{"proto"} ne "tcp")
159 {
160 croak("Unknown protocol \"$self->{proto}\" in bind()");
161 }
162
163 return 1;
164}
49afa5f6 165
49afa5f6 166
15d96390
JH
167# Description: Allow UDP source endpoint comparision to be
168# skipped for those remote interfaces that do
169# not response from the same endpoint.
170
171sub source_verify
172{
173 my $self = shift;
174 $udp_source_verify = 1 unless defined
175 ($udp_source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
176}
177
e82f584b
JH
178# Description: allows the module to use milliseconds as returned by
179# the Time::HiRes module
49afa5f6 180
e82f584b
JH
181$hires = 0;
182sub hires
183{
184 my $self = shift;
185 $hires = 1 unless defined
186 ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
187 require Time::HiRes if $hires;
49afa5f6
JH
188}
189
e82f584b
JH
190sub time
191{
192 return $hires ? Time::HiRes::time() : CORE::time();
193}
49afa5f6 194
a3b93737
RM
195# Description: Ping a host name or IP number with an optional timeout.
196# First lookup the host, and return undef if it is not found. Otherwise
b124990b 197# perform the specific ping method based on the protocol. Return the
a3b93737
RM
198# result of the ping.
199
200sub ping
201{
e82f584b
JH
202 my ($self,
203 $host, # Name or IP number of host to ping
204 $timeout, # Seconds after which ping times out
205 ) = @_;
206 my ($ip, # Packed IP number of $host
207 $ret, # The return value
208 $ping_time, # When ping began
209 );
210
211 croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
212 $timeout = $self->{"timeout"} unless $timeout;
213 croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
214
215 $ip = inet_aton($host);
216 return(undef) unless defined($ip); # Does host exist?
217
218 # Dispatch to the appropriate routine.
219 $ping_time = &time();
220 if ($self->{"proto"} eq "external") {
221 $ret = $self->ping_external($ip, $timeout);
222 }
223 elsif ($self->{"proto"} eq "udp") {
224 $ret = $self->ping_udp($ip, $timeout);
225 }
226 elsif ($self->{"proto"} eq "icmp") {
227 $ret = $self->ping_icmp($ip, $timeout);
228 }
229 elsif ($self->{"proto"} eq "tcp") {
230 $ret = $self->ping_tcp($ip, $timeout);
231 }
232 elsif ($self->{"proto"} eq "stream") {
233 $ret = $self->ping_stream($ip, $timeout);
234 } else {
787ecdfa 235 croak("Unknown protocol \"$self->{proto}\" in ping()");
e82f584b
JH
236 }
237
238 return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
787ecdfa
JH
239}
240
241# Uses Net::Ping::External to do an external ping.
242sub ping_external {
243 my ($self,
244 $ip, # Packed IP number of the host
245 $timeout # Seconds after which ping times out
246 ) = @_;
247
b124990b
JH
248 eval { require Net::Ping::External; }
249 or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
787ecdfa 250 return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
a3b93737 251}
a0d0e21e 252
49afa5f6
JH
253use constant ICMP_ECHOREPLY => 0; # ICMP packet types
254use constant ICMP_ECHO => 8;
255use constant ICMP_STRUCT => "C2 S3 A"; # Structure of a minimal ICMP packet
256use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
257use constant ICMP_FLAGS => 0; # No special flags for send or recv
258use constant ICMP_PORT => 0; # No port with ICMP
259
a3b93737
RM
260sub ping_icmp
261{
e82f584b
JH
262 my ($self,
263 $ip, # Packed IP number of the host
264 $timeout # Seconds after which ping times out
265 ) = @_;
266
267 my ($saddr, # sockaddr_in with port and ip
268 $checksum, # Checksum of ICMP packet
269 $msg, # ICMP packet to send
270 $len_msg, # Length of $msg
271 $rbits, # Read bits, filehandles for reading
272 $nfound, # Number of ready filehandles found
273 $finish_time, # Time ping should be finished
274 $done, # set to 1 when we are done
275 $ret, # Return value
276 $recv_msg, # Received message including IP header
277 $from_saddr, # sockaddr_in of sender
278 $from_port, # Port packet was sent from
279 $from_ip, # Packed IP of sender
280 $from_type, # ICMP type
281 $from_subcode, # ICMP subcode
282 $from_chk, # ICMP packet checksum
283 $from_pid, # ICMP packet id
284 $from_seq, # ICMP packet sequence
285 $from_msg # ICMP message
286 );
287
288 $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
289 $checksum = 0; # No checksum for starters
290 $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
291 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
292 $checksum = Net::Ping->checksum($msg);
293 $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
294 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
295 $len_msg = length($msg);
296 $saddr = sockaddr_in(ICMP_PORT, $ip);
297 send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
298
299 $rbits = "";
300 vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
301 $ret = 0;
302 $done = 0;
303 $finish_time = &time() + $timeout; # Must be done by this time
304 while (!$done && $timeout > 0) # Keep trying if we have time
305 {
306 $nfound = select($rbits, undef, undef, $timeout); # Wait for packet
307 $timeout = $finish_time - &time(); # Get remaining time
308 if (!defined($nfound)) # Hmm, a strange error
a3b93737 309 {
e82f584b
JH
310 $ret = undef;
311 $done = 1;
312 }
313 elsif ($nfound) # Got a packet from somewhere
314 {
315 $recv_msg = "";
316 $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
317 ($from_port, $from_ip) = sockaddr_in($from_saddr);
318 ($from_type, $from_subcode, $from_chk,
319 $from_pid, $from_seq, $from_msg) =
320 unpack(ICMP_STRUCT . $self->{"data_size"},
321 substr($recv_msg, length($recv_msg) - $len_msg,
322 $len_msg));
323 if (($from_type == ICMP_ECHOREPLY) &&
324 ($from_ip eq $ip) &&
325 ($from_pid == $self->{"pid"}) && # Does the packet check out?
326 ($from_seq == $self->{"seq"}))
327 {
328 $ret = 1; # It's a winner
329 $done = 1;
330 }
a3b93737 331 }
e82f584b
JH
332 else # Oops, timed out
333 {
334 $done = 1;
335 }
336 }
337 return $ret;
a3b93737
RM
338}
339
340# Description: Do a checksum on the message. Basically sum all of
341# the short words and fold the high order bits into the low order bits.
342
343sub checksum
344{
e82f584b
JH
345 my ($class,
346 $msg # The message to checksum
347 ) = @_;
348 my ($len_msg, # Length of the message
349 $num_short, # The number of short words in the message
350 $short, # One short word
351 $chk # The checksum
352 );
353
354 $len_msg = length($msg);
355 $num_short = int($len_msg / 2);
356 $chk = 0;
357 foreach $short (unpack("S$num_short", $msg))
358 {
359 $chk += $short;
360 } # Add the odd byte in
361 $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
362 $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
363 return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
a3b93737
RM
364}
365
787ecdfa 366
b124990b
JH
367# Description: Perform a tcp echo ping. Since a tcp connection is
368# host specific, we have to open and close each connection here. We
369# can't just leave a socket open. Because of the robust nature of
370# tcp, it will take a while before it gives up trying to establish a
371# connection. Therefore, we use select() on a non-blocking socket to
372# check against our timeout. No data bytes are actually
373# sent since the successful establishment of a connection is proof
374# enough of the reachability of the remote host. Also, tcp is
375# expensive and doesn't need our help to add to the overhead.
376
377sub ping_tcp
787ecdfa 378{
e82f584b
JH
379 my ($self,
380 $ip, # Packed IP number of the host
381 $timeout # Seconds after which ping times out
382 ) = @_;
383 my ($ret # The return value
384 );
385
386 $@ = ""; $! = 0;
387 $ret = $self -> tcp_connect( $ip, $timeout);
ef73e1db 388 $ret = 1 if $! == ECONNREFUSED; # Connection refused
e82f584b
JH
389 $self->{"fh"}->close();
390 return $ret;
787ecdfa
JH
391}
392
b124990b 393sub tcp_connect
787ecdfa 394{
e82f584b
JH
395 my ($self,
396 $ip, # Packed IP number of the host
397 $timeout # Seconds after which connect times out
398 ) = @_;
399 my ($saddr); # Packed IP and Port
b124990b 400
e82f584b 401 $saddr = sockaddr_in($self->{"port_num"}, $ip);
b124990b 402
e82f584b 403 my $ret = 0; # Default to unreachable
b124990b 404
e82f584b
JH
405 my $do_socket = sub {
406 socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
407 croak("tcp socket error - $!");
408 if (defined $self->{"local_addr"} &&
409 !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
410 croak("tcp bind error - $!");
411 }
412 };
413 my $do_connect = sub {
414 eval {
415 die $! unless connect($self->{"fh"}, $saddr);
416 $self->{"ip"} = $ip;
417 $ret = 1;
418 };
419 $ret;
420 };
421
422 if ($^O =~ /Win32/i) {
423
424 # Buggy Winsock API doesn't allow us to use alarm() calls.
425 # Hence, if our OS is Windows, we need to create a separate
426 # process to do the blocking connect attempt.
427
428 $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
429 my $pid = fork;
430 if (!$pid) {
431 if (!defined $pid) {
432 # Fork did not work
433 warn "Win32 Fork error: $!";
434 return 0;
b124990b 435 }
b124990b
JH
436 &{ $do_socket }();
437
e82f584b
JH
438 # Try a slow blocking connect() call
439 # and report the status to the pipe.
440 if ( &{ $do_connect }() ) {
441 $self->{"fh"}->close();
442 # No error
443 exit 0;
b124990b 444 } else {
e82f584b
JH
445 # Pass the error status to the parent
446 exit $!;
b124990b 447 }
e82f584b 448 }
b124990b 449
e82f584b
JH
450 &{ $do_socket }();
451
452 my $patience = &time() + $timeout;
453
454 require POSIX;
455 my ($child);
456 $? = 0;
457 # Wait up to the timeout
458 # And clean off the zombie
459 do {
460 $child = waitpid($pid, &POSIX::WNOHANG);
461 $! = $? >> 8;
462 $@ = $!;
463 select(undef, undef, undef, 0.1);
464 } while &time() < $patience && $child != $pid;
465
466 if ($child == $pid) {
467 # Since she finished within the timeout,
468 # it is probably safe for me to try it too
b124990b 469 &{ $do_connect }();
e82f584b
JH
470 } else {
471 # Time must have run out.
472 $@ = "Timed out!";
473 # Put that choking client out of its misery
474 kill "KILL", $pid;
475 # Clean off the zombie
476 waitpid($pid, 0);
477 $ret = 0;
b124990b 478 }
e82f584b
JH
479 } else { # Win32
480 # Otherwise don't waste the resources to fork
481
482 &{ $do_socket }();
483
484 $SIG{'ALRM'} = sub { die "Timed out!"; };
485 alarm($timeout); # Interrupt connect() if we have to
486
487 &{ $do_connect }();
488 alarm(0);
489 }
787ecdfa 490
e82f584b 491 return $ret;
787ecdfa
JH
492}
493
494# This writes the given string to the socket and then reads it
495# back. It returns 1 on success, 0 on failure.
496sub tcp_echo
497{
e82f584b
JH
498 my $self = shift;
499 my $timeout = shift;
500 my $pingstring = shift;
501
502 my $ret = undef;
503 my $time = &time();
504 my $wrstr = $pingstring;
505 my $rdstr = "";
506
507 eval <<'EOM';
508 do {
509 my $rin = "";
510 vec($rin, $self->{"fh"}->fileno(), 1) = 1;
511
512 my $rout = undef;
513 if($wrstr) {
514 $rout = "";
515 vec($rout, $self->{"fh"}->fileno(), 1) = 1;
516 }
517
518 if(select($rin, $rout, undef, ($time + $timeout) - &time())) {
519
520 if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
521 my $num = syswrite($self->{"fh"}, $wrstr);
522 if($num) {
523 # If it was a partial write, update and try again.
524 $wrstr = substr($wrstr,$num);
525 } else {
526 # There was an error.
527 $ret = 0;
528 }
529 }
530
531 if(vec($rin,$self->{"fh"}->fileno(),1)) {
532 my $reply;
533 if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
534 $rdstr .= $reply;
535 $ret = 1 if $rdstr eq $pingstring;
536 } else {
537 # There was an error.
538 $ret = 0;
539 }
540 }
541
542 }
543 } until &time() > ($time + $timeout) || defined($ret);
787ecdfa
JH
544EOM
545
e82f584b 546 return $ret;
787ecdfa
JH
547}
548
787ecdfa 549
787ecdfa 550
787ecdfa
JH
551
552# Description: Perform a stream ping. If the tcp connection isn't
553# already open, it opens it. It then sends some data and waits for
554# a reply. It leaves the stream open on exit.
555
556sub ping_stream
557{
e82f584b
JH
558 my ($self,
559 $ip, # Packed IP number of the host
560 $timeout # Seconds after which ping times out
561 ) = @_;
072620d9 562
e82f584b
JH
563 # Open the stream if it's not already open
564 if(!defined $self->{"fh"}->fileno()) {
565 $self->tcp_connect($ip, $timeout) or return 0;
566 }
787ecdfa 567
e82f584b
JH
568 croak "tried to switch servers while stream pinging"
569 if $self->{"ip"} ne $ip;
570
571 return $self->tcp_echo($timeout, $pingstring);
787ecdfa
JH
572}
573
574# Description: opens the stream. You would do this if you want to
575# separate the overhead of opening the stream from the first ping.
576
577sub open
578{
e82f584b
JH
579 my ($self,
580 $host, # Host or IP address
581 $timeout # Seconds after which open times out
582 ) = @_;
583
584 my ($ip); # Packed IP number of the host
585 $ip = inet_aton($host);
586 $timeout = $self->{"timeout"} unless $timeout;
587
588 if($self->{"proto"} eq "stream") {
589 if(defined($self->{"fh"}->fileno())) {
590 croak("socket is already open");
591 } else {
592 $self->tcp_connect($ip, $timeout);
b124990b 593 }
e82f584b 594 }
072620d9
SB
595}
596
b124990b 597
a3b93737
RM
598# Description: Perform a udp echo ping. Construct a message of
599# at least the one-byte sequence number and any additional data bytes.
600# Send the message out and wait for a message to come back. If we
601# get a message, make sure all of its parts match. If they do, we are
602# done. Otherwise go back and wait for the message until we run out
603# of time. Return the result of our efforts.
604
49afa5f6
JH
605use constant UDP_FLAGS => 0; # Nothing special on send or recv
606
a3b93737
RM
607sub ping_udp
608{
e82f584b
JH
609 my ($self,
610 $ip, # Packed IP number of the host
611 $timeout # Seconds after which ping times out
612 ) = @_;
613
614 my ($saddr, # sockaddr_in with port and ip
615 $ret, # The return value
616 $msg, # Message to be echoed
617 $finish_time, # Time ping should be finished
e82f584b
JH
618 $done, # Set to 1 when we are done pinging
619 $rbits, # Read bits, filehandles for reading
620 $nfound, # Number of ready filehandles found
621 $from_saddr, # sockaddr_in of sender
622 $from_msg, # Characters echoed by $host
623 $from_port, # Port message was echoed from
624 $from_ip # Packed IP number of sender
625 );
626
627 $saddr = sockaddr_in($self->{"port_num"}, $ip);
628 $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
629 $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
630 send($self->{"fh"}, $msg, UDP_FLAGS, $saddr); # Send it
631
632 $rbits = "";
633 vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
634 $ret = 0; # Default to unreachable
635 $done = 0;
e82f584b
JH
636 $finish_time = &time() + $timeout; # Ping needs to be done by then
637 while (!$done && $timeout > 0)
638 {
639 $nfound = select($rbits, undef, undef, $timeout); # Wait for response
640 $timeout = $finish_time - &time(); # Get remaining time
641
642 if (!defined($nfound)) # Hmm, a strange error
a3b93737 643 {
e82f584b
JH
644 $ret = undef;
645 $done = 1;
a3b93737 646 }
e82f584b
JH
647 elsif ($nfound) # A packet is waiting
648 {
649 $from_msg = "";
650 $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS)
651 or last; # For example an unreachable host will make recv() fail.
652 ($from_port, $from_ip) = sockaddr_in($from_saddr);
15d96390
JH
653 if (!$udp_source_verify ||
654 (($from_ip eq $ip) && # Does the packet check out?
655 ($from_port == $self->{"port_num"}) &&
656 ($from_msg eq $msg)))
e82f584b
JH
657 {
658 $ret = 1; # It's a winner
659 $done = 1;
660 }
661 }
662 else # Oops, timed out
663 {
664 $done = 1;
665 }
666 }
a5a165b1 667 return $ret;
b124990b 668}
a0d0e21e 669
a3b93737
RM
670# Description: Close the connection unless we are using the tcp
671# protocol, since it will already be closed.
672
673sub close
674{
e82f584b 675 my ($self) = @_;
a3b93737 676
e82f584b 677 $self->{"fh"}->close() unless $self->{"proto"} eq "tcp";
a3b93737
RM
678}
679
680
a0d0e21e 6811;
8e07c86e
AD
682__END__
683
8e07c86e
AD
684=head1 NAME
685
a3b93737 686Net::Ping - check a remote host for reachability
8e07c86e 687
15d96390 688$Id: Ping.pm,v 1.1 2002/06/04 00:41:52 rob Exp $
b124990b 689
8e07c86e
AD
690=head1 SYNOPSIS
691
692 use Net::Ping;
8e07c86e 693
a3b93737
RM
694 $p = Net::Ping->new();
695 print "$host is alive.\n" if $p->ping($host);
696 $p->close();
697
698 $p = Net::Ping->new("icmp");
49afa5f6 699 $p->bind($my_addr); # Specify source interface of pings
a3b93737
RM
700 foreach $host (@host_array)
701 {
702 print "$host is ";
703 print "NOT " unless $p->ping($host, 2);
704 print "reachable.\n";
705 sleep(1);
706 }
707 $p->close();
b124990b 708
a3b93737 709 $p = Net::Ping->new("tcp", 2);
b124990b
JH
710 # Try connecting to the www port instead of the echo port
711 $p->{port_num} = getservbyname("http", "tcp");
a3b93737
RM
712 while ($stop_time > time())
713 {
714 print "$host not reachable ", scalar(localtime()), "\n"
715 unless $p->ping($host);
716 sleep(300);
717 }
718 undef($p);
b124990b 719
e82f584b
JH
720 # High precision syntax (requires Time::HiRes)
721 $p = Net::Ping->new();
722 $p->hires();
723 ($ret, $duration, $ip) = $p->ping($host, 5.5);
724 printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration)
725 if $ret;
726 $p->close();
727
a3b93737
RM
728 # For backward compatibility
729 print "$host is alive.\n" if pingecho($host);
8e07c86e 730
a3b93737 731=head1 DESCRIPTION
8e07c86e 732
a3b93737
RM
733This module contains methods to test the reachability of remote
734hosts on a network. A ping object is first created with optional
735parameters, a variable number of hosts may be pinged multiple
736times and then the connection is closed.
737
b124990b
JH
738You may choose one of four different protocols to use for the
739ping. The "udp" protocol is the default. Note that a live remote host
740may still fail to be pingable by one or more of these protocols. For
741example, www.microsoft.com is generally alive but not pingable.
787ecdfa 742
b124990b
JH
743With the "tcp" protocol the ping() method attempts to establish a
744connection to the remote host's echo port. If the connection is
745successfully established, the remote host is considered reachable. No
746data is actually echoed. This protocol does not require any special
747privileges but has higher overhead than the other two protocols.
072620d9 748
b124990b 749Specifying the "udp" protocol causes the ping() method to send a udp
a3b93737
RM
750packet to the remote host's echo port. If the echoed packet is
751received from the remote host and the received packet contains the
752same data as the packet that was sent, the remote host is considered
753reachable. This protocol does not require any special privileges.
b124990b 754It should be borne in mind that, for a udp ping, a host
787ecdfa 755will be reported as unreachable if it is not running the
b124990b
JH
756appropriate echo service. For Unix-like systems see L<inetd(8)>
757for more information.
787ecdfa 758
b124990b
JH
759If the "icmp" protocol is specified, the ping() method sends an icmp
760echo message to the remote host, which is what the UNIX ping program
761does. If the echoed message is received from the remote host and
762the echoed information is correct, the remote host is considered
763reachable. Specifying the "icmp" protocol requires that the program
764be run as root or that the program be setuid to root.
787ecdfa 765
b124990b
JH
766If the "external" protocol is specified, the ping() method attempts to
767use the C<Net::Ping::External> module to ping the remote host.
768C<Net::Ping::External> interfaces with your system's default C<ping>
769utility to perform the ping, and generally produces relatively
787ecdfa
JH
770accurate results. If C<Net::Ping::External> if not installed on your
771system, specifying the "external" protocol will result in an error.
edc5bd88 772
a3b93737
RM
773=head2 Functions
774
775=over 4
776
777=item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);
778
779Create a new ping object. All of the parameters are optional. $proto
780specifies the protocol to use when doing a ping. The current choices
781are "tcp", "udp" or "icmp". The default is "udp".
782
783If a default timeout ($def_timeout) in seconds is provided, it is used
784when a timeout is not given to the ping() method (below). The timeout
785must be greater than 0 and the default, if not specified, is 5 seconds.
786
787If the number of data bytes ($bytes) is given, that many data bytes
788are included in the ping packet sent to the remote host. The number of
789data bytes is ignored if the protocol is "tcp". The minimum (and
790default) number of data bytes is 1 if the protocol is "udp" and 0
791otherwise. The maximum number of data bytes that can be specified is
7921024.
793
15d96390
JH
794=item $p->source_verify( { 0 | 1 } );
795
796Allows source endpoint verification to be enabled or disabled.
797This is useful for those remote destinations with multiples
798interfaces where the response may not originate from the same
799endpoint that the original destination endpoint was sent to.
800
801This is enabled by default.
802
e82f584b
JH
803=item $p->hires( { 0 | 1 } );
804
805Causes this module to use Time::HiRes module, allowing milliseconds
806to be returned by subsequent calls to ping().
807
15d96390
JH
808This is disabled by default.
809
49afa5f6
JH
810=item $p->bind($local_addr);
811
812Sets the source address from which pings will be sent. This must be
813the address of one of the interfaces on the local host. $local_addr
814may be specified as a hostname or as a text IP address such as
815"192.168.1.1".
816
817If the protocol is set to "tcp", this method may be called any
818number of times, and each call to the ping() method (below) will use
819the most recent $local_addr. If the protocol is "icmp" or "udp",
820then bind() must be called at most once per object, and (if it is
821called at all) must be called before the first call to ping() for that
822object.
823
a3b93737
RM
824=item $p->ping($host [, $timeout]);
825
826Ping the remote host and wait for a response. $host can be either the
827hostname or the IP number of the remote host. The optional timeout
828must be greater than 0 seconds and defaults to whatever was specified
e82f584b
JH
829when the ping object was created. Returns a success flag. If the
830hostname cannot be found or there is a problem with the IP number, the
831success flag returned will be undef. Otherwise, the success flag will
832be 1 if the host is reachable and 0 if it is not. For most practical
833purposes, undef and 0 and can be treated as the same case. In array
834context, the elapsed time is also returned. The elapsed time value will
835be a float, as retuned by the Time::HiRes::time() function, if hires()
836has been previously called, otherwise it is returned as an integer.
b124990b
JH
837
838=item $p->open($host);
839
840When you are using the stream protocol, this call pre-opens the
841tcp socket. It's only necessary to do this if you want to
842provide a different timeout when creating the connection, or
843remove the overhead of establishing the connection from the
844first ping. If you don't call C<open()>, the connection is
845automatically opened the first time C<ping()> is called.
787ecdfa
JH
846This call simply does nothing if you are using any protocol other
847than stream.
848
a3b93737
RM
849=item $p->close();
850
851Close the network connection for this ping object. The network
852connection is also closed by "undef $p". The network connection is
853automatically closed if the ping object goes out of scope (e.g. $p is
854local to a subroutine and you leave the subroutine).
855
856=item pingecho($host [, $timeout]);
857
858To provide backward compatibility with the previous version of
859Net::Ping, a pingecho() subroutine is available with the same
860functionality as before. pingecho() uses the tcp protocol. The
861return values and parameters are the same as described for the ping()
862method. This subroutine is obsolete and may be removed in a future
863version of Net::Ping.
8e07c86e 864
a3b93737 865=back
8e07c86e 866
b124990b
JH
867=head1 WARNING
868
869pingecho() or a ping object with the tcp protocol use alarm() to
870implement the timeout. So, don't use alarm() in your program while
871you are using pingecho() or a ping object with the tcp protocol. The
872udp and icmp protocols do not use alarm() to implement the timeout.
873
a3b93737 874=head1 NOTES
8e07c86e 875
a3b93737
RM
876There will be less network overhead (and some efficiency in your
877program) if you specify either the udp or the icmp protocol. The tcp
878protocol will generate 2.5 times or more traffic for each ping than
879either udp or icmp. If many hosts are pinged frequently, you may wish
880to implement a small wait (e.g. 25ms or more) between each ping to
881avoid flooding your network with packets.
8e07c86e 882
a3b93737 883The icmp protocol requires that the program be run as root or that it
787ecdfa
JH
884be setuid to root. The other protocols do not require special
885privileges, but not all network devices implement tcp or udp echo.
8e07c86e 886
a3b93737
RM
887Local hosts should normally respond to pings within milliseconds.
888However, on a very congested network it may take up to 3 seconds or
889longer to receive an echo packet from the remote host. If the timeout
890is set too low under these conditions, it will appear that the remote
891host is not reachable (which is almost the truth).
8e07c86e 892
a3b93737 893Reachability doesn't necessarily mean that the remote host is actually
787ecdfa
JH
894functioning beyond its ability to echo packets. tcp is slightly better
895at indicating the health of a system than icmp because it uses more
896of the networking stack to respond.
8e07c86e 897
a3b93737
RM
898Because of a lack of anything better, this module uses its own
899routines to pack and unpack ICMP packets. It would be better for a
900separate module to be written which understands all of the different
901kinds of ICMP packets.
8e07c86e 902
49afa5f6 903=head1 AUTHORS
b124990b 904
e82f584b 905 Current maintainer:
49afa5f6 906 bbb@cpan.org (Rob Brown)
b124990b 907
e82f584b
JH
908 External protocol:
909 colinm@cpan.org (Colin McMillen)
910
b124990b
JH
911 Stream protocol:
912 bronson@trestle.com (Scott Bronson)
913
914 Original pingecho():
915 karrer@bernina.ethz.ch (Andreas Karrer)
916 pmarquess@bfsec.bt.co.uk (Paul Marquess)
917
918 Original Net::Ping author:
919 mose@ns.ccsn.edu (Russell Mosemann)
920
b124990b
JH
921=head1 COPYRIGHT
922
e82f584b 923Copyright (c) 2002, Rob Brown. All rights reserved.
49afa5f6 924
e82f584b 925Copyright (c) 2001, Colin McMillen. All rights reserved.
b124990b
JH
926
927This program is free software; you may redistribute it and/or
928modify it under the same terms as Perl itself.
929
a3b93737 930=cut