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

package Net::Ident;

use strict;
use warnings;

use Socket;
use Fcntl;
use FileHandle;
use Carp;
use Config;
use Errno;
require Exporter;

our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(ident_lookup lookup lookupFromInAddr);
our @EXPORT_FAIL;
our %EXPORT_TAGS;

# EXPORT_HOOKS is a sortof Exporter extension. Whenever one of the keys
# of this hash is imported as a "tag", the corresponding function is called
our %EXPORT_HOOKS = (
    'fh'     => \&_add_fh_method,
    'apache' => \&_add_apache_method,
    'debug'  => \&_set_debug,
);

# provide import magic
sub _export_hooks () {
    my ( $tag, $hook );
    while ( ( $tag, $hook ) = each %EXPORT_HOOKS ) {
        my $hookname = "_export_hook_$tag";    # pseudo-function name
        $EXPORT_TAGS{$tag} = [$hookname];
        push @EXPORT_OK,   $hookname;
        push @EXPORT_FAIL, $hookname;
    }
}

# put the export hooks in the standard Exporter structures
_export_hooks();

# for compatibility mode, uncomment the next line @@ s/^#\s*// @@
# @EXPORT = qw(_export_hook_fh);

our $VERSION = "1.25";

our $DEBUG = 0;
*STDDBG = *STDERR;

sub _set_debug {
    $DEBUG++;
    print STDDBG "Debugging turned to level $DEBUG\n";
}

# protocol number for tcp.
my $tcpproto = ( getprotobyname('tcp') )[2] || 6;

# get identd port (default to 113).
my $identport = ( getservbyname( 'ident', 'tcp' ) )[2] || 113;

# what to use to make nonblocking sockets
my $NONBLOCK = eval "&$Config{o_nonblock}";

# turn a filehandle passed as a string, or glob, into a ref
# private subroutine
sub _passfh ($) {
    my ($fh) = @_;

    # test if $fh is a reference. if it's not, we need to process...
    if ( !ref $fh ) {
        print STDDBG "passed fh: $fh is not a reference\n" if $DEBUG;

        # check for fully qualified name
        if ( $fh !~ /'|::/ ) {
            print STDDBG "$fh is not fully qualified\n" if $DEBUG;

            # get our current package
            my $mypkg = (caller)[0];
            print STDDBG "We are package $mypkg\n" if $DEBUG;

            # search for calling package
            my $depth = 1;
            my $otherpkg;
            $depth++ while ( ( $otherpkg = caller($depth) ) eq $mypkg );
            print STDDBG "We are called from package $otherpkg\n" if $DEBUG;
            $fh = "${otherpkg}::$fh";
            print STDDBG "passed fh now fully qualified: $fh\n" if $DEBUG;
        }

        # turn $fh into a reference to a $fh. we need to disable strict refs
        no strict 'refs';
        $fh = \*{$fh};
    }
    $fh;
}

# create a Net::Ident object, and perform a non-blocking connect()
# to the remote identd port.
# class method, constructor
sub new {
    my ( $class, $fh, $timeout ) = @_;
    my ( $localaddr, $remoteaddr );

    print STDDBG "Net::Ident::new fh=$fh, timeout=" . ( defined $timeout ? $timeout : "" ) . "\n"
      if $DEBUG > 1;

    # "try"
    eval {
        defined $fh or die "= fh undef\n";
        $fh = _passfh($fh);

        # get information about this (the local) end of the connection. We
        # assume that $fh is a connected socket of type SOCK_STREAM. If
        # it isn't, you'll find out soon enough because one of these functions
        # will return undef real fast.
        $localaddr = getsockname($fh) or die "= getsockname failed: $!\n";

        # get information about remote end of connection
        $remoteaddr = getpeername($fh) or die "= getpeername failed: $!\n";
    };
    if ( $@ =~ /^= (.*)/ ) {

        # here's the catch of the throw
        # return false, try to preserve errno
        local ($!);

        # we make a "fake" $self
        my $self = {
            'state' => 'error',
            'error' => "Net::Ident::new: $1\n",
        };
        print STDDBG $self->{error} if $DEBUG;

        # return our blessed $self
        return bless $self, $class;
    }
    elsif ($@) {

        # something else went wrong. barf up completely.
        confess($@);
    }

    # continue with the NewFromInAddr constructor
    $class->newFromInAddr( $localaddr, $remoteaddr, $timeout );
}

