PLEAC-Perl 教程 - Socket (Perl进阶者极力推荐)_perl unless ( bind($serversocket, $serverip) )-优快云博客

本文深入探讨了使用Perl进行网络编程的技术细节，包括TCP客户端和服务端的建立、UDP客户端和服务端的设置、使用UNIX域套接字进行通信等。此外，还介绍了如何处理多连接、重启服务器、守护进程化等方面的知识。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

17. Sockets

Introduction

#-----------------------------
use Socket;

$packed_ip   = inet_aton("208.146.240.1");
$socket_name = sockaddr_in($port, $packed_ip);
#-----------------------------
use Socket;

$socket_name = sockaddr_un("/tmp/mysock");
#-----------------------------
($port, $packed_ip) = sockaddr_in($socket_name);    # for PF_INET sockets
($filename)         = sockaddr_un($socket_name);    # for PF_UNIX sockets
#-----------------------------
$ip_address = inet_ntoa($packed_ip);
$packed_ip  = inet_aton("204.148.40.9");
$packed_ip  = inet_aton("www.oreilly.com");
#-----------------------------

Writing a TCP Client

#-----------------------------
use IO::Socket;

$socket = IO::Socket::INET->new(PeerAddr => $remote_host,
                                PeerPort => $remote_port,
                                Proto    => "tcp",
                                Type     => SOCK_STREAM)
    or die "Couldn't connect to $remote_host:$remote_port : $@/n";

# ... do something with the socket
print $socket "Why don't you call me anymore?/n";

$answer = <$socket>;

# and terminate the connection when we're done
close($socket);
#-----------------------------
use Socket;

# create a socket
socket(TO_SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));

# build the address of the remote machine
$internet_addr = inet_aton($remote_host)
    or die "Couldn't convert $remote_host into an Internet address: $!/n";
$paddr = sockaddr_in($remote_port, $internet_addr);

# connect
connect(TO_SERVER, $paddr)
    or die "Couldn't connect to $remote_host:$remote_port : $!/n";

# ... do something with the socket
print TO_SERVER "Why don't you call me anymore?/n";

# and terminate the connection when we're done
close(TO_SERVER);
#-----------------------------
$client = IO::Socket::INET->new("www.yahoo.com:80")
    or die $@;
#-----------------------------
$s = IO::Socket::INET->new(PeerAddr => "Does not Exist",
                           Peerport => 80,
                           Type     => SOCK_STREAM )
    or die $@;
#-----------------------------
$s = IO::Socket::INET->new(PeerAddr => "bad.host.com",
                           PeerPort => 80,
                           Type     => SOCK_STREAM,
                           Timeout  => 5 )
    or die $@;
#-----------------------------
$inet_addr = inet_aton("208.146.240.1");
$paddr     = sockaddr_in($port, $inet_addr);
bind(SOCKET, $paddr)         or die "bind: $!";
#-----------------------------
$inet_addr = gethostbyname("www.yahoo.com")
                            or die "Can't resolve www.yahoo.com: $!";
$paddr     = sockaddr_in($port, $inet_addr);
bind(SOCKET, $paddr)        or die "bind: $!";
#-----------------------------

Writing a TCP Server

#-----------------------------
use IO::Socket;

$server = IO::Socket::INET->new(LocalPort => $server_port,
                                Type      => SOCK_STREAM,
                                Reuse     => 1,
                                Listen    => 10 )   # or SOMAXCONN
    or die "Couldn't be a tcp server on port $server_port : $@/n";

while ($client = $server->accept()) {
    # $client is the new connection
}

close($server);
#-----------------------------
use Socket;

# make the socket
socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));

# so we can restart our server quickly
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);

# build up my socket address
$my_addr = sockaddr_in($server_port, INADDR_ANY);
bind(SERVER, $my_addr)
    or die "Couldn't bind to port $server_port : $!/n";

