#!perl -w
#IndigoSTAR Perl debug module V2.02 (c) 2001-2002 all rights reserved.

=comment
How this file is loaded:
perl -d causes perl to load perl5db.pl from any @INC directory
or run from environment variable: PERL5DB=BEGIN {require 'path/to/pridedb.pm' }
or perl -d:foo for looks for Devel/foo.pm in any @INC directory

set PERL5DB=BEGIN {require 'f:\dev\pride\Devel\pridedb.pm'}
=cut

package DB;
use strict;
use Socket;

my $debug_debugger = 0;
print "DB: BEGIN\n" if $debug_debugger;
require Cwd;
my $cwd = Cwd::cwd();
my $debug_server_host = 'localhost';
my $debug_server_port = 1956;
my $in_debugger = 0;

my $singlestep = 1;
my $subroutine_depth = 0;
my $max_subroutine_depth = 999;

my %breakpoints = ();   # $breakpoints{"$filename,$line"} = 1;
my $first_time = 1;
my $current_package;
my $socket;
my $debugger_initialized = 1;
$SIG{INT} = sub { close($socket) if ($socket); $socket = undef; };

1 ; # return true value


sub END {
	print "DB: END\n" if $debug_debugger;
	close($socket) if ($socket);
}

######################################################################
# debugger entry points
######################################################################

sub DB {
    return if $in_debugger;
	my ($package, $filename, $line) = caller ;
    print "DB::DB called from $package, $filename, $line\n" if $debug_debugger;
    $in_debugger = 1;    # turn off debugger while in the debugger

    my ($saveP) ;
	$saveP = $^P ;
	$^P = 0 ;

    HandleBreak($package, $filename, $line);

	$^P = $saveP ;
	$DB::on = 0 ;		# used only once
    $in_debugger = 0;
} # end of DB



sub sub {
   	my ($result, @result) ;
	my ($package, $filename, $line) = caller ;
    print "DB::sub $DB::sub called from $package, $filename, $line\n" if ($debug_debugger && $debugger_initialized && (!$in_debugger));
	
    $subroutine_depth++ if !$in_debugger;
	if (wantarray) {
    	no strict ; # otherwise perl gripes about calling the sub by the reference
	    @result = &$DB::sub ; # call the subroutine by name
	    use strict ;
        $subroutine_depth-- if !$in_debugger;
	    return @result ;
	}
	else {
	    no strict ; # otherwise perl gripes about calling the sub by the reference
	    $result = &$DB::sub ; # call the subroutine by name
	    use strict ;
        $subroutine_depth-- if !$in_debugger;
	    return $result ;	
	}
} # end of sub sub

######################################################################




sub IsBreakPoint
{
    return 1 if ( $singlestep && ($subroutine_depth <= $max_subroutine_depth) );

    my ($filename, $line) = @_;
    return $breakpoints{"$filename,$line"};
}

sub abspath
{
	my ($fn) = @_;
	$fn = "$cwd/$fn" if ( $fn !~ m%^(.:)|(/)% );
	return $fn;
}

sub HandleBreak
{
    my ($package, $filename, $line) = @_;
    return if ($filename =~ /pridedb.pm$/i);
	$filename = abspath($filename);
	$filename =~ s|\\|/|g;
	$current_package = $package;

    if ($first_time) {
        $first_time = 0;
		$socket = OpenConnection ($debug_server_host, $debug_server_port);
		if (!defined $socket) {
			# no connection
			return;
		}
		if (recvmsg() ne "READY") {
			# busy
			close ($socket);
			$socket = undef;
			print "ERROR: debug server is busy\n";
			return;
		}
	    sendmsg("FIRSTBREAK $package,$filename,$line");
    }
	else {
		if (!defined $socket) {
			# no connection
			return;
		}
		return if !IsBreakPoint($filename, $line);
	    sendmsg("BREAK $package,$filename,$line");
	}
	CommandLoop($package, $filename, $line);
}