sub newFromInAddr {
    my ( $class, $localaddr, $remoteaddr, $timeout ) = @_;
    my $self = {};

    print STDDBG "Net::Ident::newFromInAddr localaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" }
      ->( sockaddr_in($localaddr) ), ", remoteaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" }
      ->( sockaddr_in($remoteaddr) ), ", timeout=", defined $timeout ? $timeout : "", "\n"
      if $DEBUG > 1;

    eval {
        # unpack addresses and store in
        my ( $localip, $remoteip );
        ( $self->{localport},  $localip )  = sockaddr_in($localaddr);
        ( $self->{remoteport}, $remoteip ) = sockaddr_in($remoteaddr);

        # create a local binding port. We cannot bind to INADDR_ANY, it has
        # to be bind (bound?) to the same IP address as the connection we're
        # interested in on machines with multiple IP addresses
        my $localbind = sockaddr_in( 0, $localip );

        # store max time
        $self->{maxtime} = defined($timeout) ? time + $timeout : undef;

        # create a remote connect point
        my $identbind = sockaddr_in( $identport, $remoteip );

        # create a new FileHandle
        $self->{fh} = new FileHandle;

        # create a stream socket.
        socket( $self->{fh}, PF_INET, SOCK_STREAM, $tcpproto )
          or die "= socket failed: $!\n";

        # bind it to the same IP number as the local end of THESOCK
        bind( $self->{fh}, $localbind ) or die "= bind failed: $!\n";

        # make it a non-blocking socket
        if ( $^O ne 'MSWin32' ) {
            fcntl( $self->{fh}, F_SETFL, $NONBLOCK ) or die "= fcntl failed: $!\n";
        }

        # connect it to the remote identd port, this can return EINPROGRESS.
        # for some reason, reading $! twice doesn't work as it should
        connect( $self->{fh}, $identbind )
          or $!{EINPROGRESS}
          or die "= connect failed: $!\n";
        $self->{fh}->blocking(0) if $^O eq 'MSWin32';
    };
    if ( $@ =~ /^= (.*)/ ) {

        # here's the catch of the throw
        # return false, try to preserve errno
        local ($!);
        $self->{error} = "Net::Ident::new: $1\n";
        print STDDBG $self->{error} if $DEBUG;

        # this deletes the FileHandle, which gets closed,
        # so that might change errno
        delete $self->{fh};

        # do NOT return, so the constructor always succeeds
    }
    elsif ($@) {

        # something else went wrong. barf up completely.
        confess($@);
    }

    # clear errno in case it contains EINPROGRESS
    $! = 0;

    # mark the state of the connection
    $self->{state} = 'connect';

    # return a blessed reference
    bless $self, $class;
}