# establish a queue for incoming connections
listen(SERVER, SOMAXCONN)
    or die "Couldn't listen on port $server_port : $!/n";

# accept and process connections
while (accept(CLIENT, SERVER)) {
    # do something with CLIENT
}

close(SERVER);
#-----------------------------
use Socket;

while ($client_address = accept(CLIENT, SERVER)) {
    ($port, $packed_ip) = sockaddr_in($client_address);
    $dotted_quad = inet_ntoa($packed_ip);
    # do as thou wilt
}
#-----------------------------
while ($client = $server->accept()) {
    # ...
}
#-----------------------------
while (($client,$client_address) = $server->accept()) {
    # ...
}
#-----------------------------
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);

$flags = fcntl(SERVER, F_GETFL, 0)
            or die "Can't get flags for the socket: $!/n";

$flags = fcntl(SERVER, F_SETFL, $flags | O_NONBLOCK)
            or die "Can't set flags for the socket: $!/n";
#-----------------------------

Communicating over TCP

#-----------------------------
print SERVER "What is your name?/n";
chomp ($response = <SERVER>);
#-----------------------------
defined (send(SERVER, $data_to_send, $flags))
    or die "Can't send : $!/n";

recv(SERVER, $data_read, $maxlen, $flags)
    or die "Can't receive: $!/n";
#-----------------------------
use IO::Socket;

$server->send($data_to_send, $flags)
    or die "Can't send: $!/n";

$server->recv($data_read, $flags)
    or die "Can't recv: $!/n";
#-----------------------------
use IO::Select;

$select = IO::Select->new();
$select->add(*FROM_SERVER);
$select->add($to_client);

@read_from = $select->can_read($timeout);
foreach $socket (@read_from) {
    # read the pending data from $socket
}
#-----------------------------
use Socket;
require "sys/socket.ph";    # for &TCP_NODELAY

setsockopt(SERVER, SOL_SOCKET, &TCP_NODELAY, 1)
    or die "Couldn't disable Nagle's algorithm: $!/n";
#-----------------------------
setsockopt(SERVER, SOL_SOCKET, &TCP_NODELAY, 0)
    or die "Couldn't enable Nagle's algorithm: $!/n";
#-----------------------------
$rin = '';                          # initialize bitmask
vec($rin, fileno(SOCKET), 1) = 1;   # mark SOCKET in $rin
# repeat calls to vec() for each socket to check

$timeout = 10;                      # wait ten seconds

$nfound = select($rout = $rin, undef, undef, $timeout);
if (vec($rout, fileno(SOCKET),1)){
    # data to be read on SOCKET
}
#-----------------------------

Setting Up a UDP Client

#-----------------------------
use Socket;
socket(SOCKET, PF_INET, SOCK_DGRAM, getprotobyname("udp")) 
    or die "socket: $!";
#-----------------------------
use IO::Socket;
$handle = IO::Socket::INET->new(Proto => 'udp') 
    or die "socket: $@";     # yes, it uses $@ here
#-----------------------------
$ipaddr   = inet_aton($HOSTNAME);
$portaddr = sockaddr_in($PORTNO, $ipaddr);
send(SOCKET, $MSG, 0, $portaddr) == length($MSG)
        or die "cannot send to $HOSTNAME($PORTNO): $!";
#-----------------------------
$portaddr = recv(SOCKET, $MSG, $MAXLEN, 0)      or die "recv: $!";
($portno, $ipaddr) = sockaddr_in($portaddr);
$host = gethostbyaddr($ipaddr, AF_INET);
print "$host($portno) said $MSG/n";
#-----------------------------
send(MYSOCKET, $msg_buffer, $flags, $remote_addr)
    or die "Can't send: $!/n";
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# clockdrift - compare another system's clock with this one
use strict;
use Socket;

my ($host, $him, $src, $port, $ipaddr, $ptime, $delta);
my $SECS_of_70_YEARS      = 2_208_988_800;

