#!/usr/bin/env perl

use warnings;
use strict;

use IO::Handle qw();
use IO::Select qw();
use File::Temp qw(tempfile);

#---------------------------------------------------------------------
+-------
# CHILDREN

my $CHILD_SCRIPT_PATH = './child.pl';
my $Select_inputs     = IO::Select->new();
my %Child_of_handle;

sub spawn_child
{
    my ( $script_input ) = @_;

    my ( $tempfh, $tempname ) = tempfile();
    print $tempfh $script_input;
    close $tempfh; # flush to disk

    my $pid = open my $kidoutput, "$CHILD_SCRIPT_PATH <$tempname |";
    die "fork failed: $!" unless defined $pid;

    # Turns off buffering as well? Without this the child's
    # output comes all at once when it exits.
    $kidoutput->blocking( 0 );

    $Child_of_handle{ $kidoutput->fileno } = [ $pid, $tempname ];
    $Select_inputs->add( $kidoutput );

    return;
}

# Kill all child processes.
sub kill_procs
{
    warn "KILLING CHILD PROCESSES\n";
    kill 9, $_->[0] for values %Child_of_handle;
}

# Cleanup data and temporary input file associated with the child's pi
+pe handle.
sub cleanup_child
{
    my ( $handle ) = @_;

    my $child_ref = $Child_of_handle{ $handle->fileno }
        or die "Failed to lookup child handle $handle";
    my ( $pid, $tempfile ) = @$child_ref;

    delete $Child_of_handle{ $handle->fileno };
    $Select_inputs->remove( $handle );
    unlink $tempfile or warn "Failed to delete temp file $tempfile:\n$
+!";

    return;
}

#---------------------------------------------------------------------
+-------
# COMMANDS / PROMPT

my ( %Commands, $Prompt );

sub prompt_state
{
    my ( $input )         = @_;
    my ( $first, @args ) = split /\s+/, $input;

    unless ( $first ) {
        warn sprintf "Please enter a command: %s\n",
            join q{, }, keys %Commands;
        return;
    }

    my $cmd = $Commands{ $first };
    unless ( $cmd ) {
        warn "Unknown command: $first\n";
        return;
    }

    # I don't use arguments but you see it is possible.
    $cmd->( @args );
    return;
}

my $run_input = q{};
sub run_state
{
    my ( $input ) = @_;

    unless ( $input eq q{.} ) {
        $run_input .= $input . qq{\n};
        print q{>};
        return;
    }

    $Prompt = \&prompt_state;
    unless ( $run_input ) {
        warn "IGNORING EMPTY INPUT\n";
        return;
    }

    spawn_child( $run_input );
    $run_input = q{};
    return;
}

%Commands = ( 'run'  => sub {
                  $Prompt = \&run_state;
                  print q{>};
              },
              'exit' => sub { kill_procs(); exit 0;  },
             );

#---------------------------------------------------------------------
+-------
# MAIN LOOP

# STDIN fileno is 0
sub STDIN_NUM() { 0 }

STDOUT->autoflush( 1 ); # for the run prompt's > to display properly..
+.
$Select_inputs->add( \*STDIN );
$Prompt = \&prompt_state;

$SIG{'INT' } = sub { kill_procs(); exit 1; };
$SIG{'CHLD'} = 'IGNORE';

SELECT_LOOP:
while ( 1 ) {
    my @ready = $Select_inputs->can_read
        or die 'select returned an empty list';

    # User input is read from the prompt...
    if ( grep { $_->fileno == STDIN_NUM } @ready ) {
        # STDIN is line-buffered
        my $line = <STDIN> || q{};
        chomp $line;
        $Prompt->( $line );
        next SELECT_LOOP;
    }

    # Child process input (this is output from the child's perspective
+)
    my $next = shift @ready;
    if ( $next->eof ) {
        # If EOF is reached we are done with this child process.
        cleanup_child( $next );
        next SELECT_LOOP;
    }

    my $pid    = $Child_of_handle{ $next->fileno }[0];
    my $output = do { local $/; <$next> }; # slurp!
    print map { "$pid:$_\n" } split /\n/, $output;
}
[download]