#!perl

use Internals::DumpArenas;

Puke->main( splice @ARGV );
exit;

package Puke;

=head1 NAME

puke - pukes a perl process's guts

=head1 SYNOPSIS

  puke
    --pid pid   # puke the contents of a pid
    --help      # display this help

=cut

use Moose;
#...
no Moose;
use Getopt::Long 'GetOptions';
use Pod::Usage qw( pod2usage );

sub main {
    local ( undef, @ARGV ) = @_;
    GetOptions(
               'pid=i' => \my( $pid ),
               help => sub { pod2usage( -verbose => 2 ) },
              )
        or pod2usage( -verbose => 0 );
    if ( ! $pid ) {
        pod2usage( -verbose => 0 );
    }

    my $perl = Perl->attachToPid( pid => $pid  );

    # $perl->finishCurrentOpcode;
    $perl->pukeProcMaps;
    $perl->pukeProcSmaps;
    $perl->pukeArenas;

    $perl->detach;
}

BEGIN { $INC{'Puke.pm'} = $0 }

package Perl;

use Expect;
use IO::Stty;
use POSIX qw( ENOENT );

use Moose;
BEGIN {
    has 'gdb',            is => 'rw', isa => 'Expect';
    has 'stdin',          is => 'rw', isa => 'Expect', default => sub { Expect->init( *STDIN{IO} ) };
    has 'timeout',        is => 'rw', isa => 'Int',    default => sub { 10 };
    has 'pid',            is => 'rw', isa => 'Int';
    has 'perlContextPtr', is => 'rw', isa => 'Int';
}
no Moose;

sub DEMOLISH {
    my ( $self ) = @_;
    if ( my $gdb = $self->gdb ) {
        $gdb->soft_close;
    }
}

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

    my $gdb = $self->gdb;
    $gdb->send( "quit\n" );
    $gdb->expect( undef, -ex, 'Quit anyway' );
    $gdb->send( "y\n" );
    $gdb->soft_close;

    return $self;
}

sub subclassesDetect {
    my ( $self, $detector ) = @_;

    my @detected =
        grep { $detector->() }
            $self->meta->subclasses;

    if ( ! @detected ) {
        die;
    } elsif ( @detected > 1 ) {
        die;
    } else {
        return $detected[0];
    }
}

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

    # Attach.
    my $gdb = Expect->new;
    #$gdb->debug(3);
    #$gdb->exp_internal(1);
    $gdb->raw_pty( 1 );
    $gdb->stty(qw( raw echo ));
    $gdb->slave->stty(qw( raw echo ));
    $gdb->spawn( qw( gdb --quiet ), "--pid=@{[$self->pid]}" );
    $self->gdb( $gdb );

    # Threaded?
    $self->perlContextPtr( $self->gdbGetContext );

    # Get a better subclass.
    my $betterSubclass = $self->subclassesDetect( sub { $_->acceptsThisProcess( $self ) } );
    bless $self, $betterSubclass;
}

sub hasVariable {
    my ( $self, $variable ) = @_;
    my $gdb = $self->gdb;

    $self->send( "info variable $variable" );

    return scalar $gdb->before =~ /^0x[[:xdigit:]]+ +$variable/m;
}

sub hasFunction {
    my ( $self, $function ) = @_;
    my $gdb = $self->gdb;

    $self->send( "info function $function\n" );

    return scalar $gdb->before =~ /^0x[[:xdigit:]]+ +$function/m;
}

sub expectPrompt {
    my ( $self, $prompt ) = @_;

    my $gdb = $self->gdb;

    return $self if $gdb->before =~ /\(gdb\)\s*\z/;

    while ( 1 ) {
        my $matched = defined $gdb->expect( $self->timeout, '(gdb) ' );

        if ( $matched ) {
            last;
        }
        else {
            if ( ! defined $prompt ) {
                $prompt = "Timed out while waiting for a (gdb) prompt. Wait @{[$self->timeout]} seconds again? [Yn] ";
            }
            last if ! $self->stdinPromptYN( $prompt );
        }
          }
    $self;
}

sub stdinPromptYN {
    my ( $self, $prompt ) = @_;

    my $answer;
    my $stdin = $self->stdin;
    while ( 1 ) {
        $stdin->send( $prompt );
        my $responded = defined
            $stdin->expect(
                undef, # wait forever for the user. No automated timeouts here.
                [ qr/^y?$/i, sub { $answer = 1 } ],
                [ qr/^n$/, sub { $answer = 0 } ],
            );
        last if defined $responded;

        $stdin->send( 'Huh? ');
    }

    return $answer;
}

