$|=1;
#use strict;
#use warnings;
use ASRemote::Jacket;
use File::Basename;
use File::Path;

$Win32::OLE::_Unique = 1;

# $ASRemote::Jacket::TraceFile = './jacket-trace.log';
# $ASRemote::Jacket::SessionTraceFile = './jacket-session.log';

my %param = ( -port => 2000 );
   %param = ( -perlsock => 1 ) if ($ENV{'PerlHost'} ne '');

my $jacket = ASRemote::Jacket->new( %param );
my $rv = $jacket->Connect();

if ($rv)
{
    die "Unable to connect: $rv";
}


# Check which OLE is avaialable to us
my ($App, $Sync);

eval 'use Win32::OLE;';
if ($@ ne '') {
    die "Perl Debugger requires the Win32::OLE module extension.\n$@";
}

Win32::OLE->Initialize(Win32::OLE::COINIT_MULTITHREADED());
$App = Win32::OLE->new( 'PerlDebugger.Document' );
$Sync = Win32::OLE->new( 'PerlDB.Sync.1' );


if (!$Sync) {
    print "Failed to create the Perl Debugger Sync object.\n";
    print "Please ensure that the ActiveState Perl Debugger is properly installed " .
	    "and try again.\n";
    exit 1;
}

if (!$App) {
    print "Failed to start the ActiveState Perl Debugger.\n";
    print "Please ensure that the ActiveState Perl Debugger is properly installed " .
	    "and try again.\n";
    exit 1;
}

# strip drive and leading slash(es) to relativize pathname
# remove any file name bits that may follow an eval'd code chunk
sub StripRoot ($) {
    my $path = shift;
    $path =~ s{^([A-Z]:)?[\\/]?[\\/]}{}i;
    if ($path =~ /^\(eval (\d+)\)\[(.+?):(\d+)\]$/o) {
	$path = "(eval $1)";
    }
    return $path;
}

sub IsBreakPoint($@) {
    my $here = shift;
    my @list = @_;
    # print STDERR "Breakpoints: " . join(" ", @list) . "\n";
    foreach (@list) {
	return 1 if ($here eq $_);
    }
    return 0;
}

sub ProcessError($) {
    my $jacket = shift;
    my $error_text = $jacket->{'error_text'};

    print DB::OUT $error_text;
    goto ExitListen if ($error_text =~ /Lost connection to/);
}

sub SetBreakPoint($$$) {
    my $jacket = shift;
    my $line = shift;
    my $cond = shift;

    my %old = %{ $jacket->{'breakpoints'} };
    # print STDERR "Old breakpoints: " . join(" ", keys(%old)) . "\n";
    my $rtval = $jacket->SetBreakpoint( $line );
    ProcessError($jacket) if ($rtval);

    my %new = %{ $jacket->{'breakpoints'} };
    # print STDERR "New breakpoints: " . join(" ", keys(%new)) . "\n";
    foreach my $val (keys(%new)) {
        if (!defined($old{$val})) {
	    if ($val =~ /^(.+):(\d+)/o)
	    {
		$val = $2;
	    }
	    return $val;
	}
    }
    return 0;
}

sub RemoveBreakPoint($$) {
    my $jacket = shift;
    my $line = shift;
    my %old = %{ $jacket->{'breakpoints'} };

    # print STDERR "Old breakpoints: " . join(" ", keys(%old)) . "\n";
    my $rtval = $jacket->RemoveBreakpoint( $line );
    ProcessError($jacket) if ($rtval);

    my %new = %{ $jacket->{'breakpoints'} };
    # print STDERR "New breakpoints: " . join(" ", keys(%new)) . "\n";
    foreach my $val (keys(%old)) {
        if (!defined($new{$val})) {
	    if ($val =~ /^(.+):(\d+)/o)
	    {
		$val = $2;
	    }
	    return $val;
	}
    }
    return 0;
}

my $updatestatus = 1;
my $cmd = '';
my $rtval = 0;
my $localDir = ($ENV{'TEMP'} || $ENV{'TMP'});
unless ($localDir) {
     if (exists $ENV{windir}) {
	 $localDir = $ENV{windir};
	 my $tmp = "$localDir/Temp";
	 unless (-d $tmp) {
	     mkdir $tmp;   # ignore any error
	 }
	 $localDir = $tmp if -d $tmp;
     }
}
$localDir = "c:" unless $localDir;
$localDir =~ s{\\}{/}g;
$localDir .= "/" . $$;

sub GetSourceFile($) {
    my $jacket = shift;
    my $local_file = $localDir . "/" . StripRoot($jacket->{'filename'});
    $rtval = $jacket->GetScript( $jacket->{'filename'}, $local_file );
    ProcessError($jacket) if ($rtval);
}

