Arrgh.

The script I gave you above would have been great if it turned out to actually be non-blocking. That turns out not to be the case. This one however, IS non-blocking.

#!/usr/bin/perl

use strict;
use warnings;

use Tk;
use Tk::Text;
use IO::Socket;

use threads;
use threads::shared;

my $buffer : shared;
my $cancel : shared;

my ( $ip_addr, $line, $sock, $thread );

my $mw = new MainWindow;

# Put a Frame in it/give it a label
my $frm_name = $mw->Frame();
my $lab = $frm_name->Label( -text => "Enter IP address:port" );

# We need entry boxes for IP address:socket & a button to start runnin
+g.
my $ent1    = $frm_name->Entry();
my $but     = $mw->Button( -text => "Start", -command => \&start );
my $stopbut = $mw->Button( -text => "Stop", -command => \&stop );

# Create a window for Display and Input.

my $textarea = $mw->Frame();          #creating another frame
my $txt      = $textarea->Scrolled(
    'Text',
    -width      => 80,
    -height     => 10,
    -scrollbars => 'osoe'
);
$lab->grid( -row => 1, -column => 1 );
$ent1->grid( -row => 1, -column => 2 );
$frm_name->grid( -row => 1, -column => 1, -columnspan => 2 );

$but->grid( -row => 4, -column => 1 );
$stopbut->grid( -row => 4, -column => 2 );
$txt->grid( -row => 1, -column => 1 );

$textarea->grid( -row => 5, -column => 1, -columnspan => 2 );

#$ent1->insert( 'end', 'localhost:2345' ); #for testing

MainLoop;

sub start {
    $cancel  = 0;
    $ip_addr = $ent1->get();
    print STDOUT "addr: $ip_addr\n";

    $sock = new IO::Socket::INET(
        PeerAddr => $ip_addr,
        PeerPort => '5000',
        Proto    => 'tcp',
    );
    warn "Could not create socket: $! \n" and return unless $sock;

    $thread = threads->new( \&get_lines, $sock );
    while ( !$cancel ) {
        if ( defined $buffer and length $buffer ) {
            $line   = $buffer;
            $buffer = '';
            $line =~ s/\015\012/\n/g;
            $txt->insert( 'end', $line );
            $txt->see('end');
            last if $cancel;
        }
        $mw->update;
    }
}

sub get_lines {
    my ($sock) = @_;
    while ( defined( my $line = <$sock> ) ) {
        $buffer .= $line;
        last if $cancel;
    }
    $buffer = '';
}

sub stop {
    $cancel = 1;
    $thread->detach();
    shutdown( $sock, 0 );
    close $sock;
    undef $sock;
}
[download]