Perl/FAQ/Сокеты

Материал из Wiki.crossplatform.ru

Содержание

1 Introduction
2 Writing a TCP Client
3 Writing a TCP Server
4 Communicating over TCP
5 Setting Up a UDP Client
6 Setting Up a UDP Server
7 Using UNIX Domain Sockets
8 Identifying the Other End of a Socket
9 Finding Your Own Name and Address
10 Closing a Socket After Forking
11 Writing Bidirectional Clients
12 Forking Servers
13 Pre-Forking Servers
14 Non-Forking Servers
15 Writing a Multi-Homed Server
16 Making a Daemon Server
17 Restarting a Server on Demand
18 Program: backsniff
19 Program: fwdport

[править] 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; 
};
 
#-----------------------------

Личные инструменты

Поиск

Библиотеки

Языки

Другое

Навигация

Инструменты

Просмотры

Perl/FAQ/Сокеты

Материал из Wiki.crossplatform.ru

Содержание

[править] Introduction

[править] Writing a TCP Client

[править] Writing a TCP Server

[править] Communicating over TCP

[править] Setting Up a UDP Client

[править] Setting Up a UDP Server

[править] Using UNIX Domain Sockets

[править] Identifying the Other End of a Socket

[править] Finding Your Own Name and Address

[править] Closing a Socket After Forking

[править] Writing Bidirectional Clients

[править] Forking Servers

[править] Pre-Forking Servers

[править] Non-Forking Servers

[править] Writing a Multi-Homed Server

[править] Making a Daemon Server

[править] Restarting a Server on Demand

[править] Program: backsniff

[править] Program: fwdport