[libapp-stacktrace-perl] 03/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 3b38af8a3d321799ff6134207eba129c650a957f
Author: Josh ben Jore <jjore at cpan.org>
Date: Mon Jun 13 08:04:25 2011 -0700
import
---
Makefile.PL | 3 +-
Stacktrace.xs | 8 +-
bin/perl-stacktrace | 22 +++++
bin/pstack | 8 --
dist.ini | 3 +-
lib/App/Stacktrace.pm | 136 +++++++++++++++-----------
lib/App/Stacktrace/perl_backtrace_raw.txt | 56 +++++------
lib/App/Stacktrace/perl_backtrace_symbols.txt | 14 +--
t/basic.t | 2 +-
t/unthreaded.t | 118 ++++++++++++++++++++++
threads.h | 2 +
11 files changed, 267 insertions(+), 105 deletions(-)
diff --git a/Makefile.PL b/Makefile.PL
index 942d09c..667bc30 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,3 +1,4 @@
+use 5.010_000;
use ExtUtils::MakeMaker;
if (! `which gdb`) {
@@ -9,7 +10,7 @@ WriteMakefile(
ABSTRACT_FROM => 'lib/App/Stacktrace.pm',
AUTHOR => 'Josh Jore <jjore at cpan.org>',
EXE_FILES => [
- 'bin/pstack'
+ 'bin/perl-stacktrace'
],
$ExtUtils::MakeMaker::VERSION >= 6.30
? (LICENSE => 'perl')
diff --git a/Stacktrace.xs b/Stacktrace.xs
index 1e24749..aedd399 100644
--- a/Stacktrace.xs
+++ b/Stacktrace.xs
@@ -12,10 +12,14 @@
#include "threads.h"
SV*
-perl_offsets() {
+_perl_offsets() {
HV *hv = newHV();;
V(hv, "$CXTYPEMASK", (IV)CXTYPEMASK);
+ V(hv, "$CXt_SUB", (IV)CXt_SUB);
+ V(hv, "$CXt_EVAL", (IV)CXt_EVAL);
+ V(hv, "$CXt_FORMAT", (IV)CXt_FORMAT);
+
#ifdef USE_ITHREADS
# if PERL_VERSION >= 10
V(hv, "$POOLP_main_thread", (IV)&((my_pool_t*)0)->main_thread);
@@ -79,4 +83,4 @@ perl_offsets() {
MODULE = App::Stacktrace PACKAGE = App::Stacktrace
SV*
-perl_offsets()
+_perl_offsets()
diff --git a/bin/perl-stacktrace b/bin/perl-stacktrace
new file mode 100644
index 0000000..b3427db
--- /dev/null
+++ b/bin/perl-stacktrace
@@ -0,0 +1,22 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+perl-stacktrace - Stack trace
+
+=head1 DESCRIPTION
+
+pstack prints Perl stack traces of Perl threads for a given Perl
+process. For each Perl frame, filename and line number, if available,
+are printed.
+
+=head1 SYNOPSIS
+
+ perl-stacktrace [pid]
+ --help
+
+=cut
+
+use App::Stacktrace;
+App::Stacktrace->new->run(@ARGV);
+exit;
diff --git a/bin/pstack b/bin/pstack
deleted file mode 100644
index fe3f608..0000000
--- a/bin/pstack
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/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
index 6ca95b6..7e86b1d 100644
--- a/dist.ini
+++ b/dist.ini
@@ -12,7 +12,7 @@ except = \.gitignore
[ManifestSkip]
[MetaResources]
-homepage = http://search.cpan.org/dist/Internals-CountObjects
+homepage = http://search.cpan.org/dist/App-Stacktrace
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
@@ -20,6 +20,7 @@ repository.web = http://github.com/jbenjore/App-Stacktrace
repository.type = git
[MetaYAML]
[MetaJSON]
+[MakeMaker::Runner]
[License]
[PkgVersion]
[PodVersion]
diff --git a/lib/App/Stacktrace.pm b/lib/App/Stacktrace.pm
index b3b1221..0a91b38 100644
--- a/lib/App/Stacktrace.pm
+++ b/lib/App/Stacktrace.pm
@@ -6,17 +6,25 @@ App::Stacktrace - Stack trace
=head1 SYNOPSIS
- pstack [option] pid
+ perl-stacktrace [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.
+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.
+
+=head1 API
+
+=over
+
+=item new
+
+=item run
+
+=back
=cut
@@ -38,13 +46,30 @@ sub new {
pid => undef,
version => undef,
arch => undef,
+ 'exec' => 1,
@_
};
return bless $self, $class;
}
-sub read_arguments {
- my ($self) = @_;
+sub run {
+ my $self = shift;
+
+ $self->_read_arguments( @_ );
+
+ my $script = $self->_custom_generated_script;
+ if ($self->{exec}) {
+ $self->_run_gdb($script);
+ }
+ elsif ($self->{m}) {
+ print $script;
+ }
+
+ return;
+}
+
+sub _read_arguments {
+ my $self = shift;
local @ARGV = @_;
Getopt::Long::GetOptions(
$self,
@@ -53,6 +78,8 @@ sub read_arguments {
-verbose => 2,
-exitcode => 0 );
},
+ 'm',
+ 'exec',
'version=s',
'arch=s',
)
@@ -65,26 +92,14 @@ sub read_arguments {
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';
+ unless ($self->{pid} || $self->{m}) {
}
return;
}
-sub custom_generated_script {
+
+sub _custom_generated_script {
my ($self) = @_;
# TODO: generate this statically
@@ -101,49 +116,46 @@ sub custom_generated_script {
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: $!";;
+ 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
- my $offsets = App::Stacktrace::perl_offsets();
+ 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: $!";
+ $src .= "set $name = $offsets->{$name}\n";
}
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: $!";
+ $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 $/;
- print { $tmp } readline $template_fh;
+ $src .= readline $template_fh;
- $tmp->flush;
- $tmp->sync;
+ my $command = $self->_command_for_version;
+ $src .= <<"INVOKE";
+$command
+detach
+quit
+INVOKE
- return $tmp;
+ return $src;
}
-sub command_for_version {
+sub _command_for_version {
return
$] >= 5.014 ? 'perl_backtrace_5_14_x' :
$] >= 5.012 ? 'perl_backtrace_5_12_x' :
@@ -153,28 +165,40 @@ sub command_for_version {
die 'Support for perl-5.6 or earlier not implemented';
}
-sub run_gdb {
- my ($self, $file) = @_;
+sub _run_gdb {
+ my ($self, $src) = @_;
- my $command = $self->command_for_version;
+ # 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;
my @cmd = (
'gdb',
- '-q',
- '-batch',
- '-p', $self->{pid},
- '-x', $file,
- '-ex', $command,
+ '-quiet',
+ '-batch',
+ '-nx',
+ '-p', $self->{pid},
+ '-x', $file,
);
- 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;
+ if ($self->{exec}) {
+ exec @cmd;
+ }
+ else {
+ system @cmd;
+ my $sig_num = $? & 127;
+ my $core = $? & 128;
+ my $rc = $? >> 8;
- exit $rc;
+ 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.}
diff --git a/lib/App/Stacktrace/perl_backtrace_raw.txt b/lib/App/Stacktrace/perl_backtrace_raw.txt
index 991d393..e61c318 100644
--- a/lib/App/Stacktrace/perl_backtrace_raw.txt
+++ b/lib/App/Stacktrace/perl_backtrace_raw.txt
@@ -1,47 +1,45 @@
# Provides the commands:
#
-# perl_backtrace_5_10
-# perl_backtrace_5_12
-# perl_backtrace_5_14
+# perl_backtrace_5_10_x
+# perl_backtrace_5_12_x
+# perl_backtrace_5_14_x
#
# Example usage:
#
# gdb -p 7107
# (gdb) source gdbinit.txt
-# (gdb) set trace-commands on
-# (gdb) perl_backtrace
+# ... set lots of constants
+# (gdb) perl_backtrace_5_14_x
# (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_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 trace-commands off
set $DEBUG = 0
-set $CXTYPEMASK = 0xf
set $PERL_ITHR_JOINABLE = 0
set $PERL_ITHR_DETACHED = 1
set $PERL_ITHR_JOINED = 2
diff --git a/lib/App/Stacktrace/perl_backtrace_symbols.txt b/lib/App/Stacktrace/perl_backtrace_symbols.txt
index dfae567..a64261d 100644
--- a/lib/App/Stacktrace/perl_backtrace_symbols.txt
+++ b/lib/App/Stacktrace/perl_backtrace_symbols.txt
@@ -1,15 +1,15 @@
# Provides the commands:
#
-# perl_backtrace_5_10
-# perl_backtrace_5_12
-# perl_backtrace_5_14
+# perl_backtrace_5_10_0
+# perl_backtrace_5_10_1
+# perl_backtrace_5_12_x
+# perl_backtrace_5_14_x
#
# Example usage:
#
# gdb -p 7107
# (gdb) source gdbinit.txt
-# (gdb) set trace-commands on
-# (gdb) perl_backtrace
+# (gdb) perl_backtrace_5_14_x
# (gdb) detach
# (gdb) quit
@@ -402,7 +402,7 @@ define perl_backtrace_5_12_threads
perl_backtrace_an_interp
end
end
-define perl_backtrace_5_12
+define perl_backtrace_5_12_x
set $CXt_SUB = 8
set $CXt_FORMAT = 9
set $CXt_EVAL = 10
@@ -416,7 +416,7 @@ define perl_backtrace_5_12
end
end
-define perl_backtrace_5_14
+define perl_backtrace_5_14_x
set $CXt_SUB = 8
set $CXt_FORMAT = 9
set $CXt_EVAL = 10
diff --git a/t/basic.t b/t/basic.t
index 540b3bb..724d528 100644
--- a/t/basic.t
+++ b/t/basic.t
@@ -9,6 +9,6 @@ diag(Dumper(\%Config));
require App::Stacktrace;
$Data::Dumper::Varname = 'perl_offsets';
-diag(Dumper(App::Stacktrace::perl_offsets()));
+diag(Dumper(App::Stacktrace::_perl_offsets()));
pass('Loaded ok');
diff --git a/t/unthreaded.t b/t/unthreaded.t
new file mode 100644
index 0000000..1133f99
--- /dev/null
+++ b/t/unthreaded.t
@@ -0,0 +1,118 @@
+#!/usr/bin/perl
+use strict;
+
+my $WAITED_PID;
+my $WAITED_RC;
+$SIG{CHLD} = sub {
+ $WAITED_PID = wait;
+ $WAITED_RC = $?;
+ die 'Child exited';
+};
+
+my ( $pstack_rd, $pstack_wr );
+pipe( $pstack_rd, $pstack_wr );
+
+my ( $pstack_rd1, $pstack_wr1 );
+pipe( $pstack_rd1, $pstack_wr1 );
+
+my $pstack_ppid = $$;
+my $pstack_pid = fork;
+if (!defined $pstack_pid) {
+ die "Can't fork: $!";
+}
+elsif ($pstack_pid) {
+ require Test::More;
+ Test::More::plan( tests => 5 );
+
+ close $pstack_wr;
+ close $pstack_rd1;
+ syswrite $pstack_wr1, '.';
+ my $trace = '';
+ eval {
+ while (!$WAITED_PID) {
+ my $rin = '';
+ my $ein = '';
+ vec($rin, fileno($pstack_rd), 1) = 1;
+ vec($ein, fileno($pstack_rd), 1) = 1;
+ select $rin, undef, $ein, 60;
+ if (vec $rin, fileno($pstack_rd), 1) {
+ my $bytes = sysread $pstack_rd, $trace, 4096, length $trace;
+ last if 0 == $bytes;
+ }
+ else {
+ last;
+ }
+ }
+ };
+
+ SKIP: {
+ Test::More::diag( $trace );
+ if ( $trace && $trace =~ /ptrace: Operation not permitted/ ) {
+ Test::More::skip("ptrace permissions", 1);
+ }
+
+ Test::More::like(
+ $trace,
+ qr{
+ ^t/unthreaded\.t:\d+\n
+ (?:
+ ^(?:\+*\ *)t/unthreaded\.t:\d+\n
+ ){10}
+ }xm
+ );
+
+ }
+
+ Test::More::is( $WAITED_PID, $pstack_pid, "Reaped pstack" );
+ Test::More::is( $WAITED_RC >> 8, 0, "exit(0)" );
+ Test::More::is( $WAITED_RC & 127, 0, "No signals" );
+ Test::More::is( $WAITED_RC & 128, 0, "No core dump" );
+
+ exit;
+}
+
+close $pstack_rd;
+close $pstack_wr1;
+sysread $pstack_rd1, $_, 1;
+
+$SIG{CHLD} = sub { exit };
+my $script_ppid = $$;
+my $script_pid = fork;
+if (!defined $pstack_pid) {
+ die "Can't fork: $!";
+}
+elsif ($script_pid) {
+ require App::Stacktrace;
+ open STDOUT, '>&=' . fileno( $pstack_wr );
+ open STDERR, '>&=' . fileno( $pstack_wr );
+ App::Stacktrace->new->run(
+ '--exec',
+ $script_pid
+ );
+ kill 2, $script_pid;
+ exit;
+}
+
+$SIG{INT} = sub { exit };
+foo( 10 );
+sub foo {
+ my $v = shift;
+ if ( $v ) {
+ -- $v;
+ foo( $v );
+ }
+ else {
+ while (1) {
+ my $pstack_ppid_alive = kill 0, $pstack_ppid;
+ my $script_ppid_alive = kill 0, $script_ppid;
+ print "# Alive top @{[time]}: $pstack_ppid_alive middle: $script_ppid_alive\n";
+ if ($pstack_ppid_alive && $script_ppid_alive) {
+ select undef, undef, undef, 1;
+ }
+ else {
+ exit;
+ }
+ }
+ exit;
+ }
+}
diff --git a/threads.h b/threads.h
index d6bd130..ca255c9 100644
--- a/threads.h
+++ b/threads.h
@@ -1,3 +1,4 @@
+#ifdef USE_ITHREADS
typedef struct _ithread {
struct _ithread *next; /* Next thread in the list */
struct _ithread *prev; /* Prev thread in the list */
@@ -39,3 +40,4 @@ typedef struct {
IV default_stack_size;
IV page_size;
} my_pool_t;
+#endif
--
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