# send the query to the remote daemon.
# object method
sub query {
    my ($self) = @_;
    my ( $wmask, $timeout, $emask, $fileno, $err, $query );

    print STDDBG "Net::Ident::query\n" if $DEBUG > 1;

    # bomb out if no fh
    return undef unless $self->{fh};

    # "try"
    eval {
        $self->{state} eq 'connect' or die "= calling in the wrong order\n";
        $fileno = fileno $self->{fh};

        # calculate the time left, abort if necessary. Note that $timeout
        # is simply left undef if $self->{maxtime} is not defined
        if ( defined( $self->{maxtime} )
            && ( $timeout = $self->{maxtime} - time ) < 0 ) {
            die "= Connection timed out\n";
        }

        # wait until the socket becomes writable.
        $wmask = '';
        vec( $wmask, $fileno, 1 ) = 1;
        scalar select( undef, $wmask, $emask = $wmask, $timeout )
          or die "= Connection timed out\n";

        # Check for errors via select (you never know)
        vec( $emask, $fileno, 1 ) and die "= connection error: $!\n";

        # fh must be writable now
        vec( $wmask, $fileno, 1 ) or die "= connection timed out or error: $!\n";

        # check for errors via getsockopt(SO_ERROR)
        $err = getsockopt( $self->{fh}, SOL_SOCKET, SO_ERROR );
        if ( !defined($err) || ( $! = unpack( 'L', $err ) ) ) {
            die "= connect: $!\n";
        }

        # create the query, based on the remote port and the local port
        $query = "$self->{remoteport},$self->{localport}\r\n";

        # write the query. Ignore the chance that such a short
        # write will be fragmented.
        syswrite( $self->{fh}, $query, length $query ) == length $query
          or die "= fragmented write on socket: $!\n";
    };
    if ( $@ =~ /^= (.*)/ ) {

        # here's the catch of the throw
        # return false, try to preserve errno
        local ($!);
        $self->{error} = "Net::Ident::query: $1\n";
        print STDDBG $self->{error} if $DEBUG;

        # this deletes the FileHandle, which gets closed,
        # so that might change errno
        delete $self->{fh};
        return undef;
    }
    elsif ($@) {

        # something else went wrong. barf up completely.
        confess($@);
    }

    # initialise empty answer to prevent uninitialised value warning
    $self->{answer} = '';

    # mark the state of the connection
    $self->{state} = 'query';

    # return the same object on success
    $self;
}

# read data, if any, and check if it's enough.
# object method
sub ready {
    my ( $self, $blocking ) = @_;
    my ( $timeout, $rmask, $emask, $answer, $ret, $fileno );

    print STDDBG "Net::Ident::ready blocking=" . ( $blocking ? "true\n" : "false\n" ) if $DEBUG > 1;

    # perform the query if not already done.
    if ( $self->{state} ne 'query' ) {
        $self->query or return undef;
    }

    # exit immediately if ready returned 1 before.
    elsif ( $self->{state} eq 'ready' ) {
        return 1;
    }

    # bomb out if no fh
    return undef unless $self->{fh};

    # "try"
    $ret = eval {
        $fileno = fileno $self->{fh};

        # while $blocking, but at least once...
        do {
            # calculate the time left, abort if necessary.
            if ( defined( $self->{maxtime} )
                && ( $timeout = $self->{maxtime} - time ) < 0 ) {
                die "= Timeout\n";
            }

            # zero timeout for non-blocking
            $timeout = 0 unless $blocking;

            # wait for something
            $rmask = '';
            vec( $rmask, $fileno, 1 ) = 1;
            if ( select( $rmask, undef, $emask = $rmask, $timeout ) ) {

                # something came in
                vec( $emask, $fileno, 1 ) and die "= error while reading: $!\n";

                # check for incoming data
                if ( vec( $rmask, $fileno, 1 ) ) {

                    # try to read as much data as possible.
                    $answer = '';
                    defined sysread( $self->{fh}, $answer, 1000 )
                      or die "= read returned error: $!\n";

                    # append incoming data to total received
                    $self->{answer} .= $answer;

                    # check for max length
                    length( $self->{answer} ) <= 1000
                      or die "= remote daemon babbling too much\n";

                    # if data contains a CR or LF, we are ready receiving.
                    # strip everything after and including the CR or LF and
                    # return success
                    if ( $self->{answer} =~ /[\n\r]/ ) {
                        $self->{answer} =~ s/[\n\r].*//s;
                        print STDDBG "Net::Ident::ready received: $self->{answer}\n"
                          if $DEBUG;

                        # close the socket to the remote identd
                        close( $self->{fh} );
                        $self->{state} = 'ready';
                        return 1;
                    }
                }
            }
        } while $blocking;

        # we don't block, but we didn't receive everything yet... return false.
        0;
    };
    if ( $@ =~ /^= (.*)/ ) {

        # here's the catch of the throw
        # return undef, try to preserve errno
        local ($!);
        $self->{error} = "Net::Ident::ready: $1\n";
        print STDDBG $self->{error} if $DEBUG;

        # this deletes the FileHandle, which gets closed,
        # so that might change errno
        delete $self->{fh};
        return undef;
    }
    elsif ($@) {

        # something else went wrong. barf up completely.
        confess($@);
    }

    # return the return value from the eval{}
    $ret;
}

