line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::Ident; |
2
|
|
|
|
|
|
|
|
3
|
5
|
|
|
5
|
|
23568
|
use strict; |
|
5
|
|
|
|
|
7
|
|
|
5
|
|
|
|
|
190
|
|
4
|
5
|
|
|
5
|
|
2837
|
use Socket; |
|
5
|
|
|
|
|
14836
|
|
|
5
|
|
|
|
|
2238
|
|
5
|
5
|
|
|
5
|
|
40
|
use Fcntl; |
|
5
|
|
|
|
|
13
|
|
|
5
|
|
|
|
|
1052
|
|
6
|
5
|
|
|
5
|
|
4487
|
use FileHandle; |
|
5
|
|
|
|
|
42629
|
|
|
5
|
|
|
|
|
31
|
|
7
|
5
|
|
|
5
|
|
2266
|
use Carp; |
|
5
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
252
|
|
8
|
5
|
|
|
5
|
|
21
|
use Config; |
|
5
|
|
|
|
|
6
|
|
|
5
|
|
|
|
|
199
|
|
9
|
5
|
|
|
5
|
|
2752
|
use Errno; |
|
5
|
|
|
|
|
4616
|
|
|
5
|
|
|
|
|
256
|
|
10
|
|
|
|
|
|
|
require Exporter; |
11
|
|
|
|
|
|
|
|
12
|
5
|
|
|
|
|
2466
|
use vars qw(@ISA @EXPORT_OK $DEBUG $VERSION %EXPORT_TAGS @EXPORT_FAIL |
13
|
5
|
|
|
5
|
|
28
|
%EXPORT_HOOKS @EXPORT); |
|
5
|
|
|
|
|
5
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
16
|
|
|
|
|
|
|
@EXPORT_OK = qw(ident_lookup lookup lookupFromInAddr); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# EXPORT_HOOKS is a sortof Exporter extension. Whenever one of the keys |
19
|
|
|
|
|
|
|
# of this hash is imported as a "tag", the corresponding function is called |
20
|
|
|
|
|
|
|
%EXPORT_HOOKS = ( |
21
|
|
|
|
|
|
|
'fh' => \&_add_fh_method, |
22
|
|
|
|
|
|
|
'apache' => \&_add_apache_method, |
23
|
|
|
|
|
|
|
'debug' => \&_set_debug, |
24
|
|
|
|
|
|
|
); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# provide import magic |
27
|
|
|
|
|
|
|
sub _export_hooks () { |
28
|
5
|
|
|
5
|
|
6
|
my ( $tag, $hook ); |
29
|
5
|
|
|
|
|
43
|
while ( ( $tag, $hook ) = each %EXPORT_HOOKS ) { |
30
|
15
|
|
|
|
|
27
|
my $hookname = "_export_hook_$tag"; # pseudo-function name |
31
|
15
|
|
|
|
|
25
|
$EXPORT_TAGS{$tag} = [$hookname]; |
32
|
15
|
|
|
|
|
21
|
push @EXPORT_OK, $hookname; |
33
|
15
|
|
|
|
|
39
|
push @EXPORT_FAIL, $hookname; |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# put the export hooks in the standard Exporter structures |
38
|
|
|
|
|
|
|
_export_hooks(); |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# for compatibility mode, uncomment the next line @@ s/^#\s*// @@ |
41
|
|
|
|
|
|
|
# @EXPORT = qw(_export_hook_fh); |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
$VERSION = "1.24"; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
$DEBUG ||= 0; |
46
|
|
|
|
|
|
|
*STDDBG = *STDERR; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub _set_debug { |
49
|
0
|
|
|
0
|
|
0
|
$DEBUG++; |
50
|
0
|
|
|
|
|
0
|
print STDDBG "Debugging turned to level $DEBUG\n"; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# protocol number for tcp. |
54
|
|
|
|
|
|
|
my $tcpproto = ( getprotobyname('tcp') )[2] || 6; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# get identd port (default to 113). |
57
|
|
|
|
|
|
|
my $identport = ( getservbyname( 'ident', 'tcp' ) )[2] || 113; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# what to use to make nonblocking sockets |
60
|
|
|
|
|
|
|
my $NONBLOCK = eval "&$Config{o_nonblock}"; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# turn a filehandle passed as a string, or glob, into a ref |
63
|
|
|
|
|
|
|
# private subroutine |
64
|
|
|
|
|
|
|
sub _passfh ($) { |
65
|
1
|
|
|
1
|
|
7
|
my ($fh) = @_; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
# test if $fh is a reference. if it's not, we need to process... |
68
|
1
|
50
|
|
|
|
6
|
if ( !ref $fh ) { |
69
|
1
|
50
|
|
|
|
12
|
print STDDBG "passed fh: $fh is not a reference\n" if $DEBUG; |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
# check for fully qualified name |
72
|
1
|
50
|
|
|
|
15
|
if ( $fh !~ /'|::/ ) { |
73
|
1
|
50
|
|
|
|
8
|
print STDDBG "$fh is not fully qualified\n" if $DEBUG; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# get our current package |
76
|
1
|
|
|
|
|
3
|
my $mypkg = (caller)[0]; |
77
|
1
|
50
|
|
|
|
10
|
print STDDBG "We are package $mypkg\n" if $DEBUG; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# search for calling package |
80
|
1
|
|
|
|
|
1
|
my $depth = 1; |
81
|
1
|
|
|
|
|
1
|
my $otherpkg; |
82
|
1
|
|
|
|
|
17
|
$depth++ while ( ( $otherpkg = caller($depth) ) eq $mypkg ); |
83
|
1
|
50
|
|
|
|
16
|
print STDDBG "We are called from package $otherpkg\n" if $DEBUG; |
84
|
1
|
|
|
|
|
3
|
$fh = "${otherpkg}::$fh"; |
85
|
1
|
50
|
|
|
|
4
|
print STDDBG "passed fh now fully qualified: $fh\n" if $DEBUG; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# turn $fh into a reference to a $fh. we need to disable strict refs |
89
|
5
|
|
|
5
|
|
29
|
no strict 'refs'; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
12104
|
|
90
|
1
|
|
|
|
|
2
|
$fh = \*{$fh}; |
|
1
|
|
|
|
|
3
|
|
91
|
|
|
|
|
|
|
} |
92
|
1
|
|
|
|
|
7
|
$fh; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# create a Net::Ident object, and perform a non-blocking connect() |
96
|
|
|
|
|
|
|
# to the remote identd port. |
97
|
|
|
|
|
|
|
# class method, constructor |
98
|
|
|
|
|
|
|
sub new { |
99
|
1
|
|
|
1
|
1
|
2421
|
my ( $class, $fh, $timeout ) = @_; |
100
|
1
|
|
|
|
|
8
|
my ( $localaddr, $remoteaddr ); |
101
|
|
|
|
|
|
|
|
102
|
1
|
50
|
|
|
|
68
|
print STDDBG "Net::Ident::new fh=$fh, timeout=" . ( defined $timeout ? $timeout : "" ) . "\n" |
|
|
50
|
|
|
|
|
|
103
|
|
|
|
|
|
|
if $DEBUG > 1; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# "try" |
106
|
1
|
|
|
|
|
11
|
eval { |
107
|
1
|
50
|
|
|
|
3
|
defined $fh or die "= fh undef\n"; |
108
|
1
|
|
|
|
|
20
|
$fh = _passfh($fh); |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
# get information about this (the local) end of the connection. We |
111
|
|
|
|
|
|
|
# assume that $fh is a connected socket of type SOCK_STREAM. If |
112
|
|
|
|
|
|
|
# it isn't, you'll find out soon enough because one of these functions |
113
|
|
|
|
|
|
|
# will return undef real fast. |
114
|
1
|
50
|
|
|
|
21
|
$localaddr = getsockname($fh) or die "= getsockname failed: $!\n"; |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# get information about remote end of connection |
117
|
0
|
0
|
|
|
|
0
|
$remoteaddr = getpeername($fh) or die "= getpeername failed: $!\n"; |
118
|
|
|
|
|
|
|
}; |
119
|
1
|
50
|
|
|
|
19
|
if ( $@ =~ /^= (.*)/ ) { |
|
|
0
|
|
|
|
|
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# here's the catch of the throw |
122
|
|
|
|
|
|
|
# return false, try to preserve errno |
123
|
1
|
|
|
|
|
8
|
local ($!); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# we make a "fake" $self |
126
|
1
|
|
|
|
|
21
|
my $self = { |
127
|
|
|
|
|
|
|
'state' => 'error', |
128
|
|
|
|
|
|
|
'error' => "Net::Ident::new: $1\n", |
129
|
|
|
|
|
|
|
}; |
130
|
1
|
50
|
|
|
|
43
|
print STDDBG $self->{error} if $DEBUG; |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# return our blessed $self |
133
|
1
|
|
|
|
|
16
|
return bless $self, $class; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
elsif ($@) { |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# something else went wrong. barf up completely. |
138
|
0
|
|
|
|
|
0
|
confess($@); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# continue with the NewFromInAddr constructor |
142
|
0
|
|
|
|
|
0
|
$class->newFromInAddr( $localaddr, $remoteaddr, $timeout ); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub newFromInAddr { |
146
|
0
|
|
|
0
|
1
|
0
|
my ( $class, $localaddr, $remoteaddr, $timeout ) = @_; |
147
|
0
|
|
|
|
|
0
|
my $self = {}; |
148
|
|
|
|
|
|
|
|
149
|
0
|
|
|
0
|
|
0
|
print STDDBG "Net::Ident::newFromInAddr localaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } |
150
|
0
|
|
|
0
|
|
0
|
->( sockaddr_in($localaddr) ), ", remoteaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } |
151
|
0
|
0
|
|
|
|
0
|
->( sockaddr_in($remoteaddr) ), ", timeout=", defined $timeout ? $timeout : "", "\n" |
|
|
0
|
|
|
|
|
|
152
|
|
|
|
|
|
|
if $DEBUG > 1; |
153
|
|
|
|
|
|
|
|
154
|
0
|
|
|
|
|
0
|
eval { |
155
|
|
|
|
|
|
|
# unpack addresses and store in |
156
|
0
|
|
|
|
|
0
|
my ( $localip, $remoteip ); |
157
|
0
|
|
|
|
|
0
|
( $self->{localport}, $localip ) = sockaddr_in($localaddr); |
158
|
0
|
|
|
|
|
0
|
( $self->{remoteport}, $remoteip ) = sockaddr_in($remoteaddr); |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# create a local binding port. We cannot bind to INADDR_ANY, it has |
161
|
|
|
|
|
|
|
# to be bind (bound?) to the same IP address as the connection we're |
162
|
|
|
|
|
|
|
# interested in on machines with multiple IP addresses |
163
|
0
|
|
|
|
|
0
|
my $localbind = sockaddr_in( 0, $localip ); |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# store max time |
166
|
0
|
0
|
|
|
|
0
|
$self->{maxtime} = defined($timeout) ? time + $timeout : undef; |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
# create a remote connect point |
169
|
0
|
|
|
|
|
0
|
my $identbind = sockaddr_in( $identport, $remoteip ); |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# create a new FileHandle |
172
|
0
|
|
|
|
|
0
|
$self->{fh} = new FileHandle; |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# create a stream socket. |
175
|
0
|
0
|
|
|
|
0
|
socket( $self->{fh}, PF_INET, SOCK_STREAM, $tcpproto ) |
176
|
|
|
|
|
|
|
or die "= socket failed: $!\n"; |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# bind it to the same IP number as the local end of THESOCK |
179
|
0
|
0
|
|
|
|
0
|
bind( $self->{fh}, $localbind ) or die "= bind failed: $!\n"; |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# make it a non-blocking socket |
182
|
0
|
0
|
|
|
|
0
|
if ( $^O ne 'MSWin32' ) { |
183
|
0
|
0
|
|
|
|
0
|
fcntl( $self->{fh}, F_SETFL, $NONBLOCK ) or die "= fcntl failed: $!\n"; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# connect it to the remote identd port, this can return EINPROGRESS. |
187
|
|
|
|
|
|
|
# for some reason, reading $! twice doesn't work as it should |
188
|
0
|
0
|
0
|
|
|
0
|
connect( $self->{fh}, $identbind ) |
189
|
|
|
|
|
|
|
or $!{EINPROGRESS} |
190
|
|
|
|
|
|
|
or die "= connect failed: $!\n"; |
191
|
0
|
0
|
|
|
|
0
|
$self->{fh}->blocking(0) if $^O eq 'MSWin32'; |
192
|
|
|
|
|
|
|
}; |
193
|
0
|
0
|
|
|
|
0
|
if ( $@ =~ /^= (.*)/ ) { |
|
|
0
|
|
|
|
|
|
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# here's the catch of the throw |
196
|
|
|
|
|
|
|
# return false, try to preserve errno |
197
|
0
|
|
|
|
|
0
|
local ($!); |
198
|
0
|
|
|
|
|
0
|
$self->{error} = "Net::Ident::new: $1\n"; |
199
|
0
|
0
|
|
|
|
0
|
print STDDBG $self->{error} if $DEBUG; |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
# this deletes the FileHandle, which gets closed, |
202
|
|
|
|
|
|
|
# so that might change errno |
203
|
0
|
|
|
|
|
0
|
delete $self->{fh}; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# do NOT return, so the constructor always succeeds |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
elsif ($@) { |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
# something else went wrong. barf up completely. |
210
|
0
|
|
|
|
|
0
|
confess($@); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
# clear errno in case it contains EINPROGRESS |
214
|
0
|
|
|
|
|
0
|
$! = 0; |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
# mark the state of the connection |
217
|
0
|
|
|
|
|
0
|
$self->{state} = 'connect'; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# return a blessed reference |
220
|
0
|
|
|
|
|
0
|
bless $self, $class; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# send the query to the remote daemon. |
224
|
|
|
|
|
|
|
# object method |
225
|
|
|
|
|
|
|
sub query { |
226
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
227
|
0
|
|
|
|
|
0
|
my ( $wmask, $timeout, $emask, $fileno, $err, $query ); |
228
|
|
|
|
|
|
|
|
229
|
0
|
0
|
|
|
|
0
|
print STDDBG "Net::Ident::query\n" if $DEBUG > 1; |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# bomb out if no fh |
232
|
0
|
0
|
|
|
|
0
|
return undef unless $self->{fh}; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
# "try" |
235
|
0
|
|
|
|
|
0
|
eval { |
236
|
0
|
0
|
|
|
|
0
|
$self->{state} eq 'connect' or die "= calling in the wrong order\n"; |
237
|
0
|
|
|
|
|
0
|
$fileno = fileno $self->{fh}; |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
# calculate the time left, abort if necessary. Note that $timeout |
240
|
|
|
|
|
|
|
# is simply left undef if $self->{maxtime} is not defined |
241
|
0
|
0
|
0
|
|
|
0
|
if ( defined( $self->{maxtime} ) |
242
|
|
|
|
|
|
|
&& ( $timeout = $self->{maxtime} - time ) < 0 ) { |
243
|
0
|
|
|
|
|
0
|
die "= Connection timed out\n"; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
# wait until the socket becomes writable. |
247
|
0
|
|
|
|
|
0
|
$wmask = ''; |
248
|
0
|
|
|
|
|
0
|
vec( $wmask, $fileno, 1 ) = 1; |
249
|
0
|
0
|
|
|
|
0
|
scalar select( undef, $wmask, $emask = $wmask, $timeout ) |
250
|
|
|
|
|
|
|
or die "= Connection timed out\n"; |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
# Check for errors via select (you never know) |
253
|
0
|
0
|
|
|
|
0
|
vec( $emask, $fileno, 1 ) and die "= connection error: $!\n"; |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# fh must be writable now |
256
|
0
|
0
|
|
|
|
0
|
vec( $wmask, $fileno, 1 ) or die "= connection timed out or error: $!\n"; |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
# check for errors via getsockopt(SO_ERROR) |
259
|
0
|
|
|
|
|
0
|
$err = getsockopt( $self->{fh}, SOL_SOCKET, SO_ERROR ); |
260
|
0
|
0
|
0
|
|
|
0
|
if ( !defined($err) || ( $! = unpack( 'L', $err ) ) ) { |
261
|
0
|
|
|
|
|
0
|
die "= connect: $!\n"; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
# create the query, based on the remote port and the local port |
265
|
0
|
|
|
|
|
0
|
$query = "$self->{remoteport},$self->{localport}\r\n"; |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
# write the query. Ignore the chance that such a short |
268
|
|
|
|
|
|
|
# write will be fragmented. |
269
|
0
|
0
|
|
|
|
0
|
syswrite( $self->{fh}, $query, length $query ) == length $query |
270
|
|
|
|
|
|
|
or die "= fragmented write on socket: $!\n"; |
271
|
|
|
|
|
|
|
}; |
272
|
0
|
0
|
|
|
|
0
|
if ( $@ =~ /^= (.*)/ ) { |
|
|
0
|
|
|
|
|
|
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
# here's the catch of the throw |
275
|
|
|
|
|
|
|
# return false, try to preserve errno |
276
|
0
|
|
|
|
|
0
|
local ($!); |
277
|
0
|
|
|
|
|
0
|
$self->{error} = "Net::Ident::query: $1\n"; |
278
|
0
|
0
|
|
|
|
0
|
print STDDBG $self->{error} if $DEBUG; |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
# this deletes the FileHandle, which gets closed, |
281
|
|
|
|
|
|
|
# so that might change errno |
282
|
0
|
|
|
|
|
0
|
delete $self->{fh}; |
283
|
0
|
|
|
|
|
0
|
return undef; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
elsif ($@) { |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
# something else went wrong. barf up completely. |
288
|
0
|
|
|
|
|
0
|
confess($@); |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
# initialise empty answer to prevent uninitialised value warning |
292
|
0
|
|
|
|
|
0
|
$self->{answer} = ''; |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# mark the state of the connection |
295
|
0
|
|
|
|
|
0
|
$self->{state} = 'query'; |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
# return the same object on success |
298
|
0
|
|
|
|
|
0
|
$self; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
# read data, if any, and check if it's enough. |
302
|
|
|
|
|
|
|
# object method |
303
|
|
|
|
|
|
|
sub ready { |
304
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $blocking ) = @_; |
305
|
0
|
|
|
|
|
0
|
my ( $timeout, $rmask, $emask, $answer, $ret, $fileno ); |
306
|
|
|
|
|
|
|
|
307
|
0
|
0
|
|
|
|
0
|
print STDDBG "Net::Ident::ready blocking=" . ( $blocking ? "true\n" : "false\n" ) if $DEBUG > 1; |
|
|
0
|
|
|
|
|
|
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# perform the query if not already done. |
310
|
0
|
0
|
|
|
|
0
|
if ( $self->{state} ne 'query' ) { |
|
|
0
|
|
|
|
|
|
311
|
0
|
0
|
|
|
|
0
|
$self->query or return undef; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# exit immediately if ready returned 1 before. |
315
|
|
|
|
|
|
|
elsif ( $self->{state} eq 'ready' ) { |
316
|
0
|
|
|
|
|
0
|
return 1; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# bomb out if no fh |
320
|
0
|
0
|
|
|
|
0
|
return undef unless $self->{fh}; |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# "try" |
323
|
0
|
|
|
|
|
0
|
$ret = eval { |
324
|
0
|
|
|
|
|
0
|
$fileno = fileno $self->{fh}; |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
# while $blocking, but at least once... |
327
|
0
|
|
|
|
|
0
|
do { |
328
|
|
|
|
|
|
|
# calculate the time left, abort if necessary. |
329
|
0
|
0
|
0
|
|
|
0
|
if ( defined( $self->{maxtime} ) |
330
|
|
|
|
|
|
|
&& ( $timeout = $self->{maxtime} - time ) < 0 ) { |
331
|
0
|
|
|
|
|
0
|
die "= Timeout\n"; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
# zero timeout for non-blocking |
335
|
0
|
0
|
|
|
|
0
|
$timeout = 0 unless $blocking; |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
# wait for something |
338
|
0
|
|
|
|
|
0
|
$rmask = ''; |
339
|
0
|
|
|
|
|
0
|
vec( $rmask, $fileno, 1 ) = 1; |
340
|
0
|
0
|
|
|
|
0
|
if ( select( $rmask, undef, $emask = $rmask, $timeout ) ) { |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# something came in |
343
|
0
|
0
|
|
|
|
0
|
vec( $emask, $fileno, 1 ) and die "= error while reading: $!\n"; |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
# check for incoming data |
346
|
0
|
0
|
|
|
|
0
|
if ( vec( $rmask, $fileno, 1 ) ) { |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
# try to read as much data as possible. |
349
|
0
|
|
|
|
|
0
|
$answer = ''; |
350
|
0
|
0
|
|
|
|
0
|
defined sysread( $self->{fh}, $answer, 1000 ) |
351
|
|
|
|
|
|
|
or die "= read returned error: $!\n"; |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# append incoming data to total received |
354
|
0
|
|
|
|
|
0
|
$self->{answer} .= $answer; |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# check for max length |
357
|
0
|
0
|
|
|
|
0
|
length( $self->{answer} ) <= 1000 |
358
|
|
|
|
|
|
|
or die "= remote daemon babbling too much\n"; |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
# if data contains a CR or LF, we are ready receiving. |
361
|
|
|
|
|
|
|
# strip everything after and including the CR or LF and |
362
|
|
|
|
|
|
|
# return success |
363
|
0
|
0
|
|
|
|
0
|
if ( $self->{answer} =~ /[\n\r]/ ) { |
364
|
0
|
|
|
|
|
0
|
$self->{answer} =~ s/[\n\r].*//s; |
365
|
0
|
0
|
|
|
|
0
|
print STDDBG "Net::Ident::ready received: $self->{answer}\n" |
366
|
|
|
|
|
|
|
if $DEBUG; |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
# close the socket to the remote identd |
369
|
0
|
|
|
|
|
0
|
close( $self->{fh} ); |
370
|
0
|
|
|
|
|
0
|
$self->{state} = 'ready'; |
371
|
0
|
|
|
|
|
0
|
return 1; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
} while $blocking; |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
# we don't block, but we didn't receive everything yet... return false. |
378
|
0
|
|
|
|
|
0
|
0; |
379
|
|
|
|
|
|
|
}; |
380
|
0
|
0
|
|
|
|
0
|
if ( $@ =~ /^= (.*)/ ) { |
|
|
0
|
|
|
|
|
|
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# here's the catch of the throw |
383
|
|
|
|
|
|
|
# return undef, try to preserve errno |
384
|
0
|
|
|
|
|
0
|
local ($!); |
385
|
0
|
|
|
|
|
0
|
$self->{error} = "Net::Ident::ready: $1\n"; |
386
|
0
|
0
|
|
|
|
0
|
print STDDBG $self->{error} if $DEBUG; |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# this deletes the FileHandle, which gets closed, |
389
|
|
|
|
|
|
|
# so that might change errno |
390
|
0
|
|
|
|
|
0
|
delete $self->{fh}; |
391
|
0
|
|
|
|
|
0
|
return undef; |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
elsif ($@) { |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
# something else went wrong. barf up completely. |
396
|
0
|
|
|
|
|
0
|
confess($@); |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# return the return value from the eval{} |
400
|
0
|
|
|
|
|
0
|
$ret; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
# return the username from the rfc931 query return. |
404
|
|
|
|
|
|
|
# object method |
405
|
|
|
|
|
|
|
sub username { |
406
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
407
|
|
|
|
|
|
|
my ( |
408
|
0
|
|
|
|
|
0
|
$remoteport, $localport, $port1, $port2, $replytype, $reply, $opsys, |
409
|
|
|
|
|
|
|
$userid, $error |
410
|
|
|
|
|
|
|
); |
411
|
|
|
|
|
|
|
|
412
|
0
|
0
|
|
|
|
0
|
print STDDBG "Net::Ident::username\n" if $DEBUG > 1; |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
# wait for data, if necessary. |
415
|
0
|
0
|
|
|
|
0
|
return wantarray ? ( undef, undef, $self->{error} ) : undef |
|
|
0
|
|
|
|
|
|
416
|
|
|
|
|
|
|
unless $self->ready(1); |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
# parse the received string, split it into parts. |
419
|
0
|
|
|
|
|
0
|
( $port1, $port2, $replytype, $reply ) = ( $self->{answer} =~ /^\s*(\d+)\s*,\s*(\d+)\s*:\s*(ERROR|USERID)\s*:\s*(.*)$/ ); |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
# make sure the answer parsed properly, and that the ports are the same. |
422
|
0
|
0
|
0
|
|
|
0
|
if ( !defined($reply) |
|
|
|
0
|
|
|
|
|
423
|
|
|
|
|
|
|
|| ( $self->{remoteport} != $port1 ) |
424
|
|
|
|
|
|
|
|| ( $self->{localport} != $port2 ) ) { |
425
|
0
|
|
|
|
|
0
|
$self->{error} = "Net::Ident::username couldn't parse reply or port mismatch\n"; |
426
|
0
|
0
|
|
|
|
0
|
print STDDBG $self->{error} if $DEBUG; |
427
|
0
|
0
|
|
|
|
0
|
return wantarray ? ( undef, undef, $self->{error} ) : undef; |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
# check for error return type |
431
|
0
|
0
|
|
|
|
0
|
if ( $replytype eq "ERROR" ) { |
432
|
0
|
0
|
|
|
|
0
|
print STDDBG "Net::Ident::username: lookup returned ERROR\n" if $DEBUG; |
433
|
0
|
|
|
|
|
0
|
$userid = undef; |
434
|
0
|
|
|
|
|
0
|
$opsys = "ERROR"; |
435
|
0
|
|
|
|
|
0
|
( $error = $reply ) =~ s/\s+$//; |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
else { |
438
|
|
|
|
|
|
|
# a normal reply, parse the opsys and userid. Note that the opsys may |
439
|
|
|
|
|
|
|
# contain \ escaped colons, which is why the hairy regexp is necessary. |
440
|
0
|
0
|
|
|
|
0
|
unless ( ( $opsys, $userid ) = ( $reply =~ /\s*((?:[^\\:]+|\\.)*):(.*)$/ ) ) { |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
# didn't parse properly, abort. |
443
|
0
|
|
|
|
|
0
|
$self->{error} = "Net::Ident::username: couldn't parse userid\n"; |
444
|
0
|
0
|
|
|
|
0
|
print STDDBG $self->{error} if $DEBUG; |
445
|
0
|
0
|
|
|
|
0
|
return wantarray ? ( undef, undef, $self->{error} ) : undef; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
# remove trailing whitespace, except backwhacked whitespaces from opsys |
449
|
0
|
|
|
|
|
0
|
$opsys =~ s/([^\\])\s+$/$1/; |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
# un-backwhack opsys. |
452
|
0
|
|
|
|
|
0
|
$opsys =~ s/\\(.)/$1/g; |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
# in all cases is leading whitespace removed from the username, even |
455
|
|
|
|
|
|
|
# though rfc1413 mentions that it shouldn't be done, current |
456
|
|
|
|
|
|
|
# implementation practice dictates otherwise. What insane OS would |
457
|
|
|
|
|
|
|
# use leading whitespace in usernames anyway... |
458
|
0
|
|
|
|
|
0
|
$userid =~ s/^\s+//; |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
# Test if opsys is "special": if it contains a charset definition, |
461
|
|
|
|
|
|
|
# or if it is "OTHER". This means that it is rfc1413-like, instead |
462
|
|
|
|
|
|
|
# of rfc931-like. (Why can't they make these RFCs non-conflicting??? ;) |
463
|
|
|
|
|
|
|
# Note that while rfc1413 (the one that superseded rfc931) indicates |
464
|
|
|
|
|
|
|
# that _any_ characters following the final colon are part of the |
465
|
|
|
|
|
|
|
# username, current implementation practice inserts a space there, |
466
|
|
|
|
|
|
|
# even "modern" identd daemons. |
467
|
|
|
|
|
|
|
# Also, rfc931 specifically mentions escaping characters, while |
468
|
|
|
|
|
|
|
# rfc1413 does not mention it (it isn't really necessary). Anyway, |
469
|
|
|
|
|
|
|
# I'm going to remove trailing whitespace from userids, and I'm |
470
|
|
|
|
|
|
|
# going to un-backwhack them, unless the opsys is "special". |
471
|
0
|
0
|
0
|
|
|
0
|
unless ( $opsys =~ /,/ || $opsys eq 'OTHER' ) { |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# remove trailing whitespace, except backwhacked whitespaces. |
474
|
0
|
|
|
|
|
0
|
$userid =~ s/([^\\])\s+$/$1/; |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
# un-backwhack |
477
|
0
|
|
|
|
|
0
|
$userid =~ s/\\(.)/$1/g; |
478
|
|
|
|
|
|
|
} |
479
|
0
|
|
|
|
|
0
|
$error = undef; |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
# return the requested information, depending on whether in array context. |
483
|
0
|
0
|
|
|
|
0
|
if ( $DEBUG > 1 ) { |
484
|
0
|
|
|
|
|
0
|
print STDDBG "Net::Ident::username returns:\n"; |
485
|
0
|
0
|
|
|
|
0
|
print STDDBG "userid = ", defined $userid ? $userid : "", "\n"; |
486
|
0
|
0
|
|
|
|
0
|
print STDDBG "opsys = ", defined $opsys ? $opsys : "", "\n"; |
487
|
0
|
0
|
|
|
|
0
|
print STDDBG "error = ", defined $error ? $error : "", "\n"; |
488
|
|
|
|
|
|
|
} |
489
|
0
|
0
|
|
|
|
0
|
wantarray ? ( $userid, $opsys, $error ) : $userid; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# do the entire rfc931 lookup in one blow. |
493
|
|
|
|
|
|
|
# exportable subroutine, not a method |
494
|
|
|
|
|
|
|
sub lookup ($;$) { |
495
|
0
|
|
|
0
|
1
|
0
|
my ( $fh, $timeout ) = @_; |
496
|
|
|
|
|
|
|
|
497
|
0
|
0
|
|
|
|
0
|
print STDDBG "Net::Ident::lookup fh=$fh, timeout=", defined $timeout ? $timeout : "", "\n" |
|
|
0
|
|
|
|
|
|
498
|
|
|
|
|
|
|
if $DEBUG > 1; |
499
|
|
|
|
|
|
|
|
500
|
0
|
|
|
|
|
0
|
Net::Ident->new( $fh, $timeout )->username; |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
# do the entire rfc931 lookup from two in_addr structs |
504
|
|
|
|
|
|
|
sub lookupFromInAddr ($$;$) { |
505
|
0
|
|
|
0
|
1
|
0
|
my ( $localaddr, $remoteaddr, $timeout ) = @_; |
506
|
|
|
|
|
|
|
|
507
|
0
|
|
|
0
|
|
0
|
print STDDBG "Net::Ident::lookupFromInAddr localaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } |
508
|
0
|
|
|
0
|
|
0
|
->( sockaddr_in($localaddr) ), ", remoteaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } |
509
|
0
|
0
|
|
|
|
0
|
->( sockaddr_in($remoteaddr) ), ", timeout=", defined $timeout ? $timeout : "", "\n" |
|
|
0
|
|
|
|
|
|
510
|
|
|
|
|
|
|
if $DEBUG > 1; |
511
|
|
|
|
|
|
|
|
512
|
0
|
|
|
|
|
0
|
Net::Ident->newFromInAddr( $localaddr, $remoteaddr, $timeout )->username; |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
# alias Net::Ident::ident_lookup to Net::Ident::lookup |
516
|
|
|
|
|
|
|
sub ident_lookup ($;$); |
517
|
|
|
|
|
|
|
*ident_lookup = \&lookup; |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
# prevent "used only once" warning |
520
|
|
|
|
|
|
|
ident_lookup(0) if 0; |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
# get the FileHandle ref from the object, to be used in an external select(). |
523
|
|
|
|
|
|
|
# object method |
524
|
|
|
|
|
|
|
sub getfh ($) { |
525
|
1
|
|
|
1
|
1
|
21
|
my ($self) = @_; |
526
|
|
|
|
|
|
|
|
527
|
1
|
|
|
|
|
13
|
$self->{fh}; |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
# get the last error message. |
531
|
|
|
|
|
|
|
# object method |
532
|
|
|
|
|
|
|
sub geterror ($) { |
533
|
2
|
|
|
2
|
1
|
11
|
my ($self) = @_; |
534
|
|
|
|
|
|
|
|
535
|
2
|
|
|
|
|
2
|
$self->{error}; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
# this is called whenever a function in @EXPORT_FAIL is imported. |
539
|
|
|
|
|
|
|
# simply calls the installed export hooks from %EXPORT_HOOKS, or |
540
|
|
|
|
|
|
|
# passes along the export_fail up the inheritance chain |
541
|
|
|
|
|
|
|
sub export_fail { |
542
|
3
|
|
|
3
|
0
|
445
|
my $pkg = shift; |
543
|
3
|
|
|
|
|
6
|
my $fail; |
544
|
|
|
|
|
|
|
my @other; |
545
|
3
|
|
|
|
|
10
|
foreach $fail (@_) { |
546
|
4
|
50
|
33
|
|
|
41
|
if ( $fail =~ /^_export_hook_(.*)$/ && $EXPORT_HOOKS{$1} ) { |
547
|
4
|
|
|
|
|
7
|
&{ $EXPORT_HOOKS{$1} }; |
|
4
|
|
|
|
|
14
|
|
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
else { |
550
|
0
|
|
|
|
|
0
|
push @other, $fail; |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
} |
553
|
3
|
50
|
|
|
|
10
|
if (@other) { |
554
|
0
|
|
|
|
|
0
|
@other = SUPER::export_fail(@other); |
555
|
|
|
|
|
|
|
} |
556
|
3
|
|
|
|
|
2020
|
@other; |
557
|
|
|
|
|
|
|
} |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
# add lookup method for FileHandle objects. Note that this relies on the |
560
|
|
|
|
|
|
|
# use FileHandle; |
561
|
|
|
|
|
|
|
sub _add_fh_method { |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
# determine package to add method to |
564
|
3
|
50
|
|
3
|
|
23
|
my $pkg = grep( /^IO::/, @FileHandle::ISA ) ? "IO::Handle" : "FileHandle"; |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
# insert method in package. Arguments are already OK for std lookup |
567
|
|
|
|
|
|
|
# turn off strict refs for this glob-mangling trick |
568
|
5
|
|
|
5
|
|
73
|
no strict 'refs'; |
|
5
|
|
|
|
|
6
|
|
|
5
|
|
|
|
|
432
|
|
569
|
3
|
|
|
|
|
7
|
*{"${pkg}::ident_lookup"} = \&lookup; |
|
3
|
|
|
|
|
29
|
|
570
|
|
|
|
|
|
|
|
571
|
3
|
50
|
|
|
|
15
|
print STDDBG "Added ${pkg}::ident_lookup method\n" if $DEBUG; |
572
|
|
|
|
|
|
|
} |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
sub _add_apache_method { |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
# add method to Apache::Connection class |
577
|
5
|
|
|
5
|
|
27
|
no strict 'refs'; |
|
5
|
|
|
|
|
6
|
|
|
5
|
|
|
|
|
811
|
|
578
|
1
|
|
|
|
|
11
|
*{"Apache::Connection::ident_lookup"} = sub { |
579
|
0
|
|
|
0
|
|
0
|
my ( $self, $timeout ) = @_; |
580
|
|
|
|
|
|
|
|
581
|
0
|
0
|
|
|
|
0
|
print STDDBG "Apache::Connection::ident_lookup self=$self, ", "timeout=", defined $timeout ? $timeout : "", "\n" |
|
|
0
|
|
|
|
|
|
582
|
|
|
|
|
|
|
if $DEBUG > 1; |
583
|
0
|
|
|
|
|
0
|
lookupFromInAddr( $self->local_addr, $self->remote_addr, $timeout ); |
584
|
1
|
|
|
1
|
|
7
|
}; |
585
|
|
|
|
|
|
|
|
586
|
1
|
50
|
|
|
|
7
|
print STDDBG "Added Apache::Connection::ident_lookup method\n" if $DEBUG; |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
1; |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
__END__ |