Ohad has asked for the wisdom of the Perl Monks concerning the following question:
Hi, I'm using perl/Tk.
I've created a background process to run a cmd and I want the main process to continue working.
This is fine and works, until I invoke an additional background process.
Than the GUI is stuck until the first process is done.
This is the first background process:
open (my $st_in, "<&STDIN");
open (my $out, '>&', STDOUT);
open (my $err, '>&', STDERR);
open (STDOUT, "> /dev/null");
open (STDERR, "> /dev/null");
open (STDIN, "< /dev/null");
my $status = open ($reg_out,"$cmd 2>&1 |") or die "can't fork: $!"
+;
if ($status) #Parent
{
open (STDOUT, '>&', $out);
open (STDERR, '>&', $err);
open (STDIN, '<', $st_in);
}
else
{
exit;
}
$Reg_r{$regl_name}{$nn}{'OutP'} =$reg_out;
$Reg_r{$regl_name}{$nn}{'PID'} = $status;
$Reg_r{$regl_name}{$nn}{'JobId'} = 0;
$Reg_r{$regl_name}{$nn}{'IsRun'} = 1;
$Reg_r{$regl_name}{$nn}{'WasRuning'} = 0;
$book->raise("Sheet 1") if ($re_run_csv);
$Sbook->raise("$regl_name $nn");
$mw->fileevent($reg_out, 'readable', [\&fill_text_widget,$regl_nam
+e,$nn]);
Second can be anything, a simple xterm
system("xterm -e '$viewer $log' &")
Any idea how to solve it? So the main process will not be stuck?
As you see in the code, I tried many options, exec/system/`,I tried closing STDs..
Could really use some advice here
Re: Second background process is pausing the gui
by bliako (Monsignor) on Jun 10, 2020 at 19:04 UTC
|
Is $reg_out global? If yes, could fileevent be cancelling the current bind and binding to new shell-out? Similar problem of "freezing" was solved here: Perl::TK - fileevent and script execution theory
BTW, you certainly don't want exec because it replaces the current perl process and once finished, you program will exit.
Outside the Tk realm, if you want to run a background process you could fork first and then spawn/shellout. Like:
my $pid = fork() // die "fork: $!";
if( $pid ){
print "forked: i am shelling out\n";
spawn();
print "after shelling out.\n";
}
print "I am now waiting for background process.\n";
waitpid $pid, 0;
print "done.\n";
sub spawn {
my $pid = open(my $xx, "sleep 1 2>&1|") or die "fork: $!";
print "implicitly waiting for child...\n";
# close($xx);
}
Also, I don't know what side-effects fileevent has on the above code, but usually when forking out to an external command you must wait for it to finish. Essentially, close($reg_out) acts as a waitpid $status, 0;. But if you don't, then perl will implicitly wait for it. If the code you posted is a sub, it will not exit until $cmd is dead (again, I don't know how fileevent interferes with this if at all).
So, something like this:
print "before spawn\n";
spawn();
print "after spawn\n";
sub spawn {
my $pid = open(my $xx, "sleep 3 2>&1|") or die "fork: $!";
print "implicitly waiting for child...\n";
# the proper way to wait for the command to exit:
# close($xx);
}
# output:
before spawn
implicitly waiting for child... # sleep...
after spawn
UPDATE: exec on the other hand is used in a trick where the program forks using open(my $xx, '|-'); and at the child branch the external command is spawned using exec (which offers finer control over open if one wants to avoid the shell). But that's different to calling exec() in your normal program flow (as an alternative to system()) as it will kill your program.
bw, bliako | [reply] [Watch: Dir/Any] [d/l] [select] |
Re: Second background process is pausing the gui
by choroba (Cardinal) on Jun 11, 2020 at 20:58 UTC
|
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:
map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
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&";
}
}
}
...
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
...
}
...
bw, bliako | [reply] [Watch: Dir/Any] [d/l] [select] |
Re: Second background process is pausing the gui
by tybalt89 (Monsignor) on Jun 12, 2020 at 14:55 UTC
|
#!/usr/bin/perl
use strict; # https://perlmonks.org/?node_id=11117902
use warnings;
use Tk;
use Tk::IO;
my $date = localtime();
my $mw = MainWindow->new;
$mw->Button(-text => 'Start', -command => \&start,
)->pack(-side => 'top', -fill => 'x');
$mw->Label(-textvariable => \$date, -fg => 'blue',
)->pack(-side => 'top', -fill => 'x');
$mw->Button(-text => 'Exit', -command => sub {$mw->destroy},
)->pack(-side => 'bottom', -fill => 'x');
$_ = $mw->Text(-width => 10, -font => 14,
)->pack(-side => 'left') for my( $one, $two );
$mw->repeat( 1000, sub { $date = localtime() } );
MainLoop;
sub start
{
Tk::IO->new(-linecommand => sub {
$one->insert(end => shift);
$one->see('end');},
)->exec('for i in `seq 1 24` ; do sleep .5 ; echo $i ; done');
Tk::IO->new(-linecommand => sub {
$two->insert(end => shift);
$two->see('end');},
)->exec('for i in `seq 1 24` ; do sleep .7 ; echo $i ; done');
}
Note that the date keeps advancing while the text widgets are being filled in, indicating that the gui is still responding.
| [reply] [Watch: Dir/Any] [d/l] |
|
But if you replace one of the shell loops with find, it hangs again until the find finishes.
map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
| [reply] [Watch: Dir/Any] [d/l] |
|
|
|
Re: Second background process is pausing the gui
by perlfan (Vicar) on Jun 10, 2020 at 12:51 UTC
|
I am unfamiliar with using Tk, but this looks odd to me, what is it providing to your application - open (STDIN, "< /dev/null"); ? Is that a Tk idiom? | [reply] [Watch: Dir/Any] [d/l] |
|
| [reply] [Watch: Dir/Any] |
Re: Second background process is pausing the gui
by Anonymous Monk on Jun 18, 2020 at 12:23 UTC
|
Thanks for the answers.
I want to keep it as simple as possible, also I would prefer it to have "real-time" update, not waiting for a buffer to fill up.
This is my fileevent function:
sub fill_text_widget {
my $block = shift;
my $numb = shift;
my $widget = $Reg_r{$block}{$numb}{'Txt'};
my $out_rep = $Reg_r{$block}{$numb}{'OutP'};
if (eof($out_rep))
{
$widget->fileevent($out_rep,"readable", undef);
close $Reg_r{$block}{$numb}{'OutP'};
print "Got EOF\n" if ($DBG);
$Reg_r{$block}{$numb}{'IsRun'} =0;
&AddReRun($block, $numb);
return;
}
$_ = <$out_rep>;
$widget->insert('end', $_);
$widget->yview('end');
}
The annoying part, is that the gui keeps working fine after launching the open as if in real background, the gui is completely functional. Only when I invoke an additional process, let's say an xterm, the gui suddenly gets blocked, although both jobs are running. The gui will be free only when the initial open is done
regrading the option to use FCNTL, can you elaborate on it? I tried using it, didnt made a difference, but I think I didn't do it properly. Can I keep using fileevent or do I have to move to read? | [reply] [Watch: Dir/Any] [d/l] |
|
| [reply] [Watch: Dir/Any] |
A reply falls below the community's threshold of quality. You may see it by logging in. |
|
|