1package Net::Ping; 2 3require 5.002; 4require Exporter; 5 6use strict; 7use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION 8 $def_timeout $def_proto $def_factor $def_family 9 $max_datasize $pingstring $hires $source_verify $syn_forking); 10use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK ); 11use Socket 2.007; 12use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP 13 SOL_SOCKET SO_ERROR SO_BROADCAST 14 IPPROTO_IP IP_TOS IP_TTL 15 inet_ntoa inet_aton getnameinfo sockaddr_in ); 16use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN 17 WNOHANG ); 18use FileHandle; 19use Carp; 20use Time::HiRes; 21 22@ISA = qw(Exporter); 23@EXPORT = qw(pingecho); 24@EXPORT_OK = qw(wakeonlan); 25$VERSION = "2.74"; 26 27# Globals 28 29$def_timeout = 5; # Default timeout to wait for a reply 30$def_proto = "tcp"; # Default protocol to use for pinging 31$def_factor = 1.2; # Default exponential backoff rate. 32$def_family = AF_INET; # Default family. 33$max_datasize = 65535; # Maximum data bytes. recommended: 1472 (Ethernet MTU: 1500) 34# The data we exchange with the server for the stream protocol 35$pingstring = "pingschwingping!\n"; 36$source_verify = 1; # Default is to verify source endpoint 37$syn_forking = 0; 38 39# Constants 40 41my $AF_INET6 = eval { Socket::AF_INET6() } || 30; 42my $AF_UNSPEC = eval { Socket::AF_UNSPEC() }; 43my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() } || 4; 44my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() } || 2; 45my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() } || 41; 46my $NIx_NOSERV = eval { Socket::NIx_NOSERV() } || 2; 47#my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255 48my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/; 49my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/; 50my $Socket_VERSION = eval $Socket::VERSION; 51 52if ($^O =~ /Win32/i) { 53 # Hack to avoid this Win32 spewage: 54 # Your vendor has not defined POSIX macro ECONNREFUSED 55 my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response? 56 ENOTCONN => 10057, 57 ECONNRESET => 10054, 58 EINPROGRESS => 10036, 59 EWOULDBLOCK => 10035, 60 ); 61 while (my $name = shift @pairs) { 62 my $value = shift @pairs; 63 # When defined, these all are non-zero 64 unless (eval $name) { 65 no strict 'refs'; 66 *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value}; 67 } 68 } 69# $syn_forking = 1; # XXX possibly useful in < Win2K ? 70}; 71 72# Description: The pingecho() subroutine is provided for backward 73# compatibility with the original Net::Ping. It accepts a host 74# name/IP and an optional timeout in seconds. Create a tcp ping 75# object and try pinging the host. The result of the ping is returned. 76 77sub pingecho 78{ 79 my ($host, # Name or IP number of host to ping 80 $timeout # Optional timeout in seconds 81 ) = @_; 82 my ($p); # A ping object 83 84 $p = Net::Ping->new("tcp", $timeout); 85 $p->ping($host); # Going out of scope closes the connection 86} 87 88# Description: The new() method creates a new ping object. Optional 89# parameters may be specified for the protocol to use, the timeout in 90# seconds and the size in bytes of additional data which should be 91# included in the packet. 92# After the optional parameters are checked, the data is constructed 93# and a socket is opened if appropriate. The object is returned. 94 95sub new 96{ 97 my ($this, 98 $proto, # Optional protocol to use for pinging 99 $timeout, # Optional timeout in seconds 100 $data_size, # Optional additional bytes of data 101 $device, # Optional device to use 102 $tos, # Optional ToS to set 103 $ttl, # Optional TTL to set 104 $family, # Optional address family (AF_INET) 105 ) = @_; 106 my $class = ref($this) || $this; 107 my $self = {}; 108 my ($cnt, # Count through data bytes 109 $min_datasize # Minimum data bytes required 110 ); 111 112 bless($self, $class); 113 if (ref $proto eq 'HASH') { # support named args 114 for my $k (qw(proto timeout data_size device tos ttl family 115 gateway host port bind retrans pingstring source_verify 116 econnrefused dontfrag 117 IPV6_USE_MIN_MTU IPV6_RECVPATHMTU IPV6_HOPLIMIT)) 118 { 119 if (exists $proto->{$k}) { 120 $self->{$k} = $proto->{$k}; 121 # some are still globals 122 if ($k eq 'pingstring') { $pingstring = $proto->{$k} } 123 if ($k eq 'source_verify') { $source_verify = $proto->{$k} } 124 # and some are local 125 $timeout = $proto->{$k} if ($k eq 'timeout'); 126 $data_size = $proto->{$k} if ($k eq 'data_size'); 127 $device = $proto->{$k} if ($k eq 'device'); 128 $tos = $proto->{$k} if ($k eq 'tos'); 129 $ttl = $proto->{$k} if ($k eq 'ttl'); 130 $family = $proto->{$k} if ($k eq 'family'); 131 delete $proto->{$k}; 132 } 133 } 134 if (%$proto) { 135 croak("Invalid named argument: ",join(" ",keys (%$proto))); 136 } 137 $proto = $self->{'proto'}; 138 } 139 140 $proto = $def_proto unless $proto; # Determine the protocol 141 croak('Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"') 142 unless $proto =~ m/^(icmp|icmpv6|udp|tcp|syn|stream|external)$/; 143 $self->{proto} = $proto; 144 145 $timeout = $def_timeout unless defined $timeout; # Determine the timeout 146 croak("Default timeout for ping must be greater than 0 seconds") 147 if $timeout <= 0; 148 $self->{timeout} = $timeout; 149 150 $self->{device} = $device; 151 152 $self->{tos} = $tos; 153 154 if ($self->{'host'}) { 155 my $host = $self->{'host'}; 156 my $ip = $self->_resolv($host) or 157 carp("could not resolve host $host"); 158 $self->{host} = $ip; 159 $self->{family} = $ip->{family}; 160 } 161 162 if ($self->{bind}) { 163 my $addr = $self->{bind}; 164 my $ip = $self->_resolv($addr) 165 or carp("could not resolve local addr $addr"); 166 $self->{local_addr} = $ip; 167 } else { 168 $self->{local_addr} = undef; # Don't bind by default 169 } 170 171 if ($self->{proto} eq 'icmp') { 172 croak('TTL must be from 0 to 255') 173 if ($ttl && ($ttl < 0 || $ttl > 255)); 174 $self->{ttl} = $ttl; 175 } 176 177 if ($family) { 178 if ($family =~ $qr_family) { 179 if ($family =~ $qr_family4) { 180 $self->{family} = AF_INET; 181 } else { 182 $self->{family} = $AF_INET6; 183 } 184 } else { 185 croak('Family must be "ipv4" or "ipv6"') 186 } 187 } else { 188 if ($self->{proto} eq 'icmpv6') { 189 $self->{family} = $AF_INET6; 190 } else { 191 $self->{family} = $def_family; 192 } 193 } 194 195 $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size 196 $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp"; 197 # allow for fragmented packets if data_size>1472 (MTU 1500) 198 croak("Data for ping must be from $min_datasize to $max_datasize bytes") 199 if ($data_size < $min_datasize) || ($data_size > $max_datasize); 200 $data_size-- if $self->{proto} eq "udp"; # We provide the first byte 201 $self->{data_size} = $data_size; 202 203 $self->{data} = ""; # Construct data bytes 204 for ($cnt = 0; $cnt < $self->{data_size}; $cnt++) 205 { 206 $self->{data} .= chr($cnt % 256); 207 } 208 209 # Default exponential backoff rate 210 $self->{retrans} = $def_factor unless exists $self->{retrans}; 211 # Default Connection refused behavior 212 $self->{econnrefused} = undef unless exists $self->{econnrefused}; 213 214 $self->{seq} = 0; # For counting packets 215 if ($self->{proto} eq "udp") # Open a socket 216 { 217 $self->{proto_num} = eval { (getprotobyname('udp'))[2] } || 218 croak("Can't udp protocol by name"); 219 $self->{port_num} = $self->{port} 220 || (getservbyname('echo', 'udp'))[2] 221 || croak("Can't get udp echo port by name"); 222 $self->{fh} = FileHandle->new(); 223 socket($self->{fh}, PF_INET, SOCK_DGRAM, 224 $self->{proto_num}) || 225 croak("udp socket error - $!"); 226 $self->_setopts(); 227 } 228 elsif ($self->{proto} eq "icmp") 229 { 230 croak("icmp ping requires root privilege") if !_isroot(); 231 $self->{proto_num} = eval { (getprotobyname('icmp'))[2] } || 232 croak("Can't get icmp protocol by name"); 233 $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid 234 $self->{fh} = FileHandle->new(); 235 socket($self->{fh}, PF_INET, SOCK_RAW, $self->{proto_num}) || 236 croak("icmp socket error - $!"); 237 $self->_setopts(); 238 if ($self->{'ttl'}) { 239 setsockopt($self->{fh}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'})) 240 or croak "error configuring ttl to $self->{'ttl'} $!"; 241 } 242 } 243 elsif ($self->{proto} eq "icmpv6") 244 { 245 #croak("icmpv6 ping requires root privilege") if !_isroot(); 246 croak("Wrong family $self->{family} for icmpv6 protocol") 247 if $self->{family} and $self->{family} != $AF_INET6; 248 $self->{family} = $AF_INET6; 249 $self->{proto_num} = eval { (getprotobyname('ipv6-icmp'))[2] } || 250 croak("Can't get ipv6-icmp protocol by name"); # 58 251 $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid 252 $self->{fh} = FileHandle->new(); 253 socket($self->{fh}, $AF_INET6, SOCK_RAW, $self->{proto_num}) || 254 croak("icmp socket error - $!"); 255 $self->_setopts(); 256 if ($self->{'gateway'}) { 257 my $g = $self->{gateway}; 258 my $ip = $self->_resolv($g) 259 or croak("nonexistent gateway $g"); 260 $self->{family} eq $AF_INET6 261 or croak("gateway requires the AF_INET6 family"); 262 $ip->{family} eq $AF_INET6 263 or croak("gateway address needs to be IPv6"); 264 my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21 265 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip)) 266 or croak "error configuring gateway to $g NEXTHOP $!"; 267 } 268 if (exists $self->{IPV6_USE_MIN_MTU}) { 269 my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 42; 270 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU, 271 pack("I*", $self->{'IPV6_USE_MIN_MT'})) 272 or croak "error configuring IPV6_USE_MIN_MT} $!"; 273 } 274 if (exists $self->{IPV6_RECVPATHMTU}) { 275 my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43; 276 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU, 277 pack("I*", $self->{'RECVPATHMTU'})) 278 or croak "error configuring IPV6_RECVPATHMTU $!"; 279 } 280 if ($self->{'tos'}) { 281 my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6; 282 setsockopt($self->{fh}, $proto, IP_TOS, pack("I*", $self->{'tos'})) 283 or croak "error configuring tos to $self->{'tos'} $!"; 284 } 285 if ($self->{'ttl'}) { 286 my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6; 287 setsockopt($self->{fh}, $proto, IP_TTL, pack("I*", $self->{'ttl'})) 288 or croak "error configuring ttl to $self->{'ttl'} $!"; 289 } 290 } 291 elsif ($self->{proto} eq "tcp" || $self->{proto} eq "stream") 292 { 293 $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } || 294 croak("Can't get tcp protocol by name"); 295 $self->{port_num} = $self->{port} 296 || (getservbyname('echo', 'tcp'))[2] 297 || croak("Can't get tcp echo port by name"); 298 $self->{fh} = FileHandle->new(); 299 } 300 elsif ($self->{proto} eq "syn") 301 { 302 $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } || 303 croak("Can't get tcp protocol by name"); 304 $self->{port_num} = (getservbyname('echo', 'tcp'))[2] || 305 croak("Can't get tcp echo port by name"); 306 if ($syn_forking) { 307 $self->{fork_rd} = FileHandle->new(); 308 $self->{fork_wr} = FileHandle->new(); 309 pipe($self->{fork_rd}, $self->{fork_wr}); 310 $self->{fh} = FileHandle->new(); 311 $self->{good} = {}; 312 $self->{bad} = {}; 313 } else { 314 $self->{wbits} = ""; 315 $self->{bad} = {}; 316 } 317 $self->{syn} = {}; 318 $self->{stop_time} = 0; 319 } 320 321 return($self); 322} 323 324# Description: Set the local IP address from which pings will be sent. 325# For ICMP, UDP and TCP pings, just saves the address to be used when 326# the socket is opened. Returns non-zero if successful; croaks on error. 327sub bind 328{ 329 my ($self, 330 $local_addr # Name or IP number of local interface 331 ) = @_; 332 my ($ip, # Hash of addr (string), addr_in (packed), family 333 $h # resolved hash 334 ); 335 336 croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2; 337 croak("already bound") if defined($self->{local_addr}) && 338 ($self->{proto} eq "udp" || $self->{proto} eq "icmp"); 339 340 $ip = $self->_resolv($local_addr); 341 carp("nonexistent local address $local_addr") unless defined($ip); 342 $self->{local_addr} = $ip; 343 344 if (($self->{proto} ne "udp") && 345 ($self->{proto} ne "icmp") && 346 ($self->{proto} ne "tcp") && 347 ($self->{proto} ne "syn")) 348 { 349 croak("Unknown protocol \"$self->{proto}\" in bind()"); 350 } 351 352 return 1; 353} 354 355# Description: A select() wrapper that compensates for platform 356# peculiarities. 357sub mselect 358{ 359 if ($_[3] > 0 and $^O eq 'MSWin32') { 360 # On windows, select() doesn't process the message loop, 361 # but sleep() will, allowing alarm() to interrupt the latter. 362 # So we chop up the timeout into smaller pieces and interleave 363 # select() and sleep() calls. 364 my $t = $_[3]; 365 my $gran = 0.5; # polling granularity in seconds 366 my @args = @_; 367 while (1) { 368 $gran = $t if $gran > $t; 369 my $nfound = select($_[0], $_[1], $_[2], $gran); 370 undef $nfound if $nfound == -1; 371 $t -= $gran; 372 return $nfound if $nfound or !defined($nfound) or $t <= 0; 373 374 sleep(0); 375 ($_[0], $_[1], $_[2]) = @args; 376 } 377 } 378 else { 379 my $nfound = select($_[0], $_[1], $_[2], $_[3]); 380 undef $nfound if $nfound == -1; 381 return $nfound; 382 } 383} 384 385# Description: Allow UDP source endpoint comparison to be 386# skipped for those remote interfaces that do 387# not response from the same endpoint. 388 389sub source_verify 390{ 391 my $self = shift; 392 $source_verify = 1 unless defined 393 ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self); 394} 395 396# Description: Set whether or not the connect 397# behavior should enforce remote service 398# availability as well as reachability. 399 400sub service_check 401{ 402 my $self = shift; 403 $self->{econnrefused} = 1 unless defined 404 ($self->{econnrefused} = shift()); 405} 406 407sub tcp_service_check 408{ 409 service_check(@_); 410} 411 412# Description: Set exponential backoff for retransmission. 413# Should be > 1 to retain exponential properties. 414# If set to 0, retransmissions are disabled. 415 416sub retrans 417{ 418 my $self = shift; 419 $self->{retrans} = shift; 420} 421 422sub _IsAdminUser { 423 return unless $^O eq 'MSWin32' or $^O eq "cygwin"; 424 return unless eval { require Win32 }; 425 return unless defined &Win32::IsAdminUser; 426 return Win32::IsAdminUser(); 427} 428 429sub _isroot { 430 if (($> and $^O ne 'VMS' and $^O ne 'cygwin') 431 or (($^O eq 'MSWin32' or $^O eq 'cygwin') 432 and !_IsAdminUser()) 433 or ($^O eq 'VMS' 434 and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) { 435 return 0; 436 } 437 else { 438 return 1; 439 } 440} 441 442# Description: Sets ipv6 reachability 443# REACHCONF was removed in RFC3542, ping6 -R supports it. requires root. 444 445sub IPV6_REACHCONF 446{ 447 my $self = shift; 448 my $on = shift; 449 if ($on) { 450 my $reachconf = eval { Socket::IPV6_REACHCONF() }; 451 if (!$reachconf) { 452 carp "IPV6_REACHCONF not supported on this platform"; 453 return 0; 454 } 455 if (!_isroot()) { 456 carp "IPV6_REACHCONF requires root permissions"; 457 return 0; 458 } 459 $self->{IPV6_REACHCONF} = 1; 460 } 461 else { 462 return $self->{IPV6_REACHCONF}; 463 } 464} 465 466# Description: set it on or off. 467 468sub IPV6_USE_MIN_MTU 469{ 470 my $self = shift; 471 my $on = shift; 472 if (defined $on) { 473 my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 43; 474 #if (!$IPV6_USE_MIN_MTU) { 475 # carp "IPV6_USE_MIN_MTU not supported on this platform"; 476 # return 0; 477 #} 478 $self->{IPV6_USE_MIN_MTU} = $on ? 1 : 0; 479 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU, 480 pack("I*", $self->{'IPV6_USE_MIN_MT'})) 481 or croak "error configuring IPV6_USE_MIN_MT} $!"; 482 } 483 else { 484 return $self->{IPV6_USE_MIN_MTU}; 485 } 486} 487 488# Description: notify an according MTU 489 490sub IPV6_RECVPATHMTU 491{ 492 my $self = shift; 493 my $on = shift; 494 if ($on) { 495 my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43; 496 #if (!$RECVPATHMTU) { 497 # carp "IPV6_RECVPATHMTU not supported on this platform"; 498 # return 0; 499 #} 500 $self->{IPV6_RECVPATHMTU} = 1; 501 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU, 502 pack("I*", $self->{'IPV6_RECVPATHMTU'})) 503 or croak "error configuring IPV6_RECVPATHMTU} $!"; 504 } 505 else { 506 return $self->{IPV6_RECVPATHMTU}; 507 } 508} 509 510# Description: allows the module to use milliseconds as returned by 511# the Time::HiRes module 512 513$hires = 1; 514sub hires 515{ 516 my $self = shift; 517 $hires = 1 unless defined 518 ($hires = ((defined $self) && (ref $self)) ? shift() : $self); 519} 520 521sub time 522{ 523 return $hires ? Time::HiRes::time() : CORE::time(); 524} 525 526# Description: Sets or clears the O_NONBLOCK flag on a file handle. 527sub socket_blocking_mode 528{ 529 my ($self, 530 $fh, # the file handle whose flags are to be modified 531 $block) = @_; # if true then set the blocking 532 # mode (clear O_NONBLOCK), otherwise 533 # set the non-blocking mode (set O_NONBLOCK) 534 535 my $flags; 536 if ($^O eq 'MSWin32' || $^O eq 'VMS') { 537 # FIONBIO enables non-blocking sockets on windows and vms. 538 # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h 539 my $f = 0x8004667e; 540 my $v = pack("L", $block ? 0 : 1); 541 ioctl($fh, $f, $v) or croak("ioctl failed: $!"); 542 return; 543 } 544 if ($flags = fcntl($fh, F_GETFL, 0)) { 545 $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK); 546 if (!fcntl($fh, F_SETFL, $flags)) { 547 croak("fcntl F_SETFL: $!"); 548 } 549 } else { 550 croak("fcntl F_GETFL: $!"); 551 } 552} 553 554# Description: Ping a host name or IP number with an optional timeout. 555# First lookup the host, and return undef if it is not found. Otherwise 556# perform the specific ping method based on the protocol. Return the 557# result of the ping. 558 559sub ping 560{ 561 my ($self, 562 $host, # Name or IP number of host to ping 563 $timeout, # Seconds after which ping times out 564 $family, # Address family 565 ) = @_; 566 my ($ip, # Hash of addr (string), addr_in (packed), family 567 $ret, # The return value 568 $ping_time, # When ping began 569 ); 570 571 $host = $self->{host} if !defined $host and $self->{host}; 572 croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host; 573 $timeout = $self->{timeout} unless $timeout; 574 croak("Timeout must be greater than 0 seconds") if $timeout <= 0; 575 576 if ($family) { 577 if ($family =~ $qr_family) { 578 if ($family =~ $qr_family4) { 579 $self->{family_local} = AF_INET; 580 } else { 581 $self->{family_local} = $AF_INET6; 582 } 583 } else { 584 croak('Family must be "ipv4" or "ipv6"') 585 } 586 } else { 587 $self->{family_local} = $self->{family}; 588 } 589 590 $ip = $self->_resolv($host); 591 return () unless defined($ip); # Does host exist? 592 593 # Dispatch to the appropriate routine. 594 $ping_time = &time(); 595 if ($self->{proto} eq "external") { 596 $ret = $self->ping_external($ip, $timeout); 597 } 598 elsif ($self->{proto} eq "udp") { 599 $ret = $self->ping_udp($ip, $timeout); 600 } 601 elsif ($self->{proto} eq "icmp") { 602 $ret = $self->ping_icmp($ip, $timeout); 603 } 604 elsif ($self->{proto} eq "icmpv6") { 605 $ret = $self->ping_icmpv6($ip, $timeout); 606 } 607 elsif ($self->{proto} eq "tcp") { 608 $ret = $self->ping_tcp($ip, $timeout); 609 } 610 elsif ($self->{proto} eq "stream") { 611 $ret = $self->ping_stream($ip, $timeout); 612 } 613 elsif ($self->{proto} eq "syn") { 614 $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout); 615 } else { 616 croak("Unknown protocol \"$self->{proto}\" in ping()"); 617 } 618 619 return wantarray ? ($ret, &time() - $ping_time, $self->ntop($ip)) : $ret; 620} 621 622# Uses Net::Ping::External to do an external ping. 623sub ping_external { 624 my ($self, 625 $ip, # Hash of addr (string), addr_in (packed), family 626 $timeout, # Seconds after which ping times out 627 $family 628 ) = @_; 629 630 $ip = $self->{host} if !defined $ip and $self->{host}; 631 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; 632 my @addr = exists $ip->{addr_in} 633 ? ('ip' => $ip->{addr_in}) 634 : ('host' => $ip->{host}); 635 636 eval { 637 local @INC = @INC; 638 pop @INC if $INC[-1] eq '.'; 639 require Net::Ping::External; 640 } or croak('Protocol "external" not supported on your system: Net::Ping::External not found'); 641 return Net::Ping::External::ping(@addr, timeout => $timeout, 642 family => $family); 643} 644 645# h2ph "asm/socket.h" 646# require "asm/socket.ph"; 647use constant SO_BINDTODEVICE => 25; 648use constant ICMP_ECHOREPLY => 0; # ICMP packet types 649use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types 650use constant ICMP_UNREACHABLE => 3; # ICMP packet types 651use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types 652use constant ICMPv6_NI_REPLY => 140; # ICMP packet types 653use constant ICMP_ECHO => 8; 654use constant ICMPv6_ECHO => 128; 655use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types 656use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types 657use constant ICMP_TIMESTAMP => 13; 658use constant ICMP_TIMESTAMP_REPLY => 14; 659use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet 660use constant ICMP_TIMESTAMP_STRUCT => "C2 n3 N3"; # Structure of a minimal timestamp ICMP packet 661use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY 662use constant ICMP_FLAGS => 0; # No special flags for send or recv 663use constant ICMP_PORT => 0; # No port with ICMP 664use constant IP_MTU_DISCOVER => 10; # linux only 665 666sub message_type 667{ 668 my ($self, 669 $type 670 ) = @_; 671 672 croak "Setting message type only supported on 'icmp' protocol" 673 unless $self->{proto} eq 'icmp'; 674 675 return $self->{message_type} || 'echo' 676 unless defined($type); 677 678 croak "Supported icmp message type are limited to 'echo' and 'timestamp': '$type' not supported" 679 unless $type =~ /^echo|timestamp$/i; 680 681 $self->{message_type} = lc($type); 682} 683 684sub ping_icmp 685{ 686 my ($self, 687 $ip, # Hash of addr (string), addr_in (packed), family 688 $timeout # Seconds after which ping times out 689 ) = @_; 690 691 my ($saddr, # sockaddr_in with port and ip 692 $checksum, # Checksum of ICMP packet 693 $msg, # ICMP packet to send 694 $len_msg, # Length of $msg 695 $rbits, # Read bits, filehandles for reading 696 $nfound, # Number of ready filehandles found 697 $finish_time, # Time ping should be finished 698 $done, # set to 1 when we are done 699 $ret, # Return value 700 $recv_msg, # Received message including IP header 701 $recv_msg_len, # Length of recevied message, less any additional data 702 $from_saddr, # sockaddr_in of sender 703 $from_port, # Port packet was sent from 704 $from_ip, # Packed IP of sender 705 $timestamp_msg, # ICMP timestamp message type 706 $from_type, # ICMP type 707 $from_subcode, # ICMP subcode 708 $from_chk, # ICMP packet checksum 709 $from_pid, # ICMP packet id 710 $from_seq, # ICMP packet sequence 711 $from_msg # ICMP message 712 ); 713 714 $ip = $self->{host} if !defined $ip and $self->{host}; 715 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; 716 $timestamp_msg = $self->{message_type} && $self->{message_type} eq 'timestamp' ? 1 : 0; 717 718 socket($self->{fh}, $ip->{family}, SOCK_RAW, $self->{proto_num}) || 719 croak("icmp socket error - $!"); 720 721 if (defined $self->{local_addr} && 722 !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { 723 croak("icmp bind error - $!"); 724 } 725 $self->_setopts(); 726 727 $self->{seq} = ($self->{seq} + 1) % 65536; # Increment sequence 728 $checksum = 0; # No checksum for starters 729 if ($ip->{family} == AF_INET) { 730 if ($timestamp_msg) { 731 $msg = pack(ICMP_TIMESTAMP_STRUCT, ICMP_TIMESTAMP, SUBCODE, 732 $checksum, $self->{pid}, $self->{seq}, 0, 0, 0); 733 } else { 734 $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE, 735 $checksum, $self->{pid}, $self->{seq}, $self->{data}); 736 } 737 } else { 738 # how to get SRC 739 my $pseudo_header = pack('a16a16Nnn', $ip->{addr_in}, $ip->{addr_in}, 8+length($self->{data}), 0, 0x003a); 740 $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE, 741 $checksum, $self->{pid}, $self->{seq}, $self->{data}); 742 $msg = $pseudo_header.$msg 743 } 744 $checksum = Net::Ping->checksum($msg); 745 if ($ip->{family} == AF_INET) { 746 if ($timestamp_msg) { 747 $msg = pack(ICMP_TIMESTAMP_STRUCT, ICMP_TIMESTAMP, SUBCODE, 748 $checksum, $self->{pid}, $self->{seq}, 0, 0, 0); 749 } else { 750 $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE, 751 $checksum, $self->{pid}, $self->{seq}, $self->{data}); 752 } 753 } else { 754 $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE, 755 $checksum, $self->{pid}, $self->{seq}, $self->{data}); 756 } 757 $len_msg = length($msg); 758 $saddr = _pack_sockaddr_in(ICMP_PORT, $ip); 759 $self->{from_ip} = undef; 760 $self->{from_type} = undef; 761 $self->{from_subcode} = undef; 762 send($self->{fh}, $msg, ICMP_FLAGS, $saddr); # Send the message 763 764 $rbits = ""; 765 vec($rbits, $self->{fh}->fileno(), 1) = 1; 766 $ret = 0; 767 $done = 0; 768 $finish_time = &time() + $timeout; # Must be done by this time 769 while (!$done && $timeout > 0) # Keep trying if we have time 770 { 771 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet 772 $timeout = $finish_time - &time(); # Get remaining time 773 if (!defined($nfound)) # Hmm, a strange error 774 { 775 $ret = undef; 776 $done = 1; 777 } 778 elsif ($nfound) # Got a packet from somewhere 779 { 780 $recv_msg = ""; 781 $from_pid = -1; 782 $from_seq = -1; 783 $from_saddr = recv($self->{fh}, $recv_msg, 1500, ICMP_FLAGS); 784 $recv_msg_len = length($recv_msg) - length($self->{data}); 785 ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); 786 # ICMP echo includes the header and ICMPv6 doesn't. 787 # IPv4 length($recv_msg) is 28 (20 header + 8 payload) 788 # while IPv6 length is only 8 (sans header). 789 my $off = ($ip->{family} == AF_INET) ? 20 : 0; # payload offset 790 ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, $off, 2)); 791 if ($from_type == ICMP_TIMESTAMP_REPLY) { 792 ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, $off + 4, 4)) 793 if length $recv_msg >= $off + 8; 794 } elsif ($from_type == ICMP_ECHOREPLY || $from_type == ICMPv6_ECHOREPLY) { 795 #warn "ICMP_ECHOREPLY: ", $ip->{family}, " ",$recv_msg, ":", length($recv_msg); 796 ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, $off + 4, 4)) 797 if $recv_msg_len == $off + 8; 798 } elsif ($from_type == ICMPv6_NI_REPLY) { 799 ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4)) 800 if ($ip->{family} == $AF_INET6 && length $recv_msg == 8); 801 } else { 802 #warn "ICMP: ", $from_type, " ",$ip->{family}, " ",$recv_msg, ":", length($recv_msg); 803 ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, $off + 32, 4)) 804 if length $recv_msg >= $off + 36; 805 } 806 $self->{from_ip} = $from_ip; 807 $self->{from_type} = $from_type; 808 $self->{from_subcode} = $from_subcode; 809 next if ($from_pid != $self->{pid}); 810 next if ($from_seq != $self->{seq}); 811 if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out? 812 if (!$timestamp_msg && (($from_type == ICMP_ECHOREPLY) || ($from_type == ICMPv6_ECHOREPLY))) { 813 $ret = 1; 814 $done = 1; 815 } elsif ($timestamp_msg && $from_type == ICMP_TIMESTAMP_REPLY) { 816 $ret = 1; 817 $done = 1; 818 } elsif (($from_type == ICMP_UNREACHABLE) || ($from_type == ICMPv6_UNREACHABLE)) { 819 $done = 1; 820 } elsif ($from_type == ICMP_TIME_EXCEEDED) { 821 $ret = 0; 822 $done = 1; 823 } 824 } 825 } else { # Oops, timed out 826 $done = 1; 827 } 828 } 829 return $ret; 830} 831 832sub ping_icmpv6 833{ 834 shift->ping_icmp(@_); 835} 836 837sub icmp_result { 838 my ($self) = @_; 839 my $addr = $self->{from_ip} || ""; 840 $addr = "\0\0\0\0" unless 4 == length $addr; 841 return ($self->ntop($addr),($self->{from_type} || 0), ($self->{from_subcode} || 0)); 842} 843 844# Description: Do a checksum on the message. Basically sum all of 845# the short words and fold the high order bits into the low order bits. 846 847sub checksum 848{ 849 my ($class, 850 $msg # The message to checksum 851 ) = @_; 852 my ($len_msg, # Length of the message 853 $num_short, # The number of short words in the message 854 $short, # One short word 855 $chk # The checksum 856 ); 857 858 $len_msg = length($msg); 859 $num_short = int($len_msg / 2); 860 $chk = 0; 861 foreach $short (unpack("n$num_short", $msg)) 862 { 863 $chk += $short; 864 } # Add the odd byte in 865 $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2; 866 $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low 867 return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement 868} 869 870 871# Description: Perform a tcp echo ping. Since a tcp connection is 872# host specific, we have to open and close each connection here. We 873# can't just leave a socket open. Because of the robust nature of 874# tcp, it will take a while before it gives up trying to establish a 875# connection. Therefore, we use select() on a non-blocking socket to 876# check against our timeout. No data bytes are actually 877# sent since the successful establishment of a connection is proof 878# enough of the reachability of the remote host. Also, tcp is 879# expensive and doesn't need our help to add to the overhead. 880 881sub ping_tcp 882{ 883 my ($self, 884 $ip, # Hash of addr (string), addr_in (packed), family 885 $timeout # Seconds after which ping times out 886 ) = @_; 887 my ($ret # The return value 888 ); 889 890 $ip = $self->{host} if !defined $ip and $self->{host}; 891 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; 892 893 $! = 0; 894 $ret = $self -> tcp_connect( $ip, $timeout); 895 if (!$self->{econnrefused} && 896 $! == ECONNREFUSED) { 897 $ret = 1; # "Connection refused" means reachable 898 } 899 $self->{fh}->close(); 900 return $ret; 901} 902 903sub tcp_connect 904{ 905 my ($self, 906 $ip, # Hash of addr (string), addr_in (packed), family 907 $timeout # Seconds after which connect times out 908 ) = @_; 909 my ($saddr); # Packed IP and Port 910 911 $ip = $self->{host} if !defined $ip and $self->{host}; 912 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; 913 914 $saddr = _pack_sockaddr_in($self->{port_num}, $ip); 915 916 my $ret = 0; # Default to unreachable 917 918 my $do_socket = sub { 919 socket($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num}) || 920 croak("tcp socket error - $!"); 921 if (defined $self->{local_addr} && 922 !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { 923 croak("tcp bind error - $!"); 924 } 925 $self->_setopts(); 926 }; 927 my $do_connect = sub { 928 $self->{ip} = $ip->{addr_in}; 929 # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?, 930 # we'll get (10061 & 255) = 77, so we cannot check it in the parent process. 931 return ($ret = connect($self->{fh}, $saddr) || ($! == ECONNREFUSED && !$self->{econnrefused})); 932 }; 933 my $do_connect_nb = sub { 934 # Set O_NONBLOCK property on filehandle 935 $self->socket_blocking_mode($self->{fh}, 0); 936 937 # start the connection attempt 938 if (!connect($self->{fh}, $saddr)) { 939 if ($! == ECONNREFUSED) { 940 $ret = 1 unless $self->{econnrefused}; 941 } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) { 942 # EINPROGRESS is the expected error code after a connect() 943 # on a non-blocking socket. But if the kernel immediately 944 # determined that this connect() will never work, 945 # Simply respond with "unreachable" status. 946 # (This can occur on some platforms with errno 947 # EHOSTUNREACH or ENETUNREACH.) 948 return 0; 949 } else { 950 # Got the expected EINPROGRESS. 951 # Just wait for connection completion... 952 my ($wbits, $wout, $wexc); 953 $wout = $wexc = $wbits = ""; 954 vec($wbits, $self->{fh}->fileno, 1) = 1; 955 956 my $nfound = mselect(undef, 957 ($wout = $wbits), 958 ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef), 959 $timeout); 960 warn("select: $!") unless defined $nfound; 961 962 if ($nfound && vec($wout, $self->{fh}->fileno, 1)) { 963 # the socket is ready for writing so the connection 964 # attempt completed. test whether the connection 965 # attempt was successful or not 966 967 if (getpeername($self->{fh})) { 968 # Connection established to remote host 969 $ret = 1; 970 } else { 971 # TCP ACK will never come from this host 972 # because there was an error connecting. 973 974 # This should set $! to the correct error. 975 my $char; 976 sysread($self->{fh},$char,1); 977 $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i); 978 979 $ret = 1 if (!$self->{econnrefused} 980 && $! == ECONNREFUSED); 981 } 982 } else { 983 # the connection attempt timed out (or there were connect 984 # errors on Windows) 985 if ($^O =~ 'MSWin32') { 986 # If the connect will fail on a non-blocking socket, 987 # winsock reports ECONNREFUSED as an exception, and we 988 # need to fetch the socket-level error code via getsockopt() 989 # instead of using the thread-level error code that is in $!. 990 if ($nfound && vec($wexc, $self->{fh}->fileno, 1)) { 991 $! = unpack("i", getsockopt($self->{fh}, SOL_SOCKET, 992 SO_ERROR)); 993 } 994 } 995 } 996 } 997 } else { 998 # Connection established to remote host 999 $ret = 1; 1000 } 1001 1002 # Unset O_NONBLOCK property on filehandle 1003 $self->socket_blocking_mode($self->{fh}, 1); 1004 $self->{ip} = $ip->{addr_in}; 1005 return $ret; 1006 }; 1007 1008 if ($syn_forking) { 1009 # Buggy Winsock API doesn't allow nonblocking connect. 1010 # Hence, if our OS is Windows, we need to create a separate 1011 # process to do the blocking connect attempt. 1012 # XXX Above comments are not true at least for Win2K, where 1013 # nonblocking connect works. 1014 1015 $| = 1; # Clear buffer prior to fork to prevent duplicate flushing. 1016 $self->{'tcp_chld'} = fork; 1017 if (!$self->{'tcp_chld'}) { 1018 if (!defined $self->{'tcp_chld'}) { 1019 # Fork did not work 1020 warn "Fork error: $!"; 1021 return 0; 1022 } 1023 &{ $do_socket }(); 1024 1025 # Try a slow blocking connect() call 1026 # and report the status to the parent. 1027 if ( &{ $do_connect }() ) { 1028 $self->{fh}->close(); 1029 # No error 1030 exit 0; 1031 } else { 1032 # Pass the error status to the parent 1033 # Make sure that $! <= 255 1034 exit($! <= 255 ? $! : 255); 1035 } 1036 } 1037 1038 &{ $do_socket }(); 1039 1040 my $patience = &time() + $timeout; 1041 1042 my ($child, $child_errno); 1043 $? = 0; $child_errno = 0; 1044 # Wait up to the timeout 1045 # And clean off the zombie 1046 do { 1047 $child = waitpid($self->{'tcp_chld'}, &WNOHANG()); 1048 $child_errno = $? >> 8; 1049 select(undef, undef, undef, 0.1); 1050 } while &time() < $patience && $child != $self->{'tcp_chld'}; 1051 1052 if ($child == $self->{'tcp_chld'}) { 1053 if ($self->{proto} eq "stream") { 1054 # We need the socket connected here, in parent 1055 # Should be safe to connect because the child finished 1056 # within the timeout 1057 &{ $do_connect }(); 1058 } 1059 # $ret cannot be set by the child process 1060 $ret = !$child_errno; 1061 } else { 1062 # Time must have run out. 1063 # Put that choking client out of its misery 1064 kill "KILL", $self->{'tcp_chld'}; 1065 # Clean off the zombie 1066 waitpid($self->{'tcp_chld'}, 0); 1067 $ret = 0; 1068 } 1069 delete $self->{'tcp_chld'}; 1070 $! = $child_errno; 1071 } else { 1072 # Otherwise don't waste the resources to fork 1073 1074 &{ $do_socket }(); 1075 1076 &{ $do_connect_nb }(); 1077 } 1078 1079 return $ret; 1080} 1081 1082sub DESTROY { 1083 my $self = shift; 1084 if ($self->{'proto'} eq 'tcp' && 1085 $self->{'tcp_chld'}) { 1086 # Put that choking client out of its misery 1087 kill "KILL", $self->{'tcp_chld'}; 1088 # Clean off the zombie 1089 waitpid($self->{'tcp_chld'}, 0); 1090 } 1091} 1092 1093# This writes the given string to the socket and then reads it 1094# back. It returns 1 on success, 0 on failure. 1095sub tcp_echo 1096{ 1097 my ($self, $timeout, $pingstring) = @_; 1098 1099 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; 1100 $pingstring = $self->{pingstring} if !defined $pingstring and $self->{pingstring}; 1101 1102 my $ret = undef; 1103 my $time = &time(); 1104 my $wrstr = $pingstring; 1105 my $rdstr = ""; 1106 1107 eval <<'EOM'; 1108 do { 1109 my $rin = ""; 1110 vec($rin, $self->{fh}->fileno(), 1) = 1; 1111 1112 my $rout = undef; 1113 if($wrstr) { 1114 $rout = ""; 1115 vec($rout, $self->{fh}->fileno(), 1) = 1; 1116 } 1117 1118 if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) { 1119 1120 if($rout && vec($rout,$self->{fh}->fileno(),1)) { 1121 my $num = syswrite($self->{fh}, $wrstr, length $wrstr); 1122 if($num) { 1123 # If it was a partial write, update and try again. 1124 $wrstr = substr($wrstr,$num); 1125 } else { 1126 # There was an error. 1127 $ret = 0; 1128 } 1129 } 1130 1131 if(vec($rin,$self->{fh}->fileno(),1)) { 1132 my $reply; 1133 if(sysread($self->{fh},$reply,length($pingstring)-length($rdstr))) { 1134 $rdstr .= $reply; 1135 $ret = 1 if $rdstr eq $pingstring; 1136 } else { 1137 # There was an error. 1138 $ret = 0; 1139 } 1140 } 1141 1142 } 1143 } until &time() > ($time + $timeout) || defined($ret); 1144EOM 1145 1146 return $ret; 1147} 1148 1149# Description: Perform a stream ping. If the tcp connection isn't 1150# already open, it opens it. It then sends some data and waits for 1151# a reply. It leaves the stream open on exit. 1152 1153sub ping_stream 1154{ 1155 my ($self, 1156 $ip, # Hash of addr (string), addr_in (packed), family 1157 $timeout # Seconds after which ping times out 1158 ) = @_; 1159 1160 # Open the stream if it's not already open 1161 if(!defined $self->{fh}->fileno()) { 1162 $self->tcp_connect($ip, $timeout) or return 0; 1163 } 1164 1165 croak "tried to switch servers while stream pinging" 1166 if $self->{ip} ne $ip->{addr_in}; 1167 1168 return $self->tcp_echo($timeout, $pingstring); 1169} 1170 1171# Description: opens the stream. You would do this if you want to 1172# separate the overhead of opening the stream from the first ping. 1173 1174sub open 1175{ 1176 my ($self, 1177 $host, # Host or IP address 1178 $timeout, # Seconds after which open times out 1179 $family 1180 ) = @_; 1181 my $ip; # Hash of addr (string), addr_in (packed), family 1182 $host = $self->{host} unless defined $host; 1183 1184 if ($family) { 1185 if ($family =~ $qr_family) { 1186 if ($family =~ $qr_family4) { 1187 $self->{family_local} = AF_INET; 1188 } else { 1189 $self->{family_local} = $AF_INET6; 1190 } 1191 } else { 1192 croak('Family must be "ipv4" or "ipv6"') 1193 } 1194 } else { 1195 $self->{family_local} = $self->{family}; 1196 } 1197 1198 $timeout = $self->{timeout} unless $timeout; 1199 $ip = $self->_resolv($host); 1200 1201 if ($self->{proto} eq "stream") { 1202 if (defined($self->{fh}->fileno())) { 1203 croak("socket is already open"); 1204 } else { 1205 return () unless $ip; 1206 $self->tcp_connect($ip, $timeout); 1207 } 1208 } 1209} 1210 1211sub _dontfrag { 1212 my $self = shift; 1213 # bsd solaris 1214 my $IP_DONTFRAG = eval { Socket::IP_DONTFRAG() }; 1215 if ($IP_DONTFRAG) { 1216 my $i = 1; 1217 setsockopt($self->{fh}, IPPROTO_IP, $IP_DONTFRAG, pack("I*", $i)) 1218 or croak "error configuring IP_DONTFRAG $!"; 1219 # Linux needs more: Path MTU Discovery as defined in RFC 1191 1220 # For non SOCK_STREAM sockets it is the user's responsibility to packetize 1221 # the data in MTU sized chunks and to do the retransmits if necessary. 1222 # The kernel will reject packets that are bigger than the known path 1223 # MTU if this flag is set (with EMSGSIZE). 1224 if ($^O eq 'linux') { 1225 my $i = 2; # IP_PMTUDISC_DO 1226 setsockopt($self->{fh}, IPPROTO_IP, IP_MTU_DISCOVER, pack("I*", $i)) 1227 or croak "error configuring IP_MTU_DISCOVER $!"; 1228 } 1229 } 1230} 1231 1232# SO_BINDTODEVICE + IP_TOS 1233sub _setopts { 1234 my $self = shift; 1235 if ($self->{'device'}) { 1236 setsockopt($self->{fh}, SOL_SOCKET, SO_BINDTODEVICE, pack("Z*", $self->{'device'})) 1237 or croak "error binding to device $self->{'device'} $!"; 1238 } 1239 if ($self->{'tos'}) { # need to re-apply ToS (RT #6706) 1240 setsockopt($self->{fh}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) 1241 or croak "error applying tos to $self->{'tos'} $!"; 1242 } 1243 if ($self->{'dontfrag'}) { 1244 $self->_dontfrag; 1245 } 1246} 1247 1248 1249# Description: Perform a udp echo ping. Construct a message of 1250# at least the one-byte sequence number and any additional data bytes. 1251# Send the message out and wait for a message to come back. If we 1252# get a message, make sure all of its parts match. If they do, we are 1253# done. Otherwise go back and wait for the message until we run out 1254# of time. Return the result of our efforts. 1255 1256use constant UDP_FLAGS => 0; # Nothing special on send or recv 1257sub ping_udp 1258{ 1259 my ($self, 1260 $ip, # Hash of addr (string), addr_in (packed), family 1261 $timeout # Seconds after which ping times out 1262 ) = @_; 1263 1264 my ($saddr, # sockaddr_in with port and ip 1265 $ret, # The return value 1266 $msg, # Message to be echoed 1267 $finish_time, # Time ping should be finished 1268 $flush, # Whether socket needs to be disconnected 1269 $connect, # Whether socket needs to be connected 1270 $done, # Set to 1 when we are done pinging 1271 $rbits, # Read bits, filehandles for reading 1272 $nfound, # Number of ready filehandles found 1273 $from_saddr, # sockaddr_in of sender 1274 $from_msg, # Characters echoed by $host 1275 $from_port, # Port message was echoed from 1276 $from_ip # Packed IP number of sender 1277 ); 1278 1279 $saddr = _pack_sockaddr_in($self->{port_num}, $ip); 1280 $self->{seq} = ($self->{seq} + 1) % 256; # Increment sequence 1281 $msg = chr($self->{seq}) . $self->{data}; # Add data if any 1282 1283 socket($self->{fh}, $ip->{family}, SOCK_DGRAM, 1284 $self->{proto_num}) || 1285 croak("udp socket error - $!"); 1286 1287 if (defined $self->{local_addr} && 1288 !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { 1289 croak("udp bind error - $!"); 1290 } 1291 1292 $self->_setopts(); 1293 1294 if ($self->{connected}) { 1295 if ($self->{connected} ne $saddr) { 1296 # Still connected to wrong destination. 1297 # Need to flush out the old one. 1298 $flush = 1; 1299 } 1300 } else { 1301 # Not connected yet. 1302 # Need to connect() before send() 1303 $connect = 1; 1304 } 1305 1306 # Have to connect() and send() instead of sendto() 1307 # in order to pick up on the ECONNREFUSED setting 1308 # from recv() or double send() errno as utilized in 1309 # the concept by rdw @ perlmonks. See: 1310 # http://perlmonks.thepen.com/42898.html 1311 if ($flush) { 1312 # Need to socket() again to flush the descriptor 1313 # This will disconnect from the old saddr. 1314 socket($self->{fh}, $ip->{family}, SOCK_DGRAM, 1315 $self->{proto_num}); 1316 $self->_setopts(); 1317 } 1318 # Connect the socket if it isn't already connected 1319 # to the right destination. 1320 if ($flush || $connect) { 1321 connect($self->{fh}, $saddr); # Tie destination to socket 1322 $self->{connected} = $saddr; 1323 } 1324 send($self->{fh}, $msg, UDP_FLAGS); # Send it 1325 1326 $rbits = ""; 1327 vec($rbits, $self->{fh}->fileno(), 1) = 1; 1328 $ret = 0; # Default to unreachable 1329 $done = 0; 1330 my $retrans = 0.01; 1331 my $factor = $self->{retrans}; 1332 $finish_time = &time() + $timeout; # Ping needs to be done by then 1333 while (!$done && $timeout > 0) 1334 { 1335 if ($factor > 1) 1336 { 1337 $timeout = $retrans if $timeout > $retrans; 1338 $retrans*= $factor; # Exponential backoff 1339 } 1340 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response 1341 my $why = $!; 1342 $timeout = $finish_time - &time(); # Get remaining time 1343 1344 if (!defined($nfound)) # Hmm, a strange error 1345 { 1346 $ret = undef; 1347 $done = 1; 1348 } 1349 elsif ($nfound) # A packet is waiting 1350 { 1351 $from_msg = ""; 1352 $from_saddr = recv($self->{fh}, $from_msg, 1500, UDP_FLAGS); 1353 if (!$from_saddr) { 1354 # For example an unreachable host will make recv() fail. 1355 if (!$self->{econnrefused} && 1356 ($! == ECONNREFUSED || 1357 $! == ECONNRESET)) { 1358 # "Connection refused" means reachable 1359 # Good, continue 1360 $ret = 1; 1361 } 1362 $done = 1; 1363 } else { 1364 ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); 1365 my $addr_in = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip; 1366 if (!$source_verify || 1367 (($from_ip eq $addr_in) && # Does the packet check out? 1368 ($from_port == $self->{port_num}) && 1369 ($from_msg eq $msg))) 1370 { 1371 $ret = 1; # It's a winner 1372 $done = 1; 1373 } 1374 } 1375 } 1376 elsif ($timeout <= 0) # Oops, timed out 1377 { 1378 $done = 1; 1379 } 1380 else 1381 { 1382 # Send another in case the last one dropped 1383 if (send($self->{fh}, $msg, UDP_FLAGS)) { 1384 # Another send worked? The previous udp packet 1385 # must have gotten lost or is still in transit. 1386 # Hopefully this new packet will arrive safely. 1387 } else { 1388 if (!$self->{econnrefused} && 1389 $! == ECONNREFUSED) { 1390 # "Connection refused" means reachable 1391 # Good, continue 1392 $ret = 1; 1393 } 1394 $done = 1; 1395 } 1396 } 1397 } 1398 return $ret; 1399} 1400 1401# Description: Send a TCP SYN packet to host specified. 1402sub ping_syn 1403{ 1404 my $self = shift; 1405 my $host = shift; 1406 my $ip = shift; 1407 my $start_time = shift; 1408 my $stop_time = shift; 1409 1410 if ($syn_forking) { 1411 return $self->ping_syn_fork($host, $ip, $start_time, $stop_time); 1412 } 1413 1414 my $fh = FileHandle->new(); 1415 my $saddr = _pack_sockaddr_in($self->{port_num}, $ip); 1416 1417 # Create TCP socket 1418 if (!socket ($fh, $ip->{family}, SOCK_STREAM, $self->{proto_num})) { 1419 croak("tcp socket error - $!"); 1420 } 1421 1422 if (defined $self->{local_addr} && 1423 !CORE::bind($fh, _pack_sockaddr_in(0, $self->{local_addr}))) { 1424 croak("tcp bind error - $!"); 1425 } 1426 1427 $self->_setopts(); 1428 # Set O_NONBLOCK property on filehandle 1429 $self->socket_blocking_mode($fh, 0); 1430 1431 # Attempt the non-blocking connect 1432 # by just sending the TCP SYN packet 1433 if (connect($fh, $saddr)) { 1434 # Non-blocking, yet still connected? 1435 # Must have connected very quickly, 1436 # or else it wasn't very non-blocking. 1437 #warn "WARNING: Nonblocking connect connected anyway? ($^O)"; 1438 } else { 1439 # Error occurred connecting. 1440 if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) { 1441 # The connection is just still in progress. 1442 # This is the expected condition. 1443 } else { 1444 # Just save the error and continue on. 1445 # The ack() can check the status later. 1446 $self->{bad}->{$host} = $!; 1447 } 1448 } 1449 1450 my $entry = [ $host, $ip, $fh, $start_time, $stop_time, $self->{port_num} ]; 1451 $self->{syn}->{$fh->fileno} = $entry; 1452 if ($self->{stop_time} < $stop_time) { 1453 $self->{stop_time} = $stop_time; 1454 } 1455 vec($self->{wbits}, $fh->fileno, 1) = 1; 1456 1457 return 1; 1458} 1459 1460sub ping_syn_fork { 1461 my ($self, $host, $ip, $start_time, $stop_time) = @_; 1462 1463 # Buggy Winsock API doesn't allow nonblocking connect. 1464 # Hence, if our OS is Windows, we need to create a separate 1465 # process to do the blocking connect attempt. 1466 my $pid = fork(); 1467 if (defined $pid) { 1468 if ($pid) { 1469 # Parent process 1470 my $entry = [ $host, $ip, $pid, $start_time, $stop_time ]; 1471 $self->{syn}->{$pid} = $entry; 1472 if ($self->{stop_time} < $stop_time) { 1473 $self->{stop_time} = $stop_time; 1474 } 1475 } else { 1476 # Child process 1477 my $saddr = _pack_sockaddr_in($self->{port_num}, $ip); 1478 1479 # Create TCP socket 1480 if (!socket ($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num})) { 1481 croak("tcp socket error - $!"); 1482 } 1483 1484 if (defined $self->{local_addr} && 1485 !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { 1486 croak("tcp bind error - $!"); 1487 } 1488 1489 $self->_setopts(); 1490 1491 $!=0; 1492 # Try to connect (could take a long time) 1493 connect($self->{fh}, $saddr); 1494 # Notify parent of connect error status 1495 my $err = $!+0; 1496 my $wrstr = "$$ $err"; 1497 # Force to 16 chars including \n 1498 $wrstr .= " "x(15 - length $wrstr). "\n"; 1499 syswrite($self->{fork_wr}, $wrstr, length $wrstr); 1500 exit; 1501 } 1502 } else { 1503 # fork() failed? 1504 die "fork: $!"; 1505 } 1506 return 1; 1507} 1508 1509# Description: Wait for TCP ACK from host specified 1510# from ping_syn above. If no host is specified, wait 1511# for TCP ACK from any of the hosts in the SYN queue. 1512sub ack 1513{ 1514 my $self = shift; 1515 1516 if ($self->{proto} eq "syn") { 1517 if ($syn_forking) { 1518 my @answer = $self->ack_unfork(shift); 1519 return wantarray ? @answer : $answer[0]; 1520 } 1521 my $wbits = ""; 1522 my $stop_time = 0; 1523 if (my $host = shift or $self->{host}) { 1524 # Host passed as arg or as option to new 1525 $host = $self->{host} unless defined $host; 1526 if (exists $self->{bad}->{$host}) { 1527 if (!$self->{econnrefused} && 1528 $self->{bad}->{ $host } && 1529 (($! = ECONNREFUSED)>0) && 1530 $self->{bad}->{ $host } eq "$!") { 1531 # "Connection refused" means reachable 1532 # Good, continue 1533 } else { 1534 # ECONNREFUSED means no good 1535 return (); 1536 } 1537 } 1538 my $host_fd = undef; 1539 foreach my $fd (keys %{ $self->{syn} }) { 1540 my $entry = $self->{syn}->{$fd}; 1541 if ($entry->[0] eq $host) { 1542 $host_fd = $fd; 1543 $stop_time = $entry->[4] 1544 || croak("Corrupted SYN entry for [$host]"); 1545 last; 1546 } 1547 } 1548 croak("ack called on [$host] without calling ping first!") 1549 unless defined $host_fd; 1550 vec($wbits, $host_fd, 1) = 1; 1551 } else { 1552 # No $host passed so scan all hosts 1553 # Use the latest stop_time 1554 $stop_time = $self->{stop_time}; 1555 # Use all the bits 1556 $wbits = $self->{wbits}; 1557 } 1558 1559 while ($wbits !~ /^\0*\z/) { 1560 my $timeout = $stop_time - &time(); 1561 # Force a minimum of 10 ms timeout. 1562 $timeout = 0.01 if $timeout <= 0.01; 1563 1564 my $winner_fd = undef; 1565 my $wout = $wbits; 1566 my $fd = 0; 1567 # Do "bad" fds from $wbits first 1568 while ($wout !~ /^\0*\z/) { 1569 if (vec($wout, $fd, 1)) { 1570 # Wipe it from future scanning. 1571 vec($wout, $fd, 1) = 0; 1572 if (my $entry = $self->{syn}->{$fd}) { 1573 if ($self->{bad}->{ $entry->[0] }) { 1574 $winner_fd = $fd; 1575 last; 1576 } 1577 } 1578 } 1579 $fd++; 1580 } 1581 1582 if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) { 1583 if (defined $winner_fd) { 1584 $fd = $winner_fd; 1585 } else { 1586 # Done waiting for one of the ACKs 1587 $fd = 0; 1588 # Determine which one 1589 while ($wout !~ /^\0*\z/ && 1590 !vec($wout, $fd, 1)) { 1591 $fd++; 1592 } 1593 } 1594 if (my $entry = $self->{syn}->{$fd}) { 1595 # Wipe it from future scanning. 1596 delete $self->{syn}->{$fd}; 1597 vec($self->{wbits}, $fd, 1) = 0; 1598 vec($wbits, $fd, 1) = 0; 1599 if (!$self->{econnrefused} && 1600 $self->{bad}->{ $entry->[0] } && 1601 (($! = ECONNREFUSED)>0) && 1602 $self->{bad}->{ $entry->[0] } eq "$!") { 1603 # "Connection refused" means reachable 1604 # Good, continue 1605 } elsif (getpeername($entry->[2])) { 1606 # Connection established to remote host 1607 # Good, continue 1608 } else { 1609 # TCP ACK will never come from this host 1610 # because there was an error connecting. 1611 1612 # This should set $! to the correct error. 1613 my $char; 1614 sysread($entry->[2],$char,1); 1615 # Store the excuse why the connection failed. 1616 $self->{bad}->{$entry->[0]} = $!; 1617 if (!$self->{econnrefused} && 1618 (($! == ECONNREFUSED) || 1619 ($! == EAGAIN && $^O =~ /cygwin/i))) { 1620 # "Connection refused" means reachable 1621 # Good, continue 1622 } else { 1623 # No good, try the next socket... 1624 next; 1625 } 1626 } 1627 # Everything passed okay, return the answer 1628 return wantarray ? 1629 ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]), $entry->[5]) 1630 : $entry->[0]; 1631 } else { 1632 warn "Corrupted SYN entry: unknown fd [$fd] ready!"; 1633 vec($wbits, $fd, 1) = 0; 1634 vec($self->{wbits}, $fd, 1) = 0; 1635 } 1636 } elsif (defined $nfound) { 1637 # Timed out waiting for ACK 1638 foreach my $fd (keys %{ $self->{syn} }) { 1639 if (vec($wbits, $fd, 1)) { 1640 my $entry = $self->{syn}->{$fd}; 1641 $self->{bad}->{$entry->[0]} = "Timed out"; 1642 vec($wbits, $fd, 1) = 0; 1643 vec($self->{wbits}, $fd, 1) = 0; 1644 delete $self->{syn}->{$fd}; 1645 } 1646 } 1647 } else { 1648 # Weird error occurred with select() 1649 warn("select: $!"); 1650 $self->{syn} = {}; 1651 $wbits = ""; 1652 } 1653 } 1654 } 1655 return (); 1656} 1657 1658sub ack_unfork { 1659 my ($self,$host) = @_; 1660 my $stop_time = $self->{stop_time}; 1661 if ($host) { 1662 # Host passed as arg 1663 if (my $entry = $self->{good}->{$host}) { 1664 delete $self->{good}->{$host}; 1665 return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])); 1666 } 1667 } 1668 1669 my $rbits = ""; 1670 my $timeout; 1671 1672 if (keys %{ $self->{syn} }) { 1673 # Scan all hosts that are left 1674 vec($rbits, fileno($self->{fork_rd}), 1) = 1; 1675 $timeout = $stop_time - &time(); 1676 # Force a minimum of 10 ms timeout. 1677 $timeout = 0.01 if $timeout < 0.01; 1678 } else { 1679 # No hosts left to wait for 1680 $timeout = 0; 1681 } 1682 1683 if ($timeout > 0) { 1684 my $nfound; 1685 while ( keys %{ $self->{syn} } and 1686 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) { 1687 # Done waiting for one of the ACKs 1688 if (!sysread($self->{fork_rd}, $_, 16)) { 1689 # Socket closed, which means all children are done. 1690 return (); 1691 } 1692 my ($pid, $how) = split; 1693 if ($pid) { 1694 # Flush the zombie 1695 waitpid($pid, 0); 1696 if (my $entry = $self->{syn}->{$pid}) { 1697 # Connection attempt to remote host is done 1698 delete $self->{syn}->{$pid}; 1699 if (!$how || # If there was no error connecting 1700 (!$self->{econnrefused} && 1701 $how == ECONNREFUSED)) { # "Connection refused" means reachable 1702 if ($host && $entry->[0] ne $host) { 1703 # A good connection, but not the host we need. 1704 # Move it from the "syn" hash to the "good" hash. 1705 $self->{good}->{$entry->[0]} = $entry; 1706 # And wait for the next winner 1707 next; 1708 } 1709 return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])); 1710 } 1711 } else { 1712 # Should never happen 1713 die "Unknown ping from pid [$pid]"; 1714 } 1715 } else { 1716 die "Empty response from status socket?"; 1717 } 1718 } 1719 if (defined $nfound) { 1720 # Timed out waiting for ACK status 1721 } else { 1722 # Weird error occurred with select() 1723 warn("select: $!"); 1724 } 1725 } 1726 if (my @synners = keys %{ $self->{syn} }) { 1727 # Kill all the synners 1728 kill 9, @synners; 1729 foreach my $pid (@synners) { 1730 # Wait for the deaths to finish 1731 # Then flush off the zombie 1732 waitpid($pid, 0); 1733 } 1734 } 1735 $self->{syn} = {}; 1736 return (); 1737} 1738 1739# Description: Tell why the ack() failed 1740sub nack { 1741 my $self = shift; 1742 my $host = shift || croak('Usage> nack($failed_ack_host)'); 1743 return $self->{bad}->{$host} || undef; 1744} 1745 1746# Description: Close the connection. 1747 1748sub close 1749{ 1750 my ($self) = @_; 1751 1752 if ($self->{proto} eq "syn") { 1753 delete $self->{syn}; 1754 } elsif ($self->{proto} eq "tcp") { 1755 # The connection will already be closed 1756 } elsif ($self->{proto} eq "external") { 1757 # Nothing to close 1758 } else { 1759 $self->{fh}->close(); 1760 } 1761} 1762 1763sub port_number { 1764 my $self = shift; 1765 if(@_) { 1766 $self->{port_num} = shift @_; 1767 $self->service_check(1); 1768 } 1769 return $self->{port_num}; 1770} 1771 1772sub ntop { 1773 my($self, $ip) = @_; 1774 1775 # Vista doesn't define a inet_ntop. It has InetNtop instead. 1776 # Not following ANSI... priceless. getnameinfo() is defined 1777 # for Windows 2000 and later, so that may be the choice. 1778 1779 # Any port will work, even undef, but this will work for now. 1780 # Socket warns when undef is passed in, but it still works. 1781 my $port = getservbyname('echo', 'udp'); 1782 my $sockaddr = _pack_sockaddr_in($port, $ip); 1783 my ($error, $address) = getnameinfo($sockaddr, $NI_NUMERICHOST); 1784 croak $error if $error; 1785 return $address; 1786} 1787 1788sub wakeonlan { 1789 my ($mac_addr, $host, $port) = @_; 1790 1791 # use the discard service if $port not passed in 1792 if (! defined $host) { $host = '255.255.255.255' } 1793 if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 } 1794 1795 require IO::Socket::INET; 1796 my $sock = IO::Socket::INET->new(Proto=>'udp') || return undef; 1797 1798 my $ip_addr = inet_aton($host); 1799 my $sock_addr = sockaddr_in($port, $ip_addr); 1800 $mac_addr =~ s/://g; 1801 my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16); 1802 1803 setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1); 1804 send($sock, $packet, 0, $sock_addr); 1805 $sock->close; 1806 1807 return 1; 1808} 1809 1810######################################################## 1811# DNS hostname resolution 1812# return: 1813# $h->{name} = host - as passed in 1814# $h->{host} = host - as passed in without :port 1815# $h->{port} = OPTIONAL - if :port, then value of port 1816# $h->{addr} = resolved numeric address 1817# $h->{addr_in} = aton/pton result 1818# $h->{family} = AF_INET/6 1819############################ 1820sub _resolv { 1821 my ($self, 1822 $name, 1823 ) = @_; 1824 1825 my %h; 1826 $h{name} = $name; 1827 my $family = $self->{family}; 1828 1829 if (defined($self->{family_local})) { 1830 $family = $self->{family_local} 1831 } 1832 1833# START - host:port 1834 my $cnt = 0; 1835 1836 # Count ":" 1837 $cnt++ while ($name =~ m/:/g); 1838 1839 # 0 = hostname or IPv4 address 1840 if ($cnt == 0) { 1841 $h{host} = $name 1842 # 1 = IPv4 address with port 1843 } elsif ($cnt == 1) { 1844 ($h{host}, $h{port}) = split /:/, $name 1845 # >=2 = IPv6 address 1846 } elsif ($cnt >= 2) { 1847 #IPv6 with port - [2001::1]:port 1848 if ($name =~ /^\[.*\]:\d{1,5}$/) { 1849 ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last : 1850 # IPv6 without port 1851 } else { 1852 $h{host} = $name 1853 } 1854 } 1855 1856 # Clean up host 1857 $h{host} =~ s/\[//g; 1858 $h{host} =~ s/\]//g; 1859 # Clean up port 1860 if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) { 1861 croak("Invalid port `$h{port}' in `$name'"); 1862 return undef; 1863 } 1864# END - host:port 1865 1866 # address check 1867 # new way 1868 if ($Socket_VERSION > 1.94) { 1869 my %hints = ( 1870 family => $AF_UNSPEC, 1871 protocol => IPPROTO_TCP, 1872 flags => $AI_NUMERICHOST 1873 ); 1874 1875 # numeric address, return 1876 my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints); 1877 if (defined($getaddr[0])) { 1878 $h{addr} = $h{host}; 1879 $h{family} = $getaddr[0]->{family}; 1880 if ($h{family} == AF_INET) { 1881 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr}; 1882 } else { 1883 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr}; 1884 } 1885 return \%h 1886 } 1887 # old way 1888 } else { 1889 # numeric address, return 1890 my $ret = gethostbyname($h{host}); 1891 if (defined($ret) && (_inet_ntoa($ret) eq $h{host})) { 1892 $h{addr} = $h{host}; 1893 $h{addr_in} = $ret; 1894 $h{family} = AF_INET; 1895 return \%h 1896 } 1897 } 1898 1899 # resolve 1900 # new way 1901 if ($Socket_VERSION >= 1.94) { 1902 my %hints = ( 1903 family => $family, 1904 protocol => IPPROTO_TCP 1905 ); 1906 1907 my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints); 1908 if (defined($getaddr[0])) { 1909 my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST, $NIx_NOSERV); 1910 if (defined($address)) { 1911 $h{addr} = $address; 1912 $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6 1913 $h{family} = $getaddr[0]->{family}; 1914 if ($h{family} == AF_INET) { 1915 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr}; 1916 } else { 1917 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr}; 1918 } 1919 return \%h; 1920 } else { 1921 carp("getnameinfo($getaddr[0]->{addr}) failed - $err"); 1922 return undef; 1923 } 1924 } else { 1925 warn(sprintf("getaddrinfo($h{host},,%s) failed - $err", 1926 $family == AF_INET ? "AF_INET" : "AF_INET6")); 1927 return undef; 1928 } 1929 # old way 1930 } else { 1931 if ($family == $AF_INET6) { 1932 croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION"); 1933 return undef; 1934 } 1935 1936 my @gethost = gethostbyname($h{host}); 1937 if (defined($gethost[4])) { 1938 $h{addr} = inet_ntoa($gethost[4]); 1939 $h{addr_in} = $gethost[4]; 1940 $h{family} = AF_INET; 1941 return \%h 1942 } else { 1943 carp("gethostbyname($h{host}) failed - $^E"); 1944 return undef; 1945 } 1946 } 1947 return undef; 1948} 1949 1950sub _pack_sockaddr_in($$) { 1951 my ($port, 1952 $ip, 1953 ) = @_; 1954 1955 my $addr = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip; 1956 if (length($addr) <= 4 ) { 1957 return Socket::pack_sockaddr_in($port, $addr); 1958 } else { 1959 return Socket::pack_sockaddr_in6($port, $addr); 1960 } 1961} 1962 1963sub _unpack_sockaddr_in($;$) { 1964 my ($addr, 1965 $family, 1966 ) = @_; 1967 1968 my ($port, $host); 1969 if ($family == AF_INET || (!defined($family) and length($addr) <= 16 )) { 1970 ($port, $host) = Socket::unpack_sockaddr_in($addr); 1971 } else { 1972 ($port, $host) = Socket::unpack_sockaddr_in6($addr); 1973 } 1974 return $port, $host 1975} 1976 1977sub _inet_ntoa { 1978 my ($addr 1979 ) = @_; 1980 1981 my $ret; 1982 if ($Socket_VERSION >= 1.94) { 1983 my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST); 1984 if (defined($address)) { 1985 $ret = $address; 1986 } else { 1987 carp("getnameinfo($addr) failed - $err"); 1988 } 1989 } else { 1990 $ret = inet_ntoa($addr) 1991 } 1992 1993 return $ret 1994} 1995 19961; 1997__END__ 1998 1999=head1 NAME 2000 2001Net::Ping - check a remote host for reachability 2002 2003=head1 SYNOPSIS 2004 2005 use Net::Ping; 2006 2007 $p = Net::Ping->new(); 2008 print "$host is alive.\n" if $p->ping($host); 2009 $p->close(); 2010 2011 $p = Net::Ping->new("icmp"); 2012 $p->bind($my_addr); # Specify source interface of pings 2013 foreach $host (@host_array) 2014 { 2015 print "$host is "; 2016 print "NOT " unless $p->ping($host, 2); 2017 print "reachable.\n"; 2018 sleep(1); 2019 } 2020 $p->close(); 2021 2022 $p = Net::Ping->new("icmpv6"); 2023 $ip = "[fd00:dead:beef::4e]"; 2024 print "$ip is alive.\n" if $p->ping($ip); 2025 2026 $p = Net::Ping->new("tcp", 2); 2027 # Try connecting to the www port instead of the echo port 2028 $p->port_number(scalar(getservbyname("http", "tcp"))); 2029 while ($stop_time > time()) 2030 { 2031 print "$host not reachable ", scalar(localtime()), "\n" 2032 unless $p->ping($host); 2033 sleep(300); 2034 } 2035 undef($p); 2036 2037 # Like tcp protocol, but with many hosts 2038 $p = Net::Ping->new("syn"); 2039 $p->port_number(getservbyname("http", "tcp")); 2040 foreach $host (@host_array) { 2041 $p->ping($host); 2042 } 2043 while (($host,$rtt,$ip) = $p->ack) { 2044 print "HOST: $host [$ip] ACKed in $rtt seconds.\n"; 2045 } 2046 2047 # High precision syntax (requires Time::HiRes) 2048 $p = Net::Ping->new(); 2049 $p->hires(); 2050 ($ret, $duration, $ip) = $p->ping($host, 5.5); 2051 printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 2052 1000 * $duration) 2053 if $ret; 2054 $p->close(); 2055 2056 # For backward compatibility 2057 print "$host is alive.\n" if pingecho($host); 2058 2059=head1 DESCRIPTION 2060 2061This module contains methods to test the reachability of remote 2062hosts on a network. A ping object is first created with optional 2063parameters, a variable number of hosts may be pinged multiple 2064times and then the connection is closed. 2065 2066You may choose one of six different protocols to use for the 2067ping. The "tcp" protocol is the default. Note that a live remote host 2068may still fail to be pingable by one or more of these protocols. For 2069example, www.microsoft.com is generally alive but not "icmp" pingable. 2070 2071With the "tcp" protocol the ping() method attempts to establish a 2072connection to the remote host's echo port. If the connection is 2073successfully established, the remote host is considered reachable. No 2074data is actually echoed. This protocol does not require any special 2075privileges but has higher overhead than the "udp" and "icmp" protocols. 2076 2077Specifying the "udp" protocol causes the ping() method to send a udp 2078packet to the remote host's echo port. If the echoed packet is 2079received from the remote host and the received packet contains the 2080same data as the packet that was sent, the remote host is considered 2081reachable. This protocol does not require any special privileges. 2082It should be borne in mind that, for a udp ping, a host 2083will be reported as unreachable if it is not running the 2084appropriate echo service. For Unix-like systems see L<inetd(8)> 2085for more information. 2086 2087If the "icmp" protocol is specified, the ping() method sends an icmp 2088echo message to the remote host, which is what the UNIX ping program 2089does. If the echoed message is received from the remote host and 2090the echoed information is correct, the remote host is considered 2091reachable. Specifying the "icmp" protocol requires that the program 2092be run as root or that the program be setuid to root. 2093 2094If the "external" protocol is specified, the ping() method attempts to 2095use the C<Net::Ping::External> module to ping the remote host. 2096C<Net::Ping::External> interfaces with your system's default C<ping> 2097utility to perform the ping, and generally produces relatively 2098accurate results. If C<Net::Ping::External> if not installed on your 2099system, specifying the "external" protocol will result in an error. 2100 2101If the "syn" protocol is specified, the L</ping> method will only 2102send a TCP SYN packet to the remote host then immediately return. 2103If the syn packet was sent successfully, it will return a true value, 2104otherwise it will return false. NOTE: Unlike the other protocols, 2105the return value does NOT determine if the remote host is alive or 2106not since the full TCP three-way handshake may not have completed 2107yet. The remote host is only considered reachable if it receives 2108a TCP ACK within the timeout specified. To begin waiting for the 2109ACK packets, use the L</ack> method as explained below. Use the 2110"syn" protocol instead the "tcp" protocol to determine reachability 2111of multiple destinations simultaneously by sending parallel TCP 2112SYN packets. It will not block while testing each remote host. 2113This protocol does not require any special privileges. 2114 2115=head2 Functions 2116 2117=over 4 2118 2119=item Net::Ping->new([proto, timeout, bytes, device, tos, ttl, family, 2120 host, port, bind, gateway, retrans, pingstring, 2121 source_verify econnrefused dontfrag 2122 IPV6_USE_MIN_MTU IPV6_RECVPATHMTU]) 2123X<new> 2124 2125Create a new ping object. All of the parameters are optional and can 2126be passed as hash ref. All options besides the first 7 must be passed 2127as hash ref. 2128 2129C<proto> specifies the protocol to use when doing a ping. The current 2130choices are "tcp", "udp", "icmp", "icmpv6", "stream", "syn", or 2131"external". The default is "tcp". 2132 2133If a C<timeout> in seconds is provided, it is used 2134when a timeout is not given to the ping() method (below). The timeout 2135must be greater than 0 and the default, if not specified, is 5 seconds. 2136 2137If the number of data bytes (C<bytes>) is given, that many data bytes 2138are included in the ping packet sent to the remote host. The number of 2139data bytes is ignored if the protocol is "tcp". The minimum (and 2140default) number of data bytes is 1 if the protocol is "udp" and 0 2141otherwise. The maximum number of data bytes that can be specified is 214265535, but staying below the MTU (1472 bytes for ICMP) is recommended. 2143Many small devices cannot deal with fragmented ICMP packets. 2144 2145If C<device> is given, this device is used to bind the source endpoint 2146before sending the ping packet. I believe this only works with 2147superuser privileges and with udp and icmp protocols at this time. 2148 2149If <tos> is given, this ToS is configured into the socket. 2150 2151For icmp, C<ttl> can be specified to set the TTL of the outgoing packet. 2152 2153Valid C<family> values for IPv4: 2154 2155 4, v4, ip4, ipv4, AF_INET (constant) 2156 2157Valid C<family> values for IPv6: 2158 2159 6, v6, ip6, ipv6, AF_INET6 (constant) 2160 2161The C<host> argument implicitly specifies the family if the family 2162argument is not given. 2163 2164The C<port> argument is only valid for a udp, tcp or stream ping, and will not 2165do what you think it does. ping returns true when we get a "Connection refused"! 2166The default is the echo port. 2167 2168The C<bind> argument specifies the local_addr to bind to. 2169By specifying a bind argument you don't need the bind method. 2170 2171The C<gateway> argument is only valid for IPv6, and requires a IPv6 2172address. 2173 2174The C<retrans> argument the exponential backoff rate, default 1.2. 2175It matches the $def_factor global. 2176 2177The C<dontfrag> argument sets the IP_DONTFRAG bit, but note that 2178IP_DONTFRAG is not yet defined by Socket, and not available on many 2179systems. Then it is ignored. On linux it also sets IP_MTU_DISCOVER to 2180IP_PMTUDISC_DO but need we don't chunk oversized packets. You need to 2181set $data_size manually. 2182 2183=item $p->ping($host [, $timeout [, $family]]); 2184X<ping> 2185 2186Ping the remote host and wait for a response. $host can be either the 2187hostname or the IP number of the remote host. The optional timeout 2188must be greater than 0 seconds and defaults to whatever was specified 2189when the ping object was created. Returns a success flag. If the 2190hostname cannot be found or there is a problem with the IP number, the 2191success flag returned will be undef. Otherwise, the success flag will 2192be 1 if the host is reachable and 0 if it is not. For most practical 2193purposes, undef and 0 and can be treated as the same case. In array 2194context, the elapsed time as well as the string form of the ip the 2195host resolved to are also returned. The elapsed time value will 2196be a float, as returned by the Time::HiRes::time() function, if hires() 2197has been previously called, otherwise it is returned as an integer. 2198 2199=item $p->source_verify( { 0 | 1 } ); 2200X<source_verify> 2201 2202Allows source endpoint verification to be enabled or disabled. 2203This is useful for those remote destinations with multiples 2204interfaces where the response may not originate from the same 2205endpoint that the original destination endpoint was sent to. 2206This only affects udp and icmp protocol pings. 2207 2208This is enabled by default. 2209 2210=item $p->service_check( { 0 | 1 } ); 2211X<service_check> 2212 2213Set whether or not the connect behavior should enforce 2214remote service availability as well as reachability. Normally, 2215if the remote server reported ECONNREFUSED, it must have been 2216reachable because of the status packet that it reported. 2217With this option enabled, the full three-way tcp handshake 2218must have been established successfully before it will 2219claim it is reachable. NOTE: It still does nothing more 2220than connect and disconnect. It does not speak any protocol 2221(i.e., HTTP or FTP) to ensure the remote server is sane in 2222any way. The remote server CPU could be grinding to a halt 2223and unresponsive to any clients connecting, but if the kernel 2224throws the ACK packet, it is considered alive anyway. To 2225really determine if the server is responding well would be 2226application specific and is beyond the scope of Net::Ping. 2227For udp protocol, enabling this option demands that the 2228remote server replies with the same udp data that it was sent 2229as defined by the udp echo service. 2230 2231This affects the "udp", "tcp", and "syn" protocols. 2232 2233This is disabled by default. 2234 2235=item $p->tcp_service_check( { 0 | 1 } ); 2236X<tcp_service_check> 2237 2238Deprecated method, but does the same as service_check() method. 2239 2240=item $p->hires( { 0 | 1 } ); 2241X<hires> 2242 2243With 1 causes this module to use Time::HiRes module, allowing milliseconds 2244to be returned by subsequent calls to ping(). 2245 2246=item $p->time 2247X<time> 2248 2249The current time, hires or not. 2250 2251=item $p->socket_blocking_mode( $fh, $mode ); 2252X<socket_blocking_mode> 2253 2254Sets or clears the O_NONBLOCK flag on a file handle. 2255 2256=item $p->IPV6_USE_MIN_MTU 2257X<IPV6_USE_MIN_MTU> 2258 2259With argument sets the option. 2260Without returns the option value. 2261 2262=item $p->IPV6_RECVPATHMTU 2263X<IPV6_RECVPATHMTU> 2264 2265Notify an according IPv6 MTU. 2266 2267With argument sets the option. 2268Without returns the option value. 2269 2270=item $p->IPV6_HOPLIMIT 2271X<IPV6_HOPLIMIT> 2272 2273With argument sets the option. 2274Without returns the option value. 2275 2276=item $p->IPV6_REACHCONF I<NYI> 2277X<IPV6_REACHCONF> 2278 2279Sets ipv6 reachability 2280IPV6_REACHCONF was removed in RFC3542. ping6 -R supports it. 2281IPV6_REACHCONF requires root/admin permissions. 2282 2283With argument sets the option. 2284Without returns the option value. 2285 2286Not yet implemented. 2287 2288=item $p->bind($local_addr); 2289X<bind> 2290 2291Sets the source address from which pings will be sent. This must be 2292the address of one of the interfaces on the local host. $local_addr 2293may be specified as a hostname or as a text IP address such as 2294"192.168.1.1". 2295 2296If the protocol is set to "tcp", this method may be called any 2297number of times, and each call to the ping() method (below) will use 2298the most recent $local_addr. If the protocol is "icmp" or "udp", 2299then bind() must be called at most once per object, and (if it is 2300called at all) must be called before the first call to ping() for that 2301object. 2302 2303The bind() call can be omitted when specifying the C<bind> option to 2304new(). 2305 2306=item $p->message_type([$ping_type]); 2307X<message_type> 2308 2309When you are using the "icmp" protocol, this call permit to change the 2310message type to 'echo' or 'timestamp' (only for IPv4, see RFC 792). 2311 2312Without argument, it returns the currently used icmp protocol message type. 2313By default, it returns 'echo'. 2314 2315=item $p->open($host); 2316X<open> 2317 2318When you are using the "stream" protocol, this call pre-opens the 2319tcp socket. It's only necessary to do this if you want to 2320provide a different timeout when creating the connection, or 2321remove the overhead of establishing the connection from the 2322first ping. If you don't call C<open()>, the connection is 2323automatically opened the first time C<ping()> is called. 2324This call simply does nothing if you are using any protocol other 2325than stream. 2326 2327The $host argument can be omitted when specifying the C<host> option to 2328new(). 2329 2330=item $p->ack( [ $host ] ); 2331X<ack> 2332 2333When using the "syn" protocol, use this method to determine 2334the reachability of the remote host. This method is meant 2335to be called up to as many times as ping() was called. Each 2336call returns the host (as passed to ping()) that came back 2337with the TCP ACK. The order in which the hosts are returned 2338may not necessarily be the same order in which they were 2339SYN queued using the ping() method. If the timeout is 2340reached before the TCP ACK is received, or if the remote 2341host is not listening on the port attempted, then the TCP 2342connection will not be established and ack() will return 2343undef. In list context, the host, the ack time, the dotted ip 2344string, and the port number will be returned instead of just the host. 2345If the optional C<$host> argument is specified, the return 2346value will be pertaining to that host only. 2347This call simply does nothing if you are using any protocol 2348other than "syn". 2349 2350When L</new> had a host option, this host will be used. 2351Without C<$host> argument, all hosts are scanned. 2352 2353=item $p->nack( $failed_ack_host ); 2354X<nack> 2355 2356The reason that C<host $failed_ack_host> did not receive a 2357valid ACK. Useful to find out why when C<ack($fail_ack_host)> 2358returns a false value. 2359 2360=item $p->ack_unfork($host) 2361X<ack_unfork> 2362 2363The variant called by L</ack> with the "syn" protocol and C<$syn_forking> 2364enabled. 2365 2366=item $p->ping_icmp([$host, $timeout, $family]) 2367X<ping_icmp> 2368 2369The L</ping> method used with the icmp protocol. 2370 2371=item $p->ping_icmpv6([$host, $timeout, $family]) 2372X<ping_icmpv6> 2373 2374The L</ping> method used with the icmpv6 protocol. 2375 2376=item $p->ping_stream([$host, $timeout, $family]) 2377X<ping_stream> 2378 2379The L</ping> method used with the stream protocol. 2380 2381Perform a stream ping. If the tcp connection isn't 2382already open, it opens it. It then sends some data and waits for 2383a reply. It leaves the stream open on exit. 2384 2385=item $p->ping_syn([$host, $ip, $start_time, $stop_time]) 2386X<ping_syn> 2387 2388The L</ping> method used with the syn protocol. 2389Sends a TCP SYN packet to host specified. 2390 2391=item $p->ping_syn_fork([$host, $timeout, $family]) 2392X<ping_syn_fork> 2393 2394The L</ping> method used with the forking syn protocol. 2395 2396=item $p->ping_tcp([$host, $timeout, $family]) 2397X<ping_tcp> 2398 2399The L</ping> method used with the tcp protocol. 2400 2401=item $p->ping_udp([$host, $timeout, $family]) 2402X<ping_udp> 2403 2404The L</ping> method used with the udp protocol. 2405 2406Perform a udp echo ping. Construct a message of 2407at least the one-byte sequence number and any additional data bytes. 2408Send the message out and wait for a message to come back. If we 2409get a message, make sure all of its parts match. If they do, we are 2410done. Otherwise go back and wait for the message until we run out 2411of time. Return the result of our efforts. 2412 2413=item $p->ping_external([$host, $timeout, $family]) 2414X<ping_external> 2415 2416The L</ping> method used with the external protocol. 2417Uses L<Net::Ping::External> to do an external ping. 2418 2419=item $p->tcp_connect([$ip, $timeout]) 2420X<tcp_connect> 2421 2422Initiates a TCP connection, for a tcp ping. 2423 2424=item $p->tcp_echo([$ip, $timeout, $pingstring]) 2425X<tcp_echo> 2426 2427Performs a TCP echo. 2428It writes the given string to the socket and then reads it 2429back. It returns 1 on success, 0 on failure. 2430 2431=item $p->close(); 2432X<close> 2433 2434Close the network connection for this ping object. The network 2435connection is also closed by "undef $p". The network connection is 2436automatically closed if the ping object goes out of scope (e.g. $p is 2437local to a subroutine and you leave the subroutine). 2438 2439=item $p->port_number([$port_number]) 2440X<port_number> 2441 2442When called with a port number, the port number used to ping is set to 2443C<$port_number> rather than using the echo port. It also has the effect 2444of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful 2445response only if that specific port is accessible. This function returns 2446the value of the port that L</ping> will connect to. 2447 2448=item $p->mselect 2449X<mselect> 2450 2451A C<select()> wrapper that compensates for platform 2452peculiarities. 2453 2454=item $p->ntop 2455X<ntop> 2456 2457Platform abstraction over C<inet_ntop()> 2458 2459=item $p->checksum($msg) 2460X<checksum> 2461 2462Do a checksum on the message. Basically sum all of 2463the short words and fold the high order bits into the low order bits. 2464 2465=item $p->icmp_result 2466X<icmp_result> 2467 2468Returns a list of addr, type, subcode. 2469 2470=item pingecho($host [, $timeout]); 2471X<pingecho> 2472 2473To provide backward compatibility with the previous version of 2474L<Net::Ping>, a C<pingecho()> subroutine is available with the same 2475functionality as before. C<pingecho()> uses the tcp protocol. The 2476return values and parameters are the same as described for the L</ping> 2477method. This subroutine is obsolete and may be removed in a future 2478version of L<Net::Ping>. 2479 2480=item wakeonlan($mac, [$host, [$port]]) 2481X<wakeonlan> 2482 2483Emit the popular wake-on-lan magic udp packet to wake up a local 2484device. See also L<Net::Wake>, but this has the mac address as 1st arg. 2485C<$host> should be the local gateway. Without it will broadcast. 2486 2487Default host: '255.255.255.255' 2488Default port: 9 2489 2490 perl -MNet::Ping=wakeonlan -e'wakeonlan "e0:69:95:35:68:d2"' 2491 2492=back 2493 2494=head1 NOTES 2495 2496There will be less network overhead (and some efficiency in your 2497program) if you specify either the udp or the icmp protocol. The tcp 2498protocol will generate 2.5 times or more traffic for each ping than 2499either udp or icmp. If many hosts are pinged frequently, you may wish 2500to implement a small wait (e.g. 25ms or more) between each ping to 2501avoid flooding your network with packets. 2502 2503The icmp and icmpv6 protocols requires that the program be run as root 2504or that it be setuid to root. The other protocols do not require 2505special privileges, but not all network devices implement tcp or udp 2506echo. 2507 2508Local hosts should normally respond to pings within milliseconds. 2509However, on a very congested network it may take up to 3 seconds or 2510longer to receive an echo packet from the remote host. If the timeout 2511is set too low under these conditions, it will appear that the remote 2512host is not reachable (which is almost the truth). 2513 2514Reachability doesn't necessarily mean that the remote host is actually 2515functioning beyond its ability to echo packets. tcp is slightly better 2516at indicating the health of a system than icmp because it uses more 2517of the networking stack to respond. 2518 2519Because of a lack of anything better, this module uses its own 2520routines to pack and unpack ICMP packets. It would be better for a 2521separate module to be written which understands all of the different 2522kinds of ICMP packets. 2523 2524=head1 INSTALL 2525 2526The latest source tree is available via git: 2527 2528 git clone https://github.com/rurban/Net-Ping.git 2529 cd Net-Ping 2530 2531The tarball can be created as follows: 2532 2533 perl Makefile.PL ; make ; make dist 2534 2535The latest Net::Ping releases are included in cperl and perl5. 2536 2537=head1 BUGS 2538 2539For a list of known issues, visit: 2540 2541L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping> 2542and 2543L<https://github.com/rurban/Net-Ping/issues> 2544 2545To report a new bug, visit: 2546 2547L<https://github.com/rurban/Net-Ping/issues> 2548 2549=head1 AUTHORS 2550 2551 Current maintainers: 2552 perl11 (for cperl, with IPv6 support and more) 2553 p5p (for perl5) 2554 2555 Previous maintainers: 2556 bbb@cpan.org (Rob Brown) 2557 Steve Peters 2558 2559 External protocol: 2560 colinm@cpan.org (Colin McMillen) 2561 2562 Stream protocol: 2563 bronson@trestle.com (Scott Bronson) 2564 2565 Wake-on-lan: 2566 1999-2003 Clinton Wong 2567 2568 Original pingecho(): 2569 karrer@bernina.ethz.ch (Andreas Karrer) 2570 pmarquess@bfsec.bt.co.uk (Paul Marquess) 2571 2572 Original Net::Ping author: 2573 mose@ns.ccsn.edu (Russell Mosemann) 2574 2575=head1 COPYRIGHT 2576 2577Copyright (c) 2017-2020, Reini Urban. All rights reserved. 2578 2579Copyright (c) 2016, cPanel Inc. All rights reserved. 2580 2581Copyright (c) 2012, Steve Peters. All rights reserved. 2582 2583Copyright (c) 2002-2003, Rob Brown. All rights reserved. 2584 2585Copyright (c) 2001, Colin McMillen. All rights reserved. 2586 2587This program is free software; you may redistribute it and/or 2588modify it under the same terms as Perl itself. 2589 2590=cut 2591