socket(MsgBox, PF_INET, SOCK_DGRAM, getprotobyname("udp"))
    or die "socket: $!";
$him = sockaddr_in(scalar(getservbyname("time", "udp")), 
    inet_aton(shift || '127.1'));
defined(send(MsgBox, 0, 0, $him))
    or die "send: $!";
defined($src = recv(MsgBox, $ptime, 4, 0))
    or die "recv: $!";
($port, $ipaddr) = sockaddr_in($src);
$host = gethostbyaddr($ipaddr, AF_INET);
my $delta = (unpack("N", $ptime) - $SECS_of_70_YEARS) - time();
print "Clock on $host is $delta seconds ahead of this one./n";

#-----------------------------

Setting Up a UDP Server

#-----------------------------
use IO::Socket;
$server = IO::Socket::INET->new(LocalPort => $server_port,
                                Proto     => "udp")
    or die "Couldn't be a udp server on port $server_port : $@/n";
#-----------------------------
while ($him = $server->recv($datagram, $MAX_TO_READ, $flags)) {
    # do something
} 
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# udpqotd - UDP message server
use strict;
use IO::Socket;
my($sock, $oldmsg, $newmsg, $hisaddr, $hishost, $MAXLEN, $PORTNO);
$MAXLEN = 1024;
$PORTNO = 5151;
$sock = IO::Socket::INET->new(LocalPort => $PORTNO, Proto => 'udp')
    or die "socket: $@";
print "Awaiting UDP messages on port $PORTNO/n";
$oldmsg = "This is the starting message.";
while ($sock->recv($newmsg, $MAXLEN)) {
    my($port, $ipaddr) = sockaddr_in($sock->peername);
    $hishost = gethostbyaddr($ipaddr, AF_INET);
    print "Client $hishost said ``$newmsg''/n";
    $sock->send($oldmsg);
    $oldmsg = "[$hishost] $newmsg";
} 
die "recv: $!";

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# udpmsg - send a message to the udpquotd server

use IO::Socket;
use strict;

my($sock, $server_host, $msg, $port, $ipaddr, $hishost, 
   $MAXLEN, $PORTNO, $TIMEOUT);

$MAXLEN  = 1024;
$PORTNO  = 5151;
$TIMEOUT = 5;

$server_host = shift;
$msg         = "@ARGV";
$sock = IO::Socket::INET->new(Proto     => 'udp',
                              PeerPort  => $PORTNO,
                              PeerAddr  => $server_host)
    or die "Creating socket: $!/n";
$sock->send($msg) or die "send: $!";

eval {
    local $SIG{ALRM} = sub { die "alarm time out" };
    alarm $TIMEOUT;
    $sock->recv($msg, $MAXLEN)      or die "recv: $!";
    alarm 0;
    1;  # return value from eval on normalcy
} or die "recv from $server_host timed out after $TIMEOUT seconds./n";

($port, $ipaddr) = sockaddr_in($sock->peername);
$hishost = gethostbyaddr($ipaddr, AF_INET);
print "Server $hishost responded ``$msg''/n";

#-----------------------------

Using UNIX Domain Sockets

#-----------------------------
use IO::Socket;

unlink "/tmp/mysock";
$server = IO::Socket::UNIX->new(Local     => "/tmp/mysock",
                                Type      => SOCK_DGRAM,
                                Listen    => 5 )
    or die $@;

$client = IO::Socket::UNIX->new(Peer       => "/tmp/mysock",
                                Type      => SOCK_DGRAM,
                                Timeout   => 10 )
    or die $@;
#-----------------------------
use Socket;
    
socket(SERVER, PF_UNIX, SOCK_STREAM, 0);
unlink "/tmp/mysock";
bind(SERVER, sockaddr_un("/tmp/mysock"))
    or die "Can't create server: $!";

socket(CLIENT, PF_UNIX, SOCK_STREAM, 0);
connect(CLIENT, sockaddr_un("/tmp/mysock"))
    or die "Can't connect to /tmp/mysock: $!";
