package DB;

BEGIN { require TkPreventDB }

require "filedisplay.pl";
require "varwatcher.pl";
require "pad.pl";

sub DB {
    return unless $ready;
    &save;
    ($package, $filename, $line) = caller;
    $usercontext = '($@, $!, $,, $/, $\) = @saved;' .
	"package $package;";		# this won't let them modify, alas
    local($^P) = 0;			# don't debug our own evals
    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/;
	}
    }
    update;
    if ($single || $showtrace || $signal) {
	$fd->showfile($filename);
	$fd->showline($line);
        $subname = ($sub =~ /'|::/) ? $sub : "$package::$sub";
    }
    $evalarg = $action, &eval if $action;
    if ($single || $signal) {
	$evalarg = $pre, &eval if $pre;
        $single = 0;
        $signal = 0;
	$running = 0;
# Now sit in an event loop until something sets $running
	waitvar($running) until $running;
    }	
    if ($post) {
        $evalarg = $post; &eval;
    }
    ($@, $!, $,, $/, $\) = @saved;
}

sub save {
    @saved = ($@, $!, $,, $/, $\);
    $, = ""; $/ = "\n"; $\ = "";
}

# The following takes its argument via $evalarg to preserve current @_
    
sub eval {
    eval "$usercontext $evalarg; &DB::save";
    output($@) if $@;
}
			
sub sub {
    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;
    }
}

#
# Callbacks defined here
#

sub next {
    $laststep = "n";
    $single = 2;
    $running = 1;
}

sub step {
    $laststep = "s";
    $single = 1;
    $running = 1;
}

sub cont {
    my $i;
    for ($i = 0; $i <= $#stack; $i++) {
	$stack[$i] &= ~1;
    }
    $single = 0;
    $running = 1;
}

sub ret {
    $stack[$#stack] |= 2;
    $running = 1;
}

sub showstack {
    my($p,$f,$l,$s,$h,$a,@a);
    for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
	@a = @args;
	for (@a) {
	    s/'/\\'/g;
	    s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
	    s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
	    s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
	}
	$w = $w ? '@ = ' : '$ = ';
	$a = $h ? '(' . join(', ', @a) . ')' : '';
	output("$w&$s$a from file $f line $l");
	last if $signal;
    }
}

sub output {
    foreach (@_) {
        $pad->append($_);
    }
}

sub help {
    if ($helpdone) {
        wm("deiconify", $helptop);
        return;
    }
    $helptop = Toplevel::new(".help");
$helptext = <<EOH;
v var		Add variable $var to the variable watcher window
V var		Remove variable $var from the variable watcher window
T		Stack trace.
s		Single step.
n		Next, steps over subroutine calls.
r		Return from current subroutine.
c [line]	Continue; optionally inserts a one-time-only breakpoint 
		at the specified line.
<CR>		Repeat last n or s.
f filename	Switch to filename.
/pattern/	Search forwards for pattern; final / is optional.
?pattern?	Search backwards for pattern.
L		List breakpoints and actions.
S		List subroutine names.
t		Toggle trace mode.
b [line] [condition]
		Set breakpoint; line defaults to the current execution line; 
		condition breaks if it evaluates to true, defaults to \'1\'.
b subname [condition]
		Set breakpoint at first line of subroutine.
d [line]	Delete breakpoint.
D		Delete all breakpoints.
a [line] command
		Set an action to be done before the line is executed.
		Sequence is: check for breakpoint, print line if necessary,
		do action, prompt user if breakpoint or step, evaluate line.
A		Delete all actions.
< command	Define command before prompt.
> command	Define command after prompt.
p expr		Output expr to the pad
command	Execute as a perl statement in current package.
EOH
    tkpack(Button::new($helptop, "-text" => "Dismiss",
                       "-method" => sub { wm("withdraw", $helptop) }),
	   "-fill" => "x");
    tkpack(Message::new($helptop, "-text" => $helptext), "-fill" => "both");
    $helpdone = 1;
    return;
}

sub dismisshelp {
    wm("withdraw", $helptop);
}

