Thread::Deadlock - report deadlocks with stacktrace

  perl -MThread::Deadlock program          # report to STDERR
  perl -MThread::Deadlock=filename program # report to file

  use Thread::Deadlock;                    # report to STDERR
  use Thread::Deadlock 'filename';         # report to file
  use Thread::Deadlock ();                 # set up, need on() later

  use Thread::Deadlock (                   # call class methods easily
   summary  => 'auto',
   callers  => 4,
   shorten  => 1,
   format   => 'plain',
   encoding => 'iso-latin-1',
   output   => 'STDERR',
   trace    => undef,
  );

  Thread::Deadlock->summary( 'auto' );       # default, automatic
  Thread::Deadlock->summary( 0 );            # don't do summary
  Thread::Deadlock->summary( 1 );            # do summary always

  Thread::Deadlock->callers( 4 );            # default, show 4 lines in dump
  Thread::Deadlock->callers( 0 );            # show all lines in dump

  Thread::Deadlock->shorten( 1 );            # default: shorten package names
  Thread::Deadlock->shorten( 0 );            # do not shorten package names

  Thread::Deadlock->format( 'plain' );       # default, plain text format
  Thread::Deadlock->format( 'xml' );         # set XML format
  Thread::Deadlock->encoding('iso-latin-1'); # only needed for XML format

  Thread::Deadlock->off;                     # disable in this thread
  Thread::Deadlock->on;                      # enable again in this thread

  $report = Thread::Deadlock->report;        # return intermediate report

  Thread::Deadlock->output( 'filename' );    # report to file
  Thread::Deadlock->disable;                 # disable report

  Thread::Deadlock->trace( 'filename' );     # start tracing to file
  Thread::Deadlock->untrace;                 # stop tracing (default)

                  *** A note of CAUTION ***

 This module only functions on Perl versions 5.8.0 and later.
 And then only when threads are enabled with -Dusethreads.  It
 is of no use with any version of Perl before 5.8.0 or without
 threads enabled.

                  *************************

 Thread::Deadlock->on;

 Thread::Deadlock->off;

 Thread::Deadlock->summary( 'auto' );  # default, automatic

 Thread::Deadlock->summary( 0 );       # don't do summary

 Thread::Deadlock->summary( 1 );       # always do summary

 $summary = Thread::Deadlock->summary;

 Thread::Deadlock->callers( 4 );       # default, return 4 callers

 Thread::Deadlock->callers( 0 );       # return all callers

 $callers = Thread::Deadlock->callers;

 Thread::Deadlock->shorten( 1 );       # default, shorten

 Thread::Deadlock->shorten( 0 );       # do not shorten package names

 $shorten = Thread::Deadlock->shorten;

 Thread::Deadlock->format( 'plain' );  # default, make plain text report

 Thread::Deadlock->format( 'xml' );    # make xml report

 $format = Thread::Deadlock->format;

 Thread::Deadlock->encoding( 'iso-latin-1' );  # default

 $encoding = Thread::Deadlock->encoding;

 $report = Thread::Deadlock->report;

 Thread::Deadlock->output( 'filename' );  # write to specific file

 $output = Thread::Deadlock->output;      # obtain current setting

 Thread::Deadlock->disable;

 Thread::Deadlock->trace( 'filename');    # start tracing to specific file

 $trace = Thread::Deadlock->trace;

 Thread::Deadlock->untrace;

 load (any)

package Thread::Deadlock;

# Make sure we have version info for this module
# Make sure we do everything by the book from now on

$VERSION = '0.06';
use strict;

# Make sure we only load stuff when we actually need it

use load;

# Make sure we have threads
# Make sure we can lock
# Make sure signals will have END executed

use threads;
use threads::shared ();
use sigtrap qw(die normal-signals);

# Make sure we can cluck
# Initialize thread local hi-jacked flag
# Initialize output destination
# Report from each thread

use Carp ();
my $hijacked;
our $output : shared = 'STDERR';
our %report : shared;

# Initialize summary setting
# Initialize callers setting
# Initialize shorten setting
# Initialize format
# Initialize XML encoding

our $summary  : shared = 'auto';
our $callers  : shared = 4;
our $shorten  : shared = 1;
our $format   : shared = 'plain';
our $encoding : shared = 'iso-latin-1';

# Initialize trace setting
# Initialize thread local handle for writing trace

our $trace    : shared;
my $tracehandle;

# Save current coderefs

our $cond_wait      = \&threads::shared::cond_wait;
our $cond_signal    = \&threads::shared::cond_signal;
our $cond_broadcast = \&threads::shared::cond_broadcast;

# Make sure we don't get warnings for the hijacking
# Install hi-jacked coderefs, we can't do lock() yet ;-(