#-----------------------------

Identifying the Other End of a Socket

#-----------------------------
use Socket;

$other_end         = getpeername(SOCKET)
    or die "Couldn't identify other end: $!/n";
($port, $iaddr)    = unpack_sockaddr_in($other_end);
$ip_address        = inet_ntoa($iaddr);
#-----------------------------
use Socket;

$other_end        = getpeername(SOCKET)
    or die "Couldn't identify other end: $!/n";
($port, $iaddr)   = unpack_sockaddr_in($other_end);
$actual_ip        = inet_ntoa($iaddr);
$claimed_hostname = gethostbyaddr($iaddr, AF_INET);
@name_lookup      = gethostbyname($claimed_hostname)
    or die "Could not look up $claimed_hostname : $!/n";
@resolved_ips     = map { inet_ntoa($_) }
    @name_lookup[ 4 .. $#ips_for_hostname ];
#-----------------------------
$packed_ip  = gethostbyname($name) or die "Couldn't look up $name : $!/n";
$ip_address = inet_ntoa($packed_ip);
#-----------------------------

Finding Your Own Name and Address

#-----------------------------
use Sys::Hostname;

$hostname = hostname();
#-----------------------------
use POSIX qw(uname);
($kernel, $hostname, $release, $version, $hardware) = uname();

$hostname = (uname)[1];             # or just one
#-----------------------------
use Socket;                         # for AF_INET
$address  = gethostbyname($hostname)
    or die "Couldn't resolve $hostname : $!";
$hostname = gethostbyaddr($address, AF_INET)
    or die "Couldn't re-resolve $hostname : $!";
#-----------------------------

Closing a Socket After Forking

#-----------------------------
shutdown(SOCKET, 0);                # I/we have stopped reading data
shutdown(SOCKET, 1);                # I/we have stopped writing data
shutdown(SOCKET, 2);                # I/we have stopped using this socket
#-----------------------------
$socket->shutdown(0);               # I/we have stopped reading data
#-----------------------------
print SERVER "my request/n";        # send some data
shutdown(SERVER, 1);                # send eof; no more writing
$answer = <SERVER>;                 # but you can still read
#-----------------------------

Writing Bidirectional Clients

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# biclient - bidirectional forking client
    use strict;
use IO::Socket;
my ($host, $port, $kidpid, $handle, $line);

unless (@ARGV == 2) { die "usage: $0 host port" }
($host, $port) = @ARGV;

# create a tcp connection to the specified host and port
$handle = IO::Socket::INET->new(Proto     => "tcp",
                                PeerAddr  => $host,
                                PeerPort  => $port)
       or die "can't connect to port $port on $host: $!";

$handle->autoflush(1);              # so output gets there right away
print STDERR "[Connected to $host:$port]/n";

# split the program into two processes, identical twins
die "can't fork: $!" unless defined($kidpid = fork());

if ($kidpid) {                      
    # parent copies the socket to standard output
    while (defined ($line = <$handle>)) {
        print STDOUT $line;
    }
    kill("TERM" => $kidpid);        # send SIGTERM to child
}
else {                              
    # child copies standard input to the socket
    while (defined ($line = <STDIN>)) {
        print $handle $line;
    }
}
exit;

#-----------------------------
my $byte;
while (sysread($handle, $byte, 1) == 1) {
    print STDOUT $byte;
}
#-----------------------------

Forking Servers

#-----------------------------
# set up the socket SERVER, bind and listen ...
use POSIX qw(:sys_wait_h);

sub REAPER {
    1 until (-1 == waitpid(-1, WNOHANG));
    $SIG{CHLD} = /&REAPER;                 # unless $] >= 5.002
}

$SIG{CHLD} = /&REAPER;

while ($hisaddr = accept(CLIENT, SERVER)) {
    next if $pid = fork;                    # parent
    die "fork: $!" unless defined $pid;     # failure
    # otherwise child
    close(SERVER);                          # no use to child
    # ... do something
    exit;                                   # child leaves
} continue { 
    close(CLIENT);                          # no use to parent
}
#-----------------------------

Pre-Forking Servers

#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# preforker - server who forks first
use IO::Socket;
use Symbol;
use POSIX;

# establish SERVER socket, bind and listen.
$server = IO::Socket::INET->new(LocalPort => 6969,
                                Type      => SOCK_STREAM,
                                Proto     => 'tcp',
                                Reuse     => 1,
                                Listen    => 10 )
  or die "making socket: $@/n";

# global variables
$PREFORK                = 5;        # number of children to maintain
$MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process
%children               = ();       # keys are current child process IDs
$children               = 0;        # current number of children

sub REAPER {                        # takes care of dead children
    $SIG{CHLD} = /&REAPER;
    my $pid = wait;
    $children --;
    delete $children{$pid};
}

sub HUNTSMAN {                      # signal handler for SIGINT
    local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
    kill 'INT' => keys %children;
    exit;                           # clean up with dignity
}

    
# Fork off our children.
for (1 .. $PREFORK) {
    make_new_child();
}

# Install signal handlers.
$SIG{CHLD} = /&REAPER;
$SIG{INT}  = /&HUNTSMAN;

# And maintain the population.
while (1) {
    sleep;                          # wait for a signal (i.e., child's death)
    for ($i = $children; $i < $PREFORK; $i++) {
        make_new_child();           # top up the child pool
    }
}

sub make_new_child {
    my $pid;
    my $sigset;
    
    # block signal for fork
    $sigset = POSIX::SigSet->new(SIGINT);
    sigprocmask(SIG_BLOCK, $sigset)
        or die "Can't block SIGINT for fork: $!/n";
    
    die "fork: $!" unless defined ($pid = fork);
    
    if ($pid) {
        # Parent records the child's birth and returns.
        sigprocmask(SIG_UNBLOCK, $sigset)
            or die "Can't unblock SIGINT for fork: $!/n";
        $children{$pid} = 1;
        $children++;
        return;
    } else {
        # Child can *not* return from this subroutine.
        $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
    
        # unblock signals
        sigprocmask(SIG_UNBLOCK, $sigset)
            or die "Can't unblock SIGINT for fork: $!/n";
    
        # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
        for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
            $client = $server->accept()     or last;
            # do something with the connection
        }
    
        # tidy up gracefully and finish
    
        # this exit is VERY important, otherwise the child will become
        # a producer of more and more children, forking yourself into
        # process death.
        exit;
    }
}

