package App::Stacktrace;

=head1 NAME

App::Stacktrace - Stack trace

=head1 VERSION

version 0.09

=head1 SYNOPSIS

  perl-stacktrace [option] pid

    -m      Prints a gdb script
    -v      Verbose debugging
    -c      Additionally, prints C stacktrace
    --help  Show this help

    --exec  exec() into gdb

=head1 DESCRIPTION

perl-stacktrace prints Perl stack traces of Perl threads for a given
Perl process. For each Perl frame, the full file name and line number
are printed.

For example, a stack dump of a running perl program:

    $ ps x | grep cpan
    24077 pts/12   T      0:01 /usr/local/bin/perl /usr/local/bin/cpan
    24093 pts/12   S+     0:00 grep cpan

    $ perl-stacktrace 24077
    0x00d73416 in __kernel_vsyscall ()
    /usr/local/bin/cpan:11
    /usr/local/lib/perl5/5.12.2/App/Cpan.pm:364
    /usr/local/lib/perl5/5.12.2/App/Cpan.pm:295
    /usr/local/lib/perl5/5.12.2/CPAN.pm:339
    /usr/local/lib/perl5/5.12.2/Term/ReadLine.pm:198

=head1 API

There exists an internal API

=head2 new

This accepts the following parameters by applying them through
L<Getopt::Long>. This is actually just a front for the script
F<perl-stacktrace>'s command line handling.

  App::Stacktrace->new(
      $pid,       # The process to attach to
      'm',        # Dump the generated script
      'v',        # Verbose
      'exec',     # exec() into gdb
      '--noexec', # system() into gdb
  );

=head2 run

Runs the app program as configured by the C<< ->new(...) >> method.

    $obj = App::Stacktrace->new( ... );
    $obj->run;

=cut

use strict;
use Config ();
use English -no_match_vars;
use Getopt::Long ();
use Pod::Usage ();
use XSLoader ();
use File::Temp ();

our $VERSION = '0.09';

XSLoader::load(__PACKAGE__, $VERSION);

sub new {
    my $class = shift;
    my $self = {};
    bless $self, $class;

    $self->_read_arguments( @_ );

    return $self;
}

sub run {
    my $self = shift;

    if ($self->{help}) {
        Pod::Usage::pod2usage(
            -verbose => 2,
            -exitcode => 0,
        );
    }

    my $script = $self->_custom_generated_script;
    if ($self->{dump_script}) {
        print $script;
    }
    else {
        $self->_run_gdb($script);
    }

    return;
}

sub _read_arguments {
    my $self = shift;
    local @ARGV = @_;
    my %args;
    Getopt::Long::GetOptions(
         \ %args,
        'help',
        'm',
        'v',
        'c',
        'exec!',
    )
      or Pod::Usage::pod2usage(
        -verbose => 2,
        -exitcode => 2 );
    if (1 == @ARGV && $ARGV[0] =~ /^\d+$/) {
        $args{pid} = shift @ARGV;
    }
    if (@ARGV) {
        Pod::Usage::pod2usage( -verbose => 2, -exitcode => 2 );
    }

    $self->{help}        = $args{help};
    $self->{pid}         = $args{pid};
    $self->{dump_script} = $args{m};
    $self->{verbose}     = $args{v};
    $self->{c_backtrace} = $args{v} || $args{c};
    $self->{exec}        = $args{exec};

    return;
}


sub _custom_generated_script {
    my ($self) = @_;

    # TODO: generate this statically
    for my $dir ( @INC ) {
        my $file = "$dir/App/Stacktrace/perl_backtrace_raw.txt";
        if (-e $file) {
            return $self->_TODO_add_constants( $file );
        }
    }

    die "Can't locate perl-backtrace.txt in \@INC (\@INC contains: @INC)";
}

sub _TODO_add_constants {
    my ($self, $template_script) = @_;

    my $this_library = __FILE__;
    my $src = <<"TODO_preamble";
# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
# This file is built by $this_library from its data.
# Any changes made here will be lost!
#
TODO_preamble

    if ($self->{verbose}) {
        $src .= <<VERBOSE;
set trace-commands on
set \$DEBUG = 1
VERBOSE
    }
    else {
        $src .= <<QUIET;
set \$DEBUG = 0
QUIET
    }

    my $offsets = App::Stacktrace::_perl_offsets();
    for my $name (sort keys %$offsets) {
        $src .= "set $name = $offsets->{$name}\n";
    }

    if ($Config::Config{usethreads}) {
        require threads;
        my $key = "threads::_pool$threads::VERSION";
        my $len = length $key;
        $src .= <<"THREADS";
set \$POOL_KEY = "$key"
set \$POOL_KEY_LEN = $len
THREADS
    }


    open my $template_fh, '<', $template_script
        or die "Can't open $template_script: $!";
    local $/;
    $src .= readline $template_fh;

    if ($self->{c_backtrace}) {
        $src .= <<"C_BACKTRACE";
backtrace
C_BACKTRACE
    }

    my $command = $self->_command_for_version;
    $src .= <<"INVOKE";
$command
detach
quit
INVOKE

    return $src;
}

sub _command_for_version {
    return
        $] >= 5.038     ? 'perl_backtrace_5_38_x' :
        $] >= 5.014     ? 'perl_backtrace_5_14_x' :
        $] >= 5.012     ? 'perl_backtrace_5_12_x' :
        $] >= 5.010     ? 'perl_backtrace_5_10_x' :
        $] >= 5.008_009 ? 'perl_backtrace_5_8_9'  :
        $] >= 5.008     ? 'perl_backtrace_5_8_x'  :
        die 'Support for perl-5.6 or earlier not implemented';
}

sub _run_gdb {
    my ($self, $src) = @_;

    # TODO: what are the failure modes of File::Temp?
    my $tmp = File::Temp->new(
        UNLINK => 0,
        SUFFIX => '.gdb',
    );
    my $file = $tmp->filename;

    print { $tmp } $src;
    $tmp->flush;
    $tmp->sync;

    if ($self->{verbose}) {
        print $src;
    }

    my @cmd = (
        'gdb',
            '-quiet',
            '-batch',
            '-nx',
            '-p', $self->{pid},
            '-x', $file,
    );
    if ($self->{exec}) {
        exec @cmd;
    }
    else {
        system @cmd;
        my $sig_num = $? & 127;
        my $core    = $? & 128;
        my $rc      = $? >> 8;

        warn "@cmd killed by signal $sig_num" if $sig_num;
        warn "@cmd core dumped" if $core;
    }
}

q{Bartender, I'll have a Gordon Freeman on the rocks, thanks.}