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