File Coverage

blib/lib/Net/Ping.pm
Criterion Covered Total %
statement 513 887 57.8
branch 220 568 38.7
condition 89 331 26.8
subroutine 57 77 74.0
pod 36 36 100.0
total 915 1899 48.1


line stmt bran cond sub pod time code
1             package Net::Ping;
2              
3             require 5.002;
4             require Exporter;
5              
6 20     20   1359279 use strict;
  20         214  
  20         1025  
7 20         2699 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION
8             $def_timeout $def_proto $def_factor $def_family
9 20     20   126 $max_datasize $pingstring $hires $source_verify $syn_forking);
  20         36  
10 20     20   148 use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
  20         39  
  20         1472  
11 20     20   3640 use Socket 2.007;
  20         23580  
  20         10936  
12 20         4973 use 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 20     20   153 inet_ntoa inet_aton getnameinfo sockaddr_in );
  20         41  
16 20         118 use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN
17 20     20   10819 WNOHANG );
  20         134830  
18 20     20   39391 use FileHandle;
  20         198208  
  20         135  
19 20     20   7609 use Carp;
  20         46  
  20         1061  
20 20     20   10518 use Time::HiRes;
  20         25703  
  20         98  
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              
41             my $AF_INET6 = eval { Socket::AF_INET6() } || 30;
42             my $AF_UNSPEC = eval { Socket::AF_UNSPEC() };
43             my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() } || 4;
44             my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() } || 2;
45             my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() } || 41;
46             my $NIx_NOSERV = eval { Socket::NIx_NOSERV() } || 2;
47             #my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255
48             my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/;
49             my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/;
50             my $Socket_VERSION = eval $Socket::VERSION;
51              
52             if ($^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 20     20   6834 no strict 'refs';
  20         45  
  20         73943  
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              
77             sub pingecho
78             {
79 1     1 1 102 my ($host, # Name or IP number of host to ping
80             $timeout # Optional timeout in seconds
81             ) = @_;
82 1         2 my ($p); # A ping object
83              
84 1         7 $p = Net::Ping->new("tcp", $timeout);
85 1         5 $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              
95             sub new
96             {
97 41     41 1 13336 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 41   66     270 my $class = ref($this) || $this;
107 41         105 my $self = {};
108 41         85 my ($cnt, # Count through data bytes
109             $min_datasize # Minimum data bytes required
110             );
111              
112 41         97 bless($self, $class);
113 41 100       137 if (ref $proto eq 'HASH') { # support named args
114 1         6 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 19 100       36 if (exists $proto->{$k}) {
120 2         5 $self->{$k} = $proto->{$k};
121             # some are still globals
122 2 50       6 if ($k eq 'pingstring') { $pingstring = $proto->{$k} }
  0         0  
123 2 50       5 if ($k eq 'source_verify') { $source_verify = $proto->{$k} }
  0         0  
124             # and some are local
125 2 50       5 $timeout = $proto->{$k} if ($k eq 'timeout');
126 2 50       38 $data_size = $proto->{$k} if ($k eq 'data_size');
127 2 50       7 $device = $proto->{$k} if ($k eq 'device');
128 2 50       5 $tos = $proto->{$k} if ($k eq 'tos');
129 2 100       5 $ttl = $proto->{$k} if ($k eq 'ttl');
130 2 50       4 $family = $proto->{$k} if ($k eq 'family');
131 2         5 delete $proto->{$k};
132             }
133             }
134 1 50       3 if (%$proto) {
135 0         0 croak("Invalid named argument: ",join(" ",keys (%$proto)));
136             }
137 1         2 $proto = $self->{'proto'};
138             }
139              
140 41 100       109 $proto = $def_proto unless $proto; # Determine the protocol
141 41 100       562 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 40         224 $self->{proto} = $proto;
144              
145 40 100       128 $timeout = $def_timeout unless defined $timeout; # Determine the timeout
146 40 100       217 croak("Default timeout for ping must be greater than 0 seconds")
147             if $timeout <= 0;
148 39         87 $self->{timeout} = $timeout;
149              
150 39         103 $self->{device} = $device;
151              
152 39         96 $self->{tos} = $tos;
153              
154 39 50       106 if ($self->{'host'}) {
155 0         0 my $host = $self->{'host'};
156 0 0       0 my $ip = $self->_resolv($host) or
157             carp("could not resolve host $host");
158 0         0 $self->{host} = $ip;
159 0         0 $self->{family} = $ip->{family};
160             }
161              
162 39 50       120 if ($self->{bind}) {
163 0         0 my $addr = $self->{bind};
164 0 0       0 my $ip = $self->_resolv($addr)
165             or carp("could not resolve local addr $addr");
166 0         0 $self->{local_addr} = $ip;
167             } else {
168 39         89 $self->{local_addr} = undef; # Don't bind by default
169             }
170              
171 39 100       132 if ($self->{proto} eq 'icmp') {
172 11 100 100     372 croak('TTL must be from 0 to 255')
      100        
173             if ($ttl && ($ttl < 0 || $ttl > 255));
174 9         16 $self->{ttl} = $ttl;
175             }
176              
177 37 50       104 if ($family) {
178 0 0       0 if ($family =~ $qr_family) {
179 0 0       0 if ($family =~ $qr_family4) {
180 0         0 $self->{family} = AF_INET;
181             } else {
182 0         0 $self->{family} = $AF_INET6;
183             }
184             } else {
185 0         0 croak('Family must be "ipv4" or "ipv6"')
186             }
187             } else {
188 37 100       106 if ($self->{proto} eq 'icmpv6') {
189 1         3 $self->{family} = $AF_INET6;
190             } else {
191 36         86 $self->{family} = $def_family;
192             }
193             }
194              
195 37 100       125 $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
196 37 100 66     151 $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
197             # allow for fragmented packets if data_size>1472 (MTU 1500)
198 37 100 100     404 croak("Data for ping must be from $min_datasize to $max_datasize bytes")
199             if ($data_size < $min_datasize) || ($data_size > $max_datasize);
200 35 100       112 $data_size-- if $self->{proto} eq "udp"; # We provide the first byte
201 35         94 $self->{data_size} = $data_size;
202              
203 35         120 $self->{data} = ""; # Construct data bytes
204 35         172 for ($cnt = 0; $cnt < $self->{data_size}; $cnt++)
205             {
206 0         0 $self->{data} .= chr($cnt % 256);
207             }
208              
209             # Default exponential backoff rate
210 35 50       135 $self->{retrans} = $def_factor unless exists $self->{retrans};
211             # Default Connection refused behavior
212 35 50       145 $self->{econnrefused} = undef unless exists $self->{econnrefused};
213              
214 35         96 $self->{seq} = 0; # For counting packets
215 35 100 100     364 if ($self->{proto} eq "udp") # Open a socket
    100          
    100          
    100          
    50          
216             {
217 2   33     4 $self->{proto_num} = eval { (getprotobyname('udp'))[2] } ||
218             croak("Can't udp protocol by name");
219             $self->{port_num} = $self->{port}
220 2   33     89 || (getservbyname('echo', 'udp'))[2]
221             || croak("Can't get udp echo port by name");
222 2         28 $self->{fh} = FileHandle->new();
223             socket($self->{fh}, PF_INET, SOCK_DGRAM,
224 2 50       221 $self->{proto_num}) ||
225             croak("udp socket error - $!");
226 2         15 $self->_setopts();
227             }
228             elsif ($self->{proto} eq "icmp")
229             {
230 9 50       27 croak("icmp ping requires root privilege") if !_isroot();
231 9   33     18 $self->{proto_num} = eval { (getprotobyname('icmp'))[2] } ||
232             croak("Can't get icmp protocol by name");
233 9         47 $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid
234 9         67 $self->{fh} = FileHandle->new();
235 9 50       759 socket($self->{fh}, PF_INET, SOCK_RAW, $self->{proto_num}) ||
236             croak("icmp socket error - $!");
237 9         57 $self->_setopts();
238 9 100       35 if ($self->{'ttl'}) {
239 2 50       29 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 1 50 33     6 if $self->{family} and $self->{family} != $AF_INET6;
248 1         3 $self->{family} = $AF_INET6;
249 1   33     2 $self->{proto_num} = eval { (getprotobyname('ipv6-icmp'))[2] } ||
250             croak("Can't get ipv6-icmp protocol by name"); # 58
251 1         8 $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid
252 1         10 $self->{fh} = FileHandle->new();
253 1 50       119 socket($self->{fh}, $AF_INET6, SOCK_RAW, $self->{proto_num}) ||
254             croak("icmp socket error - $!");
255 1         7 $self->_setopts();
256 1 50       3 if ($self->{'gateway'}) {
257 0         0 my $g = $self->{gateway};
258 0 0       0 my $ip = $self->_resolv($g)
259             or croak("nonexistent gateway $g");
260 0 0       0 $self->{family} eq $AF_INET6
261             or croak("gateway requires the AF_INET6 family");
262 0 0       0 $ip->{family} eq $AF_INET6
263             or croak("gateway address needs to be IPv6");
264 0   0     0 my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21
265 0 0       0 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip))
266             or croak "error configuring gateway to $g NEXTHOP $!";
267             }
268 1 50       4 if (exists $self->{IPV6_USE_MIN_MTU}) {
269 0   0     0 my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 42;
270             setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU,
271 0 0       0 pack("I*", $self->{'IPV6_USE_MIN_MT'}))
272             or croak "error configuring IPV6_USE_MIN_MT} $!";
273             }
274 1 50       4 if (exists $self->{IPV6_RECVPATHMTU}) {
275 0   0     0 my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43;
276             setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU,
277 0 0       0 pack("I*", $self->{'RECVPATHMTU'}))
278             or croak "error configuring IPV6_RECVPATHMTU $!";
279             }
280 1 50       3 if ($self->{'tos'}) {
281 0 0       0 my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6;
282 0 0       0 setsockopt($self->{fh}, $proto, IP_TOS, pack("I*", $self->{'tos'}))
283             or croak "error configuring tos to $self->{'tos'} $!";
284             }
285 1 50       4 if ($self->{'ttl'}) {
286 0 0       0 my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6;
287 0 0       0 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 15   33     33 $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } ||
294             croak("Can't get tcp protocol by name");
295             $self->{port_num} = $self->{port}
296 15   33     719 || (getservbyname('echo', 'tcp'))[2]
297             || croak("Can't get tcp echo port by name");
298 15         195 $self->{fh} = FileHandle->new();
299             }
300             elsif ($self->{proto} eq "syn")
301             {
302 8   33     18 $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } ||
303             croak("Can't get tcp protocol by name");
304 8   33     315 $self->{port_num} = (getservbyname('echo', 'tcp'))[2] ||
305             croak("Can't get tcp echo port by name");
306 8 50       45 if ($syn_forking) {
307 0         0 $self->{fork_rd} = FileHandle->new();
308 0         0 $self->{fork_wr} = FileHandle->new();
309 0         0 pipe($self->{fork_rd}, $self->{fork_wr});
310 0         0 $self->{fh} = FileHandle->new();
311 0         0 $self->{good} = {};
312 0         0 $self->{bad} = {};
313             } else {
314 8         18 $self->{wbits} = "";
315 8         20 $self->{bad} = {};
316             }
317 8         30 $self->{syn} = {};
318 8         20 $self->{stop_time} = 0;
319             }
320              
321 35         912 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.
327             sub bind
328             {
329 0     0 1 0 my ($self,
330             $local_addr # Name or IP number of local interface
331             ) = @_;
332 0         0 my ($ip, # Hash of addr (string), addr_in (packed), family
333             $h # resolved hash
334             );
335              
336 0 0       0 croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
337             croak("already bound") if defined($self->{local_addr}) &&
338 0 0 0     0 ($self->{proto} eq "udp" || $self->{proto} eq "icmp");
      0        
339              
340 0         0 $ip = $self->_resolv($local_addr);
341 0 0       0 carp("nonexistent local address $local_addr") unless defined($ip);
342 0         0 $self->{local_addr} = $ip;
343              
344 0 0 0     0 if (($self->{proto} ne "udp") &&
      0        
      0        
345             ($self->{proto} ne "icmp") &&
346             ($self->{proto} ne "tcp") &&
347             ($self->{proto} ne "syn"))
348             {
349 0         0 croak("Unknown protocol \"$self->{proto}\" in bind()");
350             }
351              
352 0         0 return 1;
353             }
354              
355             # Description: A select() wrapper that compensates for platform
356             # peculiarities.
357             sub mselect
358             {
359 64 50 33 64 1 455 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 0         0 my $t = $_[3];
365 0         0 my $gran = 0.5; # polling granularity in seconds
366 0         0 my @args = @_;
367 0         0 while (1) {
368 0 0       0 $gran = $t if $gran > $t;
369 0         0 my $nfound = select($_[0], $_[1], $_[2], $gran);
370 0 0       0 undef $nfound if $nfound == -1;
371 0         0 $t -= $gran;
372 0 0 0     0 return $nfound if $nfound or !defined($nfound) or $t <= 0;
      0        
373              
374 0         0 sleep(0);
375 0         0 ($_[0], $_[1], $_[2]) = @args;
376             }
377             }
378             else {
379 64         55174337 my $nfound = select($_[0], $_[1], $_[2], $_[3]);
380 64 50       619 undef $nfound if $nfound == -1;
381 63         372 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              
389             sub source_verify
390             {
391 0     0 1 0 my $self = shift;
392 0 0 0     0 $source_verify = 1 unless defined
    0          
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              
400             sub service_check
401             {
402 14     14 1 2429 my $self = shift;
403             $self->{econnrefused} = 1 unless defined
404 14 50       52 ($self->{econnrefused} = shift());
405             }
406              
407             sub tcp_service_check
408             {
409 0     0 1 0 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              
416             sub retrans
417             {
418 0     0 1 0 my $self = shift;
419 0         0 $self->{retrans} = shift;
420             }
421              
422             sub _IsAdminUser {
423 0 0 0 0   0 return unless $^O eq 'MSWin32' or $^O eq "cygwin";
424 0 0       0 return unless eval { require Win32 };
  0         0  
425 0 0       0 return unless defined &Win32::IsAdminUser;
426 0         0 return Win32::IsAdminUser();
427             }
428              
429             sub _isroot {
430 16 50 33 16   863 if (($> and $^O ne 'VMS' and $^O ne 'cygwin')
      33        
      33        
      33        
      33        
      33        
      33        
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 0         0 return 0;
436             }
437             else {
438 16         67 return 1;
439             }
440             }
441              
442             # Description: Sets ipv6 reachability
443             # REACHCONF was removed in RFC3542, ping6 -R supports it. requires root.
444              
445             sub IPV6_REACHCONF
446             {
447 0     0 1 0 my $self = shift;
448 0         0 my $on = shift;
449 0 0       0 if ($on) {
450 0         0 my $reachconf = eval { Socket::IPV6_REACHCONF() };
  0         0  
451 0 0       0 if (!$reachconf) {
452 0         0 carp "IPV6_REACHCONF not supported on this platform";
453 0         0 return 0;
454             }
455 0 0       0 if (!_isroot()) {
456 0         0 carp "IPV6_REACHCONF requires root permissions";
457 0         0 return 0;
458             }
459 0         0 $self->{IPV6_REACHCONF} = 1;
460             }
461             else {
462 0         0 return $self->{IPV6_REACHCONF};
463             }
464             }
465              
466             # Description: set it on or off.
467              
468             sub IPV6_USE_MIN_MTU
469             {
470 0     0 1 0 my $self = shift;
471 0         0 my $on = shift;
472 0 0       0 if (defined $on) {
473 0   0     0 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 0 0       0 $self->{IPV6_USE_MIN_MTU} = $on ? 1 : 0;
479             setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU,
480 0 0       0 pack("I*", $self->{'IPV6_USE_MIN_MT'}))
481             or croak "error configuring IPV6_USE_MIN_MT} $!";
482             }
483             else {
484 0         0 return $self->{IPV6_USE_MIN_MTU};
485             }
486             }
487              
488             # Description: notify an according MTU
489              
490             sub IPV6_RECVPATHMTU
491             {
492 0     0 1 0 my $self = shift;
493 0         0 my $on = shift;
494 0 0       0 if ($on) {
495 0   0     0 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 0         0 $self->{IPV6_RECVPATHMTU} = 1;
501             setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU,
502 0 0       0 pack("I*", $self->{'IPV6_RECVPATHMTU'}))
503             or croak "error configuring IPV6_RECVPATHMTU} $!";
504             }
505             else {
506 0         0 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;
514             sub hires
515             {
516 3     3 1 2378 my $self = shift;
517 3 50 33     24 $hires = 1 unless defined
    100          
518             ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
519             }
520              
521             sub time
522             {
523 109 50   109 1 635 return $hires ? Time::HiRes::time() : CORE::time();
524             }
525              
526             # Description: Sets or clears the O_NONBLOCK flag on a file handle.
527             sub socket_blocking_mode
528             {
529 83     83 1 301 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 83         152 my $flags;
536 83 50 33     712 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 0         0 my $f = 0x8004667e;
540 0 0       0 my $v = pack("L", $block ? 0 : 1);
541 0 0       0 ioctl($fh, $f, $v) or croak("ioctl failed: $!");
542 0         0 return;
543             }
544 83 50       828 if ($flags = fcntl($fh, F_GETFL, 0)) {
545 83 100       340 $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
546 83 50       1047 if (!fcntl($fh, F_SETFL, $flags)) {
547 0         0 croak("fcntl F_SETFL: $!");
548             }
549             } else {
550 0         0 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              
559             sub ping
560             {
561 61     61 1 26474 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 61         155 my ($ip, # Hash of addr (string), addr_in (packed), family
567             $ret, # The return value
568             $ping_time, # When ping began
569             );
570              
571 61 0 33     266 $host = $self->{host} if !defined $host and $self->{host};
572 61 50 33     430 croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host;
573 61 50       281 $timeout = $self->{timeout} unless $timeout;
574 61 50       192 croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
575              
576 61 50       205 if ($family) {
577 0 0       0 if ($family =~ $qr_family) {
578 0 0       0 if ($family =~ $qr_family4) {
579 0         0 $self->{family_local} = AF_INET;
580             } else {
581 0         0 $self->{family_local} = $AF_INET6;
582             }
583             } else {
584 0         0 croak('Family must be "ipv4" or "ipv6"')
585             }
586             } else {
587 61         163 $self->{family_local} = $self->{family};
588             }
589            
590 61         240 $ip = $self->_resolv($host);
591 61 50       245 return () unless defined($ip); # Does host exist?
592              
593             # Dispatch to the appropriate routine.
594 61         225 $ping_time = &time();
595 61 50       585 if ($self->{proto} eq "external") {
    100          
    100          
    100          
    100          
    50          
    50          
596 0         0 $ret = $self->ping_external($ip, $timeout);
597             }
598             elsif ($self->{proto} eq "udp") {
599 1         7 $ret = $self->ping_udp($ip, $timeout);
600             }
601             elsif ($self->{proto} eq "icmp") {
602 4         23 $ret = $self->ping_icmp($ip, $timeout);
603             }
604             elsif ($self->{proto} eq "icmpv6") {
605 1         6 $ret = $self->ping_icmpv6($ip, $timeout);
606             }
607             elsif ($self->{proto} eq "tcp") {
608 29         118 $ret = $self->ping_tcp($ip, $timeout);
609             }
610             elsif ($self->{proto} eq "stream") {
611 0         0 $ret = $self->ping_stream($ip, $timeout);
612             }
613             elsif ($self->{proto} eq "syn") {
614 26         242 $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
615             } else {
616 0         0 croak("Unknown protocol \"$self->{proto}\" in ping()");
617             }
618              
619 60 100       602 return wantarray ? ($ret, &time() - $ping_time, $self->ntop($ip)) : $ret;
620             }
621              
622             # Uses Net::Ping::External to do an external ping.
623             sub ping_external {
624 0     0 1 0 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 0 0 0     0 $ip = $self->{host} if !defined $ip and $self->{host};
631 0 0 0     0 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
632             my @addr = exists $ip->{addr_in}
633             ? ('ip' => $ip->{addr_in})
634 0 0       0 : ('host' => $ip->{host});
635              
636 0 0       0 eval {
637 0         0 local @INC = @INC;
638 0 0       0 pop @INC if $INC[-1] eq '.';
639 0         0 require Net::Ping::External;
640             } or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
641 0         0 return Net::Ping::External::ping(@addr, timeout => $timeout,
642             family => $family);
643             }
644              
645             # h2ph "asm/socket.h"
646             # require "asm/socket.ph";
647 20     20   200 use constant SO_BINDTODEVICE => 25;
  20         46  
  20         2217  
648 20     20   149 use constant ICMP_ECHOREPLY => 0; # ICMP packet types
  20         50  
  20         1160  
649 20     20   143 use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types
  20         77  
  20         1135  
650 20     20   136 use constant ICMP_UNREACHABLE => 3; # ICMP packet types
  20         54  
  20         1156  
651 20     20   142 use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types
  20         51  
  20         1079  
652 20     20   146 use constant ICMPv6_NI_REPLY => 140; # ICMP packet types
  20         40  
  20         984  
653 20     20   123 use constant ICMP_ECHO => 8;
  20         53  
  20         1009  
654 20     20   122 use constant ICMPv6_ECHO => 128;
  20         38  
  20         1127  
655 20     20   132 use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types
  20         36  
  20         1019  
656 20     20   130 use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types
  20         50  
  20         1080  
657 20     20   145 use constant ICMP_TIMESTAMP => 13;
  20         72  
  20         1239  
658 20     20   140 use constant ICMP_TIMESTAMP_REPLY => 14;
  20         61  
  20         1664  
659 20     20   152 use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
  20         54  
  20         1103  
660 20     20   124 use constant ICMP_TIMESTAMP_STRUCT => "C2 n3 N3"; # Structure of a minimal timestamp ICMP packet
  20         37  
  20         984  
661 20     20   124 use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
  20         39  
  20         953  
662 20     20   122 use constant ICMP_FLAGS => 0; # No special flags for send or recv
  20         40  
  20         894  
663 20     20   113 use constant ICMP_PORT => 0; # No port with ICMP
  20         38  
  20         983  
664 20     20   124 use constant IP_MTU_DISCOVER => 10; # linux only
  20         44  
  20         63006  
665              
666             sub message_type
667             {
668 6     6 1 1866 my ($self,
669             $type
670             ) = @_;
671              
672             croak "Setting message type only supported on 'icmp' protocol"
673 6 100       951 unless $self->{proto} eq 'icmp';
674              
675 2 100 50     16 return $self->{message_type} || 'echo'
676             unless defined($type);
677              
678 1 50       213 croak "Supported icmp message type are limited to 'echo' and 'timestamp': '$type' not supported"
679             unless $type =~ /^echo|timestamp$/i;
680              
681 0         0 $self->{message_type} = lc($type);
682             }
683              
684             sub ping_icmp
685             {
686 5     5 1 14 my ($self,
687             $ip, # Hash of addr (string), addr_in (packed), family
688             $timeout # Seconds after which ping times out
689             ) = @_;
690              
691 5         21 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 5 0 33     22 $ip = $self->{host} if !defined $ip and $self->{host};
715 5 0 33     26 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
716 5 50 33     25 $timestamp_msg = $self->{message_type} && $self->{message_type} eq 'timestamp' ? 1 : 0;
717              
718 5 50       230 socket($self->{fh}, $ip->{family}, SOCK_RAW, $self->{proto_num}) ||
719             croak("icmp socket error - $!");
720              
721 5 50 33     26 if (defined $self->{local_addr} &&
722             !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
723 0         0 croak("icmp bind error - $!");
724             }
725 5         23 $self->_setopts();
726              
727 5         17 $self->{seq} = ($self->{seq} + 1) % 65536; # Increment sequence
728 5         10 $checksum = 0; # No checksum for starters
729 5 100       15 if ($ip->{family} == AF_INET) {
730 4 50       10 if ($timestamp_msg) {
731             $msg = pack(ICMP_TIMESTAMP_STRUCT, ICMP_TIMESTAMP, SUBCODE,
732 0         0 $checksum, $self->{pid}, $self->{seq}, 0, 0, 0);
733             } else {
734             $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
735 4         36 $checksum, $self->{pid}, $self->{seq}, $self->{data});
736             }
737             } else {
738             # how to get SRC
739 1         13 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 1         7 $checksum, $self->{pid}, $self->{seq}, $self->{data});
742 1         3 $msg = $pseudo_header.$msg
743             }
744 5         28 $checksum = Net::Ping->checksum($msg);
745 5 100       16 if ($ip->{family} == AF_INET) {
746 4 50       17 if ($timestamp_msg) {
747             $msg = pack(ICMP_TIMESTAMP_STRUCT, ICMP_TIMESTAMP, SUBCODE,
748 0         0 $checksum, $self->{pid}, $self->{seq}, 0, 0, 0);
749             } else {
750             $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE,
751 4         20 $checksum, $self->{pid}, $self->{seq}, $self->{data});
752             }
753             } else {
754             $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE,
755 1         13 $checksum, $self->{pid}, $self->{seq}, $self->{data});
756             }
757 5         9 $len_msg = length($msg);
758 5         18 $saddr = _pack_sockaddr_in(ICMP_PORT, $ip);
759 5         15 $self->{from_ip} = undef;
760 5         10 $self->{from_type} = undef;
761 5         10 $self->{from_subcode} = undef;
762 5         336 send($self->{fh}, $msg, ICMP_FLAGS, $saddr); # Send the message
763              
764 5         22 $rbits = "";
765 5         28 vec($rbits, $self->{fh}->fileno(), 1) = 1;
766 5         58 $ret = 0;
767 5         8 $done = 0;
768 5         29 $finish_time = &time() + $timeout; # Must be done by this time
769 5   66     49 while (!$done && $timeout > 0) # Keep trying if we have time
770             {
771 9         32 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
772 9         29 $timeout = $finish_time - &time(); # Get remaining time
773 9 50       31 if (!defined($nfound)) # Hmm, a strange error
    100          
774             {
775 0         0 $ret = undef;
776 0         0 $done = 1;
777             }
778             elsif ($nfound) # Got a packet from somewhere
779             {
780 8         17 $recv_msg = "";
781 8         11 $from_pid = -1;
782 8         9 $from_seq = -1;
783 8         102 $from_saddr = recv($self->{fh}, $recv_msg, 1500, ICMP_FLAGS);
784 8         40 $recv_msg_len = length($recv_msg) - length($self->{data});
785 8         23 ($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 8 50       20 my $off = ($ip->{family} == AF_INET) ? 20 : 0; # payload offset
790 8         27 ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, $off, 2));
791 8 50 66     54 if ($from_type == ICMP_TIMESTAMP_REPLY) {
    100          
    50          
792 0 0       0 ($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 4 50       25 ($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 0 0 0     0 if ($ip->{family} == $AF_INET6 && length $recv_msg == 8);
801             } else {
802             #warn "ICMP: ", $from_type, " ",$ip->{family}, " ",$recv_msg, ":", length($recv_msg);
803 4 50       19 ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, $off + 32, 4))
804             if length $recv_msg >= $off + 36;
805             }
806 8         16 $self->{from_ip} = $from_ip;
807 8         13 $self->{from_type} = $from_type;
808 8         27 $self->{from_subcode} = $from_subcode;
809 8 100       31 next if ($from_pid != $self->{pid});
810 4 50       17 next if ($from_seq != $self->{seq});
811 4 50 33     35 if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out?
812 4 50 33     25 if (!$timestamp_msg && (($from_type == ICMP_ECHOREPLY) || ($from_type == ICMPv6_ECHOREPLY))) {
    0 33        
    0 0        
    0 0        
813 4         8 $ret = 1;
814 4         14 $done = 1;
815             } elsif ($timestamp_msg && $from_type == ICMP_TIMESTAMP_REPLY) {
816 0         0 $ret = 1;
817 0         0 $done = 1;
818             } elsif (($from_type == ICMP_UNREACHABLE) || ($from_type == ICMPv6_UNREACHABLE)) {
819 0         0 $done = 1;
820             } elsif ($from_type == ICMP_TIME_EXCEEDED) {
821 0         0 $ret = 0;
822 0         0 $done = 1;
823             }
824             }
825             } else { # Oops, timed out
826 1         7 $done = 1;
827             }
828             }
829 5         15 return $ret;
830             }
831              
832             sub ping_icmpv6
833             {
834 1     1 1 9 shift->ping_icmp(@_);
835             }
836              
837             sub icmp_result {
838 0     0 1 0 my ($self) = @_;
839 0   0     0 my $addr = $self->{from_ip} || "";
840 0 0       0 $addr = "\0\0\0\0" unless 4 == length $addr;
841 0   0     0 return ($self->ntop($addr),($self->{from_type} || 0), ($self->{from_subcode} || 0));
      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              
847             sub checksum
848             {
849 5     5 1 16 my ($class,
850             $msg # The message to checksum
851             ) = @_;
852 5         11 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 5         11 $len_msg = length($msg);
859 5         16 $num_short = int($len_msg / 2);
860 5         27 $chk = 0;
861 5         31 foreach $short (unpack("n$num_short", $msg))
862             {
863 40         55 $chk += $short;
864             } # Add the odd byte in
865 5 50       18 $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
866 5         15 $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
867 5         17 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              
881             sub ping_tcp
882             {
883 29     29 1 74 my ($self,
884             $ip, # Hash of addr (string), addr_in (packed), family
885             $timeout # Seconds after which ping times out
886             ) = @_;
887 29         52 my ($ret # The return value
888             );
889              
890 29 0 33     95 $ip = $self->{host} if !defined $ip and $self->{host};
891 29 0 33     100 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
892              
893 29         106 $! = 0;
894 29         162 $ret = $self -> tcp_connect( $ip, $timeout);
895 28 100 100     405 if (!$self->{econnrefused} &&
896             $! == ECONNREFUSED) {
897 12         26 $ret = 1; # "Connection refused" means reachable
898             }
899 28         274 $self->{fh}->close();
900 28         1855 return $ret;
901             }
902              
903             sub tcp_connect
904             {
905 29     29 1 74 my ($self,
906             $ip, # Hash of addr (string), addr_in (packed), family
907             $timeout # Seconds after which connect times out
908             ) = @_;
909 29         42 my ($saddr); # Packed IP and Port
910              
911 29 0 33     74 $ip = $self->{host} if !defined $ip and $self->{host};
912 29 0 33     80 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
913              
914 29         111 $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
915              
916 29         68 my $ret = 0; # Default to unreachable
917              
918             my $do_socket = sub {
919 29 50   29   1295 socket($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num}) ||
920             croak("tcp socket error - $!");
921 29 50 33     159 if (defined $self->{local_addr} &&
922             !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
923 0         0 croak("tcp bind error - $!");
924             }
925 29         132 $self->_setopts();
926 29         252 };
927             my $do_connect = sub {
928 0     0   0 $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 0   0     0 return ($ret = connect($self->{fh}, $saddr) || ($! == ECONNREFUSED && !$self->{econnrefused}));
932 29         127 };
933             my $do_connect_nb = sub {
934             # Set O_NONBLOCK property on filehandle
935 29     29   158 $self->socket_blocking_mode($self->{fh}, 0);
936              
937             # start the connection attempt
938 29 50       3464 if (!connect($self->{fh}, $saddr)) {
939 29 50 0     439 if ($! == ECONNREFUSED) {
    50 33        
940 0 0       0 $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 0         0 return 0;
949             } else {
950             # Got the expected EINPROGRESS.
951             # Just wait for connection completion...
952 29         67 my ($wbits, $wout, $wexc);
953 29         81 $wout = $wexc = $wbits = "";
954 29         178 vec($wbits, $self->{fh}->fileno, 1) = 1;
955              
956 29 50       497 my $nfound = mselect(undef,
957             ($wout = $wbits),
958             ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
959             $timeout);
960 28 50       119 warn("select: $!") unless defined $nfound;
961              
962 28 100 66     252 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 22 100       466 if (getpeername($self->{fh})) {
968             # Connection established to remote host
969 9         57 $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 13         33 my $char;
976 13         173 sysread($self->{fh},$char,1);
977 13 50 33     130 $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
978              
979             $ret = 1 if (!$self->{econnrefused}
980 13 100 66     110 && $! == ECONNREFUSED);
981             }
982             } else {
983             # the connection attempt timed out (or there were connect
984             # errors on Windows)
985 6 50       132 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 0 0 0     0 if ($nfound && vec($wexc, $self->{fh}->fileno, 1)) {
991 0         0 $! = unpack("i", getsockopt($self->{fh}, SOL_SOCKET,
992             SO_ERROR));
993             }
994             }
995             }
996             }
997             } else {
998             # Connection established to remote host
999 0         0 $ret = 1;
1000             }
1001              
1002             # Unset O_NONBLOCK property on filehandle
1003 28         266 $self->socket_blocking_mode($self->{fh}, 1);
1004 28         160 $self->{ip} = $ip->{addr_in};
1005 28         71 return $ret;
1006 29         147 };
1007              
1008 29 50       96 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 0         0 $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
1016 0         0 $self->{'tcp_chld'} = fork;
1017 0 0       0 if (!$self->{'tcp_chld'}) {
1018 0 0       0 if (!defined $self->{'tcp_chld'}) {
1019             # Fork did not work
1020 0         0 warn "Fork error: $!";
1021 0         0 return 0;
1022             }
1023 0         0 &{ $do_socket }();
  0         0  
1024              
1025             # Try a slow blocking connect() call
1026             # and report the status to the parent.
1027 0 0       0 if ( &{ $do_connect }() ) {
  0         0  
1028 0         0 $self->{fh}->close();
1029             # No error
1030 0         0 exit 0;
1031             } else {
1032             # Pass the error status to the parent
1033             # Make sure that $! <= 255
1034 0 0       0 exit($! <= 255 ? $! : 255);
1035             }
1036             }
1037              
1038 0         0 &{ $do_socket }();
  0         0  
