I need some help, I can't figure out why my thread doesn't want to start. I don't have experience with perl, and was asked to make a script that will process a file row by row. Depending on the row, the process should execute other functions (not in snippet), call the same function on a new file or call the same function on a new file in parallel (thread).
Below, I pasted a snippet of the actual code (removed the non-relevant code).
I'm testing the multithreading part on a function called "test" which should print "ok".
The process executes correctly, "start" is printed, but then it gets stuck and after a brief delay, the process stops executing completely.
A thousand thanks to whoever may help me!
use strict;
use warnings;
use IO::Prompter;
use Getopt::Long;
use Log::Message::Simple;
use File::Basename;
use File::Spec;
use IO::Socket::INET;
use UUID::Tiny ':std';
use threads;
use threads::shared;
# *bunch of code deleted*
process_file( $cmdline{csvfile}, 1 );
sub test {
print "ok\n";
}
sub process_file {
# get parameters
my ( $input_file, $flowid ) = #_;
# init variables
# open input file
open( my $fh, '<:encoding(UTF-8)', $input_folder . $input_file )
or die "Could not open file '$input_file' $!";
# process file
while ( my $row = <$fh> ) {
chomp $row;
#request = split ";", $row;
$flow_type = $request[0];
$flow = $request[1];
# *bunch of code deleted*
$filename = "$flow.csv";
$keep_flowid = $request[2]; # keep flowid?
$tmp_flowid = $keep_flowid ? $flowid : undef; # set flowid
$thread = $request[3];
if ( $thread == 1 ) {
### Create new thread
print "start\n";
my $process_thread = threads->create("test");
$process_thread->join();
}
elsif ( $thread == 0 ) {
# wait on process to complete
process_file( $filename, $tmp_flowid );
}
# *bunch of code deleted*
}
# close file
close $fh or die "Couldn't close inputfile: $input_file";
}
It's hard to say exactly why you're having this problem - the major possiblity seems to be:
$thread = $request[3];
if ($thread == 1){
This is input from your filehandle, so a real possiblity is that "$request[3]" isn't actually 1.
I am a bit suspicious though - your code as use strict; use warnings at the top, but you're not declaring e.g. $thread, $flow etc. with my. That either means you're not using strict, or you're reusing variables - which is a good way to end up with annoying glitches (like this one).
But as it stands - we can't tell you for sure, because we cannot reproduce the problem to test it. In order to do this, we would need some sample input and a MCVE
To expand on the point about threads made in the comments - you may see warnings that they are "Discouraged". The major reason for this, is because perl threads are not like threads in other languages. They aren't lightweight, where in other languages they are. They're perfectly viable solutions to particular classes of problems - specifically, the ones where you need parallelism with more IPC than a fork based concurrency model would give you.
I suspect you are experiencing this bug, fixed in Perl 5.24.
If so, you could work around it by performing your own decoding rather than using an encoding layer.
Related
Looking for right way to detect one keyword during board boot up message.
After keyword detected, send Enter key after one second.
Kernel is Linux.
# Serial port inisialisation is finished here.
# Read boot message
($count, $result) = $ob->read(300); # at least 300 chars coming till keyword appear
if ($result =~ m/Booting_up/) {
print "send Enter ...\n";
sleep 1;
$ob->write("\r\n");
}
Thanks for hint
It appears that you are using Win32::SerialPort module, or perhaps Device::SerialPort which
provides an object-based user interface essentially identical to the one provided by the Win32::SerialPort module.
Its method read takes the number of bytes to read and returns the number read and writes them into the given string.
You may be "missing" the phrase because it's past the 300-mark, and your code doesn't read any further. Try to loop, getting a few bytes at a time and adding them up, thus building the string in small reads.
my bytes_in = 10; # length of pattern, but it does NOT ensure anything
my ($read, $result);
while (1)
{
my ($count, $read) = $ob->read( $bytes_in );
$result = $result . $read;
if ($result =~ m/Booting_up/) { # is it "Booting_up" or "Booting up" ?
print "send Enter ...\n";
sleep 1; # is this needed?
$ob->write("\r\n");
# last; # in case this is all you need to do
}
last if $count != $bytes_in; # done reading
}
I don't put the $ob->read statement in the loop condition since the documentation isn't crystal clear on how the method works. You may also be able to simply use
while ( my ($count, $read) = $ob->read( $bytes_in ) ) {
$result = $result . $read;
if ($result =~ m/Booting_up/s) {
# ...
}
last if $count != $bytes_in;
}
We read a small number of bytes at a time to prevent problems with either polling or blocking reads, brought up in comments by BenPen. See Configuration and capability methods.
You can first read those first 300 bytes that precede the pattern in one go and then start reading a few (or one) at a time, which would also lead to the quickest identification of the phrase.
This can be tweaked further but let's first see what it does as it stands (I cannot test).
Documentation also offers a few other methods which may be useful, in particular readline and streamline. As this is all rather low level there are yet other ways but if you got all else working perhaps this will be enough to complete it.
Perhaps rather index the string?
($count, $result) = $ob->read(300); # at least 300 chars coming till keyword appear
$substring = 'Booting_up';
if (index($result, $substring) != -1) {
print "send Enter ..\n";
sleep 1;
$ob->write("\r\n");
}
Im trying to write some basic chat system just to learn perl. Im trying to get the chatlog into a 1 file and print new message if it's appears in the chatlog.dat file, So i've wrote a function that does almost the same thing, but I have got some problems and don't know how to solve them.
So now I have 2 problems!
I could not understand how to keep checkFile function always active (like multiprocession) to continuously check for new messages
This problem occurs when I'm trying to write a new message that will be appended into the chatlog. The Interpreter waits for my input on the line my $newMessage = <STDIN>;, but, what if someone writes a new message? it will not be shown until he press enter... how to void that?
my ($sec,$min,$hour) = localtime();
while(1){
my $userMessage = <STDIN>;
last if $userMessage eq "::quit";
`echo "($hour:$min:$sec): $userMessage" >>chatlog.dat`;
}
sub checkFile{
my $lastMessage = "";
my $newMessage = "";
while (1) {
my $context = `cat chatlog.dat`;
split(/\n/, $context);
$newMessage = $_[$#_];
if ($newMessage ne $lastMessage) {
print $newMessage;
$lastMessage = $newMessage;
}
}
}
First:
don't use echo within a perl script. It's nasty to shell escape when you've got perfectly good IO routines.
using cat to read files is about as nasty as using 'echo'.
reading <STDIN> like that will be a blocking call - which means your script will pause.
but that's not as bad as it sounds, because otherwise you're running a 'busy wait' loop which'll repeatedy cat the file. This is a very bad idea.
You're assuming writing a file like that is an atomic operation, when it's not. You'll hit problems with doing that too.
What I would suggest you do it look at IO::Handle and also consider using flock to ensure you've got the file locked for IO. You may also wish to consider File::Tail instead.
I would actually suggest though, you want to consider a different mode of IPC - as 'file swapping' is quite inefficient. If you really want to use the filesystem for your IO, you might want to consider using a FIFO pipe - have each 'client' open it's own, and have a server reading and coalescing them.
Either way though - you'll either need to use IO::Select or perhaps multithreading, just to swap back and forth between reading and writing. http://perldoc.perl.org/IO/Select.html
Answering my own question
sub checkFile{
my $lastMessage = "";
my $newMessage = "";
my $userName = $_[0];
while (1) {
my $context = `cat chatlog.dat`;
split(/\n/, $context);
$newMessage = $_[$#_];
if ($newMessage ne $lastMessage) {
$newMessage =~ /^\(.+\):\((.+)\) (.+$)/;
if ($1 ne $userName) { print "[$1]: $2";}
$lastMessage = $newMessage;
}
}
}
my $userName = "Rocker";
my ($sec,$min,$hour) = localtime();
my $thr = threads -> create ( \&checkFile, $userName ); #Starting a thread to continuously check for the file update
while (1) {
my $userMessage = <STDIN>; #STDIN will not interfere file checking
last if $userMessage eq "::quit";
`echo "($hour:$min:$sec):($userName) $userMessage" >>chatlog.dat` if $userMessage =~ /\S+/;
}
$thr -> join();
It seems using pipe in threads might cause the threads turn into zombie. In fact the commands in the pipe truned into zombie, not the threads. This does not happen very time which is annoying since it's hard to find out the real problem. How to deal with this issue? What causes these? Was it related to the pipe? How to avoid this?
The following is the codes that creates sample files.
#buildTest.pl
use strict;
use warnings;
sub generateChrs{
my ($outfile, $num, $range)=#_;
open OUTPUT, "|gzip>$outfile";
my #set=('A','T','C','G');
my $cnt=0;
while ($cnt<$num) {
# body...
my $pos=int(rand($range));
my $str = join '' => map $set[rand #set], 1 .. rand(200)+1;
print OUTPUT "$cnt\t$pos\t$str\n";
$cnt++
}
close OUTPUT;
}
sub new_chr{
my #chrs=1..22;
push #chrs,("X","Y","M", "Other");
return #chrs;
}
for my $chr (&new_chr){
generateChrs("$chr.gz",50000,100000)
}
The following codes will create zombie threads occasionally. Reason or trigger remains unknown.
#paralRM.pl
use strict;
use threads;
use Thread::Semaphore;
my $s = Thread::Semaphore->new(10);
sub rmDup{
my $reads_chr=$_[0];
print "remove duplication $reads_chr START TIME: ",`date`;
return 0 if(!-s $reads_chr);
my $dup_removed_file=$reads_chr . ".rm.gz";
$s->down();
open READCHR, "gunzip -c $reads_chr |sort -n -k2 |" or die "Error: cannot open $reads_chr";
open OUTPUT, "|sort -k4 -n|gzip>$dup_removed_file";
my ($last_id, $last_pos, $last_reads)=split('\t',<READCHR>);
chomp($last_reads);
my $last_length=length($last_reads);
my $removalCnts=0;
while (<READCHR>) {
chomp;
my #line=split('\t',$_);
my ($id, $pos, $reads)=#line;
my $cur_length=length($reads);
if($last_pos==$pos){
#may dup
if($cur_length>$last_length){
($last_id, $last_pos, $last_reads)=#line;
$last_length=$cur_length;
}
$removalCnts++;
next;
}else{
#not dup
}
print OUTPUT join("\t",$last_id, $last_pos, $last_reads, $last_length, "\n");
($last_id, $last_pos, $last_reads)=#line;
$last_length=$cur_length;
}
print OUTPUT join("\t",$last_id, $last_pos, $last_reads, $last_length, "\n");
close OUTPUT;
close READCHR;
$s->up();
print "remove duplication $reads_chr END TIME: ",`date`;
#unlink("$reads_chr")
return $removalCnts;
}
sub parallelRMdup{
my #chrs=#_;
my %jobs;
my #removedCnts;
my #processing;
foreach my $chr(#chrs){
while (${$s}<=0) {
# body...
sleep 10;
}
$jobs{$chr}=async {
return &rmDup("$chr.gz")
}
push #processing, $chr;
};
#wait for all threads finish
foreach my $chr(#processing){
push #removedCnts, $jobs{$chr}->join();
}
}
sub new_chr{
my #chrs=1..22;
push #chrs,("X","Y","M", "Other");
return #chrs;
}
¶llelRMdup(&new_chr);
As the comments on your originating post suggest - there isn't anything obviously wrong with your code here. What might be helpful to understand is what a zombie process is.
Specifically - it's a spawned process (by your open) which has exited, but the parent hasn't collected it's return code yet.
For short running code, that's not all that significant - when your main program exits, the zombies will 'reparent' to init which will clean them up automatically.
For longer running, you can use waitpid to clean them up and collect return codes.
Now in this specific case - I can't see a specific problem, but I would guess it's to do with how you're opening your filehandles. The downside of opening filehandles like you are, is that they're globally scoped - and that's just generally bad news when you're doing thready things.
I would imagine if you changed your open calls to:
my $pid = open ( my $exec_fh, "|-", "executable" );
And then called waitpid on that $pid following your close then your zombies would finish. Test the return from waitpid to get an idea of which of your execs has errored (if any), which should help you track down why.
Alternatively - set $SIG{CHLD} = "IGNORE"; which will mean you - effectively - tell your child processes to 'just go away immediately' - but you won't be able to get a return code from them if they die.
Perl threads do not support sharing filehandles. All the elements of a shared data structure must be shared. This presents a problem if one needs to share an object which contains a filehandle.
{
package Foo;
use Mouse;
has fh =>
is => 'rw',
default => sub { \*STDOUT };
}
use threads;
use threads::shared;
my $obj = Foo->new;
$obj = shared_clone($obj); # error: "Unsupported ref type: GLOB"
print {$obj->fh} "Hello, world!\n";
It really doesn't matter if the filehandle is "shared" or not, it's only used for output. Perhaps there is a trick where the filehandle is stored outside the shared object?
This object is actually contained in another shared object which is in another and so on. The grand irony is the objects in question never use threads themselves, but must remain coordinated across the process if the user uses threads.
The real code in question can be seen here: These objects are used to configure where formatted output goes. An object is necessary because output does not always go to a filehandle.
I don't have access to threaded Perl at the moment, so can't guarantee that this will work.
But a somewhat simplistic approach would be to use a level of abstraction and store a key/index into a global filehandle hash/array into the object, something similar to the following:
my #filehandles = (); # Stores all the filehandles ### CHANGED
my $stdout; # Store the index into #filehandles, NOT filehandle.
# Should really be renamed "$stdout_id" instead.
sub stdout {
my $self = shift;
return $stdout if defined $stdout;
$stdout = scalar(#filehandles); ### CHANGED
my $stdout_fh = $self->dup_filehandle(\*STDOUT); ### CHANGED
push #filehandles, $stdout_fh; ### CHANGED
$self->autoflush($stdout_fh); ### CHANGED
$self->autoflush(\*STDOUT);
return $stdout;
}
sub safe_print {
my $self = shift;
my $fh_id = shift; ### CHANGED
my $fh = $filehandles[$fh_id]; ### CHANGED
local( $\, $, ) = ( undef, '' );
print $fh #_;
}
I have a strong feeling that you would need to somehow also thread-safe the list of IDs, so perhaps an shared index counter would be needed instead of $stdout = scalar(#filehandles);
As an alternative to my other answer with global array, here's another approach from Perlmonks:
http://perlmonks.org/?node_id=395513
It works by actually storing fileno (file descriptor) of the filehandle. Here's his sample code based on what BrowserUk posted:
my $stdout; # Store the fileno, NOT filehandle.
# Should really be renamed "$stdout_fileno" instead.
sub stdout {
my $self = shift;
return $stdout if defined $stdout;
my $stdout_fh = $self->dup_filehandle(\*STDOUT); ### CHANGED
$stdout = fileno $stdout_fh; ### CHANGED
$self->autoflush($stdout_fh); ### CHANGED
$self->autoflush(\*STDOUT);
return $stdout;
}
sub safe_print {
my $self = shift;
my $fh_id = shift; ### CHANGED
open(my $fh, ">>&=$fh_id") ### CHANGED
|| die "Error opening filehandle: $fh_id: $!\n"; ### CHANGED
local( $\, $, ) = ( undef, '' );
print $fh #_;
}
CAVEAT - as of 2004, this had a bug where you couldn't read from the shared filehandle from >1 thread. I am guessing that writing is OK. More specifics on how to do synchronised writes on a shared filehandle (from the same Monk): http://www.perlmonks.org/?node_id=807540
It just occurred to me there's two possible solutions:
Put the filehandle outside the Streamer object.
Put the Streamer object outside the Formatter.
#DVK's suggestions are all about doing 1.
But 2 is in some ways simpler than 1. Instead of holding the Streamer object itself, the Formatter can hold an identifier to the Streamer object. If the Streamer is implemented inside-out, that happens naturally!
Unfortunately, reference addresses change between threads, even shared ones. This can be solved with Hash::Util::FieldHash, but that's a 5.10 thing and I have to support 5.8. It's possible something could be put together using CLONE.
Here's what I wound up with...
package ThreadSafeFilehandle;
use Mouse;
use Mouse::Util::TypeConstraints;
my %Filehandle_Storage; # unshared storage of filehandles
my $Storage_Counter = 1; # a counter to use as a key
# This "type" exists to intercept incoming filehandles.
# The filehandle goes into %Filehandle_Storage and the
# object gets the key.
subtype 'FilehandleKey' =>
as 'Int';
coerce 'FilehandleKey' =>
from 'Defined',
via {
my $key = $Storage_Counter++;
$Filehandle_Storage{$key} = $_;
return $key;
};
has thread_safe_fh =>
is => 'rw',
isa => 'FilehandleKey',
coerce => 1,
;
# This converts the stored key back into a filehandle upon getting.
around thread_safe_fh => sub {
my $orig = shift;
my $self = shift;
if( #_ ) { # setting
return $self->$orig(#_);
}
else { # getting
my $key = $self->$orig;
return $Filehandle_Storage{$key};
}
};
1;
Using type coercion ensures that the translation from filehandle to key happens even in the object constructor.
It works, but it has flaws:
Each object stores its filehandle redundantly. If a bunch of objects all store the same filehandle they could probably just store it once. The trick would be how to identify the same filehandle. fileno or the refaddr are options.
The filehandle is not removed from %Filehandle_Storage upon object deletion. I originally put in a DESTROY method to do so, but since the object cloning idiom is $clone = shared_clone($obj) $clone's filehandle is trashed once $obj goes out of scope.
Changes which occur in children are not shared.
These are all acceptable for my purposes which will only create a handful of these objects per process.
Then again, one could use https://metacpan.org/module/Coro if one did not have an allergic reaction to its trolldocs.
I am trying to take a Perl program I wrote and thread it. The problem is I read that some modules aren't "thread safe". How do I know if a module is thread safe? I've looked around for a list and cannot locate one.
To test out one module I use frequently (Text::CSV_XS) I tried the following code out:
use strict;
use warnings;
use threads;
use threads::shared;
require Text::CSV_XS;
my $CSV = Text::CSV_XS->new ({ binary => 1, eol => "\n" }) or die("Cannot use CSV: ".Text::CSV->error_diag());
open my $OUTPUT , ">:encoding(utf8)", "test.csv" or die("test.csv: $!");
share($CSV);
my $thr1 = threads->create(\&sayHello('1'));
my $thr2 = threads->create(\&sayHello('2'));
my $thr3 = threads->create(\&sayHello('3'));
sub sayHello
{
my($num) = #_;
print("Hello thread number: $num\n");
my #row = ($num);
lock($CSV);{
$CSV->print($OUTPUT, \#row);
$OUTPUT->autoflush(1);
}#lock
}#sayHello
The output I receive is the following:
Hello thread number: 1
Segmentation fault
Does this mean the module is not thread safe, or is it another problem?
Thanks
Generally speaking, core and high-visibility modules are thread-safe unless their documentation says otherwise.
That said, there are a few missteps in your post:
share($CSV)
This clears $CSV (a blessed hashref), just as documented in threads. Generally, you want to share() complex objects prior to initialization or, perhaps in this case, share() some dumb $lock variable between threads.
Since $CSV holds state for the underlying XS, this might lead to undefined behavior.
But this isn't your segfault.
threads->create(\&sayHello('1'));
You are mistakenly invoking sayHello(1) in the main thread and passing a reference to its return value to threads->create() as a (bogus) start routine.
You meant to say:
threads->create(\&sayHello, '1');
But this isn't your segfault.
(EDIT Just to clarify -- a bad start routine here doesn't risk a SEGV in any case. threads::create properly complains if an unrecognized subroutine name or non-CODE ref is passed in. In your case, however, you are segfaulting too quickly to reach this error handling.)
Encodings are not thread-safe.
Again as documented in encodings, the encoding module is not thread-safe.
Here's the smallest possible code I could get to reproduce your symptoms:
use threads;
open my $OUTPUT , ">:encoding(utf8)", "/dev/null" or die $!;
threads->create( sub {} )->join;
That's perl 5.12.1 with threads-1.77 on i686-linux-thread-multi, if you're interested. Drop the "utf8" magic, and it works just fine.
This is your segfault