I am looking to run two subroutines in parallel, where both perform the same task on an android handset using ADB commands. With help from SO and other research I have produced the following code below, however I am new to multithreading and I get an error of 'Free to wrong pool' during execution. I am assuming I get this as I am using the $_ variable in both threads, is this correct? I am using Windows7 to run this, but my Perl interpreter crashes on running this script. Any guidance would be greatly appreciated. Thanks.
use strict;
use Win32::OLE;
use EFS_Handle;
use HelperFunctions;
use threads;
#### Various ADB command sequences follow ####
#### Start of multithread to run the same function on different android handsets ####
my #jobs;
push #jobs, threads->create(
sub {
print "\n\t" . curTime() . " :\t DUT Time at start of MPLMN search";
open my $fh1, '>', "output.txt" or die "Cannot open output.txt: $!";
my $pid1 = open my $log1, "-|", "adb -s 42d8d7dd logcat";
system('adb -s 42d8d7dd shell input keyevent KEYCODE_ENTER');
while (<$log1>) {
$fh1->print($_);
last if m/Sorted scan results/;
}
kill "TERM", $pid1;
close $log1;
print "\n\t" . curTime() . " :\t DUT Time at End of MPLMN search\n";
}
);
push #jobs, threads->create(
sub {
print "\n\t" . curTime() . " :\t REF Time at start of MPLMN search";
open my $fh, '>', "output.txt" or die "Cannot open output.txt: $!";
my $pid = open my $log, "-|", "adb -s 0123456789ABCDEF logcat";
system('adb -s 0123456789ABCDEF shell input keyevent KEYCODE_ENTER');
while (<$log>) {
$fh->print($_);
last if m/EVENT_NETWORK_SCAN_COMPLETED/;
}
kill "TERM", $pid;
close $log;
print "\n\t" . curTime() . " :\t REF Time at End of MPLMN search\n";
}
);
$_->join for #jobs;
The Win32::OLE module is famously not thread-safe
If you remove use Win32::OLE (you don't seem to use it) then your code will run fine
If have my doubts about adb cooperating with multiple simultaneous commands, but that is a different matter
I think the problem could be related to the fact you are writing from both threads to the same file "output.txt" with ">". Try opening them with ">>".
Also remember to close that file.
"I am assuming I get this as I am using the $_ variable in both threads..."
If you use strict, and $_ is in separate methods/subroutines, then there should be no global-access problems.
Related
I'm trying to capture the output my perl code generates both from print and similar statements and external commands.
Due to design constraints I can't use solutions like Capture::Tiny. I need to forward the output to the buffer variable as soon as it is generated and I need to be able to differentiate between STDOUT and STDERR. Ideally a solution for external commands would essentially work just like system apart from being able to capture STDOUT and STDERR instead of printing them.
My code is supposed to:
Save the old STDOUT/STDERR file handles.
Create a new ones for both STDERR and STDOUT.
Redirect all the output to this place.
Print a couple of things.
Restore the old filehandles.
Do something with the captured output, e.g. print it.
However I'm unable to capture the output generated from external commands. I can't do it with IPC::Run3 nor with IPC::Open3.
#!/usr/bin/perl -CSDAL
use warnings;
use strict;
use IPC::Open3;
#use IPC::Run3;
# Save old filehandles
open(my $oldout, ">&STDOUT") or die "Can't dup STDOUT: $!";
open(my $olderr, ">&STDERR") or die "Can't dup STDERR: $!";
my $buffer = "";
close(STDOUT);
close(STDERR);
open(STDOUT, '>', \$buffer) or die "Can't redirect STDOUT: $!";
*STDERR = *STDOUT; # In this example STDOUT and STDERR are printed to the same buffer.
print "1: Test\n";
#run3 ["date"], undef, \*STDOUT, \*STDERR; # This doesn't work as expected
my $pid = open3("<&STDIN", ">&STDOUT", ">&STDERR", "date");
waitpid($pid,0); # Nor does this.
print STDERR "2: Test\n";
open(STDOUT, ">&", $oldout) or die "Can't dup \$oldout: $!";
open(STDERR, ">&", $olderr) or die "Can't dup \$olderr: $!";
print "Restored!\n";
print $buffer;
Expected result:
Restored!
1: Test
Mo 25. Mär 13:44:53 CET 2019
2: Test
Actual result:
Restored!
1: Test
2: Test
I don't have a solution to offer you, however I can provide some explanations as to the behavior you are seeing.
First, IPC::Open3 is not supposed to work when your filehandles are variables; see this question for more explanations.
Now, why isn't IPC::Run3 working? First, notice that if don't redirect STDERR and run
run3 ["date"], undef, \$buffer, { append_stdout => 1 };
instead of
run3 ["date"], undef, \*STDOUT;
then it works as expected. (you need to add { append_stdout => 1 } or your previous outputs to $buffer will be overwritten)
To understand what's happening, in your program, after
open(STDOUT, '>', \$buffer) or die "Can't redirect STDOUT: $!";
Add
print STDERR ref(\$buffer), "\n"
print STDERR ref(\*STDOUT), "\n"
Which will print
SCALAR
GLOB
That's exactly what IPC::Run3::run3 will do to know what to do with the "stdout" you give it (see the source: _fh_for_child_output, which is called by run3):
if it's a scalar, then a temporary file is used (the corresponding line is $fh = $fh_cache{$what} ||= tempfile, where tempfile is a function from File::Temp.
On the other hand, when stdout is a GLOB (or tied to IO::Handle), that filehandle is used directly (that's this line of code).
Which explains why when you call run3 with \$buffer it works, but not with \*STDOUT.
When redirecting STDERR as well, and calling
run3 ["date"], undef, \$buffer, \$buffer, { append_stdout => 1, append_stderr => 1 };
, things start to appear weird. I don't understand what's happening, but I'll share here what I found, and hopefully someone will make sense of it.
I modified the source of IPC::Run3 and added
open my $FP, '>', 'logs.txt' or die "Can't open: $!";
at the beginning of the sub run3. When running, I only see
Restored!
1: Test
on STDOUT (my terminal), but logs.txt contains the date (something in the lines of Mon Mar 25 17:49:44 CET 2019).
Investing a bit reveals that fileno $FP returns 1 (which, unless I mistaken, is usually STDOUT (but you closed it, so I'm no so surprised that its descriptor can be reused)), and fileno STDOUT returns 2 (this might depend on your Perl version and other opened filehandles though). What seems to be happening is that system assumes that STDOUT is the file descriptor 1 and thus prints to $FP instead of STDOUT (I'm just guessing though).
Please feel free to comment/edit if you understand what's happening.
I ended up with the following code:
#!/usr/bin/perl -CSDAL
use warnings;
use strict;
use IPC::Run3;
use IO::Scalar;
use Encode;
use utf8;
# Save old filehandles
open(my $oldout, ">&STDOUT") or die "Can't dup STDOUT: $!";
open(my $olderr, ">&STDERR") or die "Can't dup STDERR: $!";
open(my $FH, "+>>:utf8", undef) or die $!;
$FH->autoflush;
close(STDOUT);
close(STDERR);
open(STDOUT, '>&', $FH) or die "Can't redirect STDOUT: $!";
open(STDERR, '>&', $FH) or die "Can't redirect STDOUT: $!";
print "1: Test\n";
run3 ["/bin/date"], undef, $FH, $FH, { append_stdout => 1, append_stderr => 1 };
print STDERR "2: Test\n";
open(STDOUT, ">&", $oldout) or die "Can't dup \$oldout: $!";
open(STDERR, ">&", $olderr) or die "Can't dup \$olderr: $!";
print "Restored!\n";
seek($FH, 0, 0);
while(<$FH>)
{
# No idea why this is even required
print Encode::decode_utf8($_);
}
close($FH);
This is far from what I originally wanted, but appears to be working at least.
The issues I have with this are:
I need an anonymous file handle creating clutter on the hard disk.
For some reason I need to fix the encoding manually.
Thank you very much to the people who dedicated their time helping me out here.
Is there a reason you need to use the parent's STDOUT and STDERR? IPC::Open3 is easily capable of redirecting the child's STDOUT and STDERR to unrelated handles in the parent which you can read from.
use strict;
use warnings;
use IPC::Open3;
my $pid = open3 undef, my $outerr, undef, 'date';
my $output = do { local $/; readline $outerr };
waitpid $pid, 0;
my $exit = $? >> 8;
This will read STDOUT and STDERR together, if you want to read them separately you need to pass my $stderr = Symbol::gensym as the third argument (as shown in the IPC::Open3 docs), and use a non-blocking loop to avoid deadlocking when reading both handles. IO::Async::Process or similar can fully automate this for you, but IPC::Run3 provides a much simpler solution if you only need to store the output in scalar variables. IPC::Run3 and Capture::Tiny can also both easily be fatpacked for deployment in scripts.
This is not an answer yet, but it seems like open3 requires STDOUT to be a regular tty file handle at the time you call open3, for example:
use feature qw(say);
use strict;
use warnings;
use IPC::Open3;
use Symbol 'gensym';
{
local *STDOUT; # <-- if you comment out this line open3 works as expected
my ($chld_in, $chld_out);
my $chld_err = gensym;
my $pid;
eval {
$pid = open3($chld_in, $chld_out, $chld_err, "date");
};
if ( $# ) {
say "IPC::Open::open3 failed: '$#'";
}
print "-> $_" for <$chld_out>;
waitpid $pid, 0;
# say "Cannot print to invalid handle..";
}
say "ok";
Output:
ma. 25. mars 16:00:01 +0100 2019
ok
Note that the arrow -> in the beginning of the line is missing,
so nothing can be read from $chld_out in this case. However, if I comment out the line:
local *STDOUT;
The output is:
-> ma. 25. mars 16:01:10 +0100 2019
ok
I am trying following code in one of my perl script and getting error, how do i execute following shell command and store in variable
#!/usr/bin/perl -w
my $p = $( PROCS=`echo /proc/[0-9]*|wc -w|tr -d ' '`; read L1 L2 L3 DUMMY < /proc/loadavg ; echo ${L1}:${L2}:${L3}:${PROCS} );
print $p;
Error:
./foo.pl
Bareword found where operator expected at /tmp/foo.pl line 3, near "$( PROCS"
(Missing operator before PROCS?)
syntax error at /tmp/foo.pl line 3, near "$( PROCS"
Unterminated <> operator at /tmp/foo.pl line 3.
What is wrong?
This:
my $p = $( PROCS=`echo /proc/[0-9]*|wc -w|tr -d ' '`; read L1 L2 L3 DUMMY < /proc/loadavg ; echo ${L1}:${L2}:${L3}:${PROCS} );
Isn't perl. It's how you'd execute a command in bash.
To run a command in perl you can:
use system.
put your command in backticks
qx (quote-execute): http://perldoc.perl.org/perlop.html#Quote-Like-Operators
However, you're enumerating a directory there, wordcounting, tr-ing and reading. So you don't actually need to do all that using a shell command. And indeed, I'd discourage you from doing so, because that's just a way to make a mess with no productive benefit.
Looks like what you're after as an end result is the 3 load average samples and a count of number of processes. Is that right?
In which case:
my $proc_count = scalar ( () = glob ( "/proc/[0-9]*" ));
open ( my $la, "<", "/proc/loadavg" ) or warn $!;
print join ( ":", split ( /\s+/, <$la> ), $proc_count ),"\n";
Something like that, anyway.
Simply printing a shell command in your Perl script won't actually execute it. You have to tell Perl that it's an external command, which you can do with system:
use strict;
use warnings;
my $command = q{
PROCS=`echo /proc/[0-9]*|wc -w|tr -d ' '`;
read L1 L2 L3 DUMMY < /proc/loadavg;
echo ${L1}:${L2}:${L3}:${PROCS}
};
system($command);
(Note that you should put use strict; use warnings; at the top of every Perl script you write.)
However, it's generally better to use native Perl functionality instead of system. All you're doing is reading from files, which Perl is perfectly capable of doing:
use strict;
use warnings;
use 5.010;
my #procs = glob '/proc/[0-9]*';
my $file = '/proc/loadavg';
open my $fh, '<', $file or die "Failed to open '$file': $!";
my $load = <$fh>;
say(join ':', (split ' ', $load)[0..2], scalar #procs);
Even better might be to use the Proc::ProcessTable module, which provides a consistent interface to the /proc filesystem across different flavors of *nix. It got some bad reviews early on but is supposedly getting bugfixes now; I haven't used it myself but you might take a look.
i want to use O_ASYNC option and when the pipe can read ,
the SIGIO's handler will run .
but the following code are not work . any one can help me ?
#!/bin/env perl
use Fcntl;
$SIG{IO}= sub {
print "catch SIGIO!\n";
};
my $flags=0;
open(FH,"-|","sleep 4 ;echo aaa") or die "$!";
fcntl(FH,F_GETFL,$flags) or die "$!";
fcntl(FH,F_SETFL,$flags | O_NONBLOCK | O_ASYNC) or die "$!";
sleep(5);
print "complete\n";
my perl version is 5.16.1 , operation system is Redhat 5u4 ,kernel 2.6.18, x86_64
Under Linux, you must both request asynchronous notification (O_ASYNC) and specify a recipient (F_SETOWN). So, you need only add one line to your example to make it work:
#!/bin/env perl
use Fcntl;
$SIG{IO}= sub {
print "catch SIGIO!\n";
};
my $flags=0;
open(FH,"-|","sleep 4 ;echo aaa") or die "$!";
fcntl(FH,F_GETFL,$flags) or die "$!";
fcntl(FH,F_SETFL,$flags | O_NONBLOCK | O_ASYNC) or die "$!";
fcntl(FH,F_SETOWN,0 + $$) or die "$!"; # <-- Note that we force $$ to be numeric
sleep(5);
print "complete\n";
Running the above:
$ perl so-12640993.pl
catch SIGIO!
complete
SIGIO based asynchronous IO is edge-triggered, not level triggered.
Before any filehandle will send you a SIGIO you must first "arm" it. To do that, you need to perform whatever is the operation - sysread() in this case - until you get an undef/EAGAIN. At that point the filehandle will now be armed for SIGIO and will send a signal when it is next read-ready. You can then read it until it yields EAGAIN, which will arm it once more.
i have a script, that parse log and find errors and warnings.
And i want to use user-friendly interpretation of this log.
For this reason, i use notepad.
Here is code:
use v5.16;
use strict;
use warnings;
use Win32::Clipboard;
use threads;
use utf8;
my $kp = Win32::Clipboard->new();
my $output = shift || "out_log.txt";
#my ($input, $output)=#ARGV;
#open my $ih, "<", $input or die "can't open input file with log\n";
open my $oh, ">", $output or die "can't open output file with log\n";
my #alls=split /\n/,$kp->Get();
for my $k(0..$#alls){
$_ = $alls[$k];
if(/^ERR.+|^WARN.+/){
print {$oh} qq(at position $k --> ).$_."\n";
}
}
my $thread =
threads->create(sub{
$SIG{INT}=sub{die"All good\n";};
qx(notepad $output);
}
);
print qq(type 'y' for quit);
do{
print "want to quit?\n>" ;
chomp;
do{
say "I will kill this thread";
$thread->kill('INT') if defined($thread);
say "and delete output";
unlink $output;
exit(0);
}if (m/y/);
}while(<>);
It falls down, when i trying to kill thread which run notepad.
How to do this, using signals and threads? Is it possible?
And your ideas about solution, please.
Thanks!
This isn't working because your SIGINT never gets passed to notepad. So it never gets closed. (And that handler - probably never gets processed).
You need to approach this differently. Look at Win32::Process for some examples of how to spawn/kill a notepad process.
my $ProcessObj;
Win32::Process::Create( $ProcessObj,
"C:\\Windows\\system32\\notepad.exe",
"notepad", 0, NORMAL_PRIORITY_CLASS, "." )
or die $!;
And then you can use
$ProcessObj -> Kill(1);
I'd suggest using Thread::Semaphore or some sort of shared variable to decide if you want to kill your notepad.
I am trying to read unbufferd data from a pipe in Perl. For example in the program below:
open FILE,"-|","iostat -dx 10 5";
$old=select FILE;
$|=1;
select $old;
$|=1;
foreach $i (<FILE>) {
print "GOT: $i\n";
}
iostat spits out data every 10 seconds (five times). You would expect this program to do the same. However, instead it appears to hang for 50 seconds (i.e. 10x5), after which it spits out all the data.
How can I get the to return whatever data is available (in an unbuffered manner), without waiting all the way for EOF?
P.S. I have seen numerous references to this under Windows - I am doing this under Linux.
#!/usr/bin/env perl
use strict;
use warnings;
open(PIPE, "iostat -dx 10 1 |") || die "couldn't start pipe: $!";
while (my $line = <PIPE>) {
print "Got line number $. from pipe: $line";
}
close(PIPE) || die "couldn't close pipe: $! $?";
If it is fine to wait in your Perl script instead on the linux command, this should work.
I don't think Linux will give control back to the Perl script before the command execution is completed.
#!/usr/bin/perl -w
my $j=0;
while($j!=5)
{
open FILE,"-|","iostat -dx 10 1";
$old=select FILE;
$|=1;
select $old;
$|=1;
foreach $i (<FILE>)
{
print "GOT: $i";
}
$j++;
sleep(5);
}
I have below code working for me
#!/usr/bin/perl
use strict;
use warnings;
open FILE,"-|","iostat -dx 10 5";
while (my $old=<FILE>)
{
print "GOT: $old\n";
}
The solutions so far did not work for me with regards to unbuffering (Windows ActiveState Perl 5.10).
According to http://perldoc.perl.org/PerlIO.html, "To get an unbuffered stream specify an unbuffered layer (e.g. :unix ) in the open call:".
So
open(PIPE, '-|:unix', 'iostat -dx 10 1') or die "couldn't start pipe: $!";
while (my $line = <PIPE>) {
print "Got $line";
}
close(PIPE);
which worked in my case.