Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much

capture output of a daemon in a tk widget on win32

by xiper (Friar)
on Mar 23, 2004 at 23:20 UTC ( #339244=perlquestion: print w/replies, xml ) Need Help??

xiper has asked for the wisdom of the Perl Monks concerning the following question:

Update: Simplified problem temporarily by removing requirement of stderr

A bucket-load of XP to the monk that can make this work:

use strict; $|++; if( $ARGV[0] eq 'child' ) { sleep 1; print STDOUT "stdout1\n"; sleep 1; print STDOUT "stdout2\n"; sleep 1; print STDOUT "stdout3\n"; sleep 1; print STDOUT "stdout4\n"; exit; } use Tk; use Tk::ROText; my $mw = MainWindow->new; my $text = $mw->ROText()->pack( -fill => 'both', -expand => 1 ); use IO::Handle; my $stdout = IO::Handle->new(); my $pid = open( $stdout, "$0 child |" ) || die; $stdout->autoflush( 1 ); $mw->fileevent( $stdout, readable => \&read_stdout ); MainLoop; sub read_stdout { print "read_stdout()\n"; my $num = $stdout->sysread( my $buffer, 1024 ); print "sysread() got $num bytes:\n[$buffer]\n"; $text->insert( 'end', $buffer ); }
Original code:
use strict; $|++; if( $ARGV[0] eq 'child' ) { sleep 1; print STDOUT "stdout1\n"; sleep 1; print STDERR "stderr1\n"; sleep 1; print STDOUT "stdout2\n"; sleep 1; print STDERR "stderr2\n"; exit; } use Tk; use Tk::ROText; my $mw = MainWindow->new; my $text = $mw->ROText()->pack( -fill => 'both', -expand => 1 ); $text->tagConfigure( 'red', -foreground => 'red' ); use IO::Handle; my $stdin = IO::Handle->new(); my $stdout = IO::Handle->new(); my $stderr = IO::Handle->new(); use IPC::Open3; my $pid = open3( $stdin, $stdout, $stderr, "$0 child" ) || die; $stdin->close; $stdout->autoflush( 1 ); $stderr->autoflush( 1 ); $mw->fileevent( $stdout, readable => \&read_stdout ); $mw->fileevent( $stderr, readable => \&read_stderr ); MainLoop; sub read_stdout { print "read_stdout()\n"; my $num = $stdout->sysread( my $buffer, 1024 ); print "sysread() got $num bytes:\n[$buffer]\n"; $text->insert( 'end', $buffer ); } sub read_stderr { print "read_stderr()\n"; my $num = $stderr->sysread( my $buffer, 1024 ); print "sysread() got $num bytes:\n[$buffer]\n"; $text->insert( 'end', $buffer, 'red' ); }
This is a simplified exmaple of what i want to achieve, which basically is to see the stdout and stderr of a program in a Tk widget. Note there are numerous problems here, such as being able to perform a non-blocking read (on win32!), avoiding deadlock between stdout and stderr, and keeping the MainLoop running. You can assume the child is never going to need stdin, and will run for a long time (ie, a daemon).

- ><iper

use japh; print;

Replies are listed 'Best First'.
Re: capture output of a daemon in a tk widget on win32
by bl0rf (Pilgrim) on Mar 24, 2004 at 03:06 UTC
    Nice code xiper.
    I tried making it work, but unfortunately the only thing I've discovered is that only the last handler/callback to be declared will be active. On my computer ( win2k, perl 5.8 ) the code only prints out the stderr messages, when reversed with stdout - it only gets the stdout messages.

      Hmm, you appear to be right. I found this in Tk::fileevent:

      The readable and writable event handlers for a file are independent, and may be created and deleted separately. However, there may be at most one readable and one writable handler for a file at a given time in a given interpreter. If fileevent is called when the specified handler already exists in the invoking interpreter, the new callback replaces the old one.

      Not sure if "file" means filehandle tho'...

      Note also how the last callback gets fired 4 times, but only twice with data waiting... Different combinations of prints in the child result in generally inconsistent behaviour (that is, incidentally, consistent with blocking/buffering/deadlock type problems).

      My output:

      read_stderr() sysread() got 9 bytes: [stderr1 ] read_stderr() sysread() got 9 bytes: [stderr2 ] read_stderr() sysread() got 0 bytes: [] read_stderr() sysread() got 0 bytes: []

      - ><iper

      use japh; print;
Re: capture output of a daemon in a tk widget on win32
by JamesNC (Chaplain) on Mar 24, 2004 at 17:40 UTC
    This is tested this on Win32(2K and XP) on AS 5.8
    FileEvent doesn't work on Win32 Tk and threads won't work with Tk. My problem was that I had several long running SQL queries which blocked Tk's updates and the user couldn't do anything else while the queries were still executing. Worse even still, if the user moved something over the main window, it would erase the window (LOL).

    After a LOT of experimentation, I found the following solution. I have commented out the database stuff and put in a mock filler for the hash table which displays the message you sent to the child from the text box. (Some SQL in my case.)

    When you press run, some text gets sent to the child which then imitates doing a long bit of work ( sleeps for 10 seconds, adding a value to a hash as it goes) about the only thing exciting (well for me when I got it to work) is that you can move the window around and do other things while the child does it stuff and while we keep looking for a return message that our job is complete. When the job finishes, the child sends a status message back to the parent "OK" or the actual error message. I used the Storable module to save and retrieve the hash. You can dream up your own stuff.

    You should note, that in Tk you have to spawn the child before the main loop, and that I have to manually reap the child by catching a DESTROY.

    use IO::Handle; use IO::Select; use Tk; use Tk::Button; use Storable; use DBI; # Author: James Moosmann , 2004 # Info: Non-block Tk Child #Set up 2 way communication with child pipe PREAD, CWRITE; pipe CREAD, PWRITE; my %hash; my $href =\ %hash; my $sql_statement = "SELECT * FROM Customers"; $|=1; my $ID; my $tmpdir = $ENV{TEMP}; $tmpdir =~s/\\/\//ig; my $tempfile = $tmpdir."/hash.dat"; my $mw = tkinit; my $var = "Status: "; my $l = $mw->Label(-text, "Message: ", -textvariable, \$var)->pack(-si +de, 'top'); my $txt = $mw->Text(-height, 2, -width, 40)->pack(-expand, 1, -fill, ' +both', -pady, 4, -padx, 4); $txt->insert('end', $sql_statement); my $b = $mw->Button(-text, "Run", -width, 10, -command, sub { &send_ms +g($txt->get('0.1','end')); })->pack(); #$mask = 0; #vec($mask, fileno(STDIN), 1); #vec($mask, fileno(PREAD), 1); #my ($read, $write) = ($mask, $mask); my $pid = fork(); if($pid==0){ # $pid == 0 for the child... this will act as our AGENT for proces +sing long running DBI calls # We have to create the child before we enter the MainLoop in Tk o +r Tk goes bonkers... # DO NOT attempt to create any widgets from here... and do not att +empt to land on Europa # Perhaps we could eval an output of the child to create widgets ? close CWRITE; close CREAD; #my $dbh = DBI->connect('dbi:ODBC:data'); while(1){ #select(undef,undef,undef, 0.05); #dead end # This seems to work fine... it doesn't block and tells me if data + is there # when $r == NO Bytes to read # when $r > 0 we have a sql statment to read and process my ($r) =(stat(PREAD))[7]; #<<<--- No Block :0) tells me if I ha +ve data... I just poll for it if($r > 0){ while(<PREAD>){ my $t = time; my $msg = $_; my $sth; # $sth = $dbh->prepare($_); # my $err = $dbh->errstr; #unless( $err){ #$sth->execute(); #while(my $hr = $sth->fetchrow_hashref){ # foreach(keys %$hr){ # $hash{$_} = $$hr{$_}; # } #} #} for(1..10){ sleep 1; $hash{$_} = $msg. ": ".$_; } print "Finished in ", (time-$t), "secs \n"; #Data is not shared between parent and child #so we will use storable module to do this for use :) #maybe slow, but at least we can use complex structures store \%hash, $tempfile; if($err=~/\w/){ $msg = "Error:".$err; }else{ $msg = "OK"; } syswrite PWRITE, "$msg\n"; last; } } } # This will likely become a zombie... # bind to a destroy to reap this puppy } close PREAD; close PWRITE; $mw->bind('<Any-Destroy>', sub{ &_cleanup;}); MainLoop; sub send_msg { my $sql = $_[0]; $sql =~s/\n/\r/g; syswrite CWRITE, $sql."\n"; $ID = $mw->repeat(100, \&datacheck); } sub datacheck{ #Do we have anything to get? my ($r) =( stat(CREAD))[7]; # <<<---- Doesn't block :o) $var = "Status: "; my $var1; if ($r > 0){ $ID->cancel; while(<CREAD>){ chomp; $var1 .= $_; %hash = %{retrieve($tempfile)}; $var1 =~s/Error:.*]\s+The/The/ig; $var1 =~s/\(.*\)//ig; if($r>0){ my (@list) = split /\./, $var1; $var .= "$_.\n" foreach +@list; $var=~s/\n\.\n+$//g;} print "$_ => $hash{$_}\n" for keys %hash; last; } } } sub _cleanup { kill 9, $pid; unlink $tempfile; } __END__

    Now, gimme those xp's ;-) (wink, wink)
      It is absolutely legal to fork after MainLoop was fired. You only must not use exit(), but rather CORE::exit() or (unfortunately needed in Tk804.026) POSIX::_exit() to quit the child process.

      At least I hope that this is true for Windows...

        Why would I make this up? Forking after MainLoop on Win32 doesn't work. The latest version of Tk on Win that is not beta is 800.024, I have tried beta 10 (804.XX) and it dies there too on Win32(2K and XP)... and that is why I said that. Believe me I have tried. Win32 doesn't really fork. It creates a thread I am told. Hence it's odd behavior ( FRUSTRATING BEHAVIOR ) in some modules. I didn't just make it up, and that is why the gent asked the question because it (and fileEvent and lots of other Tk behaviors should work but don't. I would not try to tell stuff works on platforms I cannot test on.

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://339244]
Approved by kvale
Front-paged by broquaint
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (3)
As of 2023-03-30 18:15 GMT
Find Nodes?
    Voting Booth?
    Which type of climate do you prefer to live in?

    Results (74 votes). Check out past polls.