liunx has asked for the wisdom of the Perl Monks concerning the following question:

hello, in my perl program, i need a thread to generate a alarm signal with alarm(), and the main thread accept the signal and do something, but when i try my idea, then the program crashed. here are the code

use strict;
use warnings;

use IO::Socket::INET;
use Time::Piece;
use Time::HiRes qw(sleep);
use DBI;
use POSIX qw(:signal_h);
use threads;

######################################################################
+##########
# global variable
######################################################################
+##########
my $shost = '192.168.0.201';
my $sport = 60004;

my $mhost    = '192.168.0.201';
my $dbname   = 'enterprise';
my $dbuser   = 'root';
my $dbpasswd = '123456';

# send message
sub send_message {

    # get message
    my $message = shift;

    #    print $message, "\n";

    # connect the remote server
    my $sock = IO::Socket::INET->new(
        PeerAddr => $shost,
        PeerPort => $sport,
        Proto    => 'tcp'
    ) or die "Connect failed!";

    print $sock $message;

}

sub get_message {

    # connect the mysql
    my $dbh = DBI->connect( "DBI:mysql:database=$dbname;host=$mhost",
        $dbuser, $dbpasswd, { PrintError => 0, RaiseError => 1 } );

    # execute SELECT query
    my $sth = $dbh->prepare("SELECT IMEI FROM SessionIMEI");
    $sth->execute();

    # iterate through resultset
    # print values
    my @elements;

    while ( my $ref = $sth->fetchrow_hashref() ) {
        push( @elements, $ref->{IMEI} );
    }

    my $buf = '$0';

    for my $ref (@elements) {
        $buf .= ",$ref";
    }

    # add the tail
    $buf .= "@\r\n";

    #    print $buf;

    # clean up
    $dbh->disconnect();

    # return the message
    return $buf;

}

######################################################################
+#####
# signal handler
######################################################################
+#####
my $sigset = POSIX::SigSet->new;

my $signal = undef;

# we use SIGUSR1 as the target signal
$sigset->delset(&POSIX::SIGUSR1);
$sigset->delset(&POSIX::SIGINT);
$sigset->delset(&POSIX::SIGALRM);

my $old_sigset = POSIX::SigSet->new;

# load the signal handler
sub user_handler {
    print "Get a user defined signal.\n";
    $signal = shift;
}

sub int_handler {
    print "Get a interrupt signal.\n";
    $signal = shift;

    print $signal, "\n";
}

sub alarm_handler {
    print "Get a alarm signal.\n";
    $signal = shift;
}

$SIG{USR1} = \&user_handler;
$SIG{INT}  = \&int_handler;
$SIG{ALRM} = \&alarm_handler;

# define the signals to block
# where the old sigmask will be kept
unless ( defined sigprocmask( SIG_BLOCK, $sigset, $old_sigset ) ) {
    die "Could not block SIGINT\n";
}

# suspend until a specific signal come to process.
sub sig_process {
    sigsuspend($sigset);

    my $message = undef;
    if ( $signal eq 'INT' ) {
        $message = get_message();
        send_message($message);

    }

}

######################################################################
+#####
# create threads
######################################################################
+#####
sub create_alarm {
    my $thr = threads->create( \&alarm_thread );
    $thr->detach();

}

sub alarm_thread {
    alarm(10);
}

######################################################################
+#####
# main
######################################################################
+#####
create_alarm();
sig_process();

[download]