sub attachToPid {
    my ( $class, @args ) = @_;

    my $obj = $class->new( @args );
    $obj->gdbAttachToPid;
    return $obj;
}

sub acceptsThisProcess;

sub injectDebugger;

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

    my $gdb = $self->gdb;

    $gdb->send( "call (void *)Perl_get_context()\n" );

    my $context;
    $gdb->expect(
             2,
             -re => qr/\$\d+ = \(void \*\) (0x[[:xdigit:]]+)\b/m,
             sub {
               my ( $gdb ) = @_;
               my ( $hex_context ) = $gdb->exp_matchlist;
               $context = hex $hex_context;
             } );
    $context = 0 if ! defined $context;
    $self->expectPrompt;

    return $context;
}

# sub canFinishCurrentOpcode {
#   my ( $self ) = @_;
#   return $self->hasVariable( 'Perl_sig_pending' )
#     && $self->hasFunction( 'Perl_despatch_signals' );
# }
# 
# sub finishCurrentOpcode {
#   my ( $self ) = @_;
#   my $timeout = $self->timeout;
#   my $gdb = $self->gdb;
# 
#   # Can I break into this perl's runloop?
#   if ( !( $self->canFinishCurrentOpcode ) ) {
#     die Perl::Exception::CannotCooptSignalHandler->new;
#     ##TODO# No? See if the user wants to continue anyway.
#     ##TODOif ( ! $self->stdinPromptYN( q(It seems that your perl can't be broken into using safe signals. Continue breaking in using unsafe signals? [Yn]) ) ) {
#     ##TODO}
#     ##TODOelse {
#     ##TODO  return;
#     ##TODO}
#   }
# 
#   # Yes! Break into perl.
#   $gdb->expect( undef, -ex, '(gdb)' );
#   $gdb->send( "set variable Perl_sig_pending = 1\n" );
# 
#   $gdb->expect( undef, -ex, '(gdb)' );
#   $gdb->send( "break Perl_despatch_signals\n" );
# 
#   $gdb->expect( undef, -ex, '(gdb)' );
#   $gdb->send( "continue\n" );
# 
#   my $stdin = $self->stdin;
#  FINISH_OPCODE:
#   while ( 1 ) {
#     my $finished = defined $gdb->expect( $self->timeout, -ex, '(gdb)' );
#     last if $finished;
# 
#     $stdin->send( "Timed out while waiting for current opcode to finish. Wait some more? [Yn] \n" );
#     $stdin->expect( undef,
#             -re, '[yY]', sub {},
#             -re, '[nY]', sub { last FINISH_OPCODE } );
#   }
# 
#   $self;
# }

sub send {
    my ( $self, @commands ) = @_;

    my @real_commands = $self->setATHX( @commands );
    my $gdb = $self->gdb;
    $gdb->send( @real_commands );

    $self;
}

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

    my $pid = $self->pid;
    my $a = qq{open my(\$fh), q{/proc/$pid/maps} or die qq{Can't open /proc/$pid/maps: \$!}; while( my \$line = <\$fh> ) { print STDERR \$line }};
    my $b = qq{eval q{$a; 1} or warn \$\@};
    my $c = qq{call Perl_eval_pv("$b",0)\n};

    $self->send( $c );
    $self->expectPrompt;

    $self;
}

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

    my $pid = $self->pid;
    my $a = qq{open my(\$fh), q{/proc/$pid/smaps} or die qq{Can't open /proc/$pid/smaps: \$!}; while( my \$line = <\$fh> ) { print STDERR \$line }};
    my $b = qq{eval q{$a; 1} or warn \$\@};
    my $c = qq{call Perl_eval_pv("$b",0)\n};

    $self->send( $c );
    $self->expectPrompt;

    $self;
}

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

    my $a = 'use Internals::DumpArenas; Internals::DumpArenas::DumpArenas()';
    my $b = qq{eval q{$a; 1} or warn \$\@};
    my $c = qq{call Perl_eval_pv( "$b", 0 )\n};

    $self->send( $c );
    $self->expectPrompt;

    $self;
}

BEGIN { $INC{'Perl.pm'} = $0 }

package Perl::Unthreaded;
use Moose;
# ...
no Moose;
use parent 'Perl';

sub acceptsThisProcess {
    my ( $class, $self ) = @_;

    return 0 == $self->perlContextPtr;
}

sub setATHX {
    my ( $self, @commands ) = @_;

    # Remove some "macros"
    s/\bATXH_?\b//g for @commands;

    return @commands;
}

BEGIN { $INC{'Perl/Unthreaded.pm'} = $0 }

1;
