I am using perl version 5.22 with cygwin. I am not able to figure out the problem in the following code. It looks like multi threading is not enable or something. When I ran the following code it just terminated without any message.
use warnings;
use threads;
sub threaded_task {
threads -> create(sub {
print "Starting thread\n";
sleep(2);
print "Ending thread\n";
});
}
while(1) {
threaded_task("arjun");
print "main thread\n";
sleep (2);
}
64 bit config :
32 bit config:
Related
I have a threaded application and would like to set timeouts for the threads. Peldoc for alarm suggests to use a eval-die pair and catch the ALRM signal. However, this fails with threads producing the error Alarm clock:
use strict; use warnings;
require threads;
require threads::shared;
my $t = threads->create( sub {
eval {
$SIG{ALRM} = sub { die "alarm\n" };
alarm 2;
main();
alarm 0;
};
if ($#){
die $# unless $# eq "alarm\n";
print "timed out\n";
}
}
);
my #r = $t->join;
print "done\n";
sub main {
sleep 3;
}
This post suggests that alarm is called without signal handler in the threads library. Another post is about this problem and answers suggest to use fork and waitpid, but I would really like to use threads. Another post claims to come up with a solution, but this still gives the Alarm clock error for me. I tried to catch Alarm clock in the if ($#), but no success. Any idea how I could make this work?
The whole idea of using alarm in threads is problematic.
Signals are sent to processes, not threads.
What if two threads want to use alarm?
You'll have to implement your own system. The following is an attempt at a general solution:
package Threads::Alarm;
use strict;
use warnings;
use threads;
use threads::shared;
use Exporter qw( import );
our #EXPORT_OK = qw( alarm thread_alarm );
# A list of "$time:$tid" strings sorted by ascending time.
my #alarms :shared;
sub thread_alarm {
my ($wait) = #_;
my $tid = threads->tid();
lock #alarms;
# Cancel existing alarm for this thread, if any.
for my $i (0..$#alarms) {
if ((split(/:/, $alarms[$i]))[1] == $tid) {
splice(#alarms, $i, 1);
last;
}
}
# Create an alarm
if ($wait) {
my $when = time() + $wait;
# A binary search would be better.
my $i;
for ($i=0; $i<#alarms; ++$i) {
last if $when < (split(/:/, $alarms[$i]))[0];
}
splice(#alarms, $i, 0, "$when:$tid");
}
# Notify others of change to #alarms.
cond_broadcast(#alarms);
}
{
no warnings 'once';
*alarm = \&thread_alarm;
}
threads->create(sub {
while (1) {
my $thread;
{
lock #alarms;
while (1) {
# Wait for an alarm request to come in.
cond_wait(#alarms) while !#alarms;
# Grab the soonest alarm.
my ($when, $tid) = split(/:/, $alarms[0]);
# Check if the thread still exists.
my $thread = threads->object($tid)
or last;
# Wait for the #alarms to change or for the alarm time.
last if !cond_timedwait(#alarms, $when);
}
# Before releasing the lock, remove the alarm we're about to raise.
shift(#alarms);
# Notify others of change to #alarms.
# Doesn't actually do anything at this time.
cond_broadcast(#alarms);
}
$thread->kill('ALRM') if $thread;
}
})->detach();
1;
Completely untested. Well, I made sure it compiles, but that's it.
Note that threads->kill doesn't send a real signal (since those are sent to processes, not threads), so the OS won't interrupt any operation (e.g. sleep, wait). Simple solution: Send a real signal to a handler that does nothing right after calling threads->kill. Maybe I should have written a solution that was based around the actual SIGALRM.
sub worker {
# Curse stuff
initscr();
cbreak();
noecho();
my $fh = FileHandle->new;
open $fh, q{-|},
"$myexe #pre_args make #after_args 2>&1"
or croak 'Cannot open';
process_output($fh);
my $err = close $fh;
endwin();
return;
}
sub process_output {
my ($fh) = #_;
while (my $line = <$fh>) {
#do stuff
}
}
ReadMode 3;
threads->create(\&worker);
while (threads->list(threads::running)) {
my $char = ReadKey -1, *STDIN;
if ($char) {
if ($char eq 'q') {
endwin();
kill('INT', $$);
threads->exit();
}
}
}
ReadMode 0;
foreach my $thr (threads->list) {
$thr->join();
When I press 'q':
Perl exited with active threads:
1 running and unjoined
0 finished and unjoined
0 running and detached
and then I did ps -fu myuserid
I saw that $myexe was still running
Q1) How can i force child process to exit? threads->exit() didnt seem to work
The most obvious problem with the sample program is that it is using multiple threads for the curses library. That won't work. (curses is not thread-safe). If you have to do this, keep all of the curses work in the same thread.
You call exit but don't detach or join the threads.
Stick:
foreach my $thr ( threads -> list() ) {
$thr -> join;
}
at the end, and your 'main' code will wait for your threads to (all) exit.
However - threads -> exit() is for exiting the current thread. See:
http://perldoc.perl.org/threads.html#EXITING-A-THREAD
In order to terminate another thread, you need something like threads -> kill. Either send a 'proper' kill signal, or use a signal handler for SIGUSR1 or similar.
I'd probably approach it a little differently though - define a shared variable:
my $done : shared;
And then test it within the while loop, so you've a normal execution flow rather than a mid flight kill.
Your kill ( INT, $$ ) is going to be killing your main process, and just drop the threads on the floor. That's not good style really.
So - to backtrack a bit - the problem you're having - I think - is because 'signals' in perl aren't what you're expecting them to be. Perl uses safe signals, which makes a blocking call (such as a read from a filehandle) block the signal.
http://perldoc.perl.org/perlipc.html#Deferred-Signals-%28Safe-Signals%29
So I wouldn't normally suggest using signals within threads are a good idea - they're a little erratic, which isn't good for program predictability.
You can 'throw' and 'catch' signals, by defining a signal handler within the thread:
$SIG{'USR1'} = sub { print "Caught USR1"; die };
And then 'call' it using:
$worker -> kill ( 'USR1' );
But in certain circumstances, that won't 'bail out' immediately in the way you expect.
For example - this will work:
#!/usr/bin/perl
use strict;
use warnings;
use threads;
sub worker {
print Dumper \%SIG;
my $tail_pid = open ( my $tail_proc, "-|", "tail -f /var/log/messages" );
$SIG{'USR1'} = sub { print "Caught USR1\nKilling $tail_pid"; kill ( 'TERM', $tail_pid ); die; threads -> exit() };
print "Pre-loop\n";
while ( 1 ) {
print "Thread processing\n";
sleep 1;
}
print "Done";
return;
}
my $worker = threads -> create ( \&worker );
sleep 2;
print "Sending kill\n";
$worker -> kill ( 'SIGUSR1' );
sleep 2;
print "waiting for join\n";
$worker -> join();
But if your while loop is reading from the file handle - it's a blocking call, so the 'kill' will be held until the block lifts.
E.g.
while ( <$tail_proc> ) {
Will go into a block pending IO, and your thread won't 'get' the signal until IO occurs, and the thread continues processing. That might be sufficient for your needs though. Otherwise you're potentially looking at select or IO::Select to test if the handle is readable.
So what you may want to do instead is just kill the process that's 'feeding' your while loop - because by doing so, it'll unblock and the while will become undef and exit.
E.g.:
#!/usr/bin/perl
use strict;
use warnings;
use threads;
use threads::shared;
my $kill_pid : shared;
sub worker {
$kill_pid = open ( my $tail_proc, "-|", "tail -f /var/log/messages" );
print "Pre-loop\n";
while ( <$tail_proc> ) {
print "Thread processing\n";
print;
sleep 1;
}
print "Done";
return;
}
my $worker = threads -> create ( \&worker );
sleep 2;
print "Sending kill\n";
if ( defined $kill_pid ) { print "killing tail, $kill_pid\n"; kill ( 'TERM', $kill_pid ); };
sleep 2;
print "waiting for join\n";
$worker -> join();
Well I'm new to programming Perl (or any language in general)
I have basic understandings of the language and have written a small script that runs multiple forked threads of my processes here's a snippet of the script.
use Perl6::Slurp;
use Parallel::ForkManager;
my $pm = Parallel::ForkManager->new(10);
my $time = 100;
alarm("$time");
for my $i (0 .. 100) {
my $pid = $pm->start and next;
job();
$pm->finish;
}
$pm->wait_all_children;
sub job {
print "Function Started On Thread";
}
Now, that's not my actual code. but its pretty much a summary of what it is without the function
I would like it to end when the alarm ends.
Now i don't know if this is a simple action, but as i said im really new to programming in general.
Thanks for anyone that helps!
Send a signal to the process group. Just add the following to the parent:
local $SIG{ALRM} = {
local $SIG{TERM} = 'IGNORE';
kill TERM => -$$;
die "Timed out\n";
};
I have a process that must create and close threads on demand.
Each thread forks a new process using open2. Sometimes after executing the program for a long time open2 fails to fork the process sometimes and gives a "Can not allocate memory error", sometimes this happens for threads too.I know that the Linux has soft and hard limits but the number of the concurrent threads and processes for my server does not exceed those values.
Is there something like a counter for number of processes and threads that eliminates thread and process creation after sometime?
If it is so how servers like Postgres work for a long period of time?
The project has multiple processes that communicate using TCP, but the part that causes the error that i described in a frond end to mplayer, that is written in Perl. The code is as follows:
use strict;
use warnings;
use IO::Socket::INET;
use IO::Select;
use POSIX ":sys_wait_h";
use IPC::Open2;
use 5.010;
use Config;
BEGIN
{
if(!$Config{useithreads})
{
die "Your perl does not compiled with threading support.";
}
}
use threads;
use threads::shared;
use constant
{
SERVER_PORT=>5000,
#Remote request packet fields
PACKET_REQTYPE=>0,
PACKET_FILENAM=>1,
PACKET_VOLMLVL=>2,
PACKET_ENDPOSI=>3,
PACKET_SEEKPOS=>4,
#our request typs
PLAY_REQUEST=>1,
STOP_REQUEST=>2,
INFO_REQUEST=>3,
VOCH_REQUEST=>4,
PAUS_REQUEST=>5,
PLPA_REQUEST=>6,
SEEK_REQUEST=>7,
#Play states
STATE_PAUS=>0,
STATE_PLAY=>1,
STATE_STOP=>2,
};
#The following line must be added because of a bad behavior in the perl thread library that causes a SIGPIPE to be generated under heavy usage of the threads.
$SIG{PIPE} = 'IGNORE';
#This variable holds the server socket object
my $server_socket;
#This array is used to hold objects of our all threads
my #thread_objects;
#create the server socket
$server_socket=IO::Socket::INET->new(LocalPort=>SERVER_PORT,Listen=>20,Proto=>'tcp',Reuse=>1) or
die "Creating socket error ($#)";
#Now try to accept remote connections
print "Server socket created successfully now try to accept remote connections on port: ".SERVER_PORT."\n";
while(my $client_connection=$server_socket->accept())
{
push #thread_objects,threads->create(\&player_thread,$client_connection);
$thread_objects[$#thread_objects]->detach();
}
#This subroutine is used to play something using tcp-based commands
sub player_thread
{
my $client_socket=shift;
#create a new select object
my $selector=IO::Select->new($client_socket);
#this variabe is used to pars our request
my #remote_request;
#getting th thread id of the current thread
my $tid=threads->self()->tid;
#This variable is used to hold the pid of mplayer child
my $mp_pid=-1;
#Mplayer stdin and stdout file descriptors
my ($MP_STDIN,$MP_STDOUT);
#This variable is used to check if we are playing something now or not
my $is_playing=STATE_STOP;
print "Client thread $tid created.\n";
while(1)
{
#check to see if we can read anything from our handler
#print "Before select\n";
#my #ready=$selector->can_read();
#print "After select: #ready\n";
#now the data is ready for reading so we read it here
my $data=<$client_socket>;
#This means if the connection is closed by the remote end
if(!defined($data))
{
print "Remote connection has been closed in thread $tid mplayer id is: $mp_pid and state is: $is_playing.\n";
#if we have an mplayer child when remote connection is closed we must wait for it
#so that is work is done
if($mp_pid!=-1 and $is_playing ==STATE_PLAY)
{
waitpid $mp_pid,0;
$is_playing=STATE_STOP;
}
elsif($is_playing==STATE_PAUS and $mp_pid!=-1)
{
print "thread $tid is in the paused state, we must kill mplayer.\n";
print $MP_STDIN "quit\n";
waitpid $mp_pid,0;
$is_playing=STATE_STOP;
}
last;
}#if
#FIXME:: Here we must validate our argument
#Now we try to execute the command
chomp($data);
#remote_request=split ",",$data;
print "#remote_request\n";
#Trying to reap the death child and change the state of the thread
my $dead_child=-1;
$dead_child=&reaper($mp_pid);
if($dead_child)
{
$is_playing=STATE_STOP;
$mp_pid=-1;
}
given($remote_request[PACKET_REQTYPE])
{
when($_==PLAY_REQUEST)
{
print "Play request\n";
if($is_playing==STATE_STOP)
{
eval{$mp_pid=open2($MP_STDOUT,$MP_STDIN,"mplayer -slave -really-quiet -softvol -volume ".$remote_request[PACKET_VOLMLVL]." -endpos ".$remote_request[PACKET_ENDPOSI]." ./".$remote_request[PACKET_FILENAM]);};
print "Some error occurred in open2 system call: $#\n" if $#;
$is_playing=STATE_PLAY;
print "Mplayer pid: $mp_pid.\n";
}
}
when($_==STOP_REQUEST)
{
print "Stop request\n";
if($is_playing != STATE_STOP)
{
print $MP_STDIN "pausing_keep stop\n";
#FIXME:: Maybe we should use WNOHANG here
my $id=waitpid $mp_pid,0;
print "Mplayer($id) stopped.\n";
$is_playing=STATE_STOP;
$mp_pid=-1;
}
}
when($_==PAUS_REQUEST)
{
print "pause request\n";
if($is_playing !=STATE_STOP)
{
print $MP_STDIN "pausing_keep pause\n";
$is_playing=STATE_PAUS;
}
}
when($_==VOCH_REQUEST)
{
print "volume change request\n";
if($is_playing !=STATE_STOP)
{
print $MP_STDIN "pausing_keep volume ".$remote_request[PACKET_VOLMLVL]." 1\n";
}
}
when($_==INFO_REQUEST)
{
my $id;
$id=&reaper($mp_pid);
if($id > 0)
{
print "Mplayer($id) stopped.\n";
$is_playing=STATE_STOP;
$mp_pid=-1;
}
given($is_playing)
{
when($_==STATE_STOP)
{
print $client_socket "Stopped\n";
}
when($_==STATE_PAUS)
{
print $client_socket "Paused\n";
}
when($_==STATE_PLAY)
{
print $client_socket "Playing\n";
}
}
}
when ($_==PLPA_REQUEST)
{
print "play paused request\n";
if($is_playing==STATE_STOP)
{
eval{$mp_pid=open2($MP_STDOUT,$MP_STDIN,"mplayer -slave -really-quiet -softvol -volume ".$remote_request[PACKET_VOLMLVL]." -endpos ".$remote_request[PACKET_ENDPOSI]." ./".$remote_request[PACKET_FILENAM]);};
print "Some error occurred in open2 system call: $#\n" if $#;
print $MP_STDIN "pausing_keep pause\n";
$is_playing=STATE_PAUS;
}
}
when ($_==SEEK_REQUEST)
{
print "Seek request\n";
if($is_playing != STATE_STOP)
{
my $seek_pos=abs $remote_request[PACKET_SEEKPOS];
print $MP_STDIN "seek $seek_pos 2\n";
$is_playing=STATE_PLAY;
}
}
default
{
warn "Invalid request($_)!!!";
next;
}
}#Given
}#while
$client_socket->close();
print "Thread $tid is exiting now, the child mplayer pid is: $mp_pid and state is: $is_playing.\n";
}
#The following subroutine takes a pid and if that pid is grater than 0 it tries to reap it
#if it is successful returns pid of the reaped process else 0
sub reaper
{
my $pid=shift;
if($pid > 0)
{
my $id=waitpid($pid,WNOHANG);
if($id > 0)
{
return $id;
}
}
return 0;
}
"Can not allocate memory error" is what it says, either the user exceeded its memory quota (check with ulimit -m, compare to ps ux) or you're really out of memory (free).
The limits for max user processes are only indirectly connected - if you fork() more processes then the user's memory quota permits, fork() will fail with ENOMEM.
You also might want to see:
What are some conditions that may cause fork() or system() calls to fail on Linux?
I finally found the problem, it is because of a memory leak in the Perl's thread module that causes the memory to grow after a long time. Then open2 can not allocate memory and fails.
Is there any way to get alarm (or some other timeout mechanism) working in perl (>=5.012) threads?
Run alarm in your main thread, with a signal handler that signals your active threads.
use threads;
$t1 = threads->create( \&thread_that_might_hang );
$t2 = threads->create( \&thread_that_might_hang );
$SIG{ALRM} = sub {
if ($t1->is_running) { $t1->kill('ALRM'); }
if ($t2->is_running) { $t2->kill('ALRM'); }
};
alarm 60;
# $t1->join; $t2->join;
sleep 1 until $t1->is_joinable; $t1->join;
sleep 1 until $t2->is_joinable; $t2->join;
...
sub thread_that_might_hang {
$SIG{ALRM} = sub {
print threads->self->tid(), " got SIGALRM. Good bye.\n";
threads->exit(1);
};
... do something that might hang ...
}
If you need different alarms for each thread, look into a module that allows you to set multiple alarms like Alarm::Concurrent.
Edit: commentors point out threads::join interferes with SIGALRM, so you may need to test $thr->is_joinable rather than calling $thr->join