sub CommandLoop
{
    my ($package, $filename, $line) = @_;
	while (1) {
		my $reply = recvmsg();

		if ($reply eq "STEPINTO") {
			$singlestep = 1;
			$max_subroutine_depth = $subroutine_depth + 1;
			last;
		}
		elsif ($reply eq "STEPOVER") {
			$singlestep = 1;
			$max_subroutine_depth = $subroutine_depth;
			last;
		}
		elsif ($reply eq "STEPOUT") {
			$singlestep = 1;
            $max_subroutine_depth = $subroutine_depth -1;
            $max_subroutine_depth = 0 if $max_subroutine_depth < 0;
			last;
		}
		elsif ($reply eq "CONTINUE") {
			$singlestep = 0;
			last;
		}
		elsif ($reply =~ /^SETBP /) {  # set/toggle breakpoint
			# SETBP filename,line1,line2,line3...
            $reply =~ s/^SETBP //;
			my ($file, @bp) = split(/,/, $reply);
			foreach (@bp) {
				$breakpoints{"$file,$_"} = ! $breakpoints{"$file,$_"};
			}
		}
		elsif ($reply =~ /CLEARBP/) {  # clear all breakpoints
			%breakpoints = ();
		}

		elsif ($reply =~ /^EVAL/) {  # evaluate expression
			my ($code) = $reply =~ /^EVAL (.*)$/;
			$code =~ s/__E_O_L__/\n/g;
            dbeval($current_package, $code);
		}
		elsif ($reply =~ /^GETCWD/) {     # NOT USED
            sendmsg("CWD $cwd");
		}
		elsif ($reply =~ /^CODE2VARS /) {
			#print "reply = '$reply'\n";
			my ($code) = $reply =~ /^CODE2VARS (.*)$/;
			$code =~ s/__E_O_L__/\n/g;
			my @vars;
			@vars = code2vars($code);
            #print "DBG: vars = ", join(" ,", @vars), "\n";

			my ($v, $vars);
			$vars = "";
			foreach $v (@vars) {
				#$vars .= "$v = " . evalvar($current_package, $v) . ";\n";
				$vars .= evalvar($current_package, $v);
			}
			#print "DBG: vals = $vars\n";
			$vars =~  s/\n/__E_O_L__/gs;
            sendmsg("VARS $vars");
		}
		elsif ($reply =~ /^WATCH2VARS /) {
			#print "reply = '$reply'\n";
			my ($code) = $reply =~ /^WATCH2VARS (.*)$/;
			$code =~ s/__E_O_L__/\n/g;
			my @vars;
			@vars = code2vars($code);
			my ($v, $vars);
			$vars = "";
			foreach $v (@vars) {
				$vars .= evalvar($current_package, $v);
			}
			$vars =~  s/\n/__E_O_L__/gs;
            sendmsg("WATCH $vars");
		}

	} # while (1)
}


use Data::Dumper;


sub evalvar
{
	my ($package, $expr) = @_;
    my ($result, $str, $saveW);
    no strict;
    $saveW = $^W; # save the state of the "warning"(-w) flag
    $^W = 0;

    if ($expr =~/^[\@\%\&\*]/) {
        my ($varname) = $expr =~/.(.*)/;
        $result = eval <<__EVAL__;
	       package $package;
            local \$Data::Dump::Purity = 1;
            local \$Data::Dump::Indent = 2;
            Data::Dumper->Dump([\\$expr], [qw(*$varname)]);
__EVAL__
    }
    else {
        $result = eval <<__XEVAL__;
	       package $package;
            local \$Data::Dump::Purity = 1;
            local \$Data::Dump::Indent = 2;
            Data::Dumper->Dump([$expr], [qw($expr)]);
__XEVAL__
    }


    $result = "ERROR" if $@ ;
    $^W = $saveW ; # restore the state of the "warning"(-w) flag
    use strict;

	return $result;
}



#
# convert lines of code into a list of variables
#
sub code2vars
{
	my ($code) = @_;
    # WIP
    # $foo $! ${foo} ${!} @foo %foo


	my @vars = $code =~ /(\$[a-zA-Z_0-9]+)/g;
	push(@vars, $code =~ /(\@[a-zA-Z_0-9]+)/g);

	my @uniq;
	my %uniq;
	foreach (@vars) {
	    push(@uniq,$_) unless ($uniq{$_}++);
	}
    @vars = @uniq;
    return @vars;
}




#
# Evaluate the given expression, return the result.
# Must be called from within DB::DB in order for it
# to properly interpret the vars
#
sub dbeval {
    my ($package, $expr) = @_;
    my (@result, $str, $saveW);
    no strict;
    $saveW = $^W; # save the state of the "warning"(-w) flag
    $^W = 0;

    @result = eval <<__EVAL__;
    package $package;
    $expr;
__EVAL__

    @result = ("ERROR ($@)") if $@;
    $^W = $saveW ; # restore the state of the "warning"(-w) flag
    use strict;
    return @result;
} # end of dbeval







######################################################################
# Socket IO
######################################################################
sub OpenConnection #(host, port)
{
    my ($host, $port) = @_;
    my($name,$aliases,$type,$len,$thataddr);
    my ($hostname,$ipaddr);
    my ($fh) = \*S;

    #calculate $ipaddr from $host
    if ($host =~ m/[^\d\.]/) {
        # format is foo@foo.com
        ($hostname,$aliases,$type,$len,$ipaddr) = gethostbyname($host);
        #print "ipaddr = ", sprintf("[%d.%d.%d.%d]", unpack('C4', $ipaddr)), "\n";
    }
    else {
        #123.456.789.012 format
        $ipaddr = pack('C4', split(/\./, $host));
        # if we need hostname, get it like this
        #($hostname,$aliases,$type,$len,$ipaddr) = gethostbyaddr($ipaddr, 2);
	    #print "host = $hostname\n";
    }

    my $address = pack("S n a4 x8", 2, $port, $ipaddr);
    my $proto = getprotobyname('tcp');
    #socket($fh, 2, 1, 0);
    socket($fh, PF_INET, SOCK_STREAM, $proto);

    if (!connect($fh, $address)) {
        print ("ERROR: Connect failed\n");
		sleep(5);
        return undef;
    }
    return $fh;
}


sub sendmsg
{
	my ($msg) = @_;
    print "SEND: $msg\n" if $debug_debugger;
    send($socket, "$msg\r\n", 0);
}

sub recvmsg
{
	my $msg;
	$msg = <$socket>;
	chomp $msg;
	print "RECV: $msg\n" if $debug_debugger;
	return $msg;
}
######################################################################


1;