when i run this code, i got a crash, below: Get a alarm signal. *** glibc detected *** /usr/bin/perl: double free or corruption (!prev): 0x0000000000834b80 *** ======= Backtrace: ========= /lib/x86_64-linux-gnu/libc.so.6(+0x78a8f)0x7fcecaac2a8f /lib/x86_64-linux-gnu/libc.so.6(cfree+0x73)0x7fcecaac68e3 /usr/lib/perl/5.10/auto/POSIX/POSIX.so(XS_POSIX__SigSet_DESTROY+0xaf)0x7fcec92df60f /usr/lib/libperl.so.5.10(Perl_pp_entersub+0x585)0x7fcecb531265 /usr/lib/libperl.so.5.10(Perl_call_sv+0x676)0x7fcecb4ceee6 /usr/lib/libperl.so.5.10(Perl_sv_clear+0xa6)0x7fcecb538a46 /usr/lib/libperl.so.5.10(Perl_sv_free2+0x52)0x7fcecb539212 /usr/lib/libperl.so.5.10(Perl_leave_scope+0xe15)0x7fcecb55b5f5 /usr/lib/libperl.so.5.10(Perl_pp_leave+0x106)0x7fcecb52e4e6 /usr/lib/libperl.so.5.10(Perl_runops_standard+0x20)0x7fcecb528cd0 /usr/lib/libperl.so.5.10(perl_run+0x35e)0x7fcecb4d45fe /usr/bin/perl(main+0xec)0x400ccc /lib/x86_64-linux-gnu/libc.so.6(__libc_start_main+0xff)0x7fcecaa68eff /usr/bin/perl0x400af9 ======= Memory map: ======== 00400000-00401000 r-xp 00000000 08:06 919130 /usr/bin/perl 00601000-00602000 r--p 00001000 08:06 919130 /usr/bin/perl 00602000-00603000 rw-p 00002000 08:06 919130 /usr/bin/perl 0080c000-0101c000 rw-p 00000000 00:00 0 heap 7fcec4000000-7fcec4021000 rw-p 00000000 00:00 0 7fcec4021000-7fcec8000000 ---p 00000000 00:00 0 7fcec86b2000-7fcec86c7000 r-xp 00000000 08:02 919912 /lib/x86_64-linux-gnu/libgcc_s.so.1 7fcec86c7000-7fcec88c6000 ---p 00015000 08:02 919912 /lib/x86_64-linux-gnu/libgcc_s.so.1 7fcec88c6000-7fcec88c7000 r--p 00014000 08:02 919912 /lib/x86_64-linux-gnu/libgcc_s.so.1 7fcec88c7000-7fcec88c8000 rw-p 00015000 08:02 919912 /lib/x86_64-linux-gnu/libgcc_s.so.1 7fcec88c8000-7fcec88c9000 ---p 00000000 00:00 0 7fcec88c9000-7fcec90c9000 rw-p 00000000 00:00 0 7fcec90c9000-7fcec90d3000 r-xp 00000000 08:06 145381 /usr/lib/perl/5.10.1/auto/threads/threads.so 7fcec90d3000-7fcec92d3000 ---p 0000a000 08:06 145381 /usr/lib/perl/5.10.1/auto/threads/threads.so 7fcec92d3000-7fcec92d4000 r--p 0000a000 08:06 145381 /usr/lib/perl/5.10.1/auto/threads/threads.so 7fcec92d4000-7fcec92d5000 rw-p 0000b000 08:06 145381 /usr/lib/perl/5.10.1/auto/threads/threads.so 7fcec92d5000-7fcec92f0000 r-xp 00000000 08:06 135961 /usr/lib/perl/5.10.1/auto/POSIX/POSIX.so 7fcec92f0000-7fcec94ef000 ---p 0001b000 08:06 135961 /usr/lib/perl/5.10.1/auto/POSIX/POSIX.so 7fcec94ef000-7fcec94f2000 r--p 0001a000 08:06 135961 /usr/lib/perl/5.10.1/auto/POSIX/POSIX.so 7fcec94f2000-7fcec94f3000 rw-p 0001d000 08:06 135961 /usr/lib/perl/5.10.1/auto/POSIX/POSIX.so 7fcec94f3000-7fcec94f6000 r-xp 00000000 08:06 135956 /usr/lib/perl/5.10.1/auto/Fcntl/Fcntl.so 7fcec94f6000-7fcec96f6000 ---p 00003000 08:06 135956 /usr/lib/perl/5.10.1/auto/Fcntl/Fcntl.so 7fcec96f6000-7fcec96f7000 r--p 00003000 08:06 135956 /usr/lib/perl/5.10.1/auto/Fcntl/Fcntl.so 7fcec96f7000-7fcec96f8000 rw-p 00004000 08:06 135956 /usr/lib/perl/5.10.1/auto/Fcntl/Fcntl.so 7fcec96f8000-7fcec9701000 r-xp 00000000 08:06 135960 /usr/lib/perl/5.10.1/auto/List/Util/Util.so 7fcec9701000-7fcec9900000 ---p 00009000 08:06 135960 /usr/lib/perl/5.10.1/auto/List/Util/Util.so 7fcec9900000-7fcec9901000 r--p 00008000 08:06 135960 /usr/lib/perl/5.10.1/auto/List/Util/Util.so 7fcec9901000-7fcec9902000 rw-p 00009000 08:06 135960 /usr/lib/perl/5.10.1/auto/List/Util/Util.so 7fcec9902000-7fcec9923000 r-xp 00000000 08:06 142689 /usr/lib/perl5/auto/DBI/DBI.so 7fcec9923000-7fcec9b22000 ---p 00021000 08:06 142689 /usr/lib/perl5/auto/DBI/DBI.so 7fcec9b22000-7fcec9b23000 r--p 00020000 08:06 142689 /usr/lib/perl5/auto/DBI/DBI.so 7fcec9b23000-7fcec9b24000 rw-p 00021000 08:06 142689 /usr/lib/perl5/auto/DBI/DBI.so 7fcec9b24000-7fcec9b2b000 r-xp 00000000 08:02 920674 /lib/x86_64-linux-gnu/librt-2.13.so 7fcec9b2b000-7fcec9d2a000 ---p 00007000 08:02 920674 /lib/x86_64-linux-gnu/librt-2.13.so 7fcec9d2a000-7fcec9d2b000 r--p 00006000 08:02 920674 /lib/x86_64-linux-gnu/librt-2.13.so 7fcec9d2b000-7fcec9d2c000 rw-p 00007000 08:02 920674 /lib/x86_64-linux-gnu/librt-2.13.so 7fcec9d2c000-7fcec9d32000 r-xp 00000000 08:06 145314 /usr/lib/perl/5.10.1/auto/Time/HiRes/HiRes.so 7fcec9d32000-7fcec9f31000 ---p 00006000 08:06 145314 /usr/lib/perl/5.10.1/auto/Time/HiRes/HiRes.so 7fcec9f31000-7fcec9f32000 r--p 00005000 08:06 145314 /usr/lib/perl/5.10.1/auto/Time/HiRes/HiRes.so 7fcec9f32000-7fcec9f33000 rw-p 00006000 08:06 145314 /usr/lib/perl/5.10.1/auto/Time/HiRes/HiRes.so 7fcec9f33000-7fcec9f37000 r-xp 00000000 08:06 145317 /usr/lib/perl/5.10.1/auto/Time/Piece/Piece.so 7fcec9f37000-7fceca136000 ---p 00004000 08:06 145317 /usr/lib/perl/5.10.1/auto/Time/Piece/Piece.so 7fceca136000-7fceca137000 r--p 00003000 08:06 145317 /usr/lib/perl/5.10.1/auto/Time/Piece/Piece.so 7fceca137000-7fceca138000 rw-p 00004000 08:06 145317 /usr/lib/perl/5.10.1/auto/Time/Piece/Piece.so 7fceca138000-7fceca13d000 r-xp 00000000 08:06 135964 /usr/lib/perl/5.10.1/auto/Socket/Socket.so 7fceca13d000-7fceca33d000 ---p 00005000 08:06 135964 /usr/lib/perl/5.10.1/auto/Socket/Socket.so 7fceca33d000-7fceca33e000 r--p 00005000 08:06 135964 /usr/lib/perl/5.10.1/auto/Socket/Socket.so 7fceca33e000-7fceca33f000 rw-p 00006000 08:06 135964 /usr/lib/perl/5.10.1/auto/Socket/Socket.so 7fceca33f000-7fceca344000 r-xp 00000000 08:06 135959 /usr/lib/perl/5.10.1/auto/IO/IO.so 7fceca344000-7fceca543000 ---p 00005000 08:06 135959 /usr/lib/perl/5.10.1/auto/IO/IO.so 7fceca543000-7fceca544000 r--p 00004000 08:06 135959 /usr/lib/perl/5.10.1/auto/IO/IO.so 7fceca544000-7fceca545000 rw-p 00005000 08:06 135959 /usr/lib/perl/5.10.1/auto/IO/IO.so 7fceca545000-7fceca811000 r--p 00000000 08:06 131086 /usr/lib/locale/locale-archive 7fceca811000-7fceca81a000 r-xp 00000000 08:02 920658 /lib/x86_64-linux-gnu/libcrypt-2.13.so 7fceca81a000-7fcecaa1a000 ---p 00009000 08:02 920658 /lib/x86_64-linux-gnu/libcrypt-2.13.so 7fcecaa1a000-7fcecaa1b000 r--p 00009000 08:02 920658 /lib/x86_64-linux-gnu/libcrypt-2.13.so 7fcecaa1b000-7fcecaa1c000 rw-p 0000a000 08:02 920658 /lib/x86_64-linux-gnu/libcrypt-2.13.so已放弃

