bt_cores

#! /usr/bin/perl

use strict;
use warnings;

use Digest::MD5 qw(md5_hex);
use File::Basename qw(basename dirname);
use File::Temp qw(tempdir);
use Getopt::Long;
use Pod::Usage;

our $VERSION = 0.02;

my ($opt_help, $opt_version, $opt_unlink_core);
my $opt_delay = 10;

GetOptions(
    help          => \$opt_help,
    version       => \$opt_version,
    'unlink-core' => \$opt_unlink_core,
) or pod2usage(1);
if ($opt_help) {
    pod2usage(0);
} elsif ($opt_version) {
    print "$VERSION\n";
    exit 0;
}

if ($^O =~ /^darwin$/i) {
    chdir '/cores'
	or die "failed to chdir to /cores, the directory where OSX saves core files:$!";
} elsif ($^O =~ /^linux$/i) {
    my $core_pattern = do {
	open my $fh, '<', '/proc/sys/kernel/core_pattern'
	    or die "failed to open file:/proc/sys/kernel/core_pattern:$!";
	<$fh>;
    };
    chomp $core_pattern;
    die "/proc/sys/kernel/core_pattern should be set to /<core-dir>/core.%p"
	unless basename($core_pattern) =~ m|core\.%p$|;
    if ($core_pattern =~ m|^/|) {
	my $dir = dirname $core_pattern;
	chdir $dir
	    or die "failed to chdir to dir:$dir:$!";
    }
} else {
    warn "unknown OS, bt_cores may not work as expected";
}

my $tempdir = tempdir(CLEANUP => 1);

{ # prepare gdb command file (gdb on ubuntu 9 does not seem to read from STDIN)
    open my $fh, '>', "$tempdir/gdb.cmd"
	or die "failed to open file:$tempdir/gdb.cmd:$!";
    print $fh "thread apply all bt\n";
    close $fh;
}

while (1) {
    # build list of files (with checksum)
    my %core_files = map {
        $_ => md5_file($_)
    } grep {
        ! -e bt_filename($_)
    } <core.*>;
    sleep 5;
    next unless %core_files;
    for my $core_file (sort keys %core_files) {
        # skip if the checksum of the core file has changed
        next unless $core_files{$core_file} eq md5_file($core_file);
        # take backtrace
        print "taking backtrace of core file:$core_file\n";
	my $gdb_out = call_gdb("-x $tempdir/gdb.cmd -c $core_file");
	if ($^O =~ /^linux$/i 
	    && $gdb_out =~ m|^Core was generated by `(.*?)'\.$|mi) {
	    # need to find prog on linux
	    my $prog = $1;
	    if (-e $prog) {
		$gdb_out = call_gdb("-x $tempdir/gdb.cmd -c $core_file $prog");
	    } else {
		$gdb_out = "could not find program: $prog\n\n$gdb_out";
	    }
	}
	# save backtrace
	open my $fh, '>', bt_filename($core_file)
	    or die "failed to open file:@{[bt_filename($core_file)]}:$!";
	print $fh $gdb_out;
	close $fh;
        # unlink if necessary
        if ($opt_unlink_core) {
            unlink $core_file
                or die "failed to unlink core file:$core_file:$!";
        }
    }
}

sub bt_filename {
    my $fn = shift;
    $fn =~ s/^core/bt/;
    $fn;
}

sub call_gdb {
    my $args = shift;
    open(
	my $fh,
	'-|',
	"gdb -batch $args 2>&1",
        ) or die "failed to invoke gdb:$!";
    my $out = join '', <$fh>;
    close $fh;
    $out .= "gdb exitted with exit code:$?"
	if $?;
    $out;
}

sub md5_file {
    my $fn = shift;
    open my $fh, '<', $fn
	or die "failed to open $fn:$!";
    my $md5 = Digest::MD5->new;
    $md5->addfile($fh);
    close $fh;
    $md5->hexdigest;
}

__END__

=head1 NAME

bt_cores - a daemon that takes stack backtrace of core files automatically

=head1 SYNOPSIS

  # setup (as root)
  echo /tmp/core.%p > /proc/sys/kernel/core_pattern

  # run the daemon (converts /tmp/core.<pid> to /tmp/bt.<pid>)
  bt_cores -u

=over 4

=item -u, --unlink-core

Removes the core file after taking backtrace.

=back

=head1 DESCRIPTION

Bt_cores is a daemon that waits for core files (that match pattern "core.<pid>") to appear in current directory, and takes backtraces of the images.

=head1 AUTHOR

Kazuho Oku

=cut