require 5.00557;
$DEBUG = 1;

use Tk;
sub FileHandle::flush { 
  my ($self) = @_;
  my $ofh = select $self;
  my $ob = $|++;
  print $self '';
  $| = $ob;
  select $ofh;
}

my $text = 'Click me to start';
pipe FROMCHILD, TOPARENT or die "pipe up: $!; aborting";
pipe FROMPARENT, TOCHILD or die "pipe down: $!; aborting";
for (\*FROMCHILD, \*TOCHILD, \*FROMPARENT, \*TOPARENT) {
  bless $_ => FileHandle;
  select $_;
  $|++;
}
select STDOUT;
my $pid = fork;
defined $pid or die "fork: $!; aborting";
if ($pid) {			# parent
  close TOPARENT;
  close FROMPARENT;
} else {
  close TOCHILD;
  close FROMCHILD;
  mainlooper();
  exit;
}

while ("aaaaabbbbb" =~ /.(?{pause()})/g) {
  print "----\n";
}

$DEBUG && print "PARENT: Exiting\n";
exit;

sub pause {
  $DEBUG && print "PARENT: Pausing $` $& $'\n";
  writestrs(\*TOCHILD, $`, $&, $');
  pipewait(\*FROMCHILD);
}

sub mainlooper {
  my $mw = new Tk::MainWindow;
  $mw->Button(-textvar => \$text, -command => \&button)->pack;
  MainLoop;
}

sub button {
  $DEBUG && print "CHILD: In button callback\n";
  my @text = readstrs(\*FROMPARENT);
  $text = join '/', @text;
  pipekick(\*TOPARENT);
  $DEBUG && print "CHILD: Returning to event loop.\n";
}

sub writestrs {
  my $fh = shift;
  my $n = @_;
  $DEBUG && do { local $" = ')('; print "PARENT: Writing (@_)\n" };
  print $fh $n, ':';
  local $_;
  for (@_) {
    print $fh length($_), ':', $_;
#    print STDOUT length($_), ':', $_;
  }
#  $fh->flush;
}

sub readstrs {
  my $fh = shift;
  my $n = readnum($fh);
  $DEBUG && print "CHILD: Reading $n strings from pipe:\n";
  my @strs;
  while ($n--) {
    my $len = readnum($fh);
    my $s;
    read $fh, $s, $len;
    $DEBUG && print "CHILD:   Read $s\n";
    push @strs, $s;
  }
  @strs;
}

sub readnum {
  my $n = '';
  my $fh = shift;
  my $c;
  $DEBUG && print "CHILD: Reading number from pipe:\n";
  while (($c = getc($fh)) ne ':' && $c ne '') {
    $n .= $c;
  }
  if ($c eq '') { 
    $DEBUG && print "CHILD:  Premature end of file on pipe; aborting\n";
    exit;
  }
  $DEBUG && print "CHILD:   Read number $n.\n";
  $n;
}

sub pipewait {
  my $pipe = shift;
  my $s;
  $DEBUG && print "PARENT: Waiting for kick.\n";
  sysread $pipe, $s, 1;
  $DEBUG && print "PARENT: Got the kick.\n";
}

sub pipekick {
  my $pipe = shift;
  $DEBUG && print "CHILD: Kicking pipe.\n";
  print $pipe "x";
  $pipe->flush;
}