what's wrong with my code? i try this on ubuntu11.04 x86_64, i also got the same result on ubuntu10.10 x86,thanks advance.

Replies are listed 'Best First'.
Re: perl threads crashed
by BrowserUk (Patriarch) on Jun 08, 2011 at 08:27 UTC

    So much code. Try this:

    #! perl -slw
use strict;
use Time::HiRes qw[ sleep ];
use threads;
use threads::shared;

my $sig  :shared = 0;

$SIG{ USR1 } = $SIG{ INT } = $SIG{ ALRM } = sub {
    $sig = 1;
};

async {
   while( 1 ) {
      sleep 0.1 until $sig;
      print 'Did some work';
      $sig = 0;
   }
}->detach;

alarm 10;

1 while sleep 1;

__END__
C:\test>908605.pl
No such signal: SIGUSR1 at C:\test\908605.pl line 11.
Did some work
Did some work
Did some work
Terminating on signal SIGBREAK(21)

    [download]
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
Re: perl threads crashed
by Corion (Patriarch) on Jun 08, 2011 at 06:42 UTC

    Mixing threads and signals is not advisable. Signals are a process-global thing, while threads have little to no notion of signals at all.

    I would try to avoid using signals, but as you haven't stated what the real problem you are trying to solve is, I can't give you advice as to what else to use instead.