# return the username from the rfc931 query return.
# object method
sub username {
    my ($self) = @_;
    my (
        $remoteport, $localport, $port1, $port2, $replytype, $reply, $opsys,
        $userid,     $error
    );

    print STDDBG "Net::Ident::username\n" if $DEBUG > 1;

    # wait for data, if necessary.
    return wantarray ? ( undef, undef, $self->{error} ) : undef
      unless $self->ready(1);

    # parse the received string, split it into parts.
    ( $port1, $port2, $replytype, $reply ) = ( $self->{answer} =~ /^\s*(\d+)\s*,\s*(\d+)\s*:\s*(ERROR|USERID)\s*:\s*(.*)$/ );

    # make sure the answer parsed properly, and that the ports are the same.
    if (   !defined($reply)
        || ( $self->{remoteport} != $port1 )
        || ( $self->{localport} != $port2 ) ) {
        $self->{error} = "Net::Ident::username couldn't parse reply or port mismatch\n";
        print STDDBG $self->{error} if $DEBUG;
        return wantarray ? ( undef, undef, $self->{error} ) : undef;
    }

    # check for error return type
    if ( $replytype eq "ERROR" ) {
        print STDDBG "Net::Ident::username: lookup returned ERROR\n" if $DEBUG;
        $userid = undef;
        $opsys  = "ERROR";
        ( $error = $reply ) =~ s/\s+$//;
    }
    else {
        # a normal reply, parse the opsys and userid. Note that the opsys may
        # contain \ escaped colons, which is why the hairy regexp is necessary.
        unless ( ( $opsys, $userid ) = ( $reply =~ /\s*((?:[^\\:]+|\\.)*):(.*)$/ ) ) {

            # didn't parse properly, abort.
            $self->{error} = "Net::Ident::username: couldn't parse userid\n";
            print STDDBG $self->{error} if $DEBUG;
            return wantarray ? ( undef, undef, $self->{error} ) : undef;
        }

        # remove trailing whitespace, except backwhacked whitespaces from opsys
        $opsys =~ s/([^\\])\s+$/$1/;

        # un-backwhack opsys.
        $opsys =~ s/\\(.)/$1/g;

        # in all cases is leading whitespace removed from the username, even
        # though rfc1413 mentions that it shouldn't be done, current
        # implementation practice dictates otherwise. What insane OS would
        # use leading whitespace in usernames anyway...
        $userid =~ s/^\s+//;

        # Test if opsys is "special": if it contains a charset definition,
        # or if it is "OTHER". This means that it is rfc1413-like, instead
        # of rfc931-like. (Why can't they make these RFCs non-conflicting??? ;)
        # Note that while rfc1413 (the one that superseded rfc931) indicates
        # that _any_ characters following the final colon are part of the
        # username, current implementation practice inserts a space there,
        # even "modern" identd daemons.
        # Also, rfc931 specifically mentions escaping characters, while
        # rfc1413 does not mention it (it isn't really necessary). Anyway,
        # I'm going to remove trailing whitespace from userids, and I'm
        # going to un-backwhack them, unless the opsys is "special".
        unless ( $opsys =~ /,/ || $opsys eq 'OTHER' ) {

            # remove trailing whitespace, except backwhacked whitespaces.
            $userid =~ s/([^\\])\s+$/$1/;

            # un-backwhack
            $userid =~ s/\\(.)/$1/g;
        }
        $error = undef;
    }

    # return the requested information, depending on whether in array context.
    if ( $DEBUG > 1 ) {
        print STDDBG "Net::Ident::username returns:\n";
        print STDDBG "userid = ", defined $userid ? $userid : "", "\n";
        print STDDBG "opsys = ",  defined $opsys  ? $opsys  : "", "\n";
        print STDDBG "error = ",  defined $error  ? $error  : "", "\n";
    }
    wantarray ? ( $userid, $opsys, $error ) : $userid;
}

