#!/usr/bin/perl -w 
# 
use Tk;
use vars qw/$mw $VERSION/; 
use strict; 

our ($c,$state,$PID , @info, $infov, $mw, $paus, $phand, $play, $playe
+r, $timev, $v);

$mw = MainWindow->new; 
init(); 
MainLoop(); 

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",
            -command => sub { do_fork() })->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);

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

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

    $infov = 'Hello';
    my $info = $f->Label(
        -textvariable => \$infov,
        -font         => $font,
        -background   => $green,             
    );
    $info->pack(-side => 'top');
} # end init 

sub pipe_in {

    # Now that the IPADM command has been issued, keep sysread-ing
    # until the $EOF string is read, and return all the accumulated
    # data, excluding $EOF.

    my(@data, $sysbuf, $sysdata, $sysstat, $wait);

    $mw->fileevent(\*PR, 'readable' => sub {

        if ( $Tk::VERSION  le '800.015' ) {
            $sysbuf = <PR>;
        } else {
            $sysstat = sysread PR, $sysbuf, 4096;
            die "ipadm: sysread error $!" unless defined $sysstat;
        }
        $sysdata .= $sysbuf;
        if ($sysdata =~ /EOF$/s) {
            @data = split /\n/, $sysdata;
            $#data--;        # throw $EOF away
            $wait++;         # unblock waitVariable( )
        }

    });

    $mw->waitVariable(\$wait);
    $mw->fileevent(\*PR, 'readable' => '');

    @data;

} # end pipe_in

sub pipe_out {

    # Issue an IPADM command by syswrite-ing all the data plus
    # the terminating $EOF.

    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_fork {

    my $shell_cmd = "ls -al";

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

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

    if ($PID = fork) { # parent
        close CR;
        close CW;
        #PW->autoflush(1);
        $infov = "Read:". pipe_in();

    } elsif (defined $PID) { # child, exec shell command
        close PR;
        close PW;
        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);

        exec("$shell_cmd") or die "exec $!";
        die "exec warp $!";
    } else {
        die "fork $!";
    } # ifend fork

     return;
} # end do_fork
[download]