1039              
1040 0         0 my $patience = &time() + $timeout;
1041              
1042 0         0 my ($child, $child_errno);
1043 0         0 $? = 0; $child_errno = 0;
  0         0  
1044             # Wait up to the timeout
1045             # And clean off the zombie
1046             do {
1047 0         0 $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
1048 0         0 $child_errno = $? >> 8;
1049 0         0 select(undef, undef, undef, 0.1);
1050 0   0     0 } while &time() < $patience && $child != $self->{'tcp_chld'};
1051              
1052 0 0       0 if ($child == $self->{'tcp_chld'}) {
1053 0 0       0 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 0         0 &{ $do_connect }();
  0         0  
1058             }
1059             # $ret cannot be set by the child process
1060 0         0 $ret = !$child_errno;
1061             } else {
1062             # Time must have run out.
1063             # Put that choking client out of its misery
1064 0         0 kill "KILL", $self->{'tcp_chld'};
1065             # Clean off the zombie
1066 0         0 waitpid($self->{'tcp_chld'}, 0);
1067 0         0 $ret = 0;
1068             }
1069 0         0 delete $self->{'tcp_chld'};
1070 0         0 $! = $child_errno;
1071             } else {
1072             # Otherwise don't waste the resources to fork
1073              
1074 29         56 &{ $do_socket }();
  29         96  
1075              
1076 29         56 &{ $do_connect_nb }();
  29         78  
1077             }
1078              
1079 28         688 return $ret;
1080             }
1081              
1082             sub DESTROY {
1083 41     41   14362 my $self = shift;
1084 41 50 66     2736 if ($self->{'proto'} eq 'tcp' &&
1085             $self->{'tcp_chld'}) {
1086             # Put that choking client out of its misery
1087 0         0 kill "KILL", $self->{'tcp_chld'};
1088             # Clean off the zombie
1089 0         0 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.
1095             sub tcp_echo
1096             {
1097 0     0 1 0 my ($self, $timeout, $pingstring) = @_;
1098              
1099 0 0 0     0 $timeout = $self->{timeout} if !defined $timeout and $self->{timeout};
1100 0 0 0     0 $pingstring = $self->{pingstring} if !defined $pingstring and $self->{pingstring};
1101              
1102 0         0 my $ret = undef;
1103 0         0 my $time = &time();
1104 0         0 my $wrstr = $pingstring;
1105 0         0 my $rdstr = "";
1106              
1107 0         0 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);
1144             EOM
1145              
1146 0         0 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              
1153             sub ping_stream
1154             {
1155 0     0 1 0 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 0 0       0 if(!defined $self->{fh}->fileno()) {
1162 0 0       0 $self->tcp_connect($ip, $timeout) or return 0;
1163             }
1164              
1165             croak "tried to switch servers while stream pinging"
1166 0 0       0 if $self->{ip} ne $ip->{addr_in};
1167              
1168 0         0 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              
1174             sub open
1175             {
1176 0     0 1 0 my ($self,
1177             $host, # Host or IP address
1178             $timeout, # Seconds after which open times out
1179             $family
1180             ) = @_;
1181 0         0 my $ip; # Hash of addr (string), addr_in (packed), family
1182 0 0       0 $host = $self->{host} unless defined $host;
1183              
1184 0 0       0 if ($family) {
1185 0 0       0 if ($family =~ $qr_family) {
1186 0 0       0 if ($family =~ $qr_family4) {
1187 0         0 $self->{family_local} = AF_INET;
1188             } else {
1189 0         0 $self->{family_local} = $AF_INET6;
1190             }
1191             } else {
1192 0         0 croak('Family must be "ipv4" or "ipv6"')
1193             }
1194             } else {
1195 0         0 $self->{family_local} = $self->{family};
1196             }
1197              
1198 0 0       0 $timeout = $self->{timeout} unless $timeout;
1199 0         0 $ip = $self->_resolv($host);
1200              
1201 0 0       0 if ($self->{proto} eq "stream") {
1202 0 0       0 if (defined($self->{fh}->fileno())) {
1203 0         0 croak("socket is already open");
1204             } else {
1205 0 0       0 return () unless $ip;
1206 0         0 $self->tcp_connect($ip, $timeout);
1207             }
1208             }
1209             }
1210              
1211             sub _dontfrag {
1212 0     0   0 my $self = shift;
1213             # bsd solaris
1214 0         0 my $IP_DONTFRAG = eval { Socket::IP_DONTFRAG() };
  0         0  
1215 0 0       0 if ($IP_DONTFRAG) {
1216 0         0 my $i = 1;
1217 0 0       0 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 0 0       0 if ($^O eq 'linux') {
1225 0         0 my $i = 2; # IP_PMTUDISC_DO
1226 0 0       0 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
1233             sub _setopts {
1234 73     73   297 my $self = shift;
1235 73 50       303 if ($self->{'device'}) {
1236 0 0       0 setsockopt($self->{fh}, SOL_SOCKET, SO_BINDTODEVICE, pack("Z*", $self->{'device'}))
1237             or croak "error binding to device $self->{'device'} $!";
1238             }
1239 73 100       240 if ($self->{'tos'}) { # need to re-apply ToS (RT #6706)
1240 2 50       34 setsockopt($self->{fh}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'}))
1241             or croak "error applying tos to $self->{'tos'} $!";
1242             }
1243 73 50       275 if ($self->{'dontfrag'}) {
1244 0         0 $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              
1256 20     20   231 use constant UDP_FLAGS => 0; # Nothing special on send or recv
  20         42  
  20         85637  
1257             sub ping_udp
1258             {
1259 1     1 1 4 my ($self,
1260             $ip, # Hash of addr (string), addr_in (packed), family
1261             $timeout # Seconds after which ping times out
1262             ) = @_;
1263              
1264 1         4 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 1         9 $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
1280 1         5 $self->{seq} = ($self->{seq} + 1) % 256; # Increment sequence
1281 1         4 $msg = chr($self->{seq}) . $self->{data}; # Add data if any
1282              
1283             socket($self->{fh}, $ip->{family}, SOCK_DGRAM,
1284 1 50       48 $self->{proto_num}) ||
1285             croak("udp socket error - $!");
1286              
1287 1 50 33     6 if (defined $self->{local_addr} &&
1288             !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
1289 0         0 croak("udp bind error - $!");
1290             }
1291              
1292 1         5 $self->_setopts();
1293              
1294 1 50       12 if ($self->{connected}) {
1295 0 0       0 if ($self->{connected} ne $saddr) {
1296             # Still connected to wrong destination.
1297             # Need to flush out the old one.
1298 0         0 $flush = 1;
1299             }
1300             } else {
1301             # Not connected yet.
1302             # Need to connect() before send()
1303 1         3 $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 1 50       4 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 0         0 $self->{proto_num});
1316 0         0 $self->_setopts();
1317             }
1318             # Connect the socket if it isn't already connected
1319             # to the right destination.
1320 1 50 33     6 if ($flush || $connect) {
1321 1         30 connect($self->{fh}, $saddr); # Tie destination to socket
1322 1         8 $self->{connected} = $saddr;
1323             }
1324 1         108 send($self->{fh}, $msg, UDP_FLAGS); # Send it
1325              
1326 1         5 $rbits = "";
1327 1         8 vec($rbits, $self->{fh}->fileno(), 1) = 1;
1328 1         13 $ret = 0; # Default to unreachable
1329 1         2 $done = 0;
1330 1         3 my $retrans = 0.01;
1331 1         2 my $factor = $self->{retrans};
1332 1         3 $finish_time = &time() + $timeout; # Ping needs to be done by then
1333 1   66     9 while (!$done && $timeout > 0)
1334             {
1335 1 50       3 if ($factor > 1)
1336             {
1337 1 50       4 $timeout = $retrans if $timeout > $retrans;
1338 1         2 $retrans*= $factor; # Exponential backoff
1339             }
1340 1         6 $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
1341 1         4 my $why = $!;
1342 1         2 $timeout = $finish_time - &time(); # Get remaining time
1343              
1344 1 50       5 if (!defined($nfound)) # Hmm, a strange error
    50          
    0          
1345             {
1346 0         0 $ret = undef;
1347 0         0 $done = 1;
1348             }
1349             elsif ($nfound) # A packet is waiting
1350             {
1351 1         3 $from_msg = "";
1352 1         15 $from_saddr = recv($self->{fh}, $from_msg, 1500, UDP_FLAGS);
1353 1 50       4 if (!$from_saddr) {
1354             # For example an unreachable host will make recv() fail.
1355 1 50 33     26 if (!$self->{econnrefused} &&
      33        
1356             ($! == ECONNREFUSED ||
1357             $! == ECONNRESET)) {
1358             # "Connection refused" means reachable
1359             # Good, continue
1360 1         3 $ret = 1;
1361             }
1362 1         4 $done = 1;
1363             } else {
1364 0         0 ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family});
1365 0 0       0 my $addr_in = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip;
1366 0 0 0     0 if (!$source_verify ||
      0        
      0        
1367             (($from_ip eq $addr_in) && # Does the packet check out?
1368             ($from_port == $self->{port_num}) &&
1369             ($from_msg eq $msg)))
1370             {
1371 0         0 $ret = 1; # It's a winner
1372 0         0 $done = 1;
1373             }
1374             }
1375             }
1376             elsif ($timeout <= 0) # Oops, timed out
1377             {
1378 0         0 $done = 1;
1379             }
1380             else
1381             {
1382             # Send another in case the last one dropped
1383 0 0       0 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 0 0 0     0 if (!$self->{econnrefused} &&
1389             $! == ECONNREFUSED) {
1390             # "Connection refused" means reachable
1391             # Good, continue
1392 0         0 $ret = 1;
1393             }
1394 0         0 $done = 1;
1395             }
1396             }
1397             }
1398 1         4 return $ret;
1399             }
1400              
1401             # Description: Send a TCP SYN packet to host specified.
1402             sub ping_syn
1403             {
1404 26     26 1 89 my $self = shift;
1405 26         67 my $host = shift;
1406 26         47 my $ip = shift;
1407 26         51 my $start_time = shift;
1408 26         51 my $stop_time = shift;
1409              
1410 26 50       92 if ($syn_forking) {
1411 0         0 return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
1412             }
1413              
1414 26         376 my $fh = FileHandle->new();
1415 26         1616 my $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
1416              
1417             # Create TCP socket
1418 26 50       1419 if (!socket ($fh, $ip->{family}, SOCK_STREAM, $self->{proto_num})) {
1419 0         0 croak("tcp socket error - $!");
1420             }
1421              
1422 26 50 33     180 if (defined $self->{local_addr} &&
1423             !CORE::bind($fh, _pack_sockaddr_in(0, $self->{local_addr}))) {
1424 0         0 croak("tcp bind error - $!");
1425             }
1426              
1427 26         146 $self->_setopts();
1428             # Set O_NONBLOCK property on filehandle
1429 26         118 $self->socket_blocking_mode($fh, 0);
1430              
1431             # Attempt the non-blocking connect
1432             # by just sending the TCP SYN packet
1433 26 50       3387 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 26 50 0     503 if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
      33        
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 0         0 $self->{bad}->{$host} = $!;
1447             }
1448             }
1449              
1450 26         167 my $entry = [ $host, $ip, $fh, $start_time, $stop_time, $self->{port_num} ];
1451 26         184 $self->{syn}->{$fh->fileno} = $entry;
1452 26 50       345 if ($self->{stop_time} < $stop_time) {
1453 26         65 $self->{stop_time} = $stop_time;
1454             }
1455 26         84 vec($self->{wbits}, $fh->fileno, 1) = 1;
1456              
1457 26         287 return 1;
1458             }
1459              
1460             sub ping_syn_fork {
1461 0     0 1 0 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 0         0 my $pid = fork();
1467 0 0       0 if (defined $pid) {
1468 0 0       0 if ($pid) {
1469             # Parent process
1470 0         0 my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
1471 0         0 $self->{syn}->{$pid} = $entry;
1472 0 0       0 if ($self->{stop_time} < $stop_time) {
1473 0         0 $self->{stop_time} = $stop_time;
1474             }
1475             } else {
1476             # Child process
1477 0         0 my $saddr = _pack_sockaddr_in($self->{port_num}, $ip);
1478              
1479             # Create TCP socket
1480 0 0       0 if (!socket ($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num})) {
1481 0         0 croak("tcp socket error - $!");
1482             }
1483              
1484 0 0 0     0 if (defined $self->{local_addr} &&
1485             !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) {
1486 0         0 croak("tcp bind error - $!");
1487             }
1488              
1489 0         0 $self->_setopts();
1490              
1491 0         0 $!=0;
1492             # Try to connect (could take a long time)
1493 0         0 connect($self->{fh}, $saddr);
1494             # Notify parent of connect error status
1495 0         0 my $err = $!+0;
1496 0         0 my $wrstr = "$$ $err";
1497             # Force to 16 chars including \n
1498 0         0 $wrstr .= " "x(15 - length $wrstr). "\n";
1499 0         0 syswrite($self->{fork_wr}, $wrstr, length $wrstr);
1500 0         0 exit;
1501             }
1502             } else {
1503             # fork() failed?
1504 0         0 die "fork: $!";
1505             }
1506 0         0 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.
1512             sub ack
1513             {
1514 28     28 1 16112 my $self = shift;
1515              
1516 28 50       113 if ($self->{proto} eq "syn") {
1517 28 50       74 if ($syn_forking) {
1518 0         0 my @answer = $self->ack_unfork(shift);
1519 0 0       0 return wantarray ? @answer : $answer[0];
1520             }
1521 28         52 my $wbits = "";
1522 28         50 my $stop_time = 0;
1523 28 100 66     130 if (my $host = shift or $self->{host}) {
1524             # Host passed as arg or as option to new
1525 8 50       30 $host = $self->{host} unless defined $host;
1526 8 50       27 if (exists $self->{bad}->{$host}) {
1527 0 0 0     0 if (!$self->{econnrefused} &&
      0        
      0        
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 0         0 return ();
1536             }
1537             }
1538 8         14 my $host_fd = undef;
1539 8         16 foreach my $fd (keys %{ $self->{syn} }) {
  8         36  
1540 16         37 my $entry = $self->{syn}->{$fd};
1541 16 100       49 if ($entry->[0] eq $host) {
1542 8         15 $host_fd = $fd;
1543 8   33     50 $stop_time = $entry->[4]
1544             || croak("Corrupted SYN entry for [$host]");
1545 8         19 last;
1546             }
1547             }
1548 8 50       24 croak("ack called on [$host] without calling ping first!")
1549             unless defined $host_fd;
1550 8         49 vec($wbits, $host_fd, 1) = 1;
1551             } else {
1552             # No $host passed so scan all hosts
1553             # Use the latest stop_time
1554 20         37 $stop_time = $self->{stop_time};
1555             # Use all the bits
1556 20         36 $wbits = $self->{wbits};
1557             }
1558              
1559 28         170 while ($wbits !~ /^\0*\z/) {
1560 25         72 my $timeout = $stop_time - &time();
1561             # Force a minimum of 10 ms timeout.
1562 25 100       81 $timeout = 0.01 if $timeout <= 0.01;
1563              
1564 25         42 my $winner_fd = undef;
1565 25         44 my $wout = $wbits;
1566 25         40 my $fd = 0;
1567             # Do "bad" fds from $wbits first
1568 25         95 while ($wout !~ /^\0*\z/) {
1569 239 100       430 if (vec($wout, $fd, 1)) {
1570             # Wipe it from future scanning.
1571 68         154 vec($wout, $fd, 1) = 0;
1572 68 50       199 if (my $entry = $self->{syn}->{$fd}) {
1573 68 50       162 if ($self->{bad}->{ $entry->[0] }) {
1574 0         0 $winner_fd = $fd;
1575 0         0 last;
1576             }
1577             }
1578             }
1579 239         536 $fd++;
1580             }
1581              
1582 25 100 66     123 if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
    50          
1583 22 50       83 if (defined $winner_fd) {
1584 0         0 $fd = $winner_fd;
1585             } else {
1586             # Done waiting for one of the ACKs
1587 22         52 $fd = 0;
1588             # Determine which one
1589 22   66     194 while ($wout !~ /^\0*\z/ &&
1590             !vec($wout, $fd, 1)) {
1591 150         480 $fd++;
1592             }
1593             }
1594 22 50       100 if (my $entry = $self->{syn}->{$fd}) {
1595             # Wipe it from future scanning.
1596 22         73 delete $self->{syn}->{$fd};
1597 22         80 vec($self->{wbits}, $fd, 1) = 0;
1598 22         69 vec($wbits, $fd, 1) = 0;
1599 22 50 66     365 if (!$self->{econnrefused} &&
    100 33        
      33        
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 3         12 my $char;
1614 3         43 sysread($entry->[2],$char,1);
1615             # Store the excuse why the connection failed.
1616 3         38 $self->{bad}->{$entry->[0]} = $!;
1617 3 100 33     37 if (!$self->{econnrefused} &&
      66        
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 1         28 next;
1625             }
1626             }
1627             # Everything passed okay, return the answer
1628             return wantarray ?
1629 21 100       1326 ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]), $entry->[5])
1630             : $entry->[0];
1631             } else {
1632 0         0 warn "Corrupted SYN entry: unknown fd [$fd] ready!";
1633 0         0 vec($wbits, $fd, 1) = 0;
1634 0         0 vec($self->{wbits}, $fd, 1) = 0;
1635             }
1636             } elsif (defined $nfound) {
1637             # Timed out waiting for ACK
1638 3         10 foreach my $fd (keys %{ $self->{syn} }) {
  3         58  
1639 10 100       58 if (vec($wbits, $fd, 1)) {
1640 4         20 my $entry = $self->{syn}->{$fd};
1641 4         28 $self->{bad}->{$entry->[0]} = "Timed out";
1642 4         31 vec($wbits, $fd, 1) = 0;
1643 4         30 vec($self->{wbits}, $fd, 1) = 0;
1644 4         323 delete $self->{syn}->{$fd};
1645             }
1646             }
1647             } else {
1648             # Weird error occurred with select()
1649 0         0 warn("select: $!");
1650 0         0 $self->{syn} = {};
1651 0         0 $wbits = "";
1652             }
1653             }
1654             }
1655 7         59 return ();
1656             }
1657              
1658             sub ack_unfork {
1659 0     0 1 0 my ($self,$host) = @_;
1660 0         0 my $stop_time = $self->{stop_time};
1661 0 0       0 if ($host) {
1662             # Host passed as arg
1663 0 0       0 if (my $entry = $self->{good}->{$host}) {
1664 0         0 delete $self->{good}->{$host};
1665 0         0 return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]));
1666             }
1667             }
1668              
1669 0         0 my $rbits = "";
1670 0         0 my $timeout;
1671              
1672 0 0       0 if (keys %{ $self->{syn} }) {
  0         0  
1673             # Scan all hosts that are left
1674 0         0 vec($rbits, fileno($self->{fork_rd}), 1) = 1;
1675 0         0 $timeout = $stop_time - &time();
1676             # Force a minimum of 10 ms timeout.
1677 0 0       0 $timeout = 0.01 if $timeout < 0.01;
1678             } else {
1679             # No hosts left to wait for
1680 0         0 $timeout = 0;
1681             }
1682              
1683 0 0       0 if ($timeout > 0) {
1684 0         0 my $nfound;
1685 0   0     0 while ( keys %{ $self->{syn} } and
  0         0  
1686             $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
1687             # Done waiting for one of the ACKs
1688 0 0       0 if (!sysread($self->{fork_rd}, $_, 16)) {
1689             # Socket closed, which means all children are done.
1690 0         0 return ();
1691             }
1692 0         0 my ($pid, $how) = split;
1693 0 0       0 if ($pid) {
1694             # Flush the zombie
1695 0         0 waitpid($pid, 0);
1696 0 0       0 if (my $entry = $self->{syn}->{$pid}) {
1697             # Connection attempt to remote host is done
1698 0         0 delete $self->{syn}->{$pid};
1699 0 0 0     0 if (!$how || # If there was no error connecting
      0        
1700             (!$self->{econnrefused} &&
1701             $how == ECONNREFUSED)) { # "Connection refused" means reachable
1702 0 0 0     0 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 0         0 $self->{good}->{$entry->[0]} = $entry;
1706             # And wait for the next winner
1707 0         0 next;
1708             }
1709 0         0 return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]));
1710             }
1711             } else {
1712             # Should never happen
1713 0         0 die "Unknown ping from pid [$pid]";
1714             }
1715             } else {
1716 0         0 die "Empty response from status socket?";
1717             }
1718             }
1719 0 0       0 if (defined $nfound) {
1720             # Timed out waiting for ACK status
1721             } else {
1722             # Weird error occurred with select()
1723 0         0 warn("select: $!");
1724             }
1725             }
1726 0 0       0 if (my @synners = keys %{ $self->{syn} }) {
  0         0  
1727             # Kill all the synners
1728 0         0 kill 9, @synners;
1729 0         0 foreach my $pid (@synners) {
1730             # Wait for the deaths to finish
1731             # Then flush off the zombie
1732 0         0 waitpid($pid, 0);
1733             }
1734             }
1735 0         0 $self->{syn} = {};
1736 0         0 return ();
1737             }
1738              
1739             # Description: Tell why the ack() failed
1740             sub nack {
1741 0     0 1 0 my $self = shift;
1742 0   0     0 my $host = shift || croak('Usage> nack($failed_ack_host)');
1743 0   0     0 return $self->{bad}->{$host} || undef;
1744             }
1745              
1746             # Description: Close the connection.
1747              
1748             sub close
1749             {
1750 3     3 1 7 my ($self) = @_;
1751              
1752 3 50       14 if ($self->{proto} eq "syn") {
    50          
    50          
1753 0         0 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 3         11 $self->{fh}->close();
1760             }
1761             }
1762              
1763             sub port_number {
1764 8     8 1 7432 my $self = shift;
1765 8 50       49 if(@_) {
1766 8         37 $self->{port_num} = shift @_;
1767 8         28 $self->service_check(1);
1768             }
1769 8         16 return $self->{port_num};
1770             }
1771              
1772             sub ntop {
1773 15     15 1 40 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 15         794 my $port = getservbyname('echo', 'udp');
1782 15         78 my $sockaddr = _pack_sockaddr_in($port, $ip);
1783 15         541 my ($error, $address) = getnameinfo($sockaddr, $NI_NUMERICHOST);
1784 15 50       112 croak $error if $error;
1785 15         625 return $address;
1786             }
1787              
1788             sub wakeonlan {
1789 0     0 1 0 my ($mac_addr, $host, $port) = @_;
1790              
1791             # use the discard service if $port not passed in
1792 0 0       0 if (! defined $host) { $host = '255.255.255.255' }
  0         0  
1793 0 0 0     0 if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 }
  0         0  