# do the entire rfc931 lookup in one blow.
# exportable subroutine, not a method
sub lookup ($;$) {
    my ( $fh, $timeout ) = @_;

    print STDDBG "Net::Ident::lookup fh=$fh, timeout=", defined $timeout ? $timeout : "", "\n"
      if $DEBUG > 1;

    Net::Ident->new( $fh, $timeout )->username;
}

# do the entire rfc931 lookup from two in_addr structs
sub lookupFromInAddr ($$;$) {
    my ( $localaddr, $remoteaddr, $timeout ) = @_;

    print STDDBG "Net::Ident::lookupFromInAddr localaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" }
      ->( sockaddr_in($localaddr) ), ", remoteaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" }
      ->( sockaddr_in($remoteaddr) ), ", timeout=", defined $timeout ? $timeout : "", "\n"
      if $DEBUG > 1;

    Net::Ident->newFromInAddr( $localaddr, $remoteaddr, $timeout )->username;
}

# alias Net::Ident::ident_lookup to Net::Ident::lookup
sub ident_lookup ($;$);
*ident_lookup = \&lookup;

# prevent "used only once" warning
ident_lookup(0) if 0;

# get the FileHandle ref from the object, to be used in an external select().
# object method
sub getfh ($) {
    my ($self) = @_;

    $self->{fh};
}

# get the last error message.
# object method
sub geterror ($) {
    my ($self) = @_;

    $self->{error};
}

# this is called whenever a function in @EXPORT_FAIL is imported.
# simply calls the installed export hooks from %EXPORT_HOOKS, or
# passes along the export_fail up the inheritance chain
sub export_fail {
    my $pkg = shift;
    my $fail;
    my @other;
    foreach $fail (@_) {
        if ( $fail =~ /^_export_hook_(.*)$/ && $EXPORT_HOOKS{$1} ) {
            &{ $EXPORT_HOOKS{$1} };
        }
        else {
            push @other, $fail;
        }
    }
    if (@other) {
        @other = SUPER::export_fail(@other);
    }
    @other;
}

# add lookup method for FileHandle objects. Note that this relies on the
# use FileHandle;
sub _add_fh_method {

    # determine package to add method to
    my $pkg = grep( /^IO::/, @FileHandle::ISA ) ? "IO::Handle" : "FileHandle";

    # insert method in package. Arguments are already OK for std lookup
    # turn off strict refs for this glob-mangling trick
    no strict 'refs';
    *{"${pkg}::ident_lookup"} = \&lookup;

    print STDDBG "Added ${pkg}::ident_lookup method\n" if $DEBUG;
}

sub _add_apache_method {

    # add method to Apache::Connection class
    no strict 'refs';
    *{"Apache::Connection::ident_lookup"} = sub {
        my ( $self, $timeout ) = @_;

        print STDDBG "Apache::Connection::ident_lookup self=$self, ", "timeout=", defined $timeout ? $timeout : "", "\n"
          if $DEBUG > 1;
        lookupFromInAddr( $self->local_addr, $self->remote_addr, $timeout );
    };

    print STDDBG "Added Apache::Connection::ident_lookup method\n" if $DEBUG;
}

1;

__END__