[reply]

      thank you, I just want to write a small daemon program, it suspend until a specific signal wake it up, such as a user defined signal, or the alarm signal, then do some else, after work, suspend again.

[reply]
        I don't see any need for threads. Just do your work within the sig handler. I believe that Perl sets up sigaction mask to block all signals while inside of a handler, so there is no extra stuff required to prevent a re-entrant call into the handler. The below code calls handler every 5 seconds. If you do a kill -s USR1 pid, that causes an extra call to handler. The sleep 100 never actually completes because Perl implements sleep in terms of ALRM and when the alarm goes off, it cancels the sleep. I would definitely not use INT as one of your signals. I mean "read database and send to socket" is not an action one would normally think of for CTL-C! USR1 is a lot better and intended for this sort of thing. 
        #!/usr/bin/perl -w
use strict;

$SIG{USR1} = \&handler;
$SIG{ALRM} = \&handler;

while (1){alarm 5; sleep 100;}

sub handler
{
   print "Do work \n"; #your get_message,send_message calls
}

        [download]
        Update: If SIGPIPE happens in send_message(), it won't be handled until after handler finishes. I don't see a big deal with that as since you don't have a handler installed for SIGPIPE, you are going to die anyway. I would consider connecting to the DB before the while(1)..leave connection open if you are going to use it every 10 seconds, ditto for the other socket.
