package Win32::SelectablePipe;
use strict;

use Socket;
use POSIX ();
use vars qw( @EXPORT @EXPORT_OK );

BEGIN {
    require Exporter;
    @EXPORT= qw( winpipe );
    @EXPORT_OK= qw( FIONBIO EAGAIN );
    *import= \&Exporter::import;
}

sub SO_OPENTYPE { 0x7008 }

sub POSIX::FIONBIO { ( 0x80000000 | (4<<16) | (unpack('c','f')<<8) | 1
+26 ) }
# 0x8004667E

sub POSIX::EAGAIN  { 10035 }
sub POSIX::EISCONN { 10056 }


sub winpipe {
    my( $one, $two )= @_;
    my( $server )= do { local(*SERVER); *SERVER };
    if(  2 != @_  ) {
        require Carp;
        Carp::croak( "Win32::SelectablePipe usage: pipe(*ONE,*TWO)" );
    }
    {
        my $pkg= caller;
        for my $handle (  $one, $two  ) {
            if(  ! ref($handle)
             &&  "GLOB" ne ref(\$handle)
             &&  $handle !~ /'|::/  ) {
                $handle= "$pkg::$handle"
            }
        }
    }
    my $tcp= getprotobyname('tcp');
    socket( $server, PF_INET, SOCK_STREAM, $tcp )
        or  die "Can't create TCP socket ($server): $!";
    socket( $two, PF_INET, SOCK_STREAM, $tcp )
        or  die "Can't create TCP socket ($two): $!";
    my $local= gethostbyname('localhost')
        or  die "Can't find localhost: $!";
    my $addr= sockaddr_in( 0, $local )
        or  die "Can't build localhost address: $!";
    bind( $server, $addr )
        or  die "Can't bind socket ($server) to localhost address: ",0
++$!;
    bind( $two, $addr )
        or  die "Can't bind socket ($two) to localhost address: ",0+$!
+;
    listen( $server, 1 )
        or  die "Can't listen on socket ($server): ",0+$!;
    $addr= getsockname( $server )
        or  die "Can't get socket ($server) address: ",0+$!;
    {
        my $true= 1;
        ioctl( $two, POSIX::FIONBIO(), \$true )
            or die "Can't ioctl socket ($two) to non-blocking: ", 0+$!
+;
    }
    if(  connect( $two, $addr )  ) {
        warn "Strange, connect() succeeded?";
    } elsif(  $! != POSIX::EAGAIN  ) {
        die "Can't non-blockingly connect: ", 0+$!;
    }
    accept( $one, $server ) or  die "Can't accept: ", 0+$!;
    sleep( 1 );
   # die "Can't connect: ", 0+$!;
   #   if  ! connect( $two, $addr )  &&  $! != POSIX::EISCONN;
    close( $server );
    return 1;
}


# Total *HACK* to allow winsock connect() to work on non-blocking sock
+ets
# Culprit is in perl source /win32/win32sck.c function set_socktype. W
+e
# undo the result of this function. See MSDN support on overlapped I/O
# for info: http://support.microsoft.com/support/kb/articles/Q181/6/11
+.ASP
#BEGIN {
#  my $sock = gensym();
#  socket( $sock, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
#    or die "ERROR - can't create socket\n";
#  setsockopt( $sock, SOL_SOCKET, SO_OPENTYPE, 0 )
#    or die "PORTABLE::BEGIN ERROR - Can't setsockopt to overlapped: $
+!\n";
#  close $sock;
#}

1;
[download]

#!/usr/bin/perl

use warnings;
use strict;
use IO::Handle;
use IO::Select;
use Win32::SelectablePipe qw( winpipe );
use POSIX ":sys_wait_h";
use Net::Telnet;
use Tk;
use Tk::Graph;


local ( *PIPE_READ, *PIPE_WRITE );

Win32::SelectablePipe::winpipe( *PIPE_READ, *PIPE_WRITE );
#pipe( *PIPE_READ, *PIPE_WRITE );
PIPE_READ->autoflush(1);
PIPE_WRITE->autoflush(1);

print "Pipes open\n";

if ( defined( my $pid = fork() ) ) {
  if ( $pid ) {
    my $io = new IO::Select( *PIPE_READ );
    my $mw = MainWindow->new();
    my $chart =$mw->Graph( -type => 'CIRCLE' )->pack;
    my ( $cpu_user, $cpu_sys, $cpu_idle, $cpu_wait, $data, @line );
    
    while( waitpid( $pid, WNOHANG ) != -1 ) {
      if ( $io->can_read( 0 ) ) {
        print "Reading from handle\n";
        $data = <PIPE_READ>;
        print "Got $data\n";
        @line = split(/\s+/, $data );
        ( $cpu_user, $cpu_sys, $cpu_idle, $cpu_wait ) = @line[14..17];
        if ( $cpu_wait =~ /^\d+$/ and 
             $cpu_idle =~ /^\d+$/ and 
             $cpu_sys =~ /^\d+$/ and 
             $cpu_user =~ /^\d+$/ ) {
          $chart->set( { 'Wait' => $cpu_wait, 
                         'Idle' => $cpu_idle, 
                         'System' => $cpu_sys, 
                         'User' => $cpu_user } );
          $chart->redraw;
        }
      } else {
        print "No data, sleeping\n";
        sleep 0.1
      }
    }
  } else {
    print "Username: ";
    my $username = <STDIN>;
    print "Password: ";
    my $password = <STDIN>;
    chomp $username;
    chomp $password;
    
    my $obj = new Net::Telnet( 'server.server.com' );
    $obj->prompt( '/:\s*$/' );
    $obj->login( $username, $password );
    $obj->print( "vmstat 10" );
 
    while ( my $line = $obj->getline() ) {
      print PIPE_WRITE $line;
    }

    $obj->cmd( "exit" );
  }
}
[download]