#-----------------------------

Non-Forking Servers

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# nonforker - server who multiplexes without forking
use POSIX;
use IO::Socket;
use IO::Select;
use Socket;
use Fcntl;
use Tie::RefHash;

$port = 1685;               # change this at will

# Listen to port.
$server = IO::Socket::INET->new(LocalPort => $port,
                                Listen    => 10 )
  or die "Can't make server socket: $@/n";

# begin with empty buffers
%inbuffer  = ();
%outbuffer = ();
%ready     = ();

tie %ready, 'Tie::RefHash';

nonblock($server);
$select = IO::Select->new($server);

# Main loop: check reads/accepts, check writes, check ready to process
while (1) {
    my $client;
    my $rv;
    my $data;

    # check for new information on the connections we have

    # anything to read or accept?
    foreach $client ($select->can_read(1)) {

        if ($client == $server) {
            # accept a new connection

            $client = $server->accept();
            $select->add($client);
            nonblock($client);
        } else {
            # read data
            $data = '';
            $rv   = $client->recv($data, POSIX::BUFSIZ, 0);

            unless (defined($rv) && length $data) {
                # This would be the end of file, so close the client
                delete $inbuffer{$client};
                delete $outbuffer{$client};
                delete $ready{$client};

                $select->remove($client);
                close $client;
                next;
            }

            $inbuffer{$client} .= $data;

            # test whether the data in the buffer or the data we
            # just read means there is a complete request waiting
            # to be fulfilled.  If there is, set $ready{$client}
            # to the requests waiting to be fulfilled.
            while ($inbuffer{$client} =~ s/(.*/n)//) {
                push( @{$ready{$client}}, $1 );
            }
        }
    }

    # Any complete requests to process?
    foreach $client (keys %ready) {
        handle($client);
    }

    # Buffers to flush?
    foreach $client ($select->can_write(1)) {
        # Skip this client if we have nothing to say
        next unless exists $outbuffer{$client};

        $rv = $client->send($outbuffer{$client}, 0);
        unless (defined $rv) {
            # Whine, but move on.
            warn "I was told I could write, but I can't./n";
            next;
        }
        if ($rv == length $outbuffer{$client} ||
            {$! == POSIX::EWOULDBLOCK) {
            substr($outbuffer{$client}, 0, $rv) = '';
            delete $outbuffer{$client} unless length $outbuffer{$client};
        } else {
            # Couldn't write all the data, and it wasn't because
            # it would have blocked.  Shutdown and move on.
            delete $inbuffer{$client};
            delete $outbuffer{$client};
            delete $ready{$client};

            $select->remove($client);
            close($client);
            next;
        }
    }

    # Out of band data?
    foreach $client ($select->has_exception(0)) {  # arg is timeout
        # Deal with out-of-band data here, if you want to.
    }
}

# handle($socket) deals with all pending requests for $client
sub handle {
    # requests are in $ready{$client}
    # send output to $outbuffer{$client}
    my $client = shift;
    my $request;

    foreach $request (@{$ready{$client}}) {
        # $request is the text of the request
        # put text of reply into $outbuffer{$client}
    }
    delete $ready{$client};
}

# nonblock($socket) puts socket into nonblocking mode
sub nonblock {
    my $socket = shift;
    my $flags;

    
    $flags = fcntl($socket, F_GETFL, 0)
            or die "Can't get flags for socket: $!/n";
    fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
            or die "Can't make socket nonblocking: $!/n";
}

#-----------------------------
while ($inbuffer{$client} =~ s/(.*/n)//) {
    push( @{$ready{$client}}, $1 );
}
#-----------------------------
$outbuffer{$client} .= $request;
#-----------------------------

Writing a Multi-Homed Server

#-----------------------------
use Socket;

socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);
bind(SERVER, sockaddr_in($server_port, INADDR_ANY))
    or die "Binding: $!/n";

