After some digging through the ugly (and at least partially) bad code, I think I know where the error happens, and what you might do to hide this error. There is a programming error in the code where one of the references to a shared variable gets overwritten by a number. In sub cmdloop, replace the line
$self->{rw} = 1;
by
${$self->{rw}} = 1;
This makes the code "work" for me in the sense that the segfault disappears with both Perl versions. It then seems to hang in the PRINT command, but that might well be an error in the programming logic. I've pasted my modified code below, maybe somebody sees the deadlock.
#!/usr/bin/perl -w
use strict;
use threads;
sub threadA {
for(my $i = 1; $i <= 100; $i++) {
warn "Thread A: Print $i";
print FILE "A: $i\n";
}
}
sub threadB {
for(my $i = 1; $i <= 100; $i++) {
warn "Thread B: Print $i";
print FILE "B: $i\n";
}
}
tie *FILE, 'FHShare';
open FILE, '>fhshare.out';
autoflush FILE;
my $a = threads->create('threadA');
threadB();
$a->join;
close FILE;
package FHShare;
# A package to share filehandles between threads via tie()
use strict;
use threads;
use threads::shared;
use FileHandle;
# Subroutine to start thread that accesses filehandle
sub start_thread {
my $self = shift;
$self->cmdloop();
}
sub TIEHANDLE {
my $class = shift;
my $sem : shared;
my $cw : shared = 0;
my $rw : shared = 0;
my @cmd : shared;
my @rv : shared;
my $err : shared;
my $self = {
cmd => \@cmd, # Command
rv => \@rv, # Return value
err => \$err, # Error from calling filehandle method
# A semaphore to lock access to send commands to the command
# thread:
sem => \$sem,
# A semaphore for the command thread to notify it that it has
# a command waiting:
cw => \$cw, # 1 for command waiting
# A semaphore for the command thread to notify other threads
# that return values are waiting:
rw => \$rw }; # 1 for values waiting
bless $self, $class;
# Create thread attached to this handle
threads->create('start_thread', $self)->detach();
return $self;
}
sub DESTROY {
my $self = shift;
lock $self->{sem};
${$self->{cmd}} = (); # Empty list to quit
{
lock $self->{cw};
${$self->{cw}} = 1;
cond_signal $self->{cw};
}
{
lock $self->{rw};
while (!${$self->{rw}}) {
cond_wait $self->{rw};
}
}
}
# Autoload section -- convert uppercase method names called to
# lowercase method names for the underlying filehandle.
our $AUTOLOAD;
sub AUTOLOAD {
my $self = shift;
warn "Autoloaded $AUTOLOAD";
my $method = lc($AUTOLOAD); # Convert method to lc.
$method =~ s/^.*:://; # Remove prefix.
FileHandle->can($method) or
die "Error: filehandles have no '$method' method";
my @ret; # Return value
{
lock $self->{sem}; # Lock access
# Send command:
warn "$AUTOLOAD: Sent $method(@_)";
@{$self->{cmd}} = ($method, @_);
# Tell command thread that it is waiting:
{
lock $self->{cw};
${$self->{cw}} = 1;
cond_signal $self->{cw};
}
# Wait for return values
warn "$AUTOLOAD: waiting";
{
lock $self->{rw};
while (!${$self->{rw}}) {
warn "$AUTOLOAD: waiting for data";
cond_wait $self->{rw};
warn "$AUTOLOAD: done waiting";
}
${$self->{rw}} = 0; # Reset
}
# Handle errors
if (my $err = ${$self->{err}}) {
chomp $err;
my($filename, $line) = (caller)[2,3];
die "$err at $filename line $line\n";
}
@ret = @{$self->{rv}}; # Get return values
}
return @ret; # Return w/ return vals
}
# Method for thread that accesses underlying filehandle to loop
# through commands
sub cmdloop {
my $self = shift;
warn "Entered command loop";
my $fh = new FileHandle;
while (1) {
# Wait for and get command
{
warn "Waiting for command ready";
lock $self->{cw};
while (!${$self->{cw}}) {
cond_wait $self->{cw};
}
$self->{cw} = 0; # Reset
}
# Get the method and arguments
my @cmd = @{$self->{cmd}} or last; # Quit on empty list
my $method = shift @cmd;
my @args = @cmd;
# Call the method, enqueue the return value(s)
my $mcall = "\$fh->$method(\@args)";
warn "sending \$fh->$method(@args)";
@{$self->{rv}} = eval $mcall;
#@{$self->{rv}} = $fh->$method(@args);
# Record errors
${$self->{err}} = $@;
} continue {
# Signal that values are waiting
{
warn "Signaling data available";
lock $self->{rw};
warn "locked 'rw' flag";
warn "'rw' flag is $self->{rw}";
${$self->{rw}} = 1;
warn "'rw' flag is $self->{rw}";
cond_signal $self->{rw};
warn "signalled 'rw' flag";
}
}
}
1;
|