1794              
1795 0         0 require IO::Socket::INET;
1796 0   0     0 my $sock = IO::Socket::INET->new(Proto=>'udp') || return undef;
1797              
1798 0         0 my $ip_addr = inet_aton($host);
1799 0         0 my $sock_addr = sockaddr_in($port, $ip_addr);
1800 0         0 $mac_addr =~ s/://g;
1801 0         0 my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16);
1802              
1803 0         0 setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1);
1804 0         0 send($sock, $packet, 0, $sock_addr);
1805 0         0 $sock->close;
1806              
1807 0         0 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             ############################
1820             sub _resolv {
1821 61     61   157 my ($self,
1822             $name,
1823             ) = @_;
1824              
1825 61         116 my %h;
1826 61         178 $h{name} = $name;
1827 61         123 my $family = $self->{family};
1828              
1829 61 50       196 if (defined($self->{family_local})) {
1830             $family = $self->{family_local}
1831 61         122 }
1832              
1833             # START - host:port
1834 61         115 my $cnt = 0;
1835              
1836             # Count ":"
1837 61         297 $cnt++ while ($name =~ m/:/g);
1838              
1839             # 0 = hostname or IPv4 address
1840 61 100       179 if ($cnt == 0) {
    50          
    50          
1841 60         150 $h{host} = $name
1842             # 1 = IPv4 address with port
1843             } elsif ($cnt == 1) {
1844 0         0 ($h{host}, $h{port}) = split /:/, $name
1845             # >=2 = IPv6 address
1846             } elsif ($cnt >= 2) {
1847             #IPv6 with port - [2001::1]:port
1848 1 50       4 if ($name =~ /^\[.*\]:\d{1,5}$/) {
1849 0         0 ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last :
1850             # IPv6 without port
1851             } else {
1852 1         2 $h{host} = $name
1853             }
1854             }
1855              
1856             # Clean up host
1857 61         200 $h{host} =~ s/\[//g;
1858 61         130 $h{host} =~ s/\]//g;
1859             # Clean up port
1860 61 0 0     173 if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) {
      33        
1861 0         0 croak("Invalid port `$h{port}' in `$name'");
1862 0         0 return undef;
1863             }
1864             # END - host:port
1865              
1866             # address check
1867             # new way
1868 61 50       172 if ($Socket_VERSION > 1.94) {
1869 61         314 my %hints = (
1870             family => $AF_UNSPEC,
1871             protocol => IPPROTO_TCP,
1872             flags => $AI_NUMERICHOST
1873             );
1874              
1875             # numeric address, return
1876 61         1030 my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
1877 61 100       287 if (defined($getaddr[0])) {
1878 33         74 $h{addr} = $h{host};
1879 33         107 $h{family} = $getaddr[0]->{family};
1880 33 100       100 if ($h{family} == AF_INET) {
1881 32         154 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr};
1882             } else {
1883 1         16 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
1884             }
1885 33         177 return \%h
1886             }
1887             # old way
1888             } else {
1889             # numeric address, return
1890 0         0 my $ret = gethostbyname($h{host});
1891 0 0 0     0 if (defined($ret) && (_inet_ntoa($ret) eq $h{host})) {
1892 0         0 $h{addr} = $h{host};
1893 0         0 $h{addr_in} = $ret;
1894 0         0 $h{family} = AF_INET;
1895 0         0 return \%h
1896             }
1897             }
1898              
1899             # resolve
1900             # new way
1901 28 50       104 if ($Socket_VERSION >= 1.94) {
1902 28         105 my %hints = (
1903             family => $family,
1904             protocol => IPPROTO_TCP
1905             );
1906              
1907 28         1271017 my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints);
1908 28 50       407 if (defined($getaddr[0])) {
1909 28         486 my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST, $NIx_NOSERV);
1910 28 50       110 if (defined($address)) {
1911 28         116 $h{addr} = $address;
1912 28         155 $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6
1913 28         93 $h{family} = $getaddr[0]->{family};
1914 28 50       147 if ($h{family} == AF_INET) {
1915 28         206 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr};
1916             } else {
1917 0         0 (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr};
1918             }
1919 28         415 return \%h;
1920             } else {
1921 0         0 carp("getnameinfo($getaddr[0]->{addr}) failed - $err");
1922 0         0 return undef;
1923             }
1924             } else {
1925 0 0       0 warn(sprintf("getaddrinfo($h{host},,%s) failed - $err",
1926             $family == AF_INET ? "AF_INET" : "AF_INET6"));
1927 0         0 return undef;
1928             }
1929             # old way
1930             } else {
1931 0 0       0 if ($family == $AF_INET6) {
1932 0         0 croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION");
1933 0         0 return undef;
1934             }
1935              
1936 0         0 my @gethost = gethostbyname($h{host});
1937 0 0       0 if (defined($gethost[4])) {
1938 0         0 $h{addr} = inet_ntoa($gethost[4]);
1939 0         0 $h{addr_in} = $gethost[4];
1940 0         0 $h{family} = AF_INET;
1941 0         0 return \%h
1942             } else {
1943 0         0 carp("gethostbyname($h{host}) failed - $^E");
1944 0         0 return undef;
1945             }
1946             }
1947 0         0 return undef;
1948             }
1949              
1950             sub _pack_sockaddr_in($$) {
1951 76     76   205 my ($port,
1952             $ip,
1953             ) = @_;
1954              
1955 76 100       341 my $addr = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip;
1956 76 100       261 if (length($addr) <= 4 ) {
1957 75         464 return Socket::pack_sockaddr_in($port, $addr);
1958             } else {
1959 1         6 return Socket::pack_sockaddr_in6($port, $addr);
1960             }
1961             }
1962              
1963             sub _unpack_sockaddr_in($;$) {
1964 8     8   18 my ($addr,
1965             $family,
1966             ) = @_;
1967              
1968 8         14 my ($port, $host);
1969 8 50 0     25 if ($family == AF_INET || (!defined($family) and length($addr) <= 16 )) {
      33        
1970 8         31 ($port, $host) = Socket::unpack_sockaddr_in($addr);
1971             } else {
1972 0         0 ($port, $host) = Socket::unpack_sockaddr_in6($addr);
1973             }
1974 8         23 return $port, $host
1975             }
1976              
1977             sub _inet_ntoa {
1978 0     0     my ($addr
1979             ) = @_;
1980              
1981 0           my $ret;
1982 0 0         if ($Socket_VERSION >= 1.94) {
1983 0           my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST);
1984 0 0         if (defined($address)) {
1985 0           $ret = $address;
1986             } else {
1987 0           carp("getnameinfo($addr) failed - $err");
1988             }
1989             } else {
1990 0           $ret = inet_ntoa($addr)
1991             }
1992            
1993 0           return $ret
1994             }
1995              
1996             1;
1997             __END__