#!/usr/bin/perl
use strict;
use warnings;

use IO::Socket;
use File::Basename;
use POSIX ":sys_wait_h";

use Communication;

my $Debug = 0;

my $server_port = 4714;

my $server = IO::Socket::INET->new(
    LocalPort => $server_port,
    Type      => SOCK_STREAM,
    Reuse     => 1,
    Listen    => 10,
) or die "Kann keinen TCP-Server an Port $server_port sein: $@\n";
print "Server ", basename($0), " is starting on port $server_port ...\n";

main();
close($server);
exit;


sub main {
    CLIENT: while (my $client = $server->accept()) {
        pipe PREAD, CWRITE; # child -> parent
        chomp(my $input = <$client>);
        print "Client sagt '$input'\n" if $Debug;

        unless ($input eq Communication::RE_REQUEST) {
            print $client Communication::DECLINE, "\n";
        }
        else {
            print $client Communication::ACCEPT, "\n";
            my $timeout = <$client>;
            unless (defined $timeout) {
                warn "Client schickte falsche Daten, Abbruch!\n";
                next CLIENT;
            }
            my $txt     = <$client>;
            unless (defined $txt) {
                warn "Client schickte falsche Daten, Abbruch!\n";
                next CLIENT;
            }
            my $re      = <$client>;
            unless (defined $re) {
                warn "Client schickte falsche Daten, Abbruch!\n";
                next CLIENT;
            }
            chomp ($timeout, $txt, $re);
            unless ($timeout =~ /^\d+$/) {
                warn "Timeoutwert '$timeout' ist keine natürliche Zahl\n";
                next CLIENT;
            }
            print "Client sagt timeout = '$timeout'\n",
                  "Client sagt txt     = '$txt'\n",
                  "Client sagt re      = '$re'\n" if $Debug;
print '.';
            if (my $pid = fork()) {
                parent($pid, $client, $timeout);
            }
            else {
                child($txt, $re);
            }
            
        }
    }
} # sub main


sub child {
    my ($txt, $re) = @_;

    $server->shutdown(0); # nur im Kind schließen

    close PREAD; # child - close parent end of pipe
    #print "child: id $$ dad $parent_pid\n";

    print "child: start of proccess\n" if $Debug;
    use re 'eval';
    if (my @all = $txt =~ /$re/) {
        print CWRITE "$_\n" for $`, $&, $', @all; 
    }
    else {
        print CWRITE "-1\n"; 
    }
    print "child: end of proccess\n" if $Debug;
    exit;
} # sub child


sub parent {
    my ($pid, $client, $timeout) = @_;
    close CWRITE; # parent - close child end of pipes
    print "parent id $$ child $pid\n" if $Debug;

    my @erg;
    eval { 
        local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
        alarm $timeout;
        while (waitpid($pid, WNOHANG) == 0) {
            #print "parent: kind lebt noch\n";
            #sleep 1;
        }
        alarm 0;
    };
    alarm 0; # Ist das wirklich notwendig?
    if ($@) {
        die "other error : $@"
            unless $@ eq "alarm\n";   # propagate unexpected errors
        warn "parent : child got time out!\n" if $Debug;
        print $client Communication::TIME_OUT, "\n";
    }
    else {
        chomp(@erg = <PREAD>);
        print "parent got ", join(' - ', @erg), "\n" if $Debug;
        if (@erg == 1 and $erg[0] eq -1) {
            print $client Communication::NO_MATCH, "\n";
        }
        else {
            print $client "$_\n" for @erg;
        }
    }
    #kill TERM => $pid; # Kind abschießen (in beiden Fällen, einmal als Zombie,
                       # einmal läuft es noch und verbraucht Rechenzeit)
} # sub parent

#!/usr/bin/perl
use strict;
use warnings;

use IO::Socket;
use File::Basename;

use Communication;


do_the_re(15, 'a b c d', '\s*(b)\s*(c)\s*');
do_the_re( 5, 'a b c d', '\s*(b)\s*(c)\s*');
do_the_re( 5, 'a b c d', '\s*(e)\s*');
do_the_re( 2, 'a b c d', '(?{sleep 3})');


sub do_the_re {
    my ($timeout, $txt, $re) = @_;

    my $remote_host = 'localhost';
    my $remote_port = 4714;

    my $socket = IO::Socket::INET->new(
        PeerAddr => $remote_host,
        PeerPort => $remote_port,
        Proto    => 'tcp',
        Type     => SOCK_STREAM,
    ) or die "Konnte Verbindung zu $remote_host:$remote_port nicht herstellen: $@\n";

    print "Client ", basename($0), " is starting, connected to $remote_host:$remote_port ...\n";

    print $socket Communication::RE_REQUEST, "\n";

    chomp(my $antwort = <$socket>);
    die "no server-accept\n" unless $antwort eq Communication::ACCEPT;

    print $socket "$timeout\n$txt\n$re\n";

    chomp(my @erg = <$socket>);
    if (@erg == 1 and $erg[0] eq Communication::TIME_OUT) {
        print "ABBRUCH WEGEN ZEITUEBERSCHREITUNG\n";
    }
    elsif (@erg == 1 and $erg[0] eq Communication::NO_MATCH) {
        print "KEIN MATCH\n";
    }
    else {
        print "Ergbenis: [", join('], [', @erg), "]\n";
    }
}

use strict;
use warnings;

package Communication;

#------------------------------------------------------------------------------
# Von Exporter erben:
#------------------------------------------------------------------------------
use base qw/Exporter/;
our @EXPORT      = qw//;
our @EXPORT_OK   = qw/RE_REQUEST ACCEPT DECLINE TIME_OUT NO_MATCH/;
our %EXPORT_TAGS = (all => [qw/RE_REQUEST ACCEPT DECLINE TIME_OUT NO_MATCH/]);

#------------------------------------------------------------------------------
# Konstanten:
#------------------------------------------------------------------------------
use constant RE_REQUEST => 33001;
use constant ACCEPT     => 33002;
use constant DECLINE    => 33003;
use constant TIME_OUT   => 33004;
use constant NO_MATCH   => 33005;


1;

C:\Daten\perl\socket>c4.pl
Client c4.pl is starting, connected to localhost:4714 ...
Ergbenis: [a], [ b c ], [d], [b], [c]
Client c4.pl is starting, connected to localhost:4714 ...
Ergbenis: [a], [ b c ], [d], [b], [c]
Client c4.pl is starting, connected to localhost:4714 ...
KEIN MATCH
Client c4.pl is starting, connected to localhost:4714 ...
ABBRUCH WEGEN ZEITUEBERSCHREITUNG