inspect-perl-proc
inspect-perl-proc copied to clipboard
hirose31
get %INC and dump into file
#!/usr/bin/env perl
use strict; use warnings;
use Getopt::Long qw(:config posix_default no_ignore_case no_ignore_case_always permute); use Pod::Usage;
use Carp;
my $PROG = substr($0, rindex($0, '/')+1);
my $Debug = 0;
sub dprint (@) { return unless $Debug; my @m = @_; chomp @m; print STDERR @m,"\n"; }
MAIN: { my $target_pid; my $mode; GetOptions( 'pid|p=i' => $target_pid, 'mode|m=s' => $mode, 'debug|d+' => $Debug, 'help|h|?' => sub { pod2usage(-verbose=>1) }) or pod2usage(); defined $target_pid or pod2usage; $ENV{LM_DEBUG} = 1 if $Debug;
if ($PROG eq 'dump-perl-inc') {
$mode = 'dump-inc';
} elsif ($PROG eq 'dump-perl-incpath') {
$mode = 'dump-incpath';
} elsif ($PROG eq 'dump-perl-memusage') {
$mode = 'dump-memusage';
} elsif ($PROG eq 'dump-perl-env') {
$mode = 'dump-env';
} elsif ($PROG eq 'dump-perl-stacktrace') {
$mode = 'dump-stacktrace';
} elsif ($PROG eq 'hook-perl-require') {
$mode = 'hook-require';
}
defined $mode or pod2usage('Missing --mode');
my $perl_code;
my $output_file;
if ($mode eq 'dump-inc') {
$perl_code = <<'EOPC';
open my $fh, '>', qq{/tmp/dump_inc.$$.}.time() or die $!; print {$fh} qq<{\n>; for my $mod (keys %INC) { printf {$fh} qq{'%s' => '%s',\n}, $mod, $INC{$mod}; } print {$fh} qq<};\n>; close $fh; EOPC $output_file = "/tmp/dump_inc.${target_pid}.XXXXX";
} elsif ($mode eq 'dump-incpath') {
$perl_code = <<'EOPC';
open my $fh, '>', qq{/tmp/dump_incpath.$$.}.time() or die $!; print {$fh} qq<(\n>; print {$fh} qq{'$_',\n} for @INC; print {$fh} qq<);\n>; close $fh; EOPC $output_file = "/tmp/dump_incpath.${target_pid}.XXXXX";
} elsif ($mode eq 'dump-memusage') {
$perl_code = <<'EOPC';
if (open my $fh, '>', qq{/tmp/dump_memusage.$$.}.time()) { eval { require B::Size2::Terse; unless (B::Size2::Terse->VERSION >= 2.07) { die qq{requires B::Size2::Terse >= 2.07}; } use Devel::Symdump;
my @packages = Devel::Symdump->rnew('main')->packages;
print {$fh} qq<{\n>;
for my $package ('main', sort @packages) {
local $@;
eval {
my($subs, $opcount, $opsize) = B::Size2::Terse::package_size($package);
printf {$fh} qq{'%s' => '%s',\n}, $package, $opsize;
};
if ($@) {
my $e = $@; chomp $e;
printf {$fh} qq{'%s' => '0', # ERROR %s\n}, $package, $e;
}
}
print {$fh} qq<};\n>;
}; print {$fh} qq{$@} if $@; close $fh; }; EOPC $output_file = "/tmp/dump_memusage.${target_pid}.XXXXX";
} elsif ($mode eq 'dump-env') {
$perl_code = <<'EOPC';
open my $fh, '>', qq{/tmp/dump_env.$$.}.time() or die $!; print {$fh} qq<{\n>; for my $k (sort keys %ENV) { printf {$fh} qq{'%s' => '%s',\n}, $k, $ENV{$k}; } print {$fh} qq<};\n>; close $fh; EOPC $output_file = "/tmp/dump_env.${target_pid}.XXXXX";
} elsif ($mode eq 'dump-stacktrace') {
$perl_code = <<'EOPC';
open my $fh, '>', qq{/tmp/dump_stacktrace.$$.}.time() or die $!; require Carp; print {$fh} Carp::longmess(q{Dump stacktrace}); close $fh; EOPC $output_file = "/tmp/dump_stacktrace.${target_pid}.XXXXX";
} elsif ($mode eq 'hook-require') {
# moudle call stack break off, so skip eval, base.pm, parent.pm
$perl_code = <<'EOPC';
unshift @INC, sub { my ($coderef, $filename) = @_; my $i = 0; my ($pkg, $fn, $ln, $sub); my $sfn = qq{-}; my @t = localtime(); $t[5] += 1900; $t[4]++; my $time = sprintf(qq{%04d/%02d/%02d %02d:%02d:%02d}, @t[5,4,3,2,1,0]); while (1) { ($pkg, $fn, $ln, $sub) = caller($i); last if !defined $fn; ++$i; next if substr($fn, -9) eq qq{parent.pm}; next if substr($fn, -7) eq qq{base.pm}; next if substr($fn, 0, 5) eq qq{(eval}; last; } for my $path (sort {length($b) <=> length($a)} @INC) { if (substr($fn, 0, length($path)) eq $path) { $sfn = substr($fn, length($path)+1); last; } } open my $fh, '>>', qq{/tmp/hook_require.$$} or die $!; print {$fh} qq{$time\t$filename\t$sfn\t$fn\t$ln\n}; close $fh; return undef; }; EOPC $output_file = "/tmp/hook_require.${target_pid}";
} elsif ($mode eq 'debug') {
$perl_code = <<'EOPC';
use Carp; Carp::cluck('Hello world'); EOPC $output_file = ""; } else { pod2usage("Invalid mode: $mode"); }
$perl_code =~ s/\n/ /g;
dprint("perl_code: $perl_code");
my $gdb = Devel::GDB::Tiny->new(
pid => $target_pid,
);
my $res;
# http://www.perlmonks.org/?node_id
# With Perl 5.16.3, process will exit after detach gdb,
# so we set breakpoint at main loop (Perl_runops_standard).
my $breakpoint;
$res = $gdb->send(qq{bt});
for my $frame (split /[\r\n]/, $res) {
if ($frame =~ /\s+Perl_runops_standard\s+.+at\s+(.+:[0-9]+)/) {
$breakpoint = $1;
dprint("b $breakpoint");
$gdb->send("b $breakpoint");
last;
}
}
unless ($breakpoint) {
$gdb->finish;
print "Cannot find a suitable breakpoint\n";
exit 1;
}
$gdb->send(qq{c});
$gdb->send(qq{delete breakpoints});
$res = $gdb->send(qq{call Perl_eval_pv("$perl_code",0)\n});
if ($res =~ /Too few arguments in function call/) {
# thread enabled perl?
$res = $gdb->get(qq{call Perl_eval_pv(Perl_get_context(), "$perl_code",0)\n});
}
$gdb->finish;
if ($res !~ /\s0x\w+/) {
print "Failed to inspect. Is your perl built with debug symbol?\n";
exit 1;
}
print "DONE. Please check ${output_file}\n";
exit 0;
}
========================================================================
package Devel::GDB::Tiny;
use strict; use warnings;
use IPC::Open2;
sub dprint (@) { return unless $Debug; my @m = @_; chomp @m; print STDERR @m,"\n"; }
sub new { my($class, %args) = @_;
my $self = bless {
%args,
_rh => undef,
_rw => undef,
_initialized => 0,
}, $class;
return $self;
}
sub init { my $self = shift; dprint("init");
my $gdb_cmd = 'gdb -silent -nw ';
if (defined $self->{pid}) {
$gdb_cmd .= "-p $self->{pid}";
} else {
die "fixme to accept executable-file core-file";
}
$gdb_cmd .= ' 2>&1';
open2 $self->{_rh}, $self->{_wh}, $gdb_cmd or die $!;
$self->{_initialized} = 1;
$self->send('');
$self->send('set pagination off');
$self->send('set unwindonsignal on');
}
sub finish { my $self = shift; dprint("finish");
return unless $self->{_initialized};
$self->send('detach');
$self->send('quit');
if (defined $self->{pid}) {
kill 'CONT', $self->{pid};
}
close $self->{_rh}; $self->{_rh} = undef;
close $self->{_wh}; $self->{_wh} = undef;
$self->{_initialized} = 0;
}
sub send { my($self, $cmd) = @_;
$self->init unless $self->{_initialized};
dprint("C $cmd");
if ($cmd) {
chomp $cmd; $cmd .= "\n";
my $len = syswrite $self->{_wh}, $cmd;
if ($len < length($cmd)) {
die "failed to exec: $cmd\n";
}
}
my $res = '';
while (1) {
my $buf = '';
my $len = sysread $self->{_rh}, $buf, 1024;
last if $len <= 0;
$res .= $buf;
last if $res =~ /\(gdb\)\s+$/;
}
dprint("R $res");
return $res;
}
$1 = 0xce5ad0 "AUTOJUMP_AUTOCOMPLETE_CMDS=vim cp em"
-> return "AUTOJUMP_AUTOCOMPLETE_CMDS=vim cp em"
sub get { my($self, $cmd) = @_;
my $res = $self->send($cmd);
return '' if ($res !~ /.* =\s+(.+)/s);
my $v = $1;
if ($res =~ /0x\w+\s+\"(.+)\"/) {
return $1;
}
return $v;
}
sub DESTROY { my $self = shift; $self->finish; }
END
=head1 NAME
B
=head1 SYNOPSIS
B
B
B
B
B
B
B
B
$ inspect-perl-proc -m 'dump-inc' -p 1974 OR $ dump-perl-inc -p 1974
$ inspect-perl-proc -m 'dump-incpath' -p 1974 OR $ dump-perl-incpath -p 1974
$ inspect-perl-proc -m 'dump-memusage' -p 1974 OR $ dump-perl-memusage -p 1974
$ inspect-perl-proc -m 'dump-env' -p 1974 OR $ dump-perl-env -p 1974
$ inspect-perl-proc -m 'dump-stacktrace' -p 1974 OR $ dump-perl-stacktrace -p 1974
$ inspect-perl-proc -m 'hook-require' -p 1974 OR $ hook-perl-require -p 1974
After inspecting, you can get a result as shown below.
my $result = do '/tmp/dump_memusage.1974.1368772330'; warn Dumper($result);
=head1 DESCRIPTION
This script is for inspecting running perl process.
inspect-perl-proc has several modes.
"dump-inc" is to dump %INC (loaded modules). "inspect-perl-proc --mode 'dump-inc'" is same as "dump-perl-inc".
"dump-incpath" is to dump @INC (load paths). "inspect-perl-proc --mode 'dump-incpath'" is same as "dump-perl-incpath".
"dump-memusage" is to dump memory size by package. "inspect-perl-proc --mode 'dump-memusage'" is same as "dump-perl-memusage".
"dump-env" is to dump %ENV. "inspect-perl-proc --mode 'dump-env'" is same as "dump-perl-env".
"dump-stacktrace" is to dump stacktrace (backtrace). "inspect-perl-proc --mode 'dump-stacktrace'" is same as "dump-perl-stacktrace".
"hook-perl-require" is to insert hooks into the import facility and dump name of the file to be included.
L
=head1 OPTIONS
=over 4
=item B<-m> I<MODE>, B<--mode> I<MODE>
Specify mode. I<MODE> is "dump-inc" or or "dump-incpath" "dump-memusage" or "dump-env" or "dump-stacktrace" or "hook-perl-require".
=item B<-p> I<PID>, B<--pid> I<PID>
Specify PID which process you want to examine.
=item B<-d>, B<--debug>
increase debug level. -d -d more verbosely.
=back
=head1 KNOWN ISSUE
Inspecting on CentOS 5.8's system perl(5.8.8) causes segmentation fault. (perlbrewed perl-5.8.8 on CentOS 5.8 is OK)
=head1 AUTHOR
HIROSE, Masaaki E
=head1 LICENSE
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=cut
hirose31