[reply]
[d/l]
Re: perl threads crashed
by Khen1950fx (Canon) on Jun 08, 2011 at 06:36 UTC
    FWIW, this doesn't crash. 
    #!/usr/bin/perl

use 5.10.1;
use strict;
use warnings;
use IO::Socket::INET;
use Time::Piece;
use Time::HiRes ('sleep');
use DBI;
use AutoLoader qw(AUTOLOAD);
use POSIX qw(:signal_h);
use threads 
    ('stack_size' => 64*4096,
     'exit' => 'threads_only',
     'stringify');
               
my $shost    = '192.168.0.201';
my $sport    = 60004;
my $mhost    = '192.168.0.201';
my $dbname   = 'enterprise';
my $dbuser   = 'root';
my $dbpasswd = '123456';

sub send_message {
    my $message = shift @_;
    die 'Connect failed!'
      unless my $sock = 'IO::Socket::INET'
          ->new( 'PeerAddr', $shost, 'PeerPort', $sport, 'Proto', 'tcp
+' );
    print $sock $message;
}

sub get_message {
    my $dbh = 'DBI'->connect( "DBI:mysql:database=$dbname;host=$mhost"
+,
        $dbuser, $dbpasswd, { 'PrintError', 0, 'RaiseError', 1 } );
    my $sth = $dbh->prepare('SELECT IMEI FROM SessionIMEI');
    $sth->execute;
    my @elements;
    while ( my $ref = $sth->fetchrow_hashref ) {
        push @elements, $$ref{'IMEI'};
    }
    my $buf = '$0';
    foreach my $ref (@elements) {
        $buf .= ",$ref";
    }
    $buf .= "\@\r\n";
    $dbh->disconnect;
    return $buf;
}
my $sigset = POSIX::SigSet->new(SIGINT);
my $signal = undef;
$sigset->delset(\&POSIX::SIGUSR1);
$sigset->delset(\&POSIX::SIGINT);
$sigset->delset(\&POSIX::SIGALRM);
my $old_sigset = POSIX::SigSet->new;

sub user_handler {
    print "Get a user defined signal.\n";
    $signal = shift @_;
}

sub int_handler {
    print "Get a interrupt signal.\n";
    $signal = shift @_;
    print $signal, "\n";
}

sub alarm_handler {
    print "Get a alarm signal.\n";
    $signal = shift @_;
}
$SIG{'USR1'} = \&user_handler;
$SIG{'INT'}  = \&int_handler;
$SIG{'ALRM'} = \&alarm_handler;
unless ( defined sigprocmask( \&SIG_BLOCK, $sigset, $old_sigset ) ) {
     warn "could not block sigint\n"
    }
    else {
     print "blocked sigint\n";  
}

sub sig_process {
    sigsuspend($sigset);
    my $message = undef;
    if ( $signal eq 'INT' ) {
        $message = get_message();
        send_message $message;
    }
}

sub create_alarm {
    sub start_thread {
        my @args = @_;
        say "Thread started: ", 
        join(' ', @args);
    } 
    my $thr = 'threads'->create('start_thread', \&alarm_thread);
    $thr->detach();
    if($thr->is_detached) {
        print "Thread is detached\n";
    }
    else {
        print "Thread is not detached\n";
    }
    
}

sub alarm_thread {
    eval {
        local $SIG{'ALRM'} = sub { die "alarm\n"; };
        alarm 10;
        my $buffer;
        my $nread = sysread SOCKET, $buffer, 1;
        close SOCKET;
        alarm 0;
        };
        if ($@) {
            die unless $@ eq "alarm\n";
        }
        else {
            return;
        }
}
create_alarm;
sig_process;

    [download]
[reply]
[d/l]

      thanks very much.

[reply]

Back to Seekers of Perl Wisdom