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