# accept loop
while (accept(CLIENT, SERVER)) {
    $my_socket_address = getsockname(CLIENT);
    ($port, $myaddr)   = sockaddr_in($my_socket_address);
}
#-----------------------------
$server = IO::Socket::INET->new(LocalPort => $server_port,
                                Type      => SOCK_STREAM,
                                Proto     => 'tcp',
                                Listen    => 10)
    or die "Can't create server socket: $@/n";

while ($client = $server->accept()) {
    $my_socket_address = $client->sockname();
    ($port, $myaddr)   = sockaddr_in($my_socket_address);
    # ...
}
#-----------------------------
use Socket;

$port = 4269;                       # port to bind to
$host = "specific.host.com";        # virtual host to listen on

socket(Server, PF_INET, SOCK_STREAM, getprotobyname("tcp"))
    or die "socket: $!";
bind(Server, sockaddr_in($port, inet_aton($host)))
    or die "bind: $!";
while ($client_address = accept(Client, Server)) {
    # ...
}
#-----------------------------

Making a Daemon Server

#-----------------------------
chroot("/var/daemon")
    or die "Couldn't chroot to /var/daemon: $!";
#-----------------------------
$pid = fork;
exit if $pid;
die "Couldn't fork: $!" unless defined($pid);
#-----------------------------
use POSIX;

POSIX::setsid()
    or die "Can't start a new session: $!";
