This humble novice beseeches the great monks of Perl to restore his sanity and keep at bay the hounds that demand "easy" interfaces of him so he may eat:

I have written a small server that executes system commands in a (relatively) safe way. Its main reason for existence is to interact with a CGI that provides the UI that everyone in my company will (hopefully) use. This server has a small dispatch table of commands, and exits nicely when you say "BYE\n".

Unless, that is, you're a CGI program.

My CGI has lovely taint-checking and all sorts of cool doo-dads that I'm inordinately fond of. What sucks is that, after establishing a connection with the server, and parsing for a READY signal, and evidently sending a command and even getting back output, it just sits there eternally. If I kill the server, the CGI then shows the rest of the output. Having the server shutdown() the connection also works, but I'd like to keep the server able to stay interactive instead of processing only one command per session.

Obviously this is a buffering issue, but I'm stumped. I've looked in the Jaguar, the Camel, the Ram, yea have I studied many animal entrails, and yet nothing seems to work the way I would like. I'm now contemplating using syswrite and sysread, but my aesthetics rebel at this--there's got to be a better way.

Without further ado, some relevant code:

my ($new_sock, $pid, $buf);
while ($new_sock = $main_sock->accept()) {
    $new_sock->autoflush(1);       
    # In theory, new sockets are always non-blocking anyway
    # with IO::Socket::INET, which I am using here.
    $pid = fork();
    die "Cannot fork: $!" unless defined $pid;
    if ($pid == 0) {
        # Child 
        unless ($new_sock->peerhost eq $allowed_ip) {
            shutdown $new_sock, 2;
            exit 0;
        }
        print $new_sock $greeting;
        while (defined($buf = <$new_sock>)) {
            process($buf, $new_sock);
#            shutdown($new_sock, 1);
#            Works, but shuts down the whole session
        }     
        exit 0;
    } # Else 'tis the parent process, which goes back to accept()
}
close $main_sock;

my ($error, $output);                  
        
sub process {
    my $line = shift;
    $line =~ tr/\r\n//d;    # fancy chomp
    return if $line eq '';  # What's that again?
    my ($command, @args) = split /\s+/, $line;
    undef $error;
    undef $output;                 
                  
    if ($command =~ /^BYE/) {                 
        print $new_sock "OK disconnecting . . . \n";
        shutdown $new_sock, 2;
        exit 0;
    }
                   
    unless (exists $dispatch{$command}) {
        return unless defined $command; # Ignore blank lines
        print $new_sock "ERROR unknown command \"$command\"\n";
        return;
    }
              
    $dispatch{$command}->(@args);
    if ($error) { # main scope variable set by the dispatch command
        print $new_sock <<EOF;
ERROR $error     
$output                                              
EOF                                    
EOF                                    
        return;
    }        
    else {           
        print $new_sock <<EOF;           
OK
$output
EOF              
    }                                               
}
[download]

Now, the CGI:

sub execute {
    my $port = 1200;
    
    my $sock = new IO::Socket::INET (
        PeerAddr => $host,
        PeerPort => $port,
        Proto    => 'tcp'
    );
    die "Couldn't connect to $host:$port : $@" unless ($sock);

# Saints preserve me from having to use this    
#    my $flags;
#    fcntl($sock, F_GETFL, $flags) or die "Couldn't get flags for sock
+et: $!";
#    $flags |= O_NONBLOCK;
#    fcntl($sock, F_SETFL, $flags) or die "Couldn't set flags for sock
+et: $!";
    
    my_header('Processing Command', 'wheat');
    
    printf "<b>Site %s is on %s</b><br>", param('site'), $host;
          
    my @args;
    foreach my $i ( @{ $action{$selection}{args} } ) {
        push @args, param($i);
    }
    
    my @command = join(' ', ($action{$selection}{command}, @args));

    my ($line, @output);
    
    print "Waiting for ready signal . . . <BR><PRE>";
    until ($line =~ /^READY/) {
        $line = <$sock>;  
        print $line, "\n";
    }
    print "</PRE>";
    # This part prints out fine!  But after, the web client hangs.    
    print $sock (@command, "\n");
    
    while ( $line = <$sock> ) {
        push @output, $line;
    }
    print $sock "BYE\n";
    close $sock or die "Can't close socket: $!";
    print h2("No response from server $host!<BR>") unless @output;
    print h2('Server responded:'),
          pre(@output);
    footer();
    # This all prints if I kill the server
}
[download]

Many thanks to any and all who may shed light on this vexation.

--TQuid