File Coverage

blib/lib/Net/Ident.pm
Criterion Covered Total %
statement 86 229 37.5
branch 18 170 10.5
condition 1 24 4.1
subroutine 19 31 61.2
pod 9 10 90.0
total 133 464 28.6


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__