I'm trying to understand the working of thread:wait from the below code
set logger [thread::create {
proc OpenLog {file} {
global fid
set fid [open $file a]
} proc CloseLog {} {
global fid
close $fid
} proc AddLog {
msg} {
global fid
puts $fid $msg
} thread::wait
}]
% ::thread::exists $logger
0
Why the above code does not wait for even and exit on the spot?
The problem is that your thread-creation script has some syntax errors in it, making it fail to start up correctly; it dies asynchronously and prints an error message. That error seems to be going missing in your case; no idea why, but it ought to read something like:
Error from thread tid0x100481000
wrong # args: should be "proc name args body"
while executing
"proc OpenLog {file} {
global fid
set fid [open $file a]
} proc CloseLog {} {
global fid
close $fid
} proc AddLog {
msg} {
global fid..."
If we correct the obvious syntax problems, converting spaces to newlines where it matters, then we can get this which appears to work for me:
set logger [thread::create {
proc OpenLog {file} {
global fid
set fid [open $file a]
}
proc CloseLog {} {
global fid
close $fid
}
proc AddLog {msg} {
global fid
puts $fid $msg
}
thread::wait
}]
The only differences are to whitespace. Tcl cares about whitespace. Get it right.
Related
In Perl 6 the Str type is immutable, so it seems reasonable to use a mutable buffer instead of concatenating a lot of strings. Next, I like being able to use the same API regardless if my function is writing to stdout, file or to an in-memory buffer.
In Perl, I can create an in-memory file like so
my $var = "";
open my $fh, '>', \$var;
print $fh "asdf";
close $fh;
print $var; # asdf
How do I achieve the same thing in Perl 6?
There's a minimal IO::String in the ecosystem backed by an array.
For a one-off solution, you could also do someting like
my $string;
my $handle = IO::Handle.new but role {
method print(*#stuff) { $string ~= #stuff.join };
method print-nl { $string ~= "\n" }
};
$handle.say("The answer you're looking for is 42.");
dd $string;
What I currently do is that I wrapped string concatenation in a class as a temporary solution.
class Buffer {
has $!buf = "";
multi method print($string) {
$!buf ~= $string;
}
multi method say($string) {
$!buf ~= $string ~ "\n";
}
multi method Str() {
return $!buf;
}
}
With that, I can do
my $buf = Buffer.new();
say $buf: "asdf";
print $buf.Str;
I currently have a script that kicks off threads to perform various actions on several directories. A snippet of my script is:
#main
sub BuildInit {
my $actionStr = "";
my $compStr = "";
my #component_dirs;
my #compToBeBuilt;
foreach my $comp (#compList) {
#component_dirs = GetDirs($comp); #populates #component_dirs
}
print "Printing Action List: #actionList\n";
#---------------------------------------
#---- Setup Worker Threads ----------
for ( 1 .. NUM_WORKERS ) {
async {
while ( defined( my $job = $q->dequeue() ) ) {
worker($job);
}
};
}
#-----------------------------------
#---- Enqueue The Work ----------
for my $action (#actionList) {
my $sem = Thread::Semaphore->new(0);
$q->enqueue( [ $_, $action, $sem ] ) for #component_dirs;
$sem->down( scalar #component_dirs );
print "\n------>> Waiting for prior actions to finish up... <<------\n";
}
# Nothing more to do - notify the Queue that we're not adding anything else
$q->end();
$_->join() for threads->list();
return 0;
}
#worker
sub worker {
my ($job) = #_;
my ( $component, $action, $sem ) = #$job;
Build( $component, $action );
$sem->up();
}
#builder method
sub Build {
my ( $comp, $action ) = #_;
my $cmd = "$MAKE $MAKE_INVOCATION_PATH/$comp ";
my $retCode = -1;
given ($action) {
when ("depend") { $cmd .= "$action >nul 2>&1" } #suppress output
when ("clean") { $cmd .= $action }
when ("build") { $cmd .= 'l1' }
when ("link") { $cmd .= '' } #add nothing; default is to link
default { die "Action: $action is unknown to me." }
}
print "\n\t\t*** Performing Action: \'$cmd\' on $comp ***" if $verbose;
if ( $action eq "link" ) {
# hack around potential race conditions -- will only be an issue during linking
my $tries = 1;
until ( $retCode == 0 or $tries == 0 ) {
last if ( $retCode = system($cmd) ) == 2; #compile error; stop trying
$tries--;
}
}
else {
$retCode = system($cmd);
}
push( #retCodes, ( $retCode >> 8 ) );
#testing
if ( $retCode != 0 ) {
print "\n\t\t*** ERROR IN $comp: $# !! ***\n";
print "\t\t*** Action: $cmd -->> Error Level: " . ( $retCode >> 8 ) . "\n";
#exit(-1);
}
return $retCode;
}
The print statement I'd like to be thread-safe is: print "\n\t\t*** Performing Action: \'$cmd\' on $comp ***" if $verbose; Ideally, I would like to have this output, and then each component that is having the $action performed on it, would output in related chunks. However, this obviously doesn't work right now - the output is interleaved for the most part, with each thread spitting out it's own information.
E.g.,:
ComponentAFile1.cpp
ComponentAFile2.cpp
ComponentAFile3.cpp
ComponentBFile1.cpp
ComponentCFile1.cpp
ComponentBFile2.cpp
ComponentCFile2.cpp
ComponentCFile3.cpp
... etc.
I considered executing the system commands using backticks, and capturing all of the output in a big string or something, then output it all at once, when the thread terminates. But the issue with this is (a) it seems super inefficient, and (b) I need to capture stderr.
Can anyone see a way to keep my output for each thread separate?
clarification:
My desired output would be:
ComponentAFile1.cpp
ComponentAFile2.cpp
ComponentAFile3.cpp
------------------- #some separator
ComponentBFile1.cpp
ComponentBFile2.cpp
------------------- #some separator
ComponentCFile1.cpp
ComponentCFile2.cpp
ComponentCFile3.cpp
... etc.
To ensure your output isn't interrupted, access to STDOUT and STDERR must be mutually exclusive. That means that between the time a thread starts printing and finishes printing, no other thread can be allowed to print. This can be done using Thread::Semaphore[1].
Capturing the output and printing it all at once allows you to reduce the amount of time a thread holds a lock. If you don't do that, you'll effectively make your system single-threaded system as each thread attempts lock STDOUT and STDERR while one thread runs.
Other options include:
Using a different output file for each thread.
Prepending a job id to each line of output so the output can be sorted later.
In both of those cases, you only need to lock it for a very short time span.
# Once
my $mutex = Thread::Semaphore->new(); # Shared by all threads.
# When you want to print.
$mutex->down();
print ...;
STDOUT->flush();
STDERR->flush();
$mutex->up();
or
# Once
my $mutex = Thread::Semaphore->new(); # Shared by all threads.
STDOUT->autoflush();
STDERR->autoflush();
# When you want to print.
$mutex->down();
print ...;
$mutex->up();
You can utilize the blocking behavior of $sem->down if it attempts to decrease the semaphore counter below zero, as mentioned in perldoc perlthrtut:
If down() attempts to decrement the counter below zero, it blocks
until the counter is large enough.
So here's what one could do:
Initialize a semaphore with counter 1 that is shared across all threads
my $sem = Thread::Semaphore->new( 1 );
Pass a thread counter to worker and Build
for my $thr_counter ( 1 .. NUM_WORKERS ) {
async {
while ( defined( my $job = $q->dequeue() ) ) {
worker( $job, $thr_counter );
}
};
}
sub worker {
my ( $job, $counter ) = #_;
Build( $component, $action, $counter );
}
Go ->down and ->up inside Build (and nowhere else)
sub Build {
my ( $comp, $action, $counter ) = #_;
... # Execute all concurrently-executed code here
$sem->down( 1 << ( $counter -1 ) );
print "\n\t\t*** Performing Action: \'$cmd\' on $comp ***" if $verbose;
# Execute all sequential 'chunks' here
$sem->up( 1 << ( $counter - 1) );
}
By using the thread counter to left-shift the semaphore counter, it guarantees that the threads won't trample on one another:
+-----------+---+---+---+---+
| Thread | 1 | 2 | 3 | 4 |
+-----------+---+---+---+---+
| Semaphore | 1 | 2 | 4 | 8 |
+-----------+---+---+---+---+
I've approached this problem differently in the past, by creating an IO thread, and using that to serialise the file access.
E.g.
my $output_q = Thread::Queue -> new();
sub writer {
open ( my $output_fh, ">", $output_filename );
while ( my $line = $output_q -> dequeue() ) {
print {$output_fh} $line;
}
close ( $output_fh );
}
And within threads, 'print' by:
$output_q -> enqueue ( "text_to_print\n"; );
Either with or without a wrapper - e.g. for timestamping statements if they're going to a log. (You probably want to timestamp when queued, rather than when actually printer).
i am new in threads and this is what i do :
my $thread_fifo = threads->create(sub {Plugins::Fifo->run($conf, $products, $workfifo)});
my $thread_liberty = threads->create(sub {Plugins::Fifo->run($conf, $products, $workliberty)});
and then : $thread_fifo->join(); $thread_liberty->join();
here is the Error message :
Thread 1 terminated abnormally: Can't call method "getChildrenByTagNameNS" on unblessed reference at C:/strawberry/perl/site/lib/XML/Atom/Util.pm line 61.
To see what is $thread_fifo I use ref and Dumper :
print ref($thread_fifo); # output : threads
print Dumper($thread_fifo); #output : $VAR1 = bless( do{\(my $o = '78589096')}, 'threads' );
I know an unblessed reference error is where one variable is not a legal reference to an object, but yet trying to call a function on it as if it was a legal object, however i don't see where is the problem here, all i am trying to do is call two functions simultaneously.
Thanks in advance.
Not a full solution, but should be enough to see whats going on
threads->create(\&foobar,$products,$workfifo,'info');
threads->create(\&foobar,$products,$workliberty,'liberty');
# Master Thread
my #threads = threads->list();
for(my $i=0; $i<scalar(#threads); ++$i) {
print STDERR "MASTER: about to join thread $i\n";
my $thread = $threads[$i];
eval {
$thread->join();
};
if($#) {
print STDERR "Caught error while joining thread $i ($#)\n";
}
else {
print STDERR "MASTER: finished joining thread $i\n";
}
}
#threads = threads->list();
print STDERR "I GOT " . scalar(#threads) . ", NOW EXITING\n";
exit;
# Child threads
sub foobar {
my ($products,$work,$str) = #_;
print STDERR "CHILD $str: STARTING\n";
Plugins::Fifo->run($conf, $products, $work);
print STDERR "CHILD $str: ENDING\n";
}
I have a Perl subroutine that creates a file, like so:
sub createFile {
if (open (OUTFILEHANDLE, ">$fileName")) {
print OUTFILEHANDLE "$desiredVariable\n";
}
close(OUTFILEHANDLE);
}
where $fileName and $desiredVariable have been previously defined. I call that, and then call the following subroutine, which reads from the file, takes the first (only) line, and saves it into the variable $desiredVariable:
sub getInfoFromFile {
if (existFile($fileName)) {
if (open (READFILEHANDLE, "<$fileName")) {
my #entire_file=<READFILEHANDLE>; # Slurp
$desiredVariable = $entire_file[0];
chop $desiredVariable;
close(READFILEHANDLE);
}
}
}
If I leave out the "chop" line, $desiredVariable is what I want, but with a trailing space newline. If I include the "chop" line, $desiredVariable is an empty string. For some reason, "chop" is killing the whole string. I've tried it with $desiredVariable =~ s/\s*$//; and several other string manipulation tricks.
What am I doing wrong?
The code you included does not reproduce the problem. I'm guessing it was lost in translation somehow while you were anonymizing it. I ran the script as follows, the only adjustment I made was -f instead of existsFile().
#!/usr/bin/perl
sub createFile {
if (open (OUTFILEHANDLE, ">$fileName")) {
print OUTFILEHANDLE "$desiredVariable\n";
}
close(OUTFILEHANDLE);
}
sub getInfoFromFile {
if (-f $fileName) {
if (open (READFILEHANDLE, "<$fileName")) {
my #entire_file=<READFILEHANDLE>; # Slurp
$desiredVariable = $entire_file[0];
chop $desiredVariable;
close(READFILEHANDLE);
}
}
}
$fileName = "test.txt";
$desiredVariable = "Hello World!";
createFile();
$desiredVariable = "";
getInfoFromFile();
print "Got '$desiredVariable'\n"; # Got 'Hello World!'
i am using this code its working fine when i am running it from root but when i set root priviledges to it throws up an error saying "insecure $ENV{PATH} at line system "perl $qtool -d $mqueue_directory*$queue_id";"
my script is in path /scripts/deferred.pl
#!/usr/bin/perl
use strict;
my $qtool = "/usr/local/bin/qtool.pl";
my $mqueue_directory = "/var/spool/mqueue";
my $messages_removed = 0;
my #rf_id;
my #date;
my $temp
my #write_array;
my $to;
my $from;
use Untaint;
use File::Find;
# Recursively find all files and directories in $mqueue_directory
use Untaint;
find(\&wanted, $mqueue_directory);
sub wanted {
# Is this a qf* file?
if ( /^qf(\w{14})/ ) {
my $qf_file = $_;
my $queue_id = $1;
my $deferred = 0;
my $from_postmaster = 0;
my $delivery_failure = 0;
my $junk_mail = 0;
open (QF_FILE, $_);
while(<QF_FILE>) {
$deferred = 1 if ( /^MTemporarily/ | /^Mhost map: lookup/ | /^MUser unknown/ );
$delivery_failure = 1 if \
( /^H\?\?Subject: DELIVERY FAILURE: (User|Recipient)/ );
if ( $deferred && $from_postmaster && $delivery_failure ) {
$junk_mail = 1;
}
$temp=$qf_file.':';
if($junk_mail){
while(<QF_FILE>){
chomp;
if(/rRFC822;/){
$temp.=subdtr($_,9)
}
if(/H?D?Date:/){
$temp.=':'.substr($_,10);
push #write_array, $temp."\n";
}
}
}
}
close (QF_FILE);
my $subqueue_id = substr($queue_id,9);
if ($junk_mail) {
print "Removing $queue_id...\n";
system "perl $qtool -d $mqueue_directory*$queue_id";
$messages_removed++;
}
}
}
open (MYFILE,">/scripts/mail.txt");
print MYFILE "#write_array";
close (MYFILE);
$to='yagya#mydomain.in';
$from='system#mydomain.in';
$subject='deleted mails';
open(MAIL,"|/usr/sbin/sendmail -t");
print MAIL "To: $to\n";
print MAIL "From: $from\n";
print MAIL "Subject: $subject\n\n";
print MAIL "#write_array\n";
close(MAIL);
print "\n$messages_removed total \"double bounce\" message(s) removed from ";
print "mail queue.\n";
Setuid programs automatically run in taint mode. It's all explained in perlsec, including the text in your error message. Often, if you paste the error message into a search engine, you'll quickly find out what to do about it. You might also see Insecure $ENV{ENV} while running with -T switch.