#-----------------------------
$time_to_die = 0;

sub signal_handler {
    $time_to_die = 1;
}

$SIG{INT} = $SIG{TERM} = $SIG{HUP} = /&signal_handler;
# trap or ignore $SIG{PIPE}
#-----------------------------
until ($time_to_die) {
    # ...
}
#-----------------------------

Restarting a Server on Demand

#-----------------------------
$SELF = "/usr/local/libexec/myd";   # which program I am
@ARGS = qw(-l /var/log/myd -d);     # program arguments

$SIG{HUP} = /&phoenix;

sub phoenix {
    # close all your connections, kill your children, and
    # generally prepare to be reincarnated with dignity.
    exec($SELF, @ARGS)              or die "Couldn't restart: $!/n";
}
#-----------------------------
$CONFIG_FILE = "/usr/local/etc/myprog/server_conf.pl";
$SIG{HUP} = /&read_config;
sub read_config {
    do $CONFIG_FILE;
} 
#-----------------------------

Program: backsniff

#-----------------------------
May 25 15:50:22 coprolith sniffer: Connection from 207.46.131.141 to

207.46.130.164:echo 
#-----------------------------
echo    stream  tcp nowait  nobody /usr/scripts/snfsqrd sniffer
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# backsniff - log attempts to connect to particular ports

use Sys::Syslog;
use Socket;

# identify my port and address
$sockname          = getsockname(STDIN)
                     or die "Couldn't identify myself: $!/n";
($port, $iaddr)    = sockaddr_in($sockname);
$my_address        = inet_ntoa($iaddr);

# get a name for the service
$service = (getservbyport ($port, "tcp"))[0] || $port;
# now identify remote address
$sockname          = getpeername(STDIN)
                         or die "Couldn't identify other end: $!/n";
($port, $iaddr)    = sockaddr_in($sockname);
$ex_address        = inet_ntoa($iaddr);

# and log the information
openlog("sniffer", "ndelay", "daemon");
syslog("notice", "Connection from %s to %s:%s/n", $ex_address, 

        $my_address, $service);
closelog();
exit;

#-----------------------------

Program: fwdport

#-----------------------------
#% fwdport -s nntp -l fw.oursite.com -r news.bigorg.com
#-----------------------------
#% fwdport -l myname:9191 -r news.bigorg.com:nntp
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# fwdport -- act as proxy forwarder for dedicated services

use strict;                 # require declarations
use Getopt::Long;           # for option processing
use Net::hostent;       Example 17-8    # by-name interface for host info
use IO::Socket;             # for creating server and client sockets
use POSIX ":sys_wait_h";    # for reaping our dead children

my (
    %Children,              # hash of outstanding child processes
    $REMOTE,                # whom we connect to on the outside
    $LOCAL,                 # where we listen to on the inside
    $SERVICE,               # our service name or port number
    $proxy_server,          # the socket we accept() from
    $ME,                    # basename of this program
);

($ME = $0) =~ s,.*/,,;      # retain just basename of script name

check_args();               # processing switches
start_proxy();              # launch our own server
service_clients();          # wait for incoming
die "NOT REACHED";          # you can't get here from there

# process command line switches using the extended
# version of the getopts library.
sub check_args { 
    GetOptions(
        "remote=s"    => /$REMOTE,
        "local=s"     => /$LOCAL,
        "service=s"   => /$SERVICE,
    ) or die <<EOUSAGE;
    usage: $0 [ --remote host ] [ --local interface ] [ --service service ]   
EOUSAGE
    die "Need remote"                   unless $REMOTE;
    die "Need local or service"         unless $LOCAL || $SERVICE;
}