{
 no warnings 'redefine';
 *threads::shared::cond_wait =
  sub (\[$@%]) { _remember( 'cond_wait()' ); goto &$cond_wait };
 *threads::shared::cond_signal =
  sub (\[$@%]) { _remember( 'cond_signal()' ); goto &$cond_signal };
 *threads::shared::cond_broadcast =
  sub (\[$@%]) { _remember( 'cond_broadcast()' ); goto &$cond_broadcast };
}

# Create match string for paths
# Make a regular exprssion of it

our $paths = join( '/|',sort {length($b) - length($a)} @INC ).'/';
$paths = qr#(?<= at )(?:$paths)#;

# Satisfy -require-

1;

#---------------------------------------------------------------------------

# routines for standard perl features

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 output filename (optional)
# or:
#  IN: 1 class
#      2..N method/value hash

sub import {

# Switch on reporting
# Handle simple output specification if so

    on();
    goto &output if @_ == 2;

# Get the parameter hash
# For all of the methods and values
#  Die now if invalid method
#  Call the method with the value

    my ($class,%param) = @_;
    while (my ($method,$value) = each %param) {
	die "Cannot call method $method during initialization\n"
	 unless $method =~
	  m#^(?:callers|encoding|format|output|shorten|summary|trace)$#;
        $class->$method( $value );
    }
} #import

#---------------------------------------------------------------------------

END {

# Attempt to lock the report flag
# Return now if we don't need to report

    lock( $output );
    return unless $output;

# Allow variable specifications
# Tell the world what it is
# Indicate that no-one else needs to report

    no strict 'refs';
    print {_handle( $output )} &{'_'.$format};
    $output = '';
} #END

#---------------------------------------------------------------------------

# load takes over from here

__END__

#---------------------------------------------------------------------------

# class methods

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)

sub on { $hijacked = 1 } #on

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)

sub off { $hijacked = 0 } #off

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 new summary setting
# OUT: 1 current summary setting

sub summary {

# If a new setting is specified
#  Die now if invalid parameter
#  Set new parameter
# Return current setting

    if (@_ == 2) {
        die "Invalid parameter $_[1] to summary\n"
	 unless $_[1] =~ m#^(?:auto|0|1)$#;
        $summary = $_[1];
    }
    $summary;
} #summary

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 new callers setting
# OUT: 1 current callers setting

sub callers {

# If a new setting is specified
#  Die now if invalid parameter
#  Set new parameter
# Return current setting

    if (@_ == 2) {
        die "Invalid parameter $_[1] to callers\n" unless $_[1] =~ m#^\d+$#;
        $callers = $_[1];
    }
    $callers;
} #callers

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 new shorten setting
# OUT: 1 current shorten setting

sub shorten {

# Set if a new setting is specified
# Return current setting

    $shorten = $_[1] if @_ == 2;
    $shorten;
} #shorten

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 new format setting
# OUT: 1 current format setting

sub format {

# If a new setting is specified
#  Die now if invalid parameter
#  Set new parameter
# Return current setting

    if (@_ == 2) {
        die "Invalid parameter $_[1] to summary\n"
	 unless $_[1] =~ m#^(?:plain|xml)$#;
        $format = $_[1];
    }
    $format;
} #format

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 new encoding setting
# OUT: 1 current encoding setting

sub encoding {

# Set if a new setting is specified
# Return current setting

    $encoding = $_[1] if @_ == 2;
    $encoding;
} #encoding

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
# OUT: 1 generated report

sub report {

# Allow for non variable references
# Create a report and return it

    no strict 'refs';
    join( '',&{'_'.$format} );
} #report

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 name of file to write to (no change)
# OUT: 1 current setting

sub output { $output = $_[1] if @_ >1; $output } #output

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)

sub disable { $output = '' } #disable

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 name of file to write to (no change)
# OUT: 1 current setting

sub trace { $trace = $_[1] if @_ >1; $trace } #trace

#---------------------------------------------------------------------------

# internal routines

#---------------------------------------------------------------------------
#  IN: 1 what we're remembering

