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