NAME

Net::IdentServer - An rfc 1413 Ident server which @ISA [is a] Net::Server.

SYNOPSIS

use Net::IdentServer;

my $nis = new Net::IdentServer;

run $nis;  # This is a working identd ...

DESCRIPTION

Although you can run this as you see in the SYNOPSIS, you'll
probably want to rewrite a few things.

Net::IdentServer is a child of Net::Server to be sure.  If you
wish to override the behaviours of this module, just inherit it
and start re-writing as you go.  

An example random fifteen-letter-word ident server follows:

  use strict;

  my $s = new RandomIdentServer;

  run $s;

  package RandomIdentServer;

  use strict;
  use base qw(Net::IdentServer);

  1;

  sub new {
      my $class = shift;
      my $this = $class->SUPER::new( @_ );

      open IN, "/usr/share/dict/words" or die "couldn't open dictionary: $!";
      while(<IN>) {
          if( /^(\S{15})$/ ) {
              push @{ $this->{words} }, $1;
          }
      }
      close IN;

      return $this;
  }

  sub choice {
      my $this = shift;

      my $i = int rand @{ $this->{words} };

      return $this->{words}->[$i];
  }

  sub print_response {
      my $this = shift;
      my ($local, $remote, $type, $info) = @_;

      if( $type eq "UNIX" ) {
          # intercept these valid responses and randomize them

          $info = $this->choice;
      }

      # Do what we would have done
      $this->SUPER::print_response( $local, $remote, $type, $info );
  }

The do_lookup Function

I'm including this meaty function in it's entirity, because this is 
what you'd have to re-write to do your own do_lookup.  It should be 
pretty clear.

If you're really mad about his documentation, shoot me an email and 
I WILL try to help.

sub do_lookup {
    my ($this, $local_addr, $local_port, $rem_addr, $rem_port) = @_;

    my $translate_addr = sub { my $a = shift; my @a = (); push @a, 
        $1 while $a =~ m/(..)/g; join(".", map(hex($_), reverse @a)) };
    my $translate_port = sub { hex(shift) };

    my $found = -1;

    open TCP, "/proc/net/tcp" or die "couldn't open proc/net/tcp for read: $!";
    while(<TCP>) {

        # If you know of a better way to read /proc/net/tcp, drop me a line...
        # because this sorta sucks
        if( m/^\s+\d+:\s+([A-F0-9]{8}):([A-F0-9]{4})\s+([A-F0-9]{8}):([A-F0-9]{4})\s+(\d+)\s+\S+\s+\S+\s+\S+\s+(\d+)/ ) {
            j
            my ($la, $lp, $ra, $rp, $state, $uid) = ($1, $2, $3, $4, $5, $6);

            if( $state == 1 ) {
                $la = $translate_addr->($la); $lp = $translate_port->($lp);
                $ra = $translate_addr->($ra); $rp = $translate_port->($rp);

                # wow, mistake... we are NOT comparing addrs, just ports
                # if( $local_addr eq $la and $local_port eq $lp and $rem_addr eq $ra and $rem_port eq $rp ) {

                if( $local_port eq $lp and $rem_port eq $rp ) {
                    $found = $uid;
                    last;
                }
            }
        }
    }
    close TCP;

    if( $found < 0 ) {
        $this->log(2, "lookup from $rem_addr for $local_port, $rem_port: not found");
        $this->print_error($local_port, $rem_port, 'n'); # no user for when we find no sockets!

        return;
    }

    my $name = getpwuid( $found );
    unless( $name =~ m/\w/ ) {
        # This can happen if a deleted user has a socket open.  'u' might be a better choice. 
        # I happen to think hidden user is a nice choice here.  

        $this->log(2, "lookup from $rem_addr for $local_port, $rem_port: found uid, but no pwent");
        $this->print_error($local_port, $rem_port, 'h'); 

        return;
    }

    $this->log(1, "lookup from $rem_addr for $local_port, $rem_port: found $name");
    $this->print_response($local_port, $rem_port, "UNIX", $name);

    return 1;
}

AUTHOR

Jettero Heller <japh@voltar-confed.org>

Jet is using this software in his own projects...  If you find
bugs, please please please let him know. :)

Actually, let him know if you find it handy at all.  Half the
fun of releasing this stuff is knowing that people use it.

COPYRIGHT

GPL!  I included a gpl.txt for your reading enjoyment.

Though, additionally, I will say that I'll be tickled if you
were to include this package in any commercial endeavor.
Also, any thoughts to the effect that using this module will
somehow make your commercial package GPL should be washed
away.

I hereby release you from any such silly conditions.

This package and any modifications you make to it must remain
GPL.  Any programs you (or your company) write shall remain
yours (and under whatever copyright you choose) even if you
use this package's intended and/or exported interfaces in
them.

SPECIAL THANKS

Holy smokes, Net::Server is the shizzo fo shizzo.  Everyone
send a blessing to this guy, seriously.

Paul T. Seamons <paul at seamons.com>

SEE ALSO

perl(1), Net::Server