sub SendLines ($$) {
    my $jacket = shift;
    my $app = shift;
    my $file = StripRoot($jacket->{'filename'});
    if (open my $fh, "<$localDir/$file") {
	my @lines = <$fh>;
	if ($file eq "-e") {
	    if ($lines[0] =~ /^BEGIN\s*\{\s*require.*((?i)perl5db\.pl).*\}/) {
		shift @lines;
	    }
	    chomp @lines;
	    @lines = "@lines";
	}
	$app->SetSourceFileLineCount(scalar @lines);
	my $num = 1;
	for my $line (@lines) {
	    chomp $line;
	    $app->SetSourceFileLine($num,$line);
	    ++$num;
	}
    }
    else {
	print STDERR "failed to open $localDir/$file: $!";
    }
}

mkdir($localDir);
# notify App of current directory and source file
$App->SetCurrentDirectory($localDir);
GetSourceFile($jacket);

{
    # Set the start watch list
    my @watch_categories = split( /\n/, $App->{'WatchList'} );
    my $sanitized;
    foreach my $watch_category ( @watch_categories ) {
	foreach my $watch ( split(/\t/, $watch_category) ) {
	    ($sanitized = $watch) =~ s/([\.\$\*\+\(\)\]\[\?\{\}])/\\$1/g;
	    my $rtval = $jacket->SetWatch($watch);
            ProcessError($jacket) if ($rtval);
	}
    }
}

sub UpdateWatches($) {
    my $jacket = shift;
    # Get the list of variables we are already watching
    my @was_watched;
    map { push( @was_watched, $_->{'name'} ); } @{$jacket->{'watched'}};

    # Get the new watch list
    my @watch_categories = split( /\n/, $App->{'WatchList'} );
    my %watches;
    my $sanitized;
    foreach my $watch_category ( @watch_categories ) {
	foreach my $watch ( split(/\t/, $watch_category) ) {
	    ($sanitized = $watch) =~ s/([\.\$\*\+\(\)\]\[\?\{\}])/\\$1/g;

	    if ( (!@was_watched ||
		  grep( !/$sanitized/, @was_watched ) ==  @was_watched
                 ) &&
		!exists $watches{$watch}
               )
            {
	        my $rtval = $jacket->SetWatch($watch);
                ProcessError($jacket) if ($rtval);
            }
	    $watches{$watch} = 1;
	}
    }

    foreach my $watch ( @was_watched ) {
	if (!exists $watches{$watch})
        {
            my $rtval = $jacket->RemoveWatch( $watch );
            ProcessError($jacket) if ($rtval);
        }
    }

    #print STDERR "=========================================================\n";
    #print STDERR Data::Dumper->Dump([ \@was_watched ], [ 'was_watched' ]);
    #print STDERR Data::Dumper->Dump([ \@watch_categories ], [ 'watch_categories' ]);
    #print STDERR Data::Dumper->Dump([ \@{$jacket->{'_watched'}} ], [ '_watched' ]);
    #print STDERR Data::Dumper->Dump([ \@{$jacket->{'watched'}} ], [ 'watched' ]);
    #print STDERR Data::Dumper->Dump([ \@{$jacket->{'_proximity'}} ], [ '_proximity' ]);
    #print STDERR Data::Dumper->Dump([ \@{$jacket->{'proximity'}} ], [ 'proximity' ]);
    my $watched;
    foreach my $watch_list (@watch_categories) {
	my @watch_list = split( /\t/, $watch_list );
	$watched = $jacket->{'watched'};
	my $replaced;
	my $watch_var;
	foreach $watch_var ( @watch_list ) {
	    $replaced = 0;
	    foreach my $item ( @{$watched} ) {
		if ($watch_var eq $item->{'name'}) {
		    $watch_var = $item->{'scalar'};
		    $watch_var =~ s!\n!\\n!g;
		    $watch_var =~ s!\t!\\t!g;
		    $watch_var =~ s![\x00-\x1f]!.!g;
		    if ($watch_var =~ /^\'(.*)\'$/) {
			$watch_var = $1;
		    }
		    $replaced = 1;
		    last;
		}
	    }
	    $watch_var = '' unless $replaced;
	}
	$watch_list = join("\t", @watch_list);
    }
    $App->{'WatchList'} = join( "\n", @watch_categories );
}

my $current_filename = '';

