File Coverage

blib/lib/Debug/FaultAutoBT.pm

Criterion	Covered	Total	%
statement	52	62	83.8
branch	9	30	30.0
condition	2	6	33.3
subroutine	13	13	100.0
pod	2	5	40.0
total	78	116	67.2

package Debug::FaultAutoBT;

use 5.00503;

use strict;
#use warnings;

use File::Spec::Functions;
use Config;
use Symbol;

require DynaLoader;

@Debug::FaultAutoBT::ISA = qw(DynaLoader);
$Debug::FaultAutoBT::VERSION = '0.02';
bootstrap Debug::FaultAutoBT $Debug::FaultAutoBT::VERSION;

use constant COMMAND_FILE   => 'gdb-command';
use constant CORE_FILE_BASE => 'core.backtrace.';

sub new {
    my ($class, %attrs) = @_;
    my $self = bless \%attrs, ref($class)||$class;
    $self->init();
    return $self;
}

sub init {
    my $self = shift;

    # verify that the 'dir' attribute is set and the dir is writable
    die "must specify a 'dir' attribute"
        unless exists $self->{dir} && length $self->{dir};
    die "the dir $self->{dir} must be writable"
        unless -w $self->{dir};

    # set/verify the 'exec_path' attribute
    if (exists $self->{exec_path}) {
        die "exec_path: $self->{exec_path} is not found"
            unless -e $self->{exec_path};
        die "exec_path: $self->{exec_path} is not executable"
            unless -x $self->{exec_path};
        $self->{exec_path_in} = $self->{exec_path};
    }
    else {
        $self->inteli_guess_exec_path();
        die "cannot figure out the executable path, ",
            "set the 'exec_path' attribute"
                unless exists $self->{exec_path_in};
    }


    # set/verify the 'command_path_in' attribute
    if (exists $self->{command_path}) {
        # the file should already exist and include the gdb commands
        die "command_path: cannot read $self->{command_path}"
            unless -r $self->{command_path};
        $self->{command_path_in} = $self->{command_path};
    }
    else {
        # use the default file and write it
        $self->{command_path_in} = catfile $self->{dir}, COMMAND_FILE;
        $self->write_gdb_command_file();
    }

    # set/verify the 'command_path_base_in' attribute
    if (exists $self->{core_path_base}) {
        # try to create a file using this base
        my $try_path = $self->{core_path_base} . "00000";
        my $fh = Symbol::gensym();
        if (open $fh, ">$try_path") {
            close $fh;
            unlink $try_path;
        }
        else {
            die "core_path_base: $self->{core_path_base} doesn't seem to ",
                "be suitable as a base for the path that can be written to";
        }
        $self->{core_path_base_in} = $self->{core_path_base};
    }
    else {
        # use the default file and write it
        $self->{core_path_base_in} = catfile $self->{dir}, CORE_FILE_BASE;
    }

    # set/verify the 'debugger' attribute
    # NOOP now

}

sub write_gdb_command_file {
    my $self = shift;

    #XXX: should we die here?
    #die "$self->{command_path_in} already exists, delete first"
    #    if -e $self->{command_path_in};
    #warn "creating $self->{command_path_in} for user ".(getpwuid($>))[0]."\n";
    my $fh = Symbol::gensym();
    open $fh, ">$self->{command_path_in}"
        or die "can't open $self->{command_path_in} for writing: $!";
    print $fh <
bt
kill
quit
EOI
    close $fh;
}

sub inteli_guess_exec_path {
    my $self = shift;

    if (-x $^X) {
        $self->{exec_path_in} = $^X;
    }
    elsif (-e '/proc/self/exe') {
        # linux?
        my $path = readlink("/proc/self/exe");
        $self->{exec_path_in} = $path if -e $path;
    }
    else {
        $self->{exec_path_in} = $Config{perlpath} if -x $Config{perlpath};
    }
}

sub ready {
    my $self = shift;
    #warn "calling @$self{qw(exec_path_in command_path_in core_path_base_in)}";
    set_segv_action($self->{exec_path_in},
                    $self->{command_path_in},
                    $self->{core_path_base_in});
}

DESTROY {
    my $self = shift;
    # XXX: test that this actually works, since we die here!
    # cleanup the autogenerated file if we have created it
    #unlink $self->{command_path_in} unless exists $self->{command_path};
}

1;
__END__