#!/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<inspect-perl-proc> - inspect running perl process

=head1 SYNOPSIS

B<inspect-perl-proc>
[B<-m> I<MODE>]
[B<-p> I<PID>]
[B<-d> | B<--debug>]

B<dump-perl-inc>
[B<-p> I<PID>]
[B<-d> | B<--debug>]

B<dump-perl-incpath>
[B<-p> I<PID>]
[B<-d> | B<--debug>]

B<dump-perl-memusage>
[B<-p> I<PID>]
[B<-d> | B<--debug>]

B<dump-perl-env>
[B<-p> I<PID>]
[B<-d> | B<--debug>]

B<dump-perl-stacktrace>
[B<-p> I<PID>]
[B<-d> | B<--debug>]

B<hook-perl-require>
[B<-p> I<PID>]
[B<-d> | B<--debug>]

B<inspect-perl-proc> B<-h> | B<--help> | 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<perl-requiretree> output tree format from L<hook-perl-require> dump file.
"inspect-perl-proc --mode 'hook-require'" is same as "hook-perl-require".

=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<lt>hirose31 _at_ gmail.comE<gt>

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# for Emacsen
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# cperl-close-paren-offset: -4
# cperl-indent-parens-as-block: t
# indent-tabs-mode: nil
# coding: utf-8
# End:

# vi: set ts=4 sw=4 sts=0 et ft=perl fenc=utf-8 ff=unix :