#!/usr/bin/perl -w 
use Tk;
use Tk::widgets qw/LabEntry ROText/;
use vars qw/$mw $VERSION/; 
use IO::Handle;
use strict; 

our ($c , $text, $mw);

$SIG{CHLD} = sub {wait};
$SIG{PIPE} = sub {print STDERR "pipe failure.\n"; exit};

do_pipe();

$mw = MainWindow->new; 

init(); 

$text->insert('end', "Initial Text\n");

my $line;

print "In parent about to send...\n";
pipe_out( "Parent Pid $$ is sending this\n");
print "In parent sent...\n";
chomp($line = <PR>);
print "parent just read -->$line<--\n";
print "In parent about to send...\n";
print "Parent Pid $$ just read this: `$line'\nEOF";

MainLoop(); 

close PR; 
close PW;

exit;



sub do_fork_stuff {
    my $line = <PR>;
    $text->insert('end', $line);
    $text->yview('end');
} # end do_fork


sub init { 

    $VERSION = '1.0'; 

    $mw->title("frog $VERSION"); 
    $mw->Button(-text => "Exit",
            -command => sub { exit })->pack(-side => 'bottom', 
                                            -expand => 1,
                                            -fill => 'x');
    $mw->Button(-text => "fork stuff",
            -command => sub { do_fork_stuff() })->pack(-side => 'top',
+ 
                                            -expand => 1,
                                            -fill => 'x');
    $c = $mw->Canvas(
        -width  => 1,
        -height => 1,
        -background => 'dark slate gray',
    )->pack;

    my $mainimage = $c->Photo(-file => 'table.gif');
    $c->createImage(0, 0,
        -image => $mainimage,
        -tag   => 'mainimage',
        -anchor => 'nw',
    );
    #$c->configure(-width => $mainimage->width, -height => $mainimage-
+>height);
    $c->configure(-width => 400, -height => 300);

    my $green = '#d5dac1';
    my $font = 'courier 12';

    my $f = $c->Frame(
        -width      => 270,
        -height     => 110,
        -background => $green,
        -relief     => 'sunken',
        -borderwidth => 3,         
    );
    $f->packPropagate(0);
    $c->createWindow(70, 150, -anchor => 'nw', -window => $f);

    $text= $f->Scrolled('ROText', -scrollbars => 'oe')->pack;

} # end init 


sub pipe_out {

    return unless defined $_[0];

    my($bytes, $offset, $sysdata, $sysstat, $wait);

    $sysdata = join '', @_, "EOF\n";
    $bytes = length $sysdata;
    $offset = 0;

    $mw->fileevent(\*PW, 'writable' => sub {

        while ($bytes > 0) {
            $sysstat = syswrite PW, $sysdata, $bytes, $offset;
            die "ipadm: syswrite error $!" unless defined $sysstat;
            $bytes  -= $sysstat;
            $offset += $sysstat;
        }
        $wait++;

    });

    $mw->waitVariable(\$wait);
    $mw->fileevent(\*PW, 'writable' => '');

} # end pipe_out


sub do_pipe{

    pipe CR, PW or die "cr/pw pipe $!";
    pipe PR, CW or die "pr/cw pipe $!";

    if (my $pid = fork) {
        close CR or die "Client socket close failed: $!";
        close CW or die "Client socket close failed: $!";
        PW->autoflush(1);
    } elsif (defined $pid) {
        close PR;
        close PW;
        print "in child waiting...\n";
        open STDIN,  "<&CR" or die "STDIN  open $!";
        open STDOUT, ">&CW" or die "STDOUT open $!";
        open STDERR, ">&CW" or die "STDERR open $!";
        STDOUT->autoflush(1);
        STDERR->autoflush(1);
        chomp($line = <STDIN>);
        print "Child Pid $$ just read this: `$line'\n";
        print "fork 1\n";
        print "fork 2\n";
        print "fork 3\n";
        print "fork 4\n";
        print "fork 5\n";
        print "fork 6\n";
        print "fork 7\n";
        print "fork 8\n";
        print "fork 9\n";
        print "fork 10\n";
        print "fork 11\n";
        print "fork 12\n";
        print "fork 13\n";
        print "fork 14\n";
        print "fork 15\n";
        print "fork 16\n";
        print "fork 17\n";
        print "fork 18\n";
        print "fork 19\n";
        print "fork 20\n";
        die "exec warp $!";
    } else {
        die "fork error: $!";
    }
}
[download]