This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline.
[perl5.git] / lib / Net / Ping.pm
1 package Net::Ping;
2
3 # Author:   mose@ccsn.edu (Russell Mosemann)
4 #
5 # Authors of the original pingecho():
6 #           karrer@bernina.ethz.ch (Andreas Karrer)
7 #           Paul.Marquess@btinternet.com (Paul Marquess)
8 #
9 # Copyright (c) 1996 Russell Mosemann.  All rights reserved.  This
10 # program is free software; you may redistribute it and/or modify it
11 # under the same terms as Perl itself.
12
13 use 5.005_64;
14 require Exporter;
15
16 use strict;
17 our(@ISA, @EXPORT, $VERSION, $def_timeout, $def_proto, $max_datasize);
18 use FileHandle;
19 use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
20                inet_aton sockaddr_in );
21 use Carp;
22
23 @ISA = qw(Exporter);
24 @EXPORT = qw(pingecho);
25 $VERSION = 2.02;
26
27 # Constants
28
29 $def_timeout = 5;           # Default timeout to wait for a reply
30 $def_proto = "udp";         # Default protocol to use for pinging
31 $max_datasize = 1024;       # Maximum data bytes in a packet
32
33 # Description:  The pingecho() subroutine is provided for backward
34 # compatibility with the original Net::Ping.  It accepts a host
35 # name/IP and an optional timeout in seconds.  Create a tcp ping
36 # object and try pinging the host.  The result of the ping is returned.
37
38 sub pingecho
39 {
40     my ($host,              # Name or IP number of host to ping
41         $timeout            # Optional timeout in seconds
42         ) = @_;
43     my ($p);                # A ping object
44
45     $p = Net::Ping->new("tcp", $timeout);
46     $p->ping($host);        # Going out of scope closes the connection
47 }
48
49 # Description:  The new() method creates a new ping object.  Optional
50 # parameters may be specified for the protocol to use, the timeout in
51 # seconds and the size in bytes of additional data which should be
52 # included in the packet.
53 #   After the optional parameters are checked, the data is constructed
54 # and a socket is opened if appropriate.  The object is returned.
55
56 sub new
57 {
58     my ($this,
59         $proto,             # Optional protocol to use for pinging
60         $timeout,           # Optional timeout in seconds
61         $data_size          # Optional additional bytes of data
62         ) = @_;
63     my  $class = ref($this) || $this;
64     my  $self = {};
65     my ($cnt,               # Count through data bytes
66         $min_datasize       # Minimum data bytes required
67         );
68
69     bless($self, $class);
70
71     $proto = $def_proto unless $proto;          # Determine the protocol
72     croak("Protocol for ping must be \"tcp\", \"udp\" or \"icmp\"")
73         unless $proto =~ m/^(tcp|udp|icmp)$/;
74     $self->{"proto"} = $proto;
75
76     $timeout = $def_timeout unless $timeout;    # Determine the timeout
77     croak("Default timeout for ping must be greater than 0 seconds")
78         if $timeout <= 0;
79     $self->{"timeout"} = $timeout;
80
81     $min_datasize = ($proto eq "udp") ? 1 : 0;  # Determine data size
82     $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
83     croak("Data for ping must be from $min_datasize to $max_datasize bytes")
84         if ($data_size < $min_datasize) || ($data_size > $max_datasize);
85     $data_size-- if $self->{"proto"} eq "udp";  # We provide the first byte
86     $self->{"data_size"} = $data_size;
87
88     $self->{"data"} = "";                       # Construct data bytes
89     for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
90     {
91         $self->{"data"} .= chr($cnt % 256);
92     }
93
94     $self->{"seq"} = 0;                         # For counting packets
95     if ($self->{"proto"} eq "udp")              # Open a socket
96     {
97         $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
98             croak("Can't udp protocol by name");
99         $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
100             croak("Can't get udp echo port by name");
101         $self->{"fh"} = FileHandle->new();
102         socket($self->{"fh"}, &PF_INET(), &SOCK_DGRAM(),
103                $self->{"proto_num"}) ||
104             croak("udp socket error - $!");
105     }
106     elsif ($self->{"proto"} eq "icmp")
107     {
108         croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS');
109         $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
110                     croak("Can't get icmp protocol by name");
111         $self->{"pid"} = $$ & 0xffff;           # Save lower 16 bits of pid
112         $self->{"fh"} = FileHandle->new();
113         socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) ||
114             croak("icmp socket error - $!");
115     }
116     elsif ($self->{"proto"} eq "tcp")           # Just a file handle for now
117     {
118         $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
119             croak("Can't get tcp protocol by name");
120         $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
121             croak("Can't get tcp echo port by name");
122         $self->{"fh"} = FileHandle->new();
123     }
124
125
126     return($self);
127 }
128
129 # Description: Ping a host name or IP number with an optional timeout.
130 # First lookup the host, and return undef if it is not found.  Otherwise
131 # perform the specific ping method based on the protocol.  Return the 
132 # result of the ping.
133
134 sub ping
135 {
136     my ($self,
137         $host,              # Name or IP number of host to ping
138         $timeout            # Seconds after which ping times out
139         ) = @_;
140     my ($ip,                # Packed IP number of $host
141         $ret                # The return value
142         );
143
144     croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
145     $timeout = $self->{"timeout"} unless $timeout;
146     croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
147
148     $ip = inet_aton($host);
149     return(undef) unless defined($ip);      # Does host exist?
150
151     if ($self->{"proto"} eq "udp")
152     {
153         $ret = $self->ping_udp($ip, $timeout);
154     }
155     elsif ($self->{"proto"} eq "icmp")
156     {
157         $ret = $self->ping_icmp($ip, $timeout);
158     }
159     elsif ($self->{"proto"} eq "tcp")
160     {
161         $ret = $self->ping_tcp($ip, $timeout);
162     }
163     else
164     {
165         croak("Unknown protocol \"$self->{proto}\" in ping()");
166     }
167     return($ret);
168 }
169
170 sub ping_icmp
171 {
172     my ($self,
173         $ip,                # Packed IP number of the host
174         $timeout            # Seconds after which ping times out
175         ) = @_;
176
177     my $ICMP_ECHOREPLY = 0; # ICMP packet types
178     my $ICMP_ECHO = 8;
179     my $icmp_struct = "C2 S3 A";  # Structure of a minimal ICMP packet
180     my $subcode = 0;        # No ICMP subcode for ECHO and ECHOREPLY
181     my $flags = 0;          # No special flags when opening a socket
182     my $port = 0;           # No port with ICMP
183
184     my ($saddr,             # sockaddr_in with port and ip
185         $checksum,          # Checksum of ICMP packet
186         $msg,               # ICMP packet to send
187         $len_msg,           # Length of $msg
188         $rbits,             # Read bits, filehandles for reading
189         $nfound,            # Number of ready filehandles found
190         $finish_time,       # Time ping should be finished
191         $done,              # set to 1 when we are done
192         $ret,               # Return value
193         $recv_msg,          # Received message including IP header
194         $from_saddr,        # sockaddr_in of sender
195         $from_port,         # Port packet was sent from
196         $from_ip,           # Packed IP of sender
197         $from_type,         # ICMP type
198         $from_subcode,      # ICMP subcode
199         $from_chk,          # ICMP packet checksum
200         $from_pid,          # ICMP packet id
201         $from_seq,          # ICMP packet sequence
202         $from_msg           # ICMP message
203         );
204
205     $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
206     $checksum = 0;                          # No checksum for starters
207     $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode,
208                 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
209     $checksum = Net::Ping->checksum($msg);
210     $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode,
211                 $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
212     $len_msg = length($msg);
213     $saddr = sockaddr_in($port, $ip);
214     send($self->{"fh"}, $msg, $flags, $saddr); # Send the message
215
216     $rbits = "";
217     vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
218     $ret = 0;
219     $done = 0;
220     $finish_time = time() + $timeout;       # Must be done by this time
221     while (!$done && $timeout > 0)          # Keep trying if we have time
222     {
223         $nfound = select($rbits, undef, undef, $timeout); # Wait for packet
224         $timeout = $finish_time - time();   # Get remaining time
225         if (!defined($nfound))              # Hmm, a strange error
226         {
227             $ret = undef;
228             $done = 1;
229         }
230         elsif ($nfound)                     # Got a packet from somewhere
231         {
232             $recv_msg = "";
233             $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, $flags);
234             ($from_port, $from_ip) = sockaddr_in($from_saddr);
235             ($from_type, $from_subcode, $from_chk,
236              $from_pid, $from_seq, $from_msg) =
237                 unpack($icmp_struct . $self->{"data_size"},
238                        substr($recv_msg, length($recv_msg) - $len_msg,
239                               $len_msg));
240             if (($from_type == $ICMP_ECHOREPLY) &&
241                 ($from_ip eq $ip) &&
242                 ($from_pid == $self->{"pid"}) && # Does the packet check out?
243                 ($from_seq == $self->{"seq"}))
244             {
245                 $ret = 1;                   # It's a winner
246                 $done = 1;
247             }
248         }
249         else                                # Oops, timed out
250         {
251             $done = 1;
252         }
253     }
254     return($ret)
255 }
256
257 # Description:  Do a checksum on the message.  Basically sum all of
258 # the short words and fold the high order bits into the low order bits.
259
260 sub checksum
261 {
262     my ($class,
263         $msg            # The message to checksum
264         ) = @_;
265     my ($len_msg,       # Length of the message
266         $num_short,     # The number of short words in the message
267         $short,         # One short word
268         $chk            # The checksum
269         );
270
271     $len_msg = length($msg);
272     $num_short = int($len_msg / 2);
273     $chk = 0;
274     foreach $short (unpack("S$num_short", $msg))
275     {
276         $chk += $short;
277     }                                           # Add the odd byte in
278     $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
279     $chk = ($chk >> 16) + ($chk & 0xffff);      # Fold high into low
280     return(~(($chk >> 16) + $chk) & 0xffff);    # Again and complement
281 }
282
283 # Description:  Perform a tcp echo ping.  Since a tcp connection is
284 # host specific, we have to open and close each connection here.  We
285 # can't just leave a socket open.  Because of the robust nature of
286 # tcp, it will take a while before it gives up trying to establish a
287 # connection.  Therefore, we have to set the alarm to break out of the
288 # connection sooner if the timeout expires.  No data bytes are actually
289 # sent since the successful establishment of a connection is proof
290 # enough of the reachability of the remote host.  Also, tcp is
291 # expensive and doesn't need our help to add to the overhead.
292
293 sub ping_tcp
294 {
295     my ($self,
296         $ip,                # Packed IP number of the host
297         $timeout            # Seconds after which ping times out
298         ) = @_;
299     my ($saddr,             # sockaddr_in with port and ip
300         $ret                # The return value
301         );
302                             
303     socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
304         croak("tcp socket error - $!");
305     $saddr = sockaddr_in($self->{"port_num"}, $ip);
306
307     $SIG{'ALRM'} = sub { die };
308     alarm($timeout);        # Interrupt connect() if we have to
309             
310     $ret = 0;               # Default to unreachable
311     eval <<'EOM' ;
312         return unless connect($self->{"fh"}, $saddr);
313         $ret = 1;
314 EOM
315     alarm(0);
316     $self->{"fh"}->close();
317     return($ret);
318 }
319
320 # Description:  Perform a udp echo ping.  Construct a message of
321 # at least the one-byte sequence number and any additional data bytes.
322 # Send the message out and wait for a message to come back.  If we
323 # get a message, make sure all of its parts match.  If they do, we are
324 # done.  Otherwise go back and wait for the message until we run out
325 # of time.  Return the result of our efforts.
326
327 sub ping_udp
328 {
329     my ($self,
330         $ip,                # Packed IP number of the host
331         $timeout            # Seconds after which ping times out
332         ) = @_;
333
334     my $flags = 0;          # Nothing special on open
335
336     my ($saddr,             # sockaddr_in with port and ip
337         $ret,               # The return value
338         $msg,               # Message to be echoed
339         $finish_time,       # Time ping should be finished
340         $done,              # Set to 1 when we are done pinging
341         $rbits,             # Read bits, filehandles for reading
342         $nfound,            # Number of ready filehandles found
343         $from_saddr,        # sockaddr_in of sender
344         $from_msg,          # Characters echoed by $host
345         $from_port,         # Port message was echoed from
346         $from_ip            # Packed IP number of sender
347         );
348
349     $saddr = sockaddr_in($self->{"port_num"}, $ip);
350     $self->{"seq"} = ($self->{"seq"} + 1) % 256;    # Increment sequence
351     $msg = chr($self->{"seq"}) . $self->{"data"};   # Add data if any
352     send($self->{"fh"}, $msg, $flags, $saddr);      # Send it
353
354     $rbits = "";
355     vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
356     $ret = 0;                   # Default to unreachable
357     $done = 0;
358     $finish_time = time() + $timeout;       # Ping needs to be done by then
359     while (!$done && $timeout > 0)
360     {
361         $nfound = select($rbits, undef, undef, $timeout); # Wait for response
362         $timeout = $finish_time - time();   # Get remaining time
363
364         if (!defined($nfound))  # Hmm, a strange error
365         {
366             $ret = undef;
367             $done = 1;
368         }
369         elsif ($nfound)         # A packet is waiting
370         {
371             $from_msg = "";
372             $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags)
373                 or last; # For example an unreachable host will make recv() fail.
374             ($from_port, $from_ip) = sockaddr_in($from_saddr);
375             if (($from_ip eq $ip) &&        # Does the packet check out?
376                 ($from_port == $self->{"port_num"}) &&
377                 ($from_msg eq $msg))
378             {
379                 $ret = 1;       # It's a winner
380                 $done = 1;
381             }
382         }
383         else                    # Oops, timed out
384         {
385             $done = 1;
386         }
387     }
388     return($ret);
389 }   
390
391 # Description:  Close the connection unless we are using the tcp
392 # protocol, since it will already be closed.
393
394 sub close
395 {
396     my ($self) = @_;
397
398     $self->{"fh"}->close() unless $self->{"proto"} eq "tcp";
399 }
400
401
402 1;
403 __END__
404
405 =head1 NAME
406
407 Net::Ping - check a remote host for reachability
408
409 =head1 SYNOPSIS
410
411     use Net::Ping;
412
413     $p = Net::Ping->new();
414     print "$host is alive.\n" if $p->ping($host);
415     $p->close();
416
417     $p = Net::Ping->new("icmp");
418     foreach $host (@host_array)
419     {
420         print "$host is ";
421         print "NOT " unless $p->ping($host, 2);
422         print "reachable.\n";
423         sleep(1);
424     }
425     $p->close();
426
427     $p = Net::Ping->new("tcp", 2);
428     while ($stop_time > time())
429     {
430         print "$host not reachable ", scalar(localtime()), "\n"
431             unless $p->ping($host);
432         sleep(300);
433     }
434     undef($p);
435
436     # For backward compatibility
437     print "$host is alive.\n" if pingecho($host);
438
439 =head1 DESCRIPTION
440
441 This module contains methods to test the reachability of remote
442 hosts on a network.  A ping object is first created with optional
443 parameters, a variable number of hosts may be pinged multiple
444 times and then the connection is closed.
445
446 You may choose one of three different protocols to use for the
447 ping. The "udp" protocol is the default. Note that a live remote host
448 may still fail to be pingable by one or more of these protocols. For
449 example, www.microsoft.com is generally alive but not pingable.
450
451 With the "tcp" protocol the ping() method attempts to establish a
452 connection to the remote host's echo port.  If the connection is
453 successfully established, the remote host is considered reachable.  No
454 data is actually echoed.  This protocol does not require any special
455 privileges but has higher overhead than the other two protocols.
456
457 Specifying the "udp" protocol causes the ping() method to send a udp
458 packet to the remote host's echo port.  If the echoed packet is
459 received from the remote host and the received packet contains the
460 same data as the packet that was sent, the remote host is considered
461 reachable.  This protocol does not require any special privileges.
462
463 It should be borne in mind that, for both tcp and udp ping, a host
464 will be reported as unreachable if it is not running the
465 appropriate echo service.  For Unix-like systems see L<inetd(8)> for
466 more information.
467
468 If the "icmp" protocol is specified, the ping() method sends an icmp
469 echo message to the remote host, which is what the UNIX ping program
470 does.  If the echoed message is received from the remote host and
471 the echoed information is correct, the remote host is considered
472 reachable.  Specifying the "icmp" protocol requires that the program
473 be run as root or that the program be setuid to root.
474
475 =head2 Functions
476
477 =over 4
478
479 =item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);
480
481 Create a new ping object.  All of the parameters are optional.  $proto
482 specifies the protocol to use when doing a ping.  The current choices
483 are "tcp", "udp" or "icmp".  The default is "udp".
484
485 If a default timeout ($def_timeout) in seconds is provided, it is used
486 when a timeout is not given to the ping() method (below).  The timeout
487 must be greater than 0 and the default, if not specified, is 5 seconds.
488
489 If the number of data bytes ($bytes) is given, that many data bytes
490 are included in the ping packet sent to the remote host. The number of
491 data bytes is ignored if the protocol is "tcp".  The minimum (and
492 default) number of data bytes is 1 if the protocol is "udp" and 0
493 otherwise.  The maximum number of data bytes that can be specified is
494 1024.
495
496 =item $p->ping($host [, $timeout]);
497
498 Ping the remote host and wait for a response.  $host can be either the
499 hostname or the IP number of the remote host.  The optional timeout
500 must be greater than 0 seconds and defaults to whatever was specified
501 when the ping object was created.  If the hostname cannot be found or
502 there is a problem with the IP number, undef is returned.  Otherwise,
503 1 is returned if the host is reachable and 0 if it is not.  For all
504 practical purposes, undef and 0 and can be treated as the same case.
505
506 =item $p->close();
507
508 Close the network connection for this ping object.  The network
509 connection is also closed by "undef $p".  The network connection is
510 automatically closed if the ping object goes out of scope (e.g. $p is
511 local to a subroutine and you leave the subroutine).
512
513 =item pingecho($host [, $timeout]);
514
515 To provide backward compatibility with the previous version of
516 Net::Ping, a pingecho() subroutine is available with the same
517 functionality as before.  pingecho() uses the tcp protocol.  The
518 return values and parameters are the same as described for the ping()
519 method.  This subroutine is obsolete and may be removed in a future
520 version of Net::Ping.
521
522 =back
523
524 =head1 WARNING
525
526 pingecho() or a ping object with the tcp protocol use alarm() to
527 implement the timeout.  So, don't use alarm() in your program while
528 you are using pingecho() or a ping object with the tcp protocol.  The
529 udp and icmp protocols do not use alarm() to implement the timeout.
530
531 =head1 NOTES
532
533 There will be less network overhead (and some efficiency in your
534 program) if you specify either the udp or the icmp protocol.  The tcp
535 protocol will generate 2.5 times or more traffic for each ping than
536 either udp or icmp.  If many hosts are pinged frequently, you may wish
537 to implement a small wait (e.g. 25ms or more) between each ping to
538 avoid flooding your network with packets.
539
540 The icmp protocol requires that the program be run as root or that it
541 be setuid to root.  The tcp and udp protocols do not require special
542 privileges, but not all network devices implement the echo protocol
543 for tcp or udp.
544
545 Local hosts should normally respond to pings within milliseconds.
546 However, on a very congested network it may take up to 3 seconds or
547 longer to receive an echo packet from the remote host.  If the timeout
548 is set too low under these conditions, it will appear that the remote
549 host is not reachable (which is almost the truth).
550
551 Reachability doesn't necessarily mean that the remote host is actually
552 functioning beyond its ability to echo packets.
553
554 Because of a lack of anything better, this module uses its own
555 routines to pack and unpack ICMP packets.  It would be better for a
556 separate module to be written which understands all of the different
557 kinds of ICMP packets.
558
559 =cut