[libapp-stacktrace-perl] 01/03: import
Axel Beckert
abe at deuxchevaux.org
Fri Dec 12 15:39:53 UTC 2014
This is an automated email from the git hooks/post-receive script.
abe pushed a commit to annotated tag v0.01
in repository libapp-stacktrace-perl.
commit 7ee9881c840303c894bcdb883b6897551e8c6e74
Author: Josh ben Jore <jjore at cpan.org>
Date: Mon Jun 13 00:04:10 2011 -0700
import
---
.gitignore | 2 +
Makefile.PL | 19 ++
Stacktrace.xs | 82 +++++
bin/pstack | 8 +
dist.ini | 39 +++
lib/App/Stacktrace.pm | 180 +++++++++++
lib/App/Stacktrace/perl_backtrace_raw.txt | 411 ++++++++++++++++++++++++
lib/App/Stacktrace/perl_backtrace_symbols.txt | 431 ++++++++++++++++++++++++++
t/basic.t | 14 +
threads.h | 41 +++
10 files changed, 1227 insertions(+)
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..cdb95b0
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+/App-Stacktrace-*
+/.build
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..942d09c
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,19 @@
+use ExtUtils::MakeMaker;
+
+if (! `which gdb`) {
+ print "App::Stacktrace requires gdb. Aborting installation";
+ exit 0;
+}
+
+WriteMakefile(
+ ABSTRACT_FROM => 'lib/App/Stacktrace.pm',
+ AUTHOR => 'Josh Jore <jjore at cpan.org>',
+ EXE_FILES => [
+ 'bin/pstack'
+ ],
+ $ExtUtils::MakeMaker::VERSION >= 6.30
+ ? (LICENSE => 'perl')
+ : (),
+ NAME => 'App::Stacktrace',
+ VERSION_FROM => 'lib/App/Stacktrace.pm',
+);
diff --git a/Stacktrace.xs b/Stacktrace.xs
new file mode 100644
index 0000000..1e24749
--- /dev/null
+++ b/Stacktrace.xs
@@ -0,0 +1,82 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <string.h>
+
+#include "thread.h"
+
+#include "ppport.h"
+
+#define V(h,k,v) hv_store(h, k, strlen(k), newSViv(v), 0);
+
+#include "threads.h"
+
+SV*
+perl_offsets() {
+ HV *hv = newHV();;
+
+ V(hv, "$CXTYPEMASK", (IV)CXTYPEMASK);
+#ifdef USE_ITHREADS
+# if PERL_VERSION >= 10
+ V(hv, "$POOLP_main_thread", (IV)&((my_pool_t*)0)->main_thread);
+ V(hv, "$THREAD_next", (IV)&((ithread*)0)->next);
+ V(hv, "$THREAD_interpreter", (IV)&((ithread*)0)->interp);
+ V(hv, "$THREAD_tid", (IV)&((ithread*)0)->tid);
+ V(hv, "$THREAD_state", (IV)&((ithread*)0)->state);
+ V(hv, "$INTERPRETER_modglobal", (IV)&((PerlInterpreter*)0)->Imodglobal);
+ V(hv, "$INTERPRETER_curstackinfo", (IV)&((PerlInterpreter*)0)->Icurstackinfo);
+ V(hv, "$COP_file", (IV)&((COP*)0)->cop_file);
+# elif PERL_VERSION == 8 && PERL_SUBVERSION >= 9
+ V(hv, "$POOLP_main_thread", (IV)&((my_pool_t*)0)->main_thread);
+ V(hv, "$THREAD_next", (IV)&((ithread*)0)->next);
+ V(hv, "$THREAD_interpreter", (IV)&((ithread*)0)->interp);
+ V(hv, "$THREAD_tid", (IV)&((ithread*)0)->tid);
+ V(hv, "$THREAD_state", (IV)&((ithread*)0)->state);
+ V(hv, "$INTERPRETER_modglobal", (IV)&((PerlInterpreter*)0)->Imodglobal);
+ V(hv, "$INTERPRETER_curstackinfo", (IV)&((PerlInterpreter*)0)->Tcurstackinfo);
+ V(hv, "$COP_file", (IV)&((COP*)0)->cop_file);
+# else
+ V(hv, "$THREAD_next", (IV)&((ithread*)0)->next);
+ V(hv, "$THREAD_interp", (IV)&((ithread*)0)->interp);
+ V(hv, "$THREAD_tid", (IV)&((ithread*)0)->tid);
+ V(hv, "$THREAD_state", (IV)&((ithread*)0)->state);
+ V(hv, "$INTERPRETER_curstackinfo", (IV)&((PerlInterpreter*)0)->Tcurstackinfo);
+ V(hv, "$COP_file", (IV)&((COP*)0)->cop_file);
+# endif
+#else
+ V(hv, "$COP_gv", (IV)&((COP*)0)->cop_filegv);
+#endif
+
+ V(hv, "$SV_any", (IV)&((SV*)0)->sv_any);
+ V(hv, "$STACKINFO_cxstack", (IV)&((PERL_SI*)0)->si_cxstack);
+ V(hv, "$STACKINFO_cxix", (IV)&((PERL_SI*)0)->si_cxix);
+ V(hv, "$STACKINFO_prev", (IV)&((PERL_SI*)0)->si_prev);
+ V(hv, "$CONTEXT_sizeof", sizeof(PERL_CONTEXT));
+ V(hv, "$CONTEXT_cop", (IV)&((PERL_CONTEXT*)0)->cx_u.cx_blk.blku_oldcop);
+ V(hv, "$COP_line", (IV)&((COP*)0)->cop_line);
+ V(hv, "$GP_sv", (IV)&((GP*)0)->gp_sv);
+
+#if PERL_VERSION >= 10
+ V(hv, "$CONTEXT_type", (IV)&((PERL_CONTEXT*)0)->cx_u.cx_subst.sbu_type);
+ V(hv, "$GV_gp", (IV)&((GV*)0)->sv_u.svu_gp);
+ V(hv, "$SV_pv", (IV)&((SV*)0)->sv_u.svu_pv);
+#else
+ V(hv, "$CONTEXT_type", (IV)&((PERL_CONTEXT*)0)->cx_type);
+ V(hv, "$GV_gp", (IV)&((XPVGV*)0)->xgv_gp);
+ V(hv, "$XPV_pv", (IV)&((XPV*)0)->xpv_pv);
+#endif
+
+#if PERL_VERSION >= 12
+ V(hv, "$SV_iv", (IV)&((struct xpvuv*)0)->xuv_u.xivu_uv);
+#elif PERL_VERSION >= 10
+ V(hv, "$SV_uv", (IV)&((struct xpvuv*)0)->xuv_u.xuvu_uv);
+#else
+ V(hv, "$SV_uv", (IV)&((struct xpvuv*)0)->xuv_uv);
+#endif
+ return newRV_noinc((SV*) hv);
+}
+
+MODULE = App::Stacktrace PACKAGE = App::Stacktrace
+
+SV*
+perl_offsets()
diff --git a/bin/pstack b/bin/pstack
new file mode 100644
index 0000000..fe3f608
--- /dev/null
+++ b/bin/pstack
@@ -0,0 +1,8 @@
+#!/usr/bin/perl
+use App::Stacktrace;
+App::Stacktrace->new->run(@ARGV);
+exit;
+
+=head1 NAME
+=head1 DESCRIPTION
+=head1 SYNOPSIS
diff --git a/dist.ini b/dist.ini
new file mode 100644
index 0000000..6ca95b6
--- /dev/null
+++ b/dist.ini
@@ -0,0 +1,39 @@
+name = App-Stacktrace
+author = Josh Jore <jjore at cpan.org>
+license = Perl_5
+copyright_holder = Josh Jore
+copyright_year = 2011
+
+version = 0.01
+
+[GatherDir]
+[PruneCruft]
+except = \.gitignore
+[ManifestSkip]
+
+[MetaResources]
+homepage = http://search.cpan.org/dist/Internals-CountObjects
+bugtracker.web = http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Stacktrace
+bugtracker.mailto = bug-App-Stacktrace at rt.cpan.org
+repository.url = git://github.com/jbenjore/App-Stacktrace.git
+repository.web = http://github.com/jbenjore/App-Stacktrace
+repository.type = git
+[MetaYAML]
+[MetaJSON]
+[License]
+[PkgVersion]
+[PodVersion]
+[PodCoverageTests]
+[PodSyntaxTests]
+[ExtraTests]
+[ExecDir]
+[ShareDir]
+[Manifest]
+[Git::Check]
+
+[ConfirmRelease]
+
+[Git::Commit]
+[Git::Tag]
+[Git::Push]
+[UploadToCPAN]
diff --git a/lib/App/Stacktrace.pm b/lib/App/Stacktrace.pm
new file mode 100644
index 0000000..b3b1221
--- /dev/null
+++ b/lib/App/Stacktrace.pm
@@ -0,0 +1,180 @@
+package App::Stacktrace;
+
+=head1 NAME
+
+App::Stacktrace - Stack trace
+
+=head1 SYNOPSIS
+
+ pstack [option] pid
+
+ --pid process id for which the stack trace is to be printed. The
+ process must be a Perl process.
+ --help
+
+=head1 DESCRIPTION
+
+pstack 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.
+
+=cut
+
+use strict;
+use Config ();
+use English -no_match_vars;
+use Getopt::Long ();
+use Pod::Usage ();
+use XSLoader ();
+use File::Temp ();
+
+our $VERSION = '0.01';
+
+XSLoader::load(__PACKAGE__, $VERSION);
+
+sub new {
+ my $class = shift;
+ my $self = {
+ pid => undef,
+ version => undef,
+ arch => undef,
+ @_
+ };
+ return bless $self, $class;
+}
+
+sub read_arguments {
+ my ($self) = @_;
+ local @ARGV = @_;
+ Getopt::Long::GetOptions(
+ $self,
+ help => sub {
+ Pod::Usage::pod2usage(
+ -verbose => 2,
+ -exitcode => 0 );
+ },
+ 'version=s',
+ 'arch=s',
+ )
+ or Pod::Usage::pod2usage(
+ -verbose => 2,
+ -exitcode => 2 );
+ if (1 == @ARGV && $ARGV[0] =~ /^\d+$/) {
+ $self->{pid} = shift @ARGV;
+ }
+ if (@ARGV) {
+ Pod::Usage::pod2usage( -verbose => 2, -exitcode => 2 );
+ }
+
+ return;
+}
+
+sub run {
+ my $self = shift;
+
+ $self->read_arguments( @_ );
+
+ if ($self->{same_perl}) {
+ $self->run_gdb($self->custom_generated_script);
+ }
+ else {
+ die 'Not implemented';
+ }
+
+ 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) = @_;
+
+ # TODO: what are the failure modes of File::Temp?
+ my $tmp = File::Temp->new(
+ UNLINK => 0,
+ SUFFIX => '.gdb',
+ );
+ my $file = $tmp->filename;
+
+ my $this_library = __FILE__;
+ print { $tmp } <<"TODO_preamble" or die "Can't write to $file: $!";;
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by $this_library from its data.
+# Any changes made here will be lost!
+#
+TODO_preamble
+
+ my $offsets = App::Stacktrace::perl_offsets();
+ for my $name (sort keys %$offsets) {
+ print { $tmp } "set $name = $offsets->{$name}\n"
+ or die "Can't write to $file: $!";
+ }
+
+ if ($Config::Config{usethreads}) {
+ require threads;
+ my $key = "threads::_pool$threads::VERSION";
+ my $len = length $key;
+ print { $tmp } <<"THREADS" or die "Can't write to $file: $!";
+set \$POOL_KEY = "$key"
+set \$POOL_KEY_LEN = $len
+THREADS
+ }
+
+ open my $template_fh, '<', $template_script
+ or die "Can't open $template_script: $!";
+ local $/;
+ print { $tmp } readline $template_fh;
+
+ $tmp->flush;
+ $tmp->sync;
+
+ return $tmp;
+}
+
+sub command_for_version {
+ return
+ $] >= 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, $file) = @_;
+
+ my $command = $self->command_for_version;
+
+ my @cmd = (
+ 'gdb',
+ '-q',
+ '-batch',
+ '-p', $self->{pid},
+ '-x', $file,
+ '-ex', $command,
+ );
+ 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;
+
+ exit $rc;
+}
+
+q{Bartender, I'll have a Gordon Freeman on the rocks, thanks.}
diff --git a/lib/App/Stacktrace/perl_backtrace_raw.txt b/lib/App/Stacktrace/perl_backtrace_raw.txt
new file mode 100644
index 0000000..991d393
--- /dev/null
+++ b/lib/App/Stacktrace/perl_backtrace_raw.txt
@@ -0,0 +1,411 @@
+# Provides the commands:
+#
+# perl_backtrace_5_10
+# perl_backtrace_5_12
+# perl_backtrace_5_14
+#
+# Example usage:
+#
+# gdb -p 7107
+# (gdb) source gdbinit.txt
+# (gdb) set trace-commands on
+# (gdb) perl_backtrace
+# (gdb) detach
+# (gdb) quit
+
+perl_backtrace_5_14_x -> perl_backtrace_5_12_threads
+perl_backtrace_5_14_x -> perl_backtrace_nothreads
+perl_backtrace_5_12_x -> perl_backtrace_5_12_threads
+perl_backtrace_5_12_x -> perl_backtrace_nothreads
+perl_backtrace_5_12_threads -> perl_backtrace_a_thread
+perl_backtrace_5_12_threads -> perl_backtrace_an_interp
+perl_backtrace_5_10_x -> perl_backtrace_5_10_threads
+perl_backtrace_5_10_x -> perl_backtrace_nothreads
+perl_backtrace_5_10_threads -> perl_backtrace_a_thread
+perl_backtrace_5_10_threads -> perl_backtrace_an_interp
+perl_backtrace_5_8_9 -> perl_backtrace_5_8_9_threads
+perl_backtrace_5_8_9 -> perl_backtrace_5_8_nothreads
+perl_backtrace_5_8_9_threads -> perl_backtrace_5_8_9_a_thread
+perl_backtrace_5_8_9_a_thread -> perl_backtrace_5_8_9_an_interp
+perl_backtrace_5_8_9_an_interp
+perl_backtrace_5_8_x -> perl_backtrace_5_8_threads
+perl_backtrace_5_8_x -> perl_backtrace_5_8_nothreads
+perl_backtrace_5_8_threads -> perl_backtrace_5_8_a_thread
+perl_backtrace_5_8_a_thread -> perl_backtrace_5_8_an_interp
+perl_backtrace_5_8_an_interp
+perl_backtrace_5_8_nothreads
+#perl_backtrace_an_interp
+#perl_backtrace_a_thread
+#perl_backtrace_nothreads
+
+
+set trace-commands on
+set $DEBUG = 0
+set $CXTYPEMASK = 0xf
+set $PERL_ITHR_JOINABLE = 0
+set $PERL_ITHR_DETACHED = 1
+set $PERL_ITHR_JOINED = 2
+set $PERL_ITHR_FINISHED = 4
+set $PERL_ITHR_THREAD_EXIT_ONLY = 8
+set $PERL_ITHR_NONVIABLE = 16
+set $PERL_ITHR_DIED = 32
+
+set $PERL_ITHR_UNCALLABLE = $PERL_ITHR_DETACHED | $PERL_ITHR_JOINED
+
+define perl_backtrace_an_interp
+ set $stackinfo = (int) *((int*) ($INTERPRETER_curstackinfo + (int) $interpreter))
+ while $stackinfo != 0
+ set $cxstack = (int) *((int*) ($STACKINFO_cxstack + (int) $stackinfo))
+ set $cxix = (int) *((int*) ($STACKINFO_cxix + (int) $stackinfo))
+ set $i = 0
+ while $i <= $cxix
+ set $context = (int) (($CONTEXT_sizeof * $i) + (int) $cxstack)
+ set $type = (int) (((int) *((int*) ($CONTEXT_type + (int) $context))) & $CXTYPEMASK)
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $file = 0
+ set $cop = (int) *((int*) ($CONTEXT_cop + (int) $context))
+ set $file = (char*) *(int*) ($COP_file + (int) $cop)
+ if $file == 0
+ set $file = "undef"
+ end
+ set $line = (int) *((int*) ($COP_line + (int) $cop))
+ printf "%s:%d\n", $file, $line
+ else
+ if $DEBUG
+ printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
+ end
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = (int) *((int*) ($STACKINFO_prev + (int) $stackinfo))
+ end
+end
+define perl_backtrace_a_thread
+ set $tid = (int) *((int*) ($THREAD_tid + (int) $thread))
+ set $statei = (int) *((int*) ($THREAD_state + (int) $thread))
+ if $statei == $PERL_ITHR_DETACHED
+ set $state = "detached"
+ else
+ if $statei == $PERL_ITHR_JOINED
+ set $state = "joined"
+ else
+ if $statei = $PERL_ITHR_FINISHED
+ set $state = "finished"
+ else
+ if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
+ set $state = "exit()"
+ else
+ if $statei == $PERL_ITHR_NONVIABLE
+ set $state = "thread creation failed"
+ else
+ if $statei == $PERL_ITHR_DIED
+ set $state = "died"
+ else
+ if $statei == $PERL_ITHR_UNCALLABLE
+ set $state = "uncallable"
+ else
+ set $state = "???"
+ end
+ end
+ end
+ end
+ end
+ end
+ end
+ printf "thread %d %s:\n", $tid, $state
+ set $interpreter = (int) *((int*) ($THREAD_interpreter + (int) $thread))
+ perl_backtrace_an_interp
+end
+define perl_backtrace_nothreads
+ set $stackinfo = (int) PL_curstackinfo
+ while $stackinfo
+ set $cxstack = (int) *((int*) ($STACKINFO_cxstack + (int) $stackinfo))
+ set $cxix = (int) *((int*) ($STACKINFO_cxix + (int) $stackinfo))
+ set $i = 0
+ while $i <= $cxix
+ set $context = (int) (($CONTEXT_sizeof * $i) + (int) $cxstack)
+ set $type = (int) (((int) *((int*) ($CONTEXT_type + (int) $context))) & $CXTYPEMASK)
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $file = 0
+ set $cop = (int) *((int*) ($CONTEXT_cop + (int) $context))
+ set $gv = (int) *((int*) ($COP_gv + (int) $cop))
+ if $gv
+ set $sv = (int) *((int*) ($GP_sv + *((int*) ($GV_gp + (int) $gv))))
+ if $sv
+ set $file = (char*) *(int*) ($SV_pv + (int) $sv)
+ end
+ end
+ if ! $file
+ set $file = "undef"
+ end
+ set $line = (int) *((int*) ($COP_line + (int) $cop))
+ printf "%s:%d\n", $file, $line
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = (int) *((int*) ($STACKINFO_prev + (int) $stackinfo))
+ end
+end
+
+define perl_backtrace_5_8_an_interp
+ set $stackinfo = (int) *((int*) ($INTERPRETER_curstackinfo + (int) $interpreter))
+ while $stackinfo
+ set $cxstack = (int) *((int*) ($STACKINFO_cxstack + (int) $stackinfo))
+ set $cxix = (int) *((int*) ($STACKINFO_cxix + (int) $stackinfo))
+ set $i = 0
+ while $i <= $cxix
+ set $context = (int) (($CONTEXT_sizeof * $i) + (int) $cxstack)
+ set $type = (int) (((int) *($CONTEXT_type + (int) $context)) & $CXTYPEMASK)
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $file = 0
+ set $cop = (int) *((int*) ($CONTEXT_cop + (int) $context))
+ set $file = (char*) *(int*) ($COP_file + (int) $cop)
+ if ! $file
+ set $file = "undef"
+ end
+ set $line = (int) *((int*) ($COP_line + (int) $cop))
+ printf "%s:%d\n", $file, $line
+ else
+ if $DEBUG
+ printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
+ end
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = (int) *((int*) ($STACKINFO_prev + (int) $stackinfo))
+ end
+end
+define perl_backtrace_5_8_nothreads
+ set $stackinfo = (int) PL_curstackinfo
+ while $stackinfo
+ set $cxstack = (int) *((int*) ($STACKINFO_cxstack + (int) $stackinfo))
+ set $cxix = (int) *((int*) ($STACKINFO_cxix + (int) $stackinfo))
+ set $i = 0
+ while $i <= $cxix
+ set $context = (int) (($CONTEXT_sizeof * $i) + (int) $cxstack)
+ set $type = (int) (((int) *($CONTEXT_type + (int) $context)) & $CXTYPEMASK)
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $cop = (int) *((int*) ($CONTEXT_cop + (int) $context))
+ set $gv = (int) *((int*) ($COP_gv + (int) $cop))
+ if $gv
+ set $sv = (int) *((int*) ($GP_sv + *((int*) ($GV_gp + *((int*) ($SV_any + (int) $gv))))))
+ if $sv
+ set $file = (char*) ($XPV_pv + (int) *((int*) ($SV_any + (int) $sv)))
+ else
+ set $file = "undef"
+ end
+ else
+ set $file = "undef"
+ end
+ set $line = (int) *((int*) ($COP_line + (int) $cop))
+ printf "%s:%d\n", $file, $line
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = (int) *((int*) ($STACKINFO_prev + (int) $stackinfo))
+ end
+end
+define perl_backtrace_5_8_a_thread
+ if $thread
+ set $tid = (int) *((int*) ($THREAD_tid + (int) $thread))
+ set $statei = (int) *((int*) ($THREAD_state + (int) $thread))
+ if $statei == $PERL_ITHR_DETACHED
+ set $state = "detached"
+ else
+ if $statei == $PERL_ITHR_JOINED
+ set $state = "joined"
+ else
+ if $statei = $PERL_ITHR_FINISHED
+ set $state = "finished"
+ else
+ if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
+ set $state = "exit()"
+ else
+ if $statei == $PERL_ITHR_NONVIABLE
+ set $state = "thread creation failed"
+ else
+ if $statei == $PERL_ITHR_DIED
+ set $state = "died"
+ else
+ if $statei == $PERL_ITHR_UNCALLABLE
+ set $state = "uncallable"
+ else
+ set $state = "???"
+ end
+ end
+ end
+ end
+ end
+ end
+ end
+ printf "thread %d %s:\n", $tid, $state
+ set $interpreter = (int) *((int*) ($THREAD_interpreter + (int) $thread))
+ else
+ set $interpreter = (int) my_perl
+ end
+ perl_backtrace_5_8_an_interp
+end
+define perl_backtrace_5_8_threads
+ set $main_thread = (int) threads
+ set $thread = $main_thread
+ perl_backtrace_5_8_a_thread
+ if $thread
+ set $thread = (int) *((int*) ($THREAD_next + (int) $thread))
+ while $thread && $thread != $main_thread
+ perl_backtrace_5_8_a_thread
+ set $thread = (int) *((int*) ($THREAD_next + (int) $thread))
+ end
+ end
+end
+define perl_backtrace_5_8_x
+ set $interpreter = (int) Perl_get_context()
+ if $interpreter
+ perl_backtrace_5_8_threads
+ else
+ perl_backtrace_5_8_nothreads
+ end
+end
+
+define perl_backtrace_5_8_9_an_interp
+ set $stackinfo = (int) *((int*) ($INTERPRETER_curstackinfo + (int) $interpreter))
+ while $stackinfo
+ set $cxstack = (int) *((int*) ($STACKINFO_cxstack + (int) $stackinfo))
+ set $cxix = (int) *((int*) ($STACKINFO_cxix + (int) $stackinfo))
+ set $i = 0
+ while $i <= $cxix
+ set $context = (int) (($CONTEXT_sizeof * $i) + (int) $cxstack)
+ set $type = (int) (((int) *((int*) ($CONTEXT_type + (int) $context))) & $CXTYPEMASK)
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $file = 0
+ set $cop = (int) *((int*) ($CONTEXT_cop + (int) $context))
+ set $file = (char*) *(int*) ($COP_file + (int) $cop)
+ if ! $file
+ set $file = "undef"
+ end
+ set $line = (int) *((int*) ($COP_line + (int) $cop))
+ printf "%s:%d\n", $file, $line
+ else
+ if $DEBUG
+ printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
+ end
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = (int) *((int*) ($STACKINFO_prev + (int) $stackinfo))
+ end
+end
+define perl_backtrace_5_8_9_a_thread
+ set $tid = (int) *((int*) ($THREAD_tid + (int) $thread))
+ set $statei = (int) *((int*) ($THREAD_state + (int) $thread))
+ if $statei == $PERL_ITHR_DETACHED
+ set $state = "detached"
+ else
+ if $statei == $PERL_ITHR_JOINED
+ set $state = "joined"
+ else
+ if $statei = $PERL_ITHR_FINISHED
+ set $state = "finished"
+ else
+ if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
+ set $state = "exit()"
+ else
+ if $statei == $PERL_ITHR_NONVIABLE
+ set $state = "thread creation failed"
+ else
+ if $statei == $PERL_ITHR_DIED
+ set $state = "died"
+ else
+ if $statei == $PERL_ITHR_UNCALLABLE
+ set $state = "uncallable"
+ else
+ set $state = "???"
+ end
+ end
+ end
+ end
+ end
+ end
+ end
+ printf "thread %d %s:\n", $tid, $state
+ set $interpreter = (int) *((int*) ($THREAD_interpreter + (int) $thread))
+ perl_backtrace_5_8_9_an_interp
+end
+define perl_backtrace_5_8_9_threads
+ set $main_thread = (int) threads
+ set $thread = $main_thread
+ perl_backtrace_5_8_9_a_thread
+ if $thread
+ set $thread = (int) *((int*) ($THREAD_next + (int) $thread))
+ while $thread && $thread != $main_thread
+ perl_backtrace_5_8_9_a_thread
+ set $thread = (int) *((int*) ($THREAD_next + (int) $thread))
+ end
+ end
+end
+define perl_backtrace_5_8_9
+ set $interpreter = (int) Perl_get_context()
+ if $interpreter
+ perl_backtrace_5_8_9_threads
+ else
+ perl_backtrace_5_8_nothreads
+ end
+end
+define perl_backtrace_5_10_threads
+ set $modglobal = (int) *((int*) ($INTERPRETER_modglobal + (int) $interpreter))
+ set $my_pool_svp = (int) Perl_hv_fetch((int) $interpreter, (int) $modglobal, $POOL_KEY, $POOL_KEY_LEN, 0)
+ if $my_pool_svp
+ set $my_pool_sv = (int) *((int*) (int) $my_pool_svp)
+ set $my_pool_svval = (int) *((int*) ($SV_any + (int) $my_pool_sv))
+ set $my_poolp = (int) *((int*) ($SV_iv + (int) $my_pool_svval))
+ set $main_thread = $POOLP_main_thread + (int) $my_poolp
+ set $thread = $main_thread
+ perl_backtrace_a_thread
+ set $thread = (int) *((int*) ($THREAD_next + (int) $main_thread))
+ while $thread != $main_thread
+ perl_backtrace_a_thread
+ set $thread = (int) *((int*) ($THREAD_next + (int) $thread))
+ end
+ else
+ set $interpreter = (int) my_perl
+ perl_backtrace_an_interp
+ end
+end
+define perl_backtrace_5_10_x
+ set $interpreter = (int) Perl_get_context()
+ if $interpreter
+ perl_backtrace_5_10_threads
+ else
+ perl_backtrace_nothreads
+ end
+end
+define perl_backtrace_5_12_threads
+ set $modglobal = (int) *((int*) ($INTERPRETER_modglobal + (int) $interpreter))
+ set $my_pool_svp = (int) Perl_hv_fetch((int) $interpreter, (int) $modglobal, $POOL_KEY, $POOL_KEY_LEN, 0)
+ if $my_pool_svp
+ set $my_pool_sv = (int) *((int*) (int) $my_pool_svp)
+ set $my_pool_svval = (int) *((int*) ($SV_any + (int) $my_pool_sv))
+ set $my_poolp = (int) *((int*) ($SV_uv + (int) $my_pool_svval))
+ set $main_thread = $POOLP_main_thread + (int) $my_poolp
+ set $thread = $main_thread
+ perl_backtrace_a_thread
+ set $thread = (int) *((int*) ($THREAD_next + (int) $main_thread))
+ while $thread != $main_thread
+ perl_backtrace_a_thread
+ set $thread = (int) *((int*) ($THREAD_next + (int) $thread))
+ end
+ else
+ set $interpreter = (int) my_perl
+ perl_backtrace_an_interp
+ end
+end
+define perl_backtrace_5_12_x
+ set $interpreter = (int) Perl_get_context()
+ if $interpreter
+ perl_backtrace_5_12_threads
+ else
+ perl_backtrace_nothreads
+ end
+end
+define perl_backtrace_5_14_x
+ perl_backtrace_5_12_x
+end
diff --git a/lib/App/Stacktrace/perl_backtrace_symbols.txt b/lib/App/Stacktrace/perl_backtrace_symbols.txt
new file mode 100644
index 0000000..dfae567
--- /dev/null
+++ b/lib/App/Stacktrace/perl_backtrace_symbols.txt
@@ -0,0 +1,431 @@
+# Provides the commands:
+#
+# perl_backtrace_5_10
+# perl_backtrace_5_12
+# perl_backtrace_5_14
+#
+# Example usage:
+#
+# gdb -p 7107
+# (gdb) source gdbinit.txt
+# (gdb) set trace-commands on
+# (gdb) perl_backtrace
+# (gdb) detach
+# (gdb) quit
+
+set $DEBUG = 0
+set $CXTYPEMASK = 0xf
+set $PERL_ITHR_JOINABLE = 0
+set $PERL_ITHR_DETACHED = 1
+set $PERL_ITHR_JOINED = 2
+set $PERL_ITHR_FINISHED = 4
+set $PERL_ITHR_THREAD_EXIT_ONLY = 8
+set $PERL_ITHR_NONVIABLE = 16
+set $PERL_ITHR_DIED = 32
+
+set $PERL_ITHR_UNCALLABLE = $PERL_ITHR_DETACHED | $PERL_ITHR_JOINED
+
+define perl_backtrace_an_interp
+ set $stackinfo = (PERL_SI*)$interpreter->Icurstackinfo
+ while $stackinfo != 0
+ set $cxstack = $stackinfo->si_cxstack
+ set $cxix = $stackinfo->si_cxix
+ set $i = 0
+ while $i <= $cxix
+ set $context = $cxstack[$i]
+ set $type = $context->cx_u.cx_subst.sbu_type & $CXTYPEMASK
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $file = 0
+ set $cop = $context->cx_u.cx_blk.blku_oldcop
+ set $file = $cop->cop_file
+ if $file == 0
+ set $file = "undef"
+ end
+ set $line = $cop->cop_line
+ printf "%s:%d\n", $file, $line
+ else
+ if $DEBUG
+ printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
+ end
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = $stackinfo->si_prev
+ end
+end
+define perl_backtrace_a_thread
+ set $tid = $thread->tid
+ set $statei = $thread->state
+ if $statei == $PERL_ITHR_DETACHED
+ set $state = "detached"
+ else
+ if $statei == $PERL_ITHR_JOINED
+ set $state = "joined"
+ else
+ if $statei = $PERL_ITHR_FINISHED
+ set $state = "finished"
+ else
+ if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
+ set $state = "exit()"
+ else
+ if $statei == $PERL_ITHR_NONVIABLE
+ set $state = "thread creation failed"
+ else
+ if $statei == $PERL_ITHR_DIED
+ set $state = "died"
+ else
+ if $statei == $PERL_ITHR_UNCALLABLE
+ set $state = "uncallable"
+ else
+ set $state = "???"
+ end
+ end
+ end
+ end
+ end
+ end
+ end
+ printf "thread %d %s:\n", $tid, $state
+ set $interpreter = $thread->interp
+ perl_backtrace_an_interp
+end
+define perl_backtrace_nothreads
+ set $stackinfo = PL_curstackinfo
+ while $stackinfo
+ set $cxstack = $stackinfo->si_cxstack
+ set $cxix = $stackinfo->si_cxix
+ set $i = 0
+ while $i <= $cxix
+ set $context = $cxstack[$i]
+ set $type = $context->cx_u.cx_subst.sbu_type & $CXTYPEMASK
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $file = 0
+ set $cop = $context->cx_u.cx_blk.blku_oldcop
+ set $gv = $cop->cop_filegv
+ if $gv
+ set $sv = $gv->sv_u.svu_gp->gp_sv
+ if $sv
+ set $file = $sv->sv_u.svu_pv
+ end
+ end
+ if ! $file
+ set $file = "undef"
+ end
+ set $line = $cop->cop_line
+ printf "%s:%d\n", $file, $line
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = $stackinfo->si_prev
+ end
+end
+
+define perl_backtrace_5_8_an_interp
+ set $stackinfo = (PERL_SI*)$interpreter->Tcurstackinfo
+ while $stackinfo
+ set $cxstack = $stackinfo->si_cxstack
+ set $cxix = $stackinfo->si_cxix
+ set $i = 0
+ while $i <= $cxix
+ set $context = $cxstack[$i]
+ set $type = $context->cx_type & $CXTYPEMASK
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $file = 0
+ set $cop = $context->cx_u.cx_blk.blku_oldcop
+ set $file = $cop->cop_file
+ if ! $file
+ set $file = "undef"
+ end
+ set $line = $cop->cop_line
+ printf "%s:%d\n", $file, $line
+ else
+ if $DEBUG
+ printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
+ end
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = $stackinfo->si_prev
+ end
+end
+define perl_backtrace_5_8_nothreads
+ set $stackinfo = PL_curstackinfo
+ while $stackinfo
+ set $cxstack = $stackinfo->si_cxstack
+ set $cxix = $stackinfo->si_cxix
+ set $i = 0
+ while $i <= $cxix
+ set $context = $cxstack[$i]
+ set $type = $context->cx_type & $CXTYPEMASK
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $cop = $context->cx_u.cx_blk.blku_oldcop
+ set $gv = $cop->cop_filegv
+ if $gv
+ set $sv = (((struct xpvgv*)($gv)->sv_any)->xgv_gp)->gp_sv
+ if $sv
+ set $file = ((struct xpv*) ($sv)->sv_any)->xpv_pv
+ else
+ set $file = "undef"
+ end
+ else
+ set $file = "undef"
+ end
+ set $line = $cop->cop_line
+ printf "%s:%d\n", $file, $line
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = $stackinfo->si_prev
+ end
+end
+define perl_backtrace_5_8_a_thread
+ if $thread
+ set $tid = $thread->tid
+ set $statei = $thread->state
+ if $statei == $PERL_ITHR_DETACHED
+ set $state = "detached"
+ else
+ if $statei == $PERL_ITHR_JOINED
+ set $state = "joined"
+ else
+ if $statei = $PERL_ITHR_FINISHED
+ set $state = "finished"
+ else
+ if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
+ set $state = "exit()"
+ else
+ if $statei == $PERL_ITHR_NONVIABLE
+ set $state = "thread creation failed"
+ else
+ if $statei == $PERL_ITHR_DIED
+ set $state = "died"
+ else
+ if $statei == $PERL_ITHR_UNCALLABLE
+ set $state = "uncallable"
+ else
+ set $state = "???"
+ end
+ end
+ end
+ end
+ end
+ end
+ end
+ printf "thread %d %s:\n", $tid, $state
+ set $interpreter = $thread->interp
+ else
+ set $interpreter = my_perl
+ end
+ perl_backtrace_5_8_an_interp
+end
+define perl_backtrace_5_8_threads
+ set $main_thread = threads
+ set $thread = $main_thread
+ perl_backtrace_5_8_a_thread
+ if $thread
+ set $thread = $thread->next
+ while $thread && $thread != $main_thread
+ perl_backtrace_5_8_a_thread
+ set $thread = $thread->next
+ end
+ end
+end
+define perl_backtrace_5_8
+ set $CXt_SUB = 1
+ set $CXt_EVAL = 2
+ set $CXt_FORMAT = 6
+ set $interpreter = (PerlInterpreter*)Perl_get_context()
+ if $interpreter
+ perl_backtrace_5_8_threads
+ else
+ perl_backtrace_5_8_nothreads
+ end
+end
+
+define perl_backtrace_5_8_9_an_interp
+ set $stackinfo = (PERL_SI*)$interpreter->Icurstackinfo
+ while $stackinfo
+ set $cxstack = $stackinfo->si_cxstack
+ set $cxix = $stackinfo->si_cxix
+ set $i = 0
+ while $i <= $cxix
+ set $context = $cxstack[$i]
+ set $type = $context->cx_u.cx_subst.sbu_type & $CXTYPEMASK
+ if $type == $CXt_SUB || $type == $CXt_EVAL || $type == $CXt_FORMAT
+ set $file = 0
+ set $cop = $context->cx_u.cx_blk.blku_oldcop
+ set $file = $cop->cop_file
+ if ! $file
+ set $file = "undef"
+ end
+ set $line = $cop->cop_line
+ printf "%s:%d\n", $file, $line
+ else
+ if $DEBUG
+ printf "%d\t... # (context*){cx_type=%d}\n", $i, $type
+ end
+ end
+ set $i = $i + 1
+ end
+ set $stackinfo = $stackinfo->si_prev
+ end
+end
+define perl_backtrace_5_8_9_nothreads
+ perl_backtrace_5_8_nothreads
+end
+define perl_backtrace_5_8_9_a_thread
+ set $tid = $thread->tid
+ set $statei = $thread->state
+ if $statei == $PERL_ITHR_DETACHED
+ set $state = "detached"
+ else
+ if $statei == $PERL_ITHR_JOINED
+ set $state = "joined"
+ else
+ if $statei = $PERL_ITHR_FINISHED
+ set $state = "finished"
+ else
+ if $statei == $PERL_ITHR_THREAD_EXIT_ONLY
+ set $state = "exit()"
+ else
+ if $statei == $PERL_ITHR_NONVIABLE
+ set $state = "thread creation failed"
+ else
+ if $statei == $PERL_ITHR_DIED
+ set $state = "died"
+ else
+ if $statei == $PERL_ITHR_UNCALLABLE
+ set $state = "uncallable"
+ else
+ set $state = "???"
+ end
+ end
+ end
+ end
+ end
+ end
+ end
+ printf "thread %d %s:\n", $tid, $state
+ set $interpreter = $thread->interp
+ perl_backtrace_5_8_9_an_interp
+end
+define perl_backtrace_5_8_9_threads
+ set $main_thread = threads
+ set $thread = $main_thread
+ perl_backtrace_5_8_9_a_thread
+ if $thread
+ set $thread = $thread->next
+ while $thread && $thread != $main_thread
+ perl_backtrace_5_8_9_a_thread
+ set $thread = $thread->next
+ end
+ end
+end
+define perl_backtrace_5_8_9
+ set $CXt_SUB = 1
+ set $CXt_EVAL = 2
+ set $CXt_FORMAT = 6
+ set $interpreter = (PerlInterpreter*)Perl_get_context()
+ if $interpreter
+ set $POOL_KEY = "threads::_pool1.71"
+ set $POOL_KEY_LEN = 18
+ perl_backtrace_5_8_9_threads
+ else
+ perl_backtrace_5_8_nothreads
+ end
+end
+
+define perl_backtrace_5_10_threads
+ set $modglobal = $interpreter->Imodglobal
+ set $my_pool_svp = Perl_hv_fetch($interpreter, $modglobal, $POOL_KEY, $POOL_KEY_LEN, 0)
+ if $my_pool_svp
+ set $my_pool_sv = *$my_pool_svp
+ set $my_pool_svval = (struct xpvuv*)($my_pool_sv->sv_any)
+ set $my_poolp = (my_pool_t*)($my_pool_svval->xuv_u.xuvu_uv)
+ set $main_thread = &($my_poolp->main_thread)
+ set $thread = $main_thread
+ perl_backtrace_a_thread
+ set $thread = $main_thread->next
+ while $thread != $main_thread
+ perl_backtrace_a_thread
+ set $thread = $thread->next
+ end
+ else
+ set $interpreter = my_perl
+ perl_backtrace_an_interp
+ end
+end
+define perl_backtrace_5_10_0
+ set $CXt_SUB = 1
+ set $CXt_EVAL = 2
+ set $CXt_FORMAT = 6
+ set $interpreter = (PerlInterpreter*)Perl_get_context()
+ if $interpreter
+ set $POOL_KEY = "threads::_pool1.67"
+ set $POOL_KEY_LEN = 18
+ perl_backtrace_5_10_threads
+ else
+ perl_backtrace_nothreads
+ end
+end
+define perl_backtrace_5_10_1
+ set $CXt_SUB = 1
+ set $CXt_EVAL = 2
+ set $CXt_FORMAT = 6
+ set $interpreter = (PerlInterpreter*)Perl_get_context()
+ if $interpreter
+ set $POOL_KEY = "threads::_pool1.72"
+ set $POOL_KEY_LEN = 18
+ perl_backtrace_5_10_threads
+ else
+ perl_backtrace_nothreads
+ end
+end
+
+define perl_backtrace_5_12_threads
+ set $modglobal = $interpreter->Imodglobal
+ set $my_pool_svp = Perl_hv_fetch($interpreter, $modglobal, $POOL_KEY, $POOL_KEY_LEN, 0)
+ if $my_pool_svp
+ set $my_pool_sv = *$my_pool_svp
+ set $my_pool_svval = (struct xpvuv*)($my_pool_sv->sv_any)
+ set $my_poolp = (my_pool_t*)($my_pool_svval->xuv_u.xivu_uv)
+ set $main_thread = &($my_poolp->main_thread)
+ set $thread = $main_thread
+ perl_backtrace_a_thread
+ set $thread = $main_thread->next
+ while $thread != $main_thread
+ perl_backtrace_a_thread
+ set $thread = $thread->next
+ end
+ else
+ set $interpreter = my_perl
+ perl_backtrace_an_interp
+ end
+end
+define perl_backtrace_5_12
+ set $CXt_SUB = 8
+ set $CXt_FORMAT = 9
+ set $CXt_EVAL = 10
+ set $interpreter = (PerlInterpreter*)Perl_get_context()
+ if $interpreter
+ set $POOL_KEY = "threads::_pool1.75"
+ set $POOL_KEY_LEN = 18
+ perl_backtrace_5_12_threads
+ else
+ perl_backtrace_nothreads
+ end
+end
+
+define perl_backtrace_5_14
+ set $CXt_SUB = 8
+ set $CXt_FORMAT = 9
+ set $CXt_EVAL = 10
+ set $interpreter = (PerlInterpreter*)Perl_get_context()
+ if $interpreter
+ set $POOL_KEY = "threads::_pool1.83"
+ set $POOL_KEY_LEN = 18
+ perl_backtrace_5_12_threads
+ else
+ perl_backtrace_nothreads
+ end
+end
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..540b3bb
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,14 @@
+use Test::More tests => 1;
+use Data::Dumper;
+use Config;
+
+$Data::Dumper::Sortkeys = 1;
+$Data::Dumper::Varname = 'config';
+$Data::Dumper::Terse = 1;
+diag(Dumper(\%Config));
+
+require App::Stacktrace;
+$Data::Dumper::Varname = 'perl_offsets';
+diag(Dumper(App::Stacktrace::perl_offsets()));
+
+pass('Loaded ok');
diff --git a/threads.h b/threads.h
new file mode 100644
index 0000000..d6bd130
--- /dev/null
+++ b/threads.h
@@ -0,0 +1,41 @@
+typedef struct _ithread {
+ struct _ithread *next; /* Next thread in the list */
+ struct _ithread *prev; /* Prev thread in the list */
+ PerlInterpreter *interp; /* The threads interpreter */
+ UV tid; /* Threads module's thread id */
+ perl_mutex mutex; /* Mutex for updating things in this struct */
+ int count; /* Reference count. See S_ithread_create. */
+ int state; /* Detached, joined, finished, etc. */
+ int gimme; /* Context of create */
+ SV *init_function; /* Code to run */
+ AV *params; /* Args to pass function */
+#ifdef WIN32
+ DWORD thr; /* OS's idea if thread id */
+ HANDLE handle; /* OS's waitable handle */
+#else
+ pthread_t thr; /* OS's handle for the thread */
+#endif
+ IV stack_size;
+ SV *err; /* Error from abnormally terminated thread */
+ char *err_class; /* Error object's classname if applicable */
+#ifndef WIN32
+ sigset_t initial_sigmask; /* Thread wakes up with signals blocked */
+#endif
+} ithread;
+
+typedef struct {
+ /* Structure for 'main' thread
+ * Also forms the 'base' for the doubly-linked list of threads */
+ ithread main_thread;
+
+ /* Protects the creation and destruction of threads*/
+ perl_mutex create_destruct_mutex;
+
+ UV tid_counter;
+ IV joinable_threads;
+ IV running_threads;
+ IV detached_threads;
+ IV total_threads;
+ IV default_stack_size;
+ IV page_size;
+} my_pool_t;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libapp-stacktrace-perl.git
More information about the Pkg-perl-cvs-commits
mailing list