# begin our server 
sub start_proxy {
    my @proxy_server_config = (
      Proto     => 'tcp',
      Reuse     => 1,
      Listen    => SOMAXCONN,
    );
    push @proxy_server_config, LocalPort => $SERVICE if $SERVICE;
    push @proxy_server_config, LocalAddr => $LOCAL   if $LOCAL;
    $proxy_server = IO::Socket::INET->new(@proxy_server_config)
                    or die "can't create proxy server: $@";
    print "[Proxy server on ", ($LOCAL || $SERVICE), " initialized.]/n";
}

sub service_clients { 
    my (
        $local_client,              # someone internal wanting out
        $lc_info,                   # local client's name/port information
        $remote_server,             # the socket for escaping out
        @rs_config,                 # temp array for remote socket options
        $rs_info,                   # remote server's name/port information
        $kidpid,                    # spawned child for each connection
    );

    $SIG{CHLD} = /&REAPER;          # harvest the moribund

    accepting();

    # an accepted connection here means someone inside wants out
    while ($local_client = $proxy_server->accept()) {
        $lc_info = peerinfo($local_client);
        set_state("servicing local $lc_info");
        printf "[Connect from $lc_info]/n";

        @rs_config = (
            Proto     => 'tcp',
            PeerAddr  => $REMOTE,
        );
        push(@rs_config, PeerPort => $SERVICE) if $SERVICE;

        print "[Connecting to $REMOTE...";
        set_state("connecting to $REMOTE");                 # see below
        $remote_server = IO::Socket::INET->new(@rs_config)
                         or die "remote server: $@";
        print "done]/n";

        $rs_info = peerinfo($remote_server);
        set_state("connected to $rs_info");

        $kidpid = fork();
        die "Cannot fork" unless defined $kidpid;
        if ($kidpid) {
            $Children{$kidpid} = time();            # remember his start time
            close $remote_server;                   # no use to master
            close $local_client;                    # likewise
            next;                                   # go get another client
        } 

        # at this point, we are the forked child process dedicated
        # to the incoming client.  but we want a twin to make i/o
        # easier.

        close $proxy_server;                        # no use to slave

        $kidpid = fork(); 
        die "Cannot fork" unless defined $kidpid;

        # now each twin sits around and ferries lines of data.
        # see how simple the algorithm is when you can have
        # multiple threads of control?

        # this is the fork's parent, the master's child
        if ($kidpid) {              
            set_state("$rs_info --> $lc_info");
            select($local_client); $| = 1;
            print while <$remote_server>;
            kill('TERM', $kidpid);      # kill my twin cause we're done
            } 
        # this is the fork's child, the master's grandchild
        else {                      
            set_state("$rs_info <-- $lc_info");
            select($remote_server); $| = 1;
            print while <$local_client>;
            kill('TERM', getppid());    # kill my twin cause we're done
        } 
        exit;                           # whoever's still alive bites it
    } continue {
        accepting();
    } 
}

# helper function to produce a nice string in the form HOST:PORT
sub peerinfo {
    my $sock = shift;
    my $hostinfo = gethostbyaddr($sock->peeraddr);
    return sprintf("%s:%s", 
                    $hostinfo->name || $sock->peerhost, 
                    $sock->peerport);
} 

# reset our $0, which on some systems make "ps" report
# something interesting: the string we set $0 to!
sub set_state { $0 = "$ME [@_]" } 

# helper function to call set_state
sub accepting {
    set_state("accepting proxy for " . ($REMOTE || $SERVICE));
}

# somebody just died.  keep harvesting the dead until 
# we run out of them.  check how long they ran.
sub REAPER { 
    my $child;
    my $start;
    while (($child = waitpid(-1,WNOHANG)) > 0) {
        if ($start = $Children{$child}) {
            my $runtime = time() - $start;
            printf "Child $child ran %dm%ss/n", 
                $runtime / 60, $runtime % 60;
            delete $Children{$child};
        } else {
            print "Bizarre kid $child exited $?/n";
        } 
    }
    # If I had to choose between System V and 4.2, I'd resign. --Peter Honeyman
    $SIG{CHLD} = /&REAPER; 
};

#-----------------------------