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__ |