#!/Users/jbenjore@corp.w3data.com/opt/perl-5.10.0/bin/perl
use strict;
use warnings;
use Expect;
use Getopt::Long 'GetOptions';

main( splice @ARGV );
exit;

sub main {
	local @ARGV = @_;
	GetOptions(
		'pid=i' => \my( $pid ),
		'host=s' => \my( $host ),
		'port=s' => \my( $port ),
		help => sub { die },
	)
		or die;
	if ( not( $host and $port and $pid ) ) {
		die;
	}

	my $perl = Perl->attachToPid( pid => $pid, host => $host, port => $port  );
	$perl->injectDebugger;
	$perl->detach;
	#$perl->passthroughStdin;
}

package Perl;
use Moose;
BEGIN {
	has 'gdb',     is => 'rw', isa => 'Expect';
	has 'timeout', is => 'rw', isa => 'Int', default => '10';
	has 'host',    is => 'rw', isa => 'Str', default => 'localhost';
	has 'port',    is => 'rw', isa => 'Int';
	has 'pid',     is => 'rw', isa => 'Int';
	has 'perlContext', is => 'rw', isa => 'Int';
}
no Moose;

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






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

	my $gdb = $self->gdb;
	while ( 1 ) {
		my $bytes = read *STDIN, my( $typedText ), 8192;
		if ( not defined $bytes ) {
			die $!;
		}
		elsif ( not $bytes ) {
			last;
		}

		print "Sending [$typedText]\n";
		$gdb->send( $typedText );
	}
}
sub detach {
	my ( $self ) = @_;

	$self->expectPrompt;
	$self->gdbSend( "quit\n", "y\n" );
	$self->gdb->soft_close;

	return $self;
}

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

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

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

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

	# Attach.
	my $gdb = Expect->new;
	# $gdb->raw_pty( 1 );
	$gdb->slave->stty( qw( raw -echo ));
	$gdb->spawn( "gdb -p " . $self->pid );
	$self->gdb( $gdb );

	# Threaded?
	$self->perlContext( $self->perlGetContext );

	# Get a better subclass.
	my $betterSubclass = $self->subclassesDetect( sub { $_->acceptsThisProcess( $self ) } );
	bless $self, $betterSubclass;	      
}
sub expectPrompt {
	my ( $self ) = @_;
	$self->gdb->expect( 0, [ qr/^\Q(gdb) \E/ ] );
	$self;
}

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

	my $obj = $class->new( @args );
	$obj->gdbAttachToPid;
	return $obj;
}
sub acceptsThisProcess;
sub injectDebugger;
sub perlGetContext {
	my ( $self ) = @_;

	my $gdb = $self->gdb;

	$self->expectPrompt;
	my $context;
	$self->gdbSend( "call (void *)Perl_get_context()\n" );
	$gdb->expect(
		$self->timeout,
		[
			qr/^\$\d+\Q = (void *) \E(0x[[:xdigit:]]+)\b/,
			sub {
				my ( $self ) = @_;
				( $context ) = hex( ( $self->exp_matchlist )[0] );
			},
		],
	);
	$context = 0 if not defined $context;

	return $context;
}
sub debuggerInjectionCode {
	my ( $self ) = @_;
	my $host = $self->host;
	my $port = $self->port;

	return "{ require Enbugger; local \$ENV{PERLDB_OPTS} = 'RemotePort=${host}:${port}'; Enbugger->stop; { next } }";
}
my %ESCAPES;
BEGIN {
	%ESCAPES = (
		'\\' => '\\\\',
		'"' => '\"',
		"\n" => '\n',
	);
}
sub escapedDebuggerInjectionCode {
	my ( $self ) = @_;

	my $injection = $self->debuggerInjectionCode;
	$injection =~ s/([\\"\n])/$ESCAPES{$1}/g;

	return $injection;
}
sub gdbSend {
	my ( $self, @commands ) = @_;
	$self->gdb->send( @commands );
	$self;
}
package Perl::Threaded;
BEGIN { @Perl::Threaded::ISA = 'Perl' }
sub acceptsThisProcess {
    my ( $class, $self ) = @_;
    return not not $self->perlContext;
}
sub injectDebugger {
	my ( $self ) = @_;
	my $perlContext = $self->perlContext;

	my $injection = $self->escapedDebuggerInjectionCode;

	$self->expectPrompt;
	$self->gdbSend( qq(call (void *)Perl_eval_pv( $perlContext, "$injection", 0 )\n) );
	$self;
}

package Perl::Unthreaded;
BEGIN { @Perl::Unthreaded::ISA = 'Perl' }
sub acceptsThisProcess {
    my ( $class, $self ) = @_;

    return not $self->perlContext;
}
sub injectDebugger {
	my ( $self ) = @_;

	$self->expectPrompt;
	$self->gdbSend( qq(call (void *)Perl_eval_pv( "", 0 )\n) );
	$self;
}