#
# PerlDB.pl
#
# Modified version of perl5db.pl for use with the
# ActiveState Perl Debugger(tm).
#
# Copyright (c) 1998 ActiveState Tool Corp
#.......................................................

$Win32::OLE::_Unique = 1;

# Debugger package
package DB;
require Win32::OLE;

BEGIN { $ready = 1 }

#init $deep to avoid warning
$deep=0;

# avoid stepping into OLE's END blocks
eval 'END { $ready = 0 }';

$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;
}

$app = Win32::OLE->new('PerlDebugger.Document');
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;
}

# debug output?
$ldebug = 0;

# maximum length of watch results
$MAX_WATCH_LEN = 2000;
$printUndef = 0;

# more stuff
require Config;
require Cwd;

# get current directory
$cwd = Cwd::cwd();

# cwd bug: returns C: rather than C:/ if we're in the root, so work around it
if ($cwd =~ /^[A-Z]:$/i) {
    $cwd .= "/";
}

# notify app of current directory
$app->SetCurrentDirectory($cwd);
print STDERR "Current Directory: $cwd\n" if $ldebug;

# turn off warnings (?)
local($^W) = 0;

# set console file name
$console = "con";

# set name of file with initialization code
$rcfile = "perldb.ini";

# open input and output (to and from console)
open(IN, "<$console") || open(IN,  "<&STDIN") || warn "open(IN)";
open(OUT,">$console") || open(OUT, ">&STDERR") || open(OUT, ">&STDOUT") || warn "open(OUT)";

# force autoflush of output
select(OUT);
$| = 1;		# for DB::OUT
select(STDOUT);
$| = 1;		# for real STDOUT

# to avoid warnings?
$sub = '';
#@ARGS;

my $current_filename = '';

