Re: Second background process is pausing the gui

It seems fileevent is broken. Maybe current hardware can read much faster than when Tk was originally designed, so Tk can't manage to update before next line comes in?

Fortunately, you can use repeat to read the data from the process:

#! /usr/bin/perl
use strict;
use warnings;

use Tk;

{   my $in;
    sub stop { undef $in }

    sub run {
        my ($type, $entry) = @_;
        my $command = $entry->cget('-text');
        if (1 == $type) {
            my $out = $_[2];
            open $in, '-|', $command or die $!;
            my $repeat;
            $repeat = ($entry->repeat(1, sub {
                return $entry->afterCancel($repeat)
                    if $repeat && ! defined $in;

                read $in, my $buff, 100;
                if (length $buff) {
                    $out->insert(end => $buff);
                    $out->yview('end');
                }
            }));
        } elsif (2 == $type) {
            system "$command&";
        }
    }
}

my $mw = MainWindow->new(-title => 'Two background processes');
my $le_read_from = $mw->LabEntry(-label     => 'Read from:',
                                 -labelPack => [qw[ -side left ]],
                                 -text      => 'find')->pack;
my $le_process = $mw->LabEntry(-label     => 'Run in the background:',
                               -labelPack => [qw[ -side left ]],
                               -text      => 'xterm')->pack;

my $out;
my $f_b = $mw->Frame->pack;
my $b_run1 = $f_b->Button(-text    => 'Run 1',
                          -command => sub { run(1, $le_read_from, $out
+) })
    ->pack(-side => 'left');
my $b_run2 = $f_b->Button(-text    => 'Run 2',
                          -command => [\&run, 2, $le_process])
    ->pack;
my $f_b2 = $mw->Frame->pack;
my $b_clear1 = $f_b2->Button(-text    => 'Clear',
                             -command => sub { $out->delete('0.0', 'en
+d') })
    ->pack(-side => 'left');
my $b_stop = $f_b2->Button(-text    => 'Stop',
                           -command => \&stop)->pack(-side => 'left');
my $b_quit = $f_b2->Button(-text    => 'Quit',
                           -command => sub { Tk::exit })->pack;

my $playground = $mw->Text->pack;
$playground->insert('0.0',
    "You can type any text here to check the interactivity.\n");

$out = $mw->ROText->pack;

MainLoop();
[download]

map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]

Comment on Re: Second background process is pausing the gui Select or Download Code

Replies are listed 'Best First'.

Re^2: Second background process is pausing the gui
by bliako (Monsignor) on Jun 12, 2020 at 10:39 UTC

At last some code to play with - thanks as I do not know where to start with Tk! Unfortunately it still blocks if the external process blocks, for example: sleep 10 && echo hello instead of find.

I have modified your code to non-block with some help from PM's Re: Non blocking read on a filehandle. There is a simpler way though: change the filehandle to O_NONBLOCK after you open it using Fcntl::fcntl(). It does work but it reports weird file flags and I am unsure whether it is safe (Edit: I mean safe to be used with filehandles open'ed to external commands using -| . I think it's OK but this is the warning I get, notice that the reported $flags contain the command's output! Argument "\0sy^F>V\0\0\0\0\0\0\0\0\0\0output\0\0\0\0\0\0\0\0\0\0\0..." isn't numeric in bitwise or (|) Edit2Problem solved: I was reading an older example of fcntl, it should be: my $flags = fcntl($in, F_GETFL, 0) - for non-windows OSes.). Both versions below

# non-blocking pipe using select
use Tk;

{   my $in;
    sub stop { undef $in }

    # modified by bliako
    # non-blocking way to check if $fh has output ready

    sub has_output_ready {
      my ($fh, $nbytes) = @_;
      my $timeout = 0;
      my $rin = '';
      vec($rin, fileno($fh), 1) = 1;
      if( select($rin, undef, undef, $timeout) ){
        my ($buffer);
        read ($fh, $buffer, $nbytes);
        # fh has data and we are returning nbytes max
        # make $nbytes arbitrarily large or next time (if buffer holds
+)
        return $buffer;
      }
      return; # no output at this time, return undef
    }

    sub run {
        my ($type, $entry) = @_;
        my $command = $entry->cget('-text');
        if (1 == $type) {
            my $out = $_[2];
            open $in, '-|', $command or die $!;
            my $repeat;
            $repeat = ($entry->repeat(1, sub {
                return $entry->afterCancel($repeat)
                    if $repeat && ! defined $in;

        # modified by bliako: read blocks,
        # use has_output_ready() instead
                #read $in, my $buff, 100;
        my $buff = has_output_ready($in, 100, 0);
                if ($buff && length $buff) { # undef means no data yet
                    $out->insert(end => $buff);
                    $out->yview('end');
                }
            }));
        } elsif (2 == $type) {
            system "$command&";
        }
    }
}

...
[download]

Second method, using Fcntl::fcntl()

# non-blocking pipe using O_NONBLOCK file flag, unsafe(?)

  ...
  open $in, '-|', $command or die $!;
# modified by bliako to set the filehandle to non-block IO
use Fcntl;
# EDIT: commented below is not supported and outputs warning about ORi
+ng non-numerical flags
#my $flags = "";
#fcntl($in, F_GETFL, $flags) or die "failed to get flags, $!";
# use this instead:
my $flags = fcntl($in, F_GETFL, 0);
# reporting weird flags (linux)!
print "FLAGS: '$flags'\n";
$flags |= O_NONBLOCK;
fcntl($in, F_SETFL, $flags) or die "Couldn't set file flags: $!\n";
...
# and now read is non-block,
# undef will be returned if no output ready
read $in, my $buff, 100;
if ($buff && length $buff) { # check if undef
  ...
}
...
[download]

bw, bliako

[reply]
[d/l]
[select]


Clear questions and runnable code get the best and fastest answer
	PerlMonks