sub _remember {

# Return now if there is nothing to do

    return unless $hijacked;

# Obtain the thread we're in
# Obtain the stacktrace
# Remove this call
# Add what we're remembering

    my $tid = threads->tid;
    my @cluck = split( m#(?<=$/)#,Carp::longmess() );
    shift( @cluck );
    $cluck[0] =~ s#.*?called#shift#e;

# If we're tracing
#  Obtain handle if there is no handle yet
#  Create local copy of trace line
#  Shorten it if so specified
#  Write the trace to the file
# Elseif we have a trace handle (but we stopped tracing)
#  Close the handle and mark as unused again

    if ($trace) {
        $tracehandle ||= _handle( $trace,'>>' );
	my $line = $cluck[0];
	$line =~ s#$paths## if $shorten;
	print {$tracehandle} "$tid: $line";
    } elsif ($tracehandle) {
        undef( $tracehandle );
    }

# Create a hash with valid tid's (include main thread, which is not in list)
# For all of the keys in the report hash
#  Remove this thread's report if the thread is dead
# Save the report of this thread

    my %tid = (0,1),map {$_->tid,1} threads->list;
    while (my $tid = each( %report )) {
        delete( $report{$tid} ) unless exists $tid{$tid};
    }
    $report{$tid} = join( "\0",@cluck );
} #_remember

#---------------------------------------------------------------------------
# OUT: 1 generated report in plain text
#      2..N stack dump

sub _plain {

# Tell the world what it is
# Obtain frequency and dump list references

    my $text = '*** '.__PACKAGE__." report ***\n";
    my ($at,$dump,$tid) = _dump();

# If we have any information
#  If we're to do the summary
#   Show all different locations
#   And add a divider
# Else (no information)
#  Add some explanation

    if (@$tid) {
        if ($summary eq 'auto' ? (keys %$at < keys %report) : $summary) {
            $text .= "$at->{$_} x $_" foreach sort keys %$at;
            $text .= "\n";
        }
    } else {
        $text .= "(no information found)\n";
    }

# Return the final report plus the dump

    $text,map {"#$_: ".join('',@{$dump->{$_}})."\n"} @$tid;
} #_plain

#---------------------------------------------------------------------------
# OUT: 1 generated report in XML

sub _xml {

# Tell the world what it is
# Obtain frequency and dump list references

    my $xml = <<EOD;
<?xml version="1.0" encoding="$encoding"?>
<report version="1.0">
EOD
    my ($at,$dump,$tid) = _dump();

# If we're to do the summary
#  Show all different locations

    if ($summary eq 'auto' ? (keys %$at < keys %report) : $summary) {
        $xml .= <<EOD;
 <summary>
EOD
        $xml .= <<EOD foreach sort keys %$at;
  <location frequency="$at->{$_}">$_</location>"
EOD
        $xml .= <<EOD;
 </summary>
EOD
    }

# For all of the thread id's
#  Add the XML for this thread

    foreach (@$tid) {
        $xml .= <<EOD;
 <thread id="$_">
EOD
        chomp( my @line = @{$dump->{$_}} );
	s#^\s+## foreach @line;
        $xml .= <<EOD foreach @line;
  <at>$_</at>
EOD
        $xml .= <<EOD;
 </thread>
EOD
    }

# Return the final report plus the dump

    "$xml</report>";
} #_xml

#---------------------------------------------------------------------------
# OUT: 1 reference to hash with frequencies
#      2 reference to hash with list references of dump
#      3 reference to list with keys (thread id's) in dump hash

sub _dump {

# Initialize the thread id list
# Initialize the at hash
# Initialize the dump hash

    my @tid;
    my %at;
    my %dump;

# For all of the threads still running
#  Make a list again
#  If we should shorten stuff
#   Shorten the package name
#   Remove (autosplit...) reference (don't need that usually)

    foreach (@tid = sort {$a <=> $b} keys %report) {
        my @cluck = split( "\0",$report{$_} );
        if ($shorten) {
            foreach (@cluck) {
                s#$paths##;
                s# \(autosplit(?:[^)]+)\)##;
            }
        }

#  Count the first list
#  Indicate start of thread if appropriate

        $at{$cluck[0]}++;
        $cluck[-1] =~ s#eval \{\.\.\.\} called#thread started#;

#  Shorten list of callers if so specified
#  Remove the thread information (if any)
#  Add these lines to the dump

        splice( @cluck,$callers ) if $callers;
        s/, thread #(\d+)$// foreach @cluck;
        $dump{$_} = \@cluck;
    }

# Return references to stuff we made here

    return \%at,\%dump,\@tid;
} #_dump

#---------------------------------------------------------------------------
#  IN: 1 output specification
#      2 open mode (default: '>')
# OUT: 1 opened handle

sub _handle {

# Obtain the output specification
# Obtain open mode
# Initialize handle to write to

    my $filename = shift;
    my $mode = shift || '>';
    my $handle;

# If we have the default value
#  Set to write to standard error
# Elseif we just want to print
#  Set to write to standard output

    if ($filename eq 'STDERR') {
        $handle = *STDERR;
    } elsif ($filename eq 'STDOUT') {
        $handle = *STDOUT;

# Elseif successful in opening it as a file (no action)
# Else (not successful in opening file)
#  Set to use standard error
#  And let the world know why

    } elsif (open( $handle,$mode,$filename )) {
    } else {
        $handle = *STDERR;
	print $handle <<EOD;
Could not report to $filename ($!)
Writing to STDERR instead
EOD
    }

# Return the resulting handle

    $handle;
} #_handle

#---------------------------------------------------------------------------

__END__