sub padcommand {
    my($cmd) = shift;
    output("> $cmd");
    $cmd =~ /^v\b\s*(.*)$/ && do {
        watchon($1);
        return;
    };
    $cmd =~ /^V\b\s*(.*)$/ && do {
        watchoff($1);
        return;
    };
    $cmd =~ /^t$/ && do {
        $showtrace = !$showtrace;
        output("Trace = ".($showtrace?"on":"off"));
        return;
    };
    $cmd =~ /^S$/ && do {
        foreach $subname (sort(keys %sub)) {
            output($subname);
        }
        return;
    };
    $cmd =~ /^f\b\s*(.*)/ && do {
        $file = $1;
        if (!file) {
            output("missing filename");
            return;
        }
        if (!defined $::_main{'_<' . $file}) {
            if (($try) = grep(m#^_<.*$file#, keys %::_main)) {
                $file = substr($try,2);
                output("$file:");
            }
        }
        if (!defined $::_main{'_<' . $file}) {
            output("There's no code here for anything matching $file.");
        }
        elsif ($file ne $filename) {
            *dbline = "::_<$file";
            $max = $#dbline;
            $filename = $file;
            $start = 1;
            $cmd = "l";
            $fd->showfile($filename);
            $fd->showline(1);
        }
        return;
    };
    $cmd =~ /^D$/ && do {
        output("Deleting all breakpoints...");
        for ($i = 1; $i <= $max ; $i++) {
            if (defined $dbline{$i}) {
                $dbline{$i} =~ s/^[^\0]+//;
                if ($dbline{$i} =~ s/^\0?$//) {
                    delete $dbline{$i};
                }
            }
        }
        return;
    };
    $cmd =~ /^L$/ && do {
        for ($i = 1; $i <= $max; $i++) {
            if (defined $dbline{$i}) {
                output(sprintf("%5d %s", $i, $dbline[$i]));
                ($stop,$action) = split(/\0/, $dbline{$i});
                output("  break if ( $stop )") if $stop;
                output("  action:  $action") if $action;
                return if $signal;
            }
        }
        return;
    };
    $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
        $subname = $1;
        $cond = $2 || '1';
        $subname = "$package::" . $subname unless $subname =~ /'|::/;
        $subname = "main" . $subname if substr($subname,0,1) eq "'";
        $subname = "main" . $subname if substr($subname,0,2) eq "::";
        ($filename,$i) = split(/:/, $sub{$subname});
        $i += 0;
        if ($i) {
            *dbline = "::_<$filename";
            ++$i while $dbline[$i] == 0 && $i < $#dbline;
            $dbline{$i} =~ s/^[^\0]*/$cond/;
        } else {
            output("Subroutine $subname not found.");
        }
        return;
    };
    $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
        $i = ($1?$1:$line);
        $cond = $2 || '1';
        if ($dbline[$i] == 0) {
            output("Line $i not breakable.");
        } else {        
            $dbline{$i} =~ s/^[^\0]*/$cond/;
        }
	return;
    };
    $cmd =~ /^d\b\s*(\d+)?/ && do {
        $i = ($1?$1:$line);
        $dbline{$i} =~ s/^[^\0]*//;
        delete $dbline{$i} if $dbline{$i} eq '';
        return
    };
    $cmd =~ /^A$/ && do {
        for ($i = 1; $i <= $max ; $i++) {
            if (defined $dbline{$i}) {
                $dbline{$i} =~ s/\0[^\0]*//;
                delete $dbline{$i} if $dbline{$i} eq '';
             }
        }
        return;
    };
    $cmd =~ /^<\s*(.*)/ && do {
        $pre = $1;
        return;
    };
    $cmd =~ /^>\s*(.*)/ && do {
        $post = $1;
	return;
    };
    $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
        $i = $1;
        if ($dbline[$i] == 0) {
            output("Line $i may not have an action.");
        } else {
            $dbline{$i} =~ s/\0[^\0]*//;
            $dbline{$i} .= "\0" . $3;
        }
	return;
    };
    $cmd =~ /^$/ && ($cmd = $laststep);
    $cmd =~ /^n$/ && goto &next;
    $cmd =~ /^s$/ && goto &step;
    $cmd =~ /^h$/ && goto &help;
    $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
        $i = $1;
        if ($i) {
            if ($dbline[$i] == 0) {
                output("Line $i not breakable.");
                return;
            }
            $dbline{$i} =~ s/(\0|$)/;9$1/;	# add one-time-only b.p.
        }
        for ($i=0; $i <= $#stack; ) {
            $stack[$i++] &= ~1;
        }
        $running = 1;
        return;
    };
    $cmd =~ /^\/(.*)$/ && do {
        $inpat = $1;
        $inpat =~ s:([^\\])/$:$1:;
        if ($inpat ne "") {
            eval '$inpat =~ m'."\n$inpat\n";	
                if ($@ ne "") {
                    output($@);
                    return;
                }
            $pat = $inpat;
        }
        $end = $start;
        eval '
            for (;;) {
                ++$start;
                $start = 1 if ($start > $max);
                last if ($start == $end);
                if ($dbline[$start] =~ m'."\n$pat\n".'i) {
                    $fd->showline($start);
                    last;
                }
            }
        ';
        output("/$pat/: not found") if ($start == $end);
        return;
    };
    $cmd =~ /^\?(.*)$/ && do {
        $inpat = $1;
        $inpat =~ s:([^\\])\?$:$1:;
        if ($inpat ne "") {
            eval '$inpat =~ m'."\n$inpat\n";	
            if ($@ ne "") {
                output($@);
                return;
            }
            $pat = $inpat;
        }
        $end = $start;
        eval '
            for (;;) {
                --$start;
                $start = $max if ($start <= 0);
                last if ($start == $end);
                if ($dbline[$start] =~ m'."\n$pat\n".'i) {
                    $fd->showline($start);
                    last;
                }
            }
        ';
        output("?$pat?: not found") if ($start == $end);
        return;
    };
    $cmd =~ /^r$/ && goto &ret;
    $cmd =~ /^T$/ && goto &showstack;
    $cmd =~ s/^p\b\s*(.*)$/DB::output($1)/;
    $evalarg = $cmd; &eval;
}

