# TkClient.pl
# A modification of the fileevent work around on Win32, from  the book: "Mastering Perl/Tk",
# by Steve Lidie and Nancy Walsh pp 492-493
# USAGE: open a DOS32 CONSOLE (Yes!!! CMD.EXE is 32 bit, COMMAND.COM 16 bit) and type:
# c:\> perl.exe TkClient.pl  2>&1 | perl.exe IO_server.pl
# Don't forget to leave in "perl.exe" for this to work properly
use Tk ;
use Tk ':variables';
use Tk::Event;
use POSIX ":sys_wait_h";
use strict;

our $mw = MainWindow->new( -title => "Tk client");
$mw->geometry('325x250');
our $programs = $mw->Button(-text => 'EXEC CODE ', -width => 35, -activebackground => 'steelblue', -command => \&myprograms) 
   ->place(-anchor  => 'nw', -relx => 0.10, -rely => 0.60, -relwidth => .28);
our $quitbttn = $mw->Button(-text => 'QUIT ', -width => 35, -activebackground => 'steelblue', -command => \&exit) 
   ->place(-anchor  => 'nw', -relx => 0.10, -rely => 0.80, -relwidth => .28);
################# output text box toplevel ###########
our $polling;
our $sock;
our $sel;
our $numbytes = "\x00" x 4; # pack('L' works too

my $dbgout = $mw->Toplevel;
   $dbgout->title('CAPTURED FILTERED OUTPUT');
    my $textdbg = $dbgout->Scrolled('Text', -scrollbars => 'osoe')->pack;
    $textdbg->Subwidget("text")->configure(-width => 80, -height => 25 ,-wrap => 'none');
if ($^O eq 'MSWin32') {
    use IO::Socket;
    use constant FIONBIO  => 0x8004667e;  # winsock2.h macro
    use constant FIONREAD => 0x4004667f;  # winsock2.h macro
    my $nonblocking = "\x00\x00\x00\x01"; # long nonblocking != 0;
    $sock = IO::Socket::INET->new(
            PeerAddr => 'localhost',
            PeerPort => '10254',
            Proto => 'tcp',
            ) or die "IO::Socket::INET: $!";
    ioctl($sock, FIONBIO, unpack("I",pack('P',$nonblocking))) == 0 or die "ioctlsocket(\$sock, FIONBIO,...):$!" ; 
    $polling = $mw->repeat(50 => \&read_sock);
} 
  
#################### EVENTLOOP ###############################
MainLoop;
exit;
#################### SUBROUTINES #############################
sub read_sock {
    my $hand = $sock;
    my ($stat,$buf,$content,$line,$nbytes);
    if ($^O eq 'MSWin32') {
        ioctl($hand, FIONREAD, unpack('I',pack('P',$numbytes))) == 0 or die "ioctlsocket(\$hand, FIONREAD,...):$!" ;
        $nbytes = unpack('I',$numbytes);
        $nbytes == 0 ? return : $polling->cancel;  # not re-entrant
    }	
        $stat = sysread $hand, $buf, $nbytes; 
        $line .= $buf if $stat > 0;
    $line = "sysread error: $!\n" unless defined $stat;
    # filter the text using regular expressions here, then:
    $textdbg->insert('end',"$line");
    $textdbg->yviewMoveto(1.0);
    $polling = $mw->repeat(50 => \&read_sock) if ($^O eq 'MSWin32'); # restart repeat
} 

sub myprograms{ 
# put your external calls here
# system(1, ...) returns immediately - great with Tk event loop

  my $cpid;

  $cpid = system(1,"echo --- Start of test ---");
  TkUpdates();
  $cpid = system(1,"ipconfig");
  TkUpdates();
  $cpid = system(1,"ping -n 3 localhost");
  TkUpdates();
  $cpid = system(1,"dir");
  TkUpdates();
  $cpid = system(1,"echo --- End of test ---");
  TkUpdates();
}

sub TkUpdates{
  my ($kid,$status);
  do { 
      $kid = waitpid(-1,&WNOHANG); # wait for all child processes to finish
      $status = $?;
      $mw->update;   # LET Tk DO UPDATES   
     } until $kid == -1; 
}

##</code><code>##

# IO_server.pl
# see also:
# http://aspn.activestate.com/ASPN/Mail/Message/perl-tk/1857686
use IO::Socket;
use File::Basename;
use strict;

our $data;

my $socket = IO::Socket::INET-> new(
    Listen    =>  5, 
    Reuse     =>  1, 
    LocalPort =>  10254, 
    Proto     =>  'tcp',
) or die "Couldn't open socket: $!";
print basename($0)," started\n";
my $new_sock = $socket->accept();
while ($data = <STDIN>) {
    print $data;  # tee
    syswrite $new_sock, $data;
}