perlipc.pod

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

    require 'Comm.pl';
    $ph = open_proc('cat -n');
    for (1..10) {
	print $ph "a line\n";
	print "got back ", scalar <$ph>;
    }

This way you don't have to have control over the source code of the
program you're using.  The F<Comm> library also has expect()
and interact() functions.  Find the library (and we hope its
successor F<IPC::Chat>) at your nearest CPAN archive as detailed
in the SEE ALSO section below.

The newer Expect.pm module from CPAN also addresses this kind of thing.
This module requires two other modules from CPAN: IO::Pty and IO::Stty.
It sets up a pseudo-terminal to interact with programs that insist on
using talking to the terminal device driver.  If your system is
amongst those supported, this may be your best bet.

=head2 Bidirectional Communication with Yourself

If you want, you may make low-level pipe() and fork()
to stitch this together by hand.  This example only
talks to itself, but you could reopen the appropriate
handles to STDIN and STDOUT and call other processes.

    #!/usr/bin/perl -w
    # pipe1 - bidirectional communication using two pipe pairs
    #         designed for the socketpair-challenged
    use IO::Handle;	# thousands of lines just for autoflush :-(
    pipe(PARENT_RDR, CHILD_WTR);		# XXX: failure?
    pipe(CHILD_RDR,  PARENT_WTR);		# XXX: failure?
    CHILD_WTR->autoflush(1);
    PARENT_WTR->autoflush(1);

    if ($pid = fork) {
	close PARENT_RDR; close PARENT_WTR;
	print CHILD_WTR "Parent Pid $$ is sending this\n";
	chomp($line = <CHILD_RDR>);
	print "Parent Pid $$ just read this: `$line'\n";
	close CHILD_RDR; close CHILD_WTR;
	waitpid($pid,0);
    } else {
	die "cannot fork: $!" unless defined $pid;
	close CHILD_RDR; close CHILD_WTR;
	chomp($line = <PARENT_RDR>);
	print "Child Pid $$ just read this: `$line'\n";
	print PARENT_WTR "Child Pid $$ is sending this\n";
	close PARENT_RDR; close PARENT_WTR;
	exit;
    }

But you don't actually have to make two pipe calls.  If you
have the socketpair() system call, it will do this all for you.

    #!/usr/bin/perl -w
    # pipe2 - bidirectional communication using socketpair
    #   "the best ones always go both ways"

    use Socket;
    use IO::Handle;	# thousands of lines just for autoflush :-(
    # We say AF_UNIX because although *_LOCAL is the
    # POSIX 1003.1g form of the constant, many machines
    # still don't have it.
    socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
				or  die "socketpair: $!";

    CHILD->autoflush(1);
    PARENT->autoflush(1);

    if ($pid = fork) {
	close PARENT;
	print CHILD "Parent Pid $$ is sending this\n";
	chomp($line = <CHILD>);
	print "Parent Pid $$ just read this: `$line'\n";
	close CHILD;
	waitpid($pid,0);
    } else {
	die "cannot fork: $!" unless defined $pid;
	close CHILD;
	chomp($line = <PARENT>);
	print "Child Pid $$ just read this: `$line'\n";
	print PARENT "Child Pid $$ is sending this\n";
	close PARENT;
	exit;
    }

=head1 Sockets: Client/Server Communication

While not limited to Unix-derived operating systems (e.g., WinSock on PCs
provides socket support, as do some VMS libraries), you may not have
sockets on your system, in which case this section probably isn't going to do
you much good.  With sockets, you can do both virtual circuits (i.e., TCP
streams) and datagrams (i.e., UDP packets).  You may be able to do even more
depending on your system.

The Perl function calls for dealing with sockets have the same names as
the corresponding system calls in C, but their arguments tend to differ
for two reasons: first, Perl filehandles work differently than C file
descriptors.  Second, Perl already knows the length of its strings, so you
don't need to pass that information.

One of the major problems with old socket code in Perl was that it used
hard-coded values for some of the constants, which severely hurt
portability.  If you ever see code that does anything like explicitly
setting C<$AF_INET = 2>, you know you're in for big trouble:  An
immeasurably superior approach is to use the C<Socket> module, which more
reliably grants access to various constants and functions you'll need.

