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