view release on metacpan or  search on metacpan

Ident.pm  view on Meta::CPAN

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
# our @EXPORT = qw(_export_hook_fh);

our $VERSION = "1.31";

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;

# 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 : "<undef>" ) . "\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 ($@) {