If you're not writing a server/client for an existing protocol like
NNTP or SMTP, you should give some thought to how your server will
know when the client has finished talking, and vice-versa.  Most
protocols are based on one-line messages and responses (so one party
knows the other has finished when a "\n" is received) or multi-line
messages and responses that end with a period on an empty line
("\n.\n" terminates a message/response).

=head2 Internet Line Terminators

The Internet line terminator is "\015\012".  Under ASCII variants of
Unix, that could usually be written as "\r\n", but under other systems,
"\r\n" might at times be "\015\015\012", "\012\012\015", or something
completely different.  The standards specify writing "\015\012" to be
conformant (be strict in what you provide), but they also recommend
accepting a lone "\012" on input (but be lenient in what you require).
We haven't always been very good about that in the code in this manpage,
but unless you're on a Mac, you'll probably be ok.

=head2 Internet TCP Clients and Servers

Use Internet-domain sockets when you want to do client-server
communication that might extend to machines outside of your own system.

Here's a sample TCP client using Internet-domain sockets:

    #!/usr/bin/perl -w
    use strict;
    use Socket;
    my ($remote,$port, $iaddr, $paddr, $proto, $line);

    $remote  = shift || 'localhost';
    $port    = shift || 2345;  # random port
    if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
    die "No port" unless $port;
    $iaddr   = inet_aton($remote) 		|| die "no host: $remote";
    $paddr   = sockaddr_in($port, $iaddr);

    $proto   = getprotobyname('tcp');
    socket(SOCK, PF_INET, SOCK_STREAM, $proto)	|| die "socket: $!";
    connect(SOCK, $paddr)    || die "connect: $!";
    while (defined($line = <SOCK>)) {
	print $line;
    }

    close (SOCK)	    || die "close: $!";
    exit;

And here's a corresponding server to go along with it.  We'll
leave the address as INADDR_ANY so that the kernel can choose
the appropriate interface on multihomed hosts.  If you want sit
on a particular interface (like the external side of a gateway
or firewall machine), you should fill this in with your real address
instead.

    #!/usr/bin/perl -Tw
    use strict;
    BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
    use Socket;
    use Carp;
    my $EOL = "\015\012";

    sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

    my $port = shift || 2345;
    my $proto = getprotobyname('tcp');

    ($port) = $port =~ /^(\d+)$/                        or die "invalid port";

    socket(Server, PF_INET, SOCK_STREAM, $proto)	|| die "socket: $!";
    setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
					pack("l", 1)) 	|| die "setsockopt: $!";
    bind(Server, sockaddr_in($port, INADDR_ANY))	|| die "bind: $!";
    listen(Server,SOMAXCONN) 				|| die "listen: $!";

    logmsg "server started on port $port";

    my $paddr;

    $SIG{CHLD} = \&REAPER;

    for ( ; $paddr = accept(Client,Server); close Client) {
	my($port,$iaddr) = sockaddr_in($paddr);
	my $name = gethostbyaddr($iaddr,AF_INET);

	logmsg "connection from $name [",
		inet_ntoa($iaddr), "]
		at port $port";

	print Client "Hello there, $name, it's now ",
			scalar localtime, $EOL;
    }