while(1) {

    # tell ASPD where the source file is
    if ($current_filename ne $jacket->{'filename'}) {
	$current_filename = $jacket->{'filename'};
	GetSourceFile($jacket);
	$updatestatus = 1;
	$App->{'SourceFile'} = StripRoot($jacket->{'filename'});
    }
    $App->{'LineNumber'} = int $jacket->{'linenum'};

    # check if we're immediately updating
    if ($updatestatus) {
	# update status now
	$cmd = "UpdateStatus";
	$updatestatus = 0;
    }
    else {
	# wait for command string
	$Sync->Wait();
	# get command string from Windows program
	$cmd = $App->{'Command'};
    }

    # print STDERR "Command: $cmd\n";

    if ($cmd eq "Quit") {
	last;
    }
    elsif ($cmd eq "RemoveAllBreakpoints") {
	$rtval = $jacket->ClearBreakpoints();
        ProcessError($jacket) if ($rtval);

	# notify window
	$App->RemoveAllBreakpoints();
    }
    elsif (substr($cmd,0,19) eq "CanInsertBreakpoint") {
	$App->{'Response'} = '1';
    }
    elsif (substr($cmd,0,16) eq "InsertBreakpoint") {
	# grab line number and condition
	my $i = int substr($cmd,17,9);
	my $cond = substr($cmd,27);

	$i = SetBreakPoint($jacket, $i, $cond);
        $App->InsertBreakpoint( int $i, $cond) if $i;
    }
    elsif (substr($cmd,0,16) eq "RemoveBreakpoint") {
	# grab line number
	my $i = int substr($cmd,17,9);

	$i = RemoveBreakPoint($jacket, $i);
	$App->RemoveBreakpoint(int $i) if $i;
    }
    elsif (substr($cmd,0,16) eq "ToggleBreakpoint") {
	# grab line number
	my $i = int substr($cmd,17,9);
	my $cond = "1";

	if (IsBreakPoint("$jacket->{'filename'}:$i", keys %{ $jacket->{'breakpoints'} } )) {
	    $i = RemoveBreakPoint($jacket, $i);
	    $App->RemoveBreakpoint(int $i) if $i;
	}
	else {
	    $i = SetBreakPoint($jacket, $i, $cond);
	    $App->InsertBreakpoint(int $i, $cond) if $i;
	}
    }
    elsif ($cmd eq "StepOver") {
	$rtval = $jacket->StepOver();
        ProcessError($jacket) if ($rtval);
	$updatestatus = 1;
    }
    elsif ($cmd eq "StepInto") {
	$rtval = $jacket->Step();
        ProcessError($jacket) if ($rtval);
	$updatestatus = 1;
    }
    elsif ($cmd eq "StepOut") {
	$rtval = $jacket->ReturnFromSub();
        ProcessError($jacket) if ($rtval);
	$updatestatus = 1;
    }
    elsif ($cmd eq "Continue") {
	$rtval = $jacket->RunUntil();
        ProcessError($jacket) if ($rtval);
	$updatestatus = 1;
    }
    elsif (substr($cmd,0,11) eq "RunToCursor") {
	# grab line number
	my $i = int substr($cmd,12,9);
	$rtval = $jacket->RunUntil($i);
        ProcessError($jacket) if ($rtval);
	$updatestatus = 1;
    }
    elsif ($cmd eq "CallStack") {
	# get the call stack
	$rtval = $jacket->CallStack();
        ProcessError($jacket) if ($rtval);
	# send results to app
	$App->DisplayCallStack($jacket->{'callnames'}, $jacket->{'callfiles'}, $jacket->{'calllines'});
    }
    elsif ($cmd eq "UpdateStatus") {
	UpdateWatches($jacket);
    }
    elsif (substr($cmd,0,10) eq "DoWatchTip") {
	# note that the GUI requires a trailing '\n'
        my $watchexpr = substr($cmd,11);
        if ($watchexpr eq '')
        {
            # Quick opt; nothing to display, return empty.  NOTE, though, that
            # this is _NEEDED_ as otherwise the GUI halts waiting for a
            # response to come back.
	    $App->{'Response'} = "\n";
        }
        else
        {
            # Evaluate the expression to get the result and send it back to the
            # GUI.
            $jacket->QuickEval( $watchexpr );
            $App->{'Response'} = "$jacket->{'result'}\n";
        }
    }
    elsif (substr($cmd,0,12) eq "DumpVariable") {
	# grab variable name
	my $varname = substr($cmd,13);
	# remove variable symbol
	my $varnamechar = substr($varname,0,1);
	if ($varnamechar eq '$' or		
	    $varnamechar eq '@' or
	    $varnamechar eq '%')
	{
	    $varname = substr($varname,1);
	}

	my $deref;
	if ($varnamechar eq '@' or
	    $varnamechar eq '%')
	{
	    $varnamechar = "\\$varnamechar";
	    $deref="*";
	}

	my $vardumpfilename = $App->GetTempFile();

	$rtval = $jacket->DumpVariable($varname, $varnamechar, $deref, $vardumpfilename);
        ProcessError($jacket) if ($rtval);

	# set response
	$App->{'Response'} = "$vardumpfilename\n";
	$updatestatus = 1;
    }
    elsif ($cmd eq "SourceFile") {
	GetSourceFile($jacket);
	SendLines($jacket, $App);
	$updatestatus = 1;
    }

    if ($jacket->{'terminated'}) {
	$App->SetCurrentDirectory($localDir);
	# delete the temp directory
	rmtree($localDir,0,0);
	last;
    }
}

ExitListen:

# exit script.  Be sure to tell the Jacket to quit, though, otherwise
# the connection doesn't get shut down properly to the remote script.
$jacket->Quit();

undef $jacket;
undef $Sync;
undef $App;

Win32::OLE->Uninitialize();

END { rmtree($localDir,0,0); }