#
# DB
#
# Main debugger subroutine
#
sub DB
{
    return unless $ready;
    # do important stuff
    &save;
    ($pkg, $filename, $line) = caller;
    $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
	"package $pkg;";	# this won't let them modify, alas

    if ($filename =~ s/ \(autosplit .*$//) {
	my $substr = $Config::Config{prefix};
	$filename =~ s/^\.\./$substr/;
    }

    local(*dbline) = "::_<$filename";
    $max = $#dbline;
    if (($stop,$action) = split(/\0/,$dbline{$line}))
    {
	if ($stop eq '1')
	{
	    $signal |= 1;
	}
	else
	{
	    $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
	    $dbline{$line} =~ s/;9($|\0)/$1/;
	}
    }
    if ($single || $trace || $signal)
    {
	# update watch variables first
	$updatestatus = 1;

	# more important stuff
	$prefix = $sub =~ /'|::/ ? "" : "${pkg}::";
	$prefix .= "$sub($filename:";
	if (length($prefix) > 30)
	{
	    $prefix = "";
	    $infix = ":\t";
	}
	else
	{
	    $infix = "):\t";
	}
	for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i)
	{
	    last if $dbline[$i] =~ /^\s*(}|#|\n)/;
	}
    }
    $evalarg = $action, &eval if $action;
    if ($single || $signal)
    {
	print OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4;
	# command loop
	CMD:
	while (print OUT "")
	{
	    # never stop in OLE.pm
	    last CMD if $filename =~ /ole\.pm/i;

	    # tell LPD where the source file is
	    if ($current_filename ne $filename) {
		$current_filename = $filename;
		$updatestatus = 1;
		$app->{'SourceFile'} = $filename;
	    }
	    $app->{'LineNumber'} = int $line;

	    # debug message
	    print STDERR "Source: $filename (line $line)\n" if $ldebug;

	    # check if we're immediately updating
	    if ($updatestatus)
	    {
		# update status now
		$cmd = "UpdateStatus";
		$updatestatus = 0;

		# debug message
		print STDERR "Command: $cmd\n" if $ldebug;
	    }
	    else
	    {
#		# tell program we're ready
#		$app->{'Command'} = "";

		# wait for command string
		$sync->Wait();
#		do
#		{
		    # give a little time to Windows
#DH: hack to take out currently, will chew up lots of processor resources like this though
#		    Win32::Sleep(0);
#		    sleep(0);

		    # get command string from Windows program
		    $cmd = $app->{'Command'};
#		}
#		while ($cmd eq "");

		# debug message
		print STDERR "Command: $cmd\n" if $ldebug;
	    }

	    # more important stuff
	    $single = 0;
	    $signal = 0;
	    $cmd eq '' && exit 0;

	    # check command
	    if ($cmd eq "Quit")
	    {
		# debug message
		print STDERR "Exiting script..." if $ldebug;

		# exit script
		exit 0;
	    }
	    elsif ($cmd eq "RemoveAllBreakpoints")
	    {
		# debug message
		print STDERR "Removing all breakpoints...\n" if $ldebug;

		# iterate lines and delete breakpoints
		for ($i = 1; $i <= $max ; $i++)
		{
		    if (defined $dbline{$i})
		    {
			$dbline{$i} =~ s/^[^\0]+//;
			if ($dbline{$i} =~ s/^\0?$//)
			{
			    delete $dbline{$i};
			}
		    }
		}

		# notify window
		$app->RemoveAllBreakpoints();
	    }
	    elsif (substr($cmd,0,19) eq "CanInsertBreakpoint")
	    {
		# grab line number and condition
		$i = int substr($cmd,20,9);

		# debug message
		print STDERR "Checking if breakpoint allowed at line $i...\n" if $ldebug;

		# insert breakpoint
		if ($i >= 0 && $dbline[$i] != 0)
		{
		    # say yes
		    $app->{'Response'} = "1";
		}
		else
		{
		    # say no
		    $app->{'Response'} = "0";
		}
	    }
	    elsif (substr($cmd,0,16) eq "InsertBreakpoint")
	    {
		# grab line number and condition
		$i = int substr($cmd,17,9);
		$cond = substr($cmd,27);

		# find breakable line
		# while ($dbline[$i] == 0 && $i < $#dbline) { $i++; }
		# while ($dbline[$i] == 0 && $i >= 0) { $i--; }

		# debug message
		print STDERR "Inserting breakpoint at line $i (condition ($cond))...\n" if $ldebug;

		# insert breakpoint
		if ($i >= 0 && $dbline[$i] != 0)
		{
		    # always remove old breakpoint
		    if ($dbline{$i} ne '')
		    {
			$dbline{$i} =~ s/^[^\0]*//;
			delete $dbline{$i} if $dbline{$i} eq '';
		    }

		    # insert breakpoint
		    $dbline{$i} =~ s/^[^\0]*/$cond/;
		    $app->InsertBreakpoint(int $i,$cond);
		}
		else
		{
		    # debug message
		    print STDERR "Can't insert breakpoint at line $i...\n" if $ldebug;
		}
	    }
	    elsif (substr($cmd,0,16) eq "RemoveBreakpoint")
	    {
		# grab line number
		$i = int substr($cmd,17,9);

		# find breakable line
		# while ($dbline[$i] == 0 && $i < $#dbline) { $i++; }
		# while ($dbline[$i] == 0 && $i >= 0) { $i--; }

		# debug message
		print STDERR "Removing breakpoint at line $i...\n" if $ldebug;

		# remove breakpoint
		if ($i >= 0 && $dbline[$i] != 0)
		{
		    # remove breakpoint
		    $dbline{$i} =~ s/^[^\0]*//;
		    delete $dbline{$i} if $dbline{$i} eq '';
		    $app->RemoveBreakpoint(int $i);
		}
		else
		{
		    # debug message
		    print STDERR "Can't remove breakpoint at line $i...\n" if $ldebug;
		}
	    }
	    elsif (substr($cmd,0,16) eq "ToggleBreakpoint")
	    {
		# grab line number
		$i = int substr($cmd,17,9);
		$cond = "1";

		# find breakable line
		while ($dbline[$i] == 0 && $i < $#dbline) { $i++; }
		while ($dbline[$i] == 0 && $i >= 0) { $i--; }

		# toggle breakpoint
		if ($i >= 0)
		{
		    # check if no breakpoint
		    if ($dbline{$i} eq '')
		    {
			# debug message
			print STDERR "Inserting breakpoint at line $i (condition ($cond))...\n" if $ldebug;

			# insert breakpoint
			$dbline{$i} =~ s/^[^\0]*/$cond/;
			$app->InsertBreakpoint(int $i,$cond);
		    }
		    else
		    {
			# debug message
			print STDERR "Removing breakpoint at line $i...\n" if $ldebug;

			# remove breakpoint
			$dbline{$i} =~ s/^[^\0]*//;
			delete $dbline{$i} if $dbline{$i} eq '';
			$app->RemoveBreakpoint(int $i);
		    }
		}
	    }
	    elsif ($cmd eq "StepOver")
	    {
		# debug message
		print STDERR "Stepping over...\n" if $ldebug;

		# step over
		$single = 2;
		last CMD;
	    }
	    elsif ($cmd eq "StepInto")
	    {
		# debug message
		print STDERR "Stepping into...\n" if $ldebug;

		# step into
		$single = 1;
		last CMD;
	    }
	    elsif ($cmd eq "StepOut")
	    {
		# debug message
		print STDERR "Stepping out...\n" if $ldebug;

		# step out
		$stack[$#stack] |= 2;
		last CMD;
	    }
	    elsif ($cmd eq "Continue")
	    {
		# debug message
		print STDERR "Continuing...\n" if $ldebug;

		# continue
		for ($i=0; $i <= $#stack; )
		{
		    $stack[$i++] &= ~1;
		}
		last CMD;
	    }
	    elsif (substr($cmd,0,11) eq "RunToCursor")
	    {
		# grab line number
		$i = int substr($cmd,12,9);

		# find breakable line
		while ($dbline[$i] == 0 && $i < $#dbline) { $i++; }
		while ($dbline[$i] == 0 && $i >= 0) { $i--; }

		# debug message
		print STDERR "Running to line $i...\n" if $ldebug;

		# set breakpoint at cursor
		if ($i >= 0)
		{
		    # add one-time-only breakpoint
		    $dbline{$i} =~ s/(\0|$)/;9$1/;
		}

		# continue
		for ($i=0; $i <= $#stack; )
		{
		    $stack[$i++] &= ~1;
		}
		last CMD;
	    }
	    elsif ($cmd eq "CallStack")
	    {
		# standard call stack code
		local($p,$f,$l,$s,$h,$a,@a,@sub,$callnames,$callfiles,$calllines);
		for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++)
		{
		    @a = ();
		    for $arg (@args)
		    {
			$_ = "$arg";
			s/'/\\'/g;
			s/([^\0]*)/'$1'/
			unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
			s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
			s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
			push(@a, $_);
		    }
		    $w = $w ? '@ = ' : '$ = ';
		    $a = $h ? '(' . join(', ', @a) . ')' : '';
		    push(@sub, "$w$s$a from file $f line $l\n");

		    # store my way
		    $callnames .= "$w$s$a\n";
		    $callfiles .= "$f\n";
		    $calllines .= "$l\n";

		    last if $signal;
		}

		# send results to app
		$app->DisplayCallStack($callnames,$callfiles,$calllines);
	    }
	    elsif ($cmd eq "UpdateStatus")
	    {
		# debug message
		print STDERR "Updating status...\n" if $ldebug;

		# update status
		$watchlist = $app->{'WatchList'};
		@watchlist = split("\n",$watchlist,-1);

		foreach $watchsublist (@watchlist)
		{
		    @watchsublist = split("\t",$watchsublist,-1);

		    foreach $watchexpr (@watchsublist)
		    {
			$after = "";
			$evalarg = "local \$^W=0; \$DB::after = ( " . $watchexpr . " )";
			&eval;
			defined($after) || ($after = "");
			{
			    $after =~ s!\n!\\n!g;
			    $after =~ s!\t!\\t!g;
			    $after =~ s![\x00-\x1f]!.!g;
			}
			if (length $after > $MAX_WATCH_LEN)
			{
			    $watchexpr = substr($after,0,$MAX_WATCH_LEN) . "...";
			}
			else
			{
			    $watchexpr = $after;
			}
		    }

		    $watchsublist = join("\t",@watchsublist);
		}

		$watchlist = join("\n",@watchlist);

		$app->{'WatchList'} = $watchlist;
	    }
	    elsif (substr($cmd,0,10) eq "DoWatchTip")
	    {
		# debug message
		print STDERR "Checking watch tip...\n" if $ldebug;

		# grab line number
		$watchexpr = substr($cmd,11);

		# calculate watch
		{
		    $after = "";
		    $evalarg = "\$DB::after = ( " . $watchexpr . " )";
		    &eval;
		    {
			$after =~ s!\n!\\n!g;
			$after =~ s!\t!\\t!g;
			$after =~ s![\x00-\x1f]!.!g;
		    }
		    if (length $after > $MAX_WATCH_LEN)
		    {
			$watchexpr = substr($after,0,$MAX_WATCH_LEN) . "...";
		    }
		    else
		    {
			$watchexpr = $after;
		    }
		}

		# generate response
		$app->{'Response'} = "$watchexpr\n";
	    }
	    elsif (substr($cmd,0,12) eq "DumpVariable")
	    {
		# debug message
		print STDERR "Dumping variable...\n" if $ldebug;

		# 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);
		}

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

		# send to temporary file
		my $vardump = $app->GetTempFile();
		if (open (VARDUMP,">$vardump"))
		{
		    # select temporary variable
		    local ($saveout) = select(VARDUMP);

		    # grab package name and variables

		    my ($packname, $tempvarname);
		    if (scalar(($packname, $tempvarname)=split(/::(?=[^:]+)$/, $varname)) == 2) {
			@vars = ($tempvarname);
		    }
		    else {
			$packname = $pkg;
			@vars = ( $varname );
		    }

		    {
			require Data::Dumper;
			eval ("$usercontext print Data::Dumper->new([$varnamechar$varname],['$deref$varname'])->Dump;");
		    }

		    # reselect previous output
		    select ($saveout);
		    # generate response
		    close (VARDUMP);
		}
		else
		{
		    # error
		    print DB::OUT "Unable to open '$vardump' for output!\n";
		    $vardump = "";
		}

		# set response
		$app->{'Response'} = "$vardump\n";
	    }
	    elsif ($cmd eq "SourceFile")
	    {
		# debug message
		print STDERR "Sending $filename ($#dbline lines) to debugger...\n" if $ldebug;

		# send line count
		$app->SetSourceFileLineCount($#dbline);

		# send each line
		for ($linenum = 1; $linenum <= $#dbline; $linenum++)
		{
		    $linestr = $dbline[$linenum];
		    chomp $linestr;
		    $app->SetSourceFileLine(int $linenum,$linestr);
		}
	    }
	}
    }

    # important stuff
    ($@, $!, $,, $/, $\, $^W) = @saved;
    ();
}

#
# save
#
# Save registers.
#
sub save
{
    @saved = ($@, $!, $,, $/, $\, $^W);
    $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}

#
# eval
#
# Evaluate $evalarg (to preserve current @_).
#
sub eval
{
    eval "$usercontext $evalarg; &DB::save";
}

#
# catch
#
# Catches exceptions?
#
sub catch
{
    $signal = 1;
}

#
# sub
#
# Called automatically?
#
sub sub
{
    my ($i, @i); ## dcb -- Bug Fix from John Mongan (john@rescomp.stanford.edu ) 3/20/98
    push(@stack, $single);
    $single &= 1;
    $single |= 4 if $#stack == $deep;
    if (wantarray)
    {
	@i = &$sub;
	$single |= pop(@stack);
	@i;
    }
    else
    {
        if (defined wantarray) {
	    $i = &$sub;
        } else {
            &$sub; undef $i;
        };
	$single |= pop(@stack);
	$i;
    }
}

# uninitialized warning suppression
$trace = $signal = $single = 0;

# exception handling?
$SIG{'INT'} = "DB::catch";

# some defaults
$deep = 10000;

# important stuff
@stack = (0);
@ARGS = @ARGV;
for (@args)
{
    s/'/\\'/g;
    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
}

# important stuff?
if (-f $rcfile)
{
    do "./$rcfile";
}
elsif (-f "$ENV{'LOGDIR'}/$rcfile")
{
    do "$ENV{'LOGDIR'}/$rcfile";
}
elsif (-f "$ENV{'HOME'}/$rcfile")
{
    do "$ENV{'HOME'}/$rcfile";
}

1;