And here's a multithreaded version.  It's multithreaded in that
like most typical servers, it spawns (forks) a slave server to
handle the client request so that the master server can quickly
go back to service a new client.

    #!/usr/bin/perl -Tw
    use strict;
    BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
    use Socket;
    use Carp;
    my $EOL = "\015\012";

    sub spawn;  # forward declaration
    sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }

    my $port = shift || 2345;
    my $proto = getprotobyname('tcp');

    ($port) = $port =~ /^(\d+)$/                        or die "invalid port";

    socket(Server, PF_INET, SOCK_STREAM, $proto)	|| die "socket: $!";
    setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
					pack("l", 1)) 	|| die "setsockopt: $!";
    bind(Server, sockaddr_in($port, INADDR_ANY))	|| die "bind: $!";
    listen(Server,SOMAXCONN) 				|| die "listen: $!";

    logmsg "server started on port $port";

    my $waitedpid = 0;
    my $paddr;

    use POSIX ":sys_wait_h";
    use Errno;

    sub REAPER {
        local $!;   # don't let waitpid() overwrite current error
        while ((my $pid = waitpid(-1,WNOHANG)) > 0 && WIFEXITED($?)) {
            logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
        }
        $SIG{CHLD} = \&REAPER;  # loathe sysV
    }

    $SIG{CHLD} = \&REAPER;

    while(1) {
        $paddr = accept(Client, Server) || do {
            # try again if accept() returned because a signal was received
            next if $!{EINTR};
            die "accept: $!";
        };
        my ($port, $iaddr) = sockaddr_in($paddr);
        my $name = gethostbyaddr($iaddr, AF_INET);

        logmsg "connection from $name [",
               inet_ntoa($iaddr),
               "] at port $port";

        spawn sub {
            $|=1;
            print "Hello there, $name, it's now ", scalar localtime, $EOL;
            exec '/usr/games/fortune'       # XXX: `wrong' line terminators
                or confess "can't exec fortune: $!";
        };
        close Client;
    }

    sub spawn {
        my $coderef = shift;

        unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
            confess "usage: spawn CODEREF";
        }

        my $pid;
        if (! defined($pid = fork)) {
            logmsg "cannot fork: $!";
            return;
        } 
        elsif ($pid) {
            logmsg "begat $pid";
            return; # I'm the parent
        }
        # else I'm the child -- go spawn

        open(STDIN,  "<&Client")   || die "can't dup client to stdin";
        open(STDOUT, ">&Client")   || die "can't dup client to stdout";
        ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
        exit &$coderef();
    }

This server takes the trouble to clone off a child version via fork()
for each incoming request.  That way it can handle many requests at
once, which you might not always want.  Even if you don't fork(), the
listen() will allow that many pending connections.  Forking servers
have to be particularly careful about cleaning up their dead children
(called "zombies" in Unix parlance), because otherwise you'll quickly
fill up your process table.  The REAPER subroutine is used here to
call waitpid() for any child processes that have finished, thereby
ensuring that they terminate cleanly and don't join the ranks of the
living dead.

Within the while loop we call accept() and check to see if it returns
a false value.  This would normally indicate a system error that needs
to be reported.  However the introduction of safe signals (see
L</Deferred Signals (Safe Signals)> above) in Perl 5.7.3 means that
accept() may also be interrupted when the process receives a signal.
This typically happens when one of the forked sub-processes exits and
notifies the parent process with a CHLD signal.  

If accept() is interrupted by a signal then $! will be set to EINTR.
If this happens then we can safely continue to the next iteration of
the loop and another call to accept().  It is important that your
signal handling code doesn't modify the value of $! or this test will
most likely fail.  In the REAPER subroutine we create a local version
of $! before calling waitpid().  When waitpid() sets $! to ECHILD (as
it inevitably does when it has no more children waiting), it will
update the local copy leaving the original unchanged.

We suggest that you use the B<-T> flag to use taint checking (see L<perlsec>)
even if we aren't running setuid or setgid.  This is always a good idea
for servers and other programs run on behalf of someone else (like CGI
scripts), because it lessens the chances that people from the outside will
be able to compromise your system.

Let's look at another TCP client.  This one connects to the TCP "time"
service on a number of different machines and shows how far their clocks
differ from the system on which it's being run:

    #!/usr/bin/perl  -w
    use strict;
    use Socket;

    my $SECS_of_70_YEARS = 2208988800;
    sub ctime { scalar localtime(shift) }

    my $iaddr = gethostbyname('localhost');
    my $proto = getprotobyname('tcp');
    my $port = getservbyname('time', 'tcp');
    my $paddr = sockaddr_in(0, $iaddr);
    my($host);

    $| = 1;
    printf "%-24s %8s %s\n",  "localhost", 0, ctime(time());

    foreach $host (@ARGV) {