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

# Debugger package
package DB;

# check for a valid script before we even create OLE objects and start up
# if no script then they wanted to go into the console mode debugger.
# if no -e either, same thing.
# 
if ( $0 =~ /^-e/ || $0 eq "-" ) { 
	print STDERR "No Source file, Assuming Console Debug mode\n"; 
	require 'Perl5DB.pl'; 
	# dump out of here and run the perl5 debugger off the @INCS list.
	# its begin block will take over.
	#
	}

else
{


# Check which OLE is avaialable to us
$AS_OLE = 1;
eval 'use OLE;';
if ($@ ne '') {
	eval 'use Win32::OLE;';
	if ($@ ne '') {
		
		die "Perl Debugger requires either the OLE or the Win32::OLE module extension.\n$@";
	}
	else{
		$AS_OLE = 0;
	}
}





# open Perl Debugger
# hacked for current Win32::OLE.pm module
if ($AS_OLE == 1)
{
	$app = CreateObject OLE 'PerlDebugger.Document';
}
else
{
	$app = new Win32::OLE '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;

# more stuff
require Config;
require Cwd;

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

# 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");
open(OUT,">$console") || open(OUT, ">&STDERR") || open(OUT, ">&STDOUT");

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

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

#
# DB
#
# Main debugger subroutine
#
sub DB
{
	# do important stuff
    &save;
    ($pkg, $filename, $line) = caller;
    $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
	"package $pkg;";		# this won't let them modify, alas
    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 lc(substr($filename,-6)) eq "ole.pm";

			# tell LPD where the source file is
			$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
				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 = "\$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;
						}
					}

					$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
				$varname = substr($cmd,13);

				# remove variable symbol
				my $varnamechar = substr($varname,0,1);
				if ($varnamechar eq '$' or		# ' dcb -- just a comment to fix Emacs syntax coloring
					$varnamechar eq '@' or
					$varnamechar eq '%')
				{
					$varname = substr($varname,1);
				}

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

					# grab package name and variables

					#########
					# dcb - Added bug fix from John Mongan (john@stanford.edu)
					#
					# Original:
					#$packname = $pkg;
					#@vars = ( $varname );
					#
					# New:
					my ($tempvarname);
					if (scalar(($packname, $tempvarname)=split(/::(?=[^:]+)$/, $varname)) == 2) {
						@vars = ($tempvarname);
					}
					else {
						$packname = $pkg;
						@vars = ( $varname );
					}
					# End bug fix
					#########
						
					# call dumpvar
					do 'dumpvar.pl' unless defined &main::dumpvar;
					if (defined &main::dumpvar)
					{
						# dump variable
						&main::dumpvar($packname,@vars);
					}
					else
					{
						# print error message
						print DB::OUT "Module 'dumpvar.pl' is not available!\n";
					}

					# 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 Morgan (john@stanford.edu) 3/20/98
    push(@stack, $single);
    $single &= 1;
    $single |= 4 if $#stack == $deep;
    if (wantarray)
	{
		@i = &$sub;
		$single |= pop(@stack);
		@i;
    }
    else
	{
		$i = &$sub;
		$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;
}