sub watchon {
    my($varname) = shift;
    my($vw);
    local(*thevar);

    $varname = "$package::$varname" unless $varname =~ /'|::/;
    if ($watched{$varname}) {
        output("$varname already watched");
    } else {
        *thevar = $varname;
        $vw = Varwatcher::new($varw, $varname, \$thevar),
        tkpack($vw, "-fill" => "x", "-expand" => "y");
        $watched{$varname} = $vw;
    }
}

sub watchoff {
    my($varname) = shift;
    $varname = "$package::$varname" unless $varname =~ /'|::/;
    if ($watched{$varname}) {
        undef $watched{$varname};
        delete $watched{$varname};
    } else {
        output("$varname not watched");
    }
}    

#
# Initialise everything here
#

$top = tkinit();
#tclcmd("option", "add", "*Font", "lucidasanstypewriter-12");
$sub = '';
$filename = '';
$subname = '';
$line = '';
$showtrace = '';

# button frame and its buttons
$butframe = Frame::new($top);
tkpack(Button::new($butframe, "-text" => "Quit", "-method" => sub { exit 0 }),
    Button::new($butframe, "-text" => "Help", "-method" => "DB::help"),
    Button::new($butframe, "-text" => "Stack", "-method" => "DB::showstack"),
    Button::new($butframe, "-text" => "Next", "-method" => "DB::next"),
    Button::new($butframe, "-text" => "Step", "-method" => "DB::step"),
    Button::new($butframe, "-text" => "Continue", "-method" => "DB::cont"),
    Button::new($butframe, "-text" => "Return", "-method" => "DB::ret"),
    Button::new($butframe, "-text" => "Break", "-method" => sub {$single = 1}),
    Checkbutton::new($butframe, "-text" => "trace", "-variable" => $showtrace),
    "-side" => "left", "-fill" => "x", "-expand" => "y");
$statusframe = Frame::new($top);
tkpack(Varwatcher::new($statusframe, "Filename", \$filename),
           Varwatcher::new($statusframe, "Line", \$line),
           Varwatcher::new($statusframe, "Subroutine", \$subname),
           "-side" => "left", "-fill" => "x", "-expand" => "y");
tkpack $butframe, $statusframe, "-fill" => "x";

$fd = Filedisplay::new($top);
$pad = Pad::new($top);
$pad->handler(\&padcommand);
$pad->focus();
$varw = Frame::new($top);
tkpack $fd, $pad, "-fill" => "both", "-expand" => "y";
tkpack $varw, "-fill" => "x";

wm("maxsize", $top, 2000, 2000);
# The following geometry comes from trial and error: Tk seems to have
# trouble measuring non-fully-qualified fonts
wm("geometry", $top, "51x15");

$sub = '';
$running = 1;
$single = 1;
$ready = 1;
# $trace always needs to be set otherwise we miss the event loop.
# $showtrace is set for 'trace' mode and that tracks and displays source.
$trace = 1;
$deep = 100;
@stack = (0);
@ARGS = @ARGV;
# perl5alpha6 gives a 'readonly' error for the following bit
for (@args) {
#    s/'/\\'/g;
#    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
}

1;
