path_with_debugger.pl

#!/opt/local/bin/perl

use warnings;
use strict;
use Term::InKey;
use Tk::Table;

my ($face, $memp, $x, $y, $clicked_x, $clicked_y, $done, $child, @src, @mem, @breaks);
my %slashmap = (
		'right' => 'up',
		'down'  => 'left',
		'left'  => 'down',
		'up'    => 'right',
		);
my %bslashmap = (
		 'right' => 'down',
		 'down'  => 'right',
		 'left'  => 'up',
		 'up'    => 'left',
		 );
my %call = (
	    '+'  => sub { $mem[$memp]++ },
	    '-'  => sub { $mem[$memp]-- },
	    '>'  => sub { $memp++; $mem[$memp]=0 unless defined($mem[$memp]) },
	    '<'  => sub { $memp-- },
	    ','  => sub { $mem[$memp] = ord &ReadKey },
	    '.'  => sub { print chr $mem[$memp] },
	    '^'  => sub { $face = 'up' unless $mem[$memp]  },
	    '{'  => sub { $face = 'left'  unless $mem[$memp]  },
	    '}'  => sub { $face = 'right'  unless $mem[$memp] },
	    'v'  => sub { $face = 'down'  unless $mem[$memp] },
	    '/'  => sub { $face = $slashmap{$face} },
	    '\\' => sub { $face = $bslashmap{$face} },
	    '&'  =>
	    sub {
		    if ($_=fork) {
			$mem[$memp]=$_;
			$face = $slashmap{$face};
		    } else {
			$mem[$memp]=0;
			$child=defined;
			$face = $bslashmap{$face};
		    }
		},
	    '*'	 => sub { wait; $mem[$memp] = $? >> 8 },
	    '#'  => sub { if (defined $child) {exit $mem[$memp]} else {$done = $mem[$memp]} },
	    'right' => sub { $x++ },
	    'left' => sub { $x-- },
	    'up' => sub { $y-- },
	    'down' => sub { $y++ },
	    );

(defined $ARGV[0] and open SRC, $ARGV[0]) or die "usage: $0 file_to_run. $!";
while (<SRC>) {
    chomp;
    push @src, [split ''];
}
close SRC;

my $mw = new MainWindow();
my $mem_display = $mw->Label()->pack(-expand => 'yes',-fill => 'both');
$mem_display->configure(-text => "0");


my $tableFrame = $mw
    ->Frame(-borderwidth => 2,-relief => 'raised')
    ->pack(-expand => 'yes',-fill => 'both');

my $table = $tableFrame->Table(-columns => 1000, -rows => 1000,
			       -fixedrows => 0, -scrollbars => 'se',
			       -relief => 'raised');

$mw->bind('<Any-KeyPress>', [ \&keypress, $table ]);

for ( my $i = 0; $i < scalar @src; $i++) {
    for ( my $j = 0; $j < scalar @{$src[$i]}; $j++) {
	my $data = $src[$i][$j];
	my $tmp = $table->Label(-text => $data, -padx => 2, -anchor => 'w',
				-background => 'white', -relief => 'groove'
				);
	$tmp->bind('<Button-1>', [ \&select_to_update, $table ]);
	$tmp->bind('<Button-3>', [ \&toggle_breakpoint, $table ]);

	$table->put( $i, $j, $tmp );
    }
}

$table->pack( -expand => 'yes', -fill => 'both');

my $buttonBar = $mw->Frame( -borderwidth => 4 )->pack(-fill => 'y');
my $runB = $buttonBar->Button(-text => "Run from start", -command => \&run_from_scratch);
my $contB = $buttonBar->Button(-text => "Continue Execution", -command => \&run);
my $addrowB = $buttonBar->Button(-text => "Row+", -command => \&extend_row);
my $addcolB = $buttonBar->Button(-text => "Col+", -command => \&extend_col);
my $exitB = $buttonBar->Button(-text => "Quit", -width => 10, -command => sub { exit });
foreach ( $runB, $contB, $addrowB, $addcolB, $exitB ) {
    $_->pack(-side => 'left', -padx => 2 );
}

Tk::MainLoop;

sub run_from_scratch {
    # reset execution pointers and memory
    ($face, $memp, $x, $y,) = ('right', 0, 0, 0);
    @mem = (0);
    $done = undef;
    &run;
}
sub run {
    my ($title, $cell);
    RUN: while (!defined $done) {
	if (!defined $child) {
	    $cell = $table->get($y,$x);
	    $cell->configure(-foreground => 'black');
	}
	defined $call{$src[$y][$x]} and &{$call{$src[$y][$x]}};
	&{$call{$face}};

	# Update the display, unless I'm a child
	if (!defined $child) {
	    $cell = $table->get($y,$x);
	    $cell->configure(-foreground => 'red');
	    $mw->idletasks;
	$title = '';
	    foreach (@mem) {
		$title .= " $_,";
		chop $title;
	    }
	    $mem_display->configure(-text => $title);
	}
	# We're not $done, but we're at a breakpoint. Children don't break.
	if (!defined $child) {
	    foreach (@breaks) {
		if ($$_[0] == $y and $$_[1] == $x) {
		    $title .= "\nBreakpoint caught at ($x, $y)";
		    last RUN;
		}
	    }
	}
    }
    $mem_display->configure(-text => $title.' (not running)') unless defined $child;
}
sub extend_row {
    my ($w, $t) = @_;
    my $tmp = $table->Label(-text => ' ', -padx => 2, -anchor => 'w',
			    -background => 'white', -relief => 'groove'
			    );
    $tmp->bind('<Button-1>', [ \&select_to_update, $table ]);
    $tmp->bind('<Button-3>', [ \&toggle_breakpoint, $table ]);
    $table->put( scalar @src, 0, $tmp );
    $src[scalar @src][0] = ' ';
}
sub extend_col {
    my ($w, $t) = @_;
    if (defined $clicked_x) {
	my $tmp = $table->Label(-text => ' ', -padx => 2, -anchor => 'w',
				-background => 'white', -relief => 'groove'
				);
	$tmp->bind('<Button-1>', [ \&select_to_update, $table ]);
	$tmp->bind('<Button-3>', [ \&toggle_breakpoint, $table ]);
	$table->put( $clicked_y, scalar @{$src[$clicked_y]}, $tmp );
	$src[$clicked_y][scalar @{$src[$clicked_y]}] = ' ';
    }
}
sub select_to_update {
    my ($w, $t) = @_;
    ($clicked_y, $clicked_x) = $t->Posn( $w );
}
sub toggle_breakpoint {
    my ($w, $t) = @_;
    my ($x, $y) = $t->Posn( $w );
    my $tmp = $t->get($x, $y);
    my $found;
    # If I'm a break, disable me. If not, enable
    for (my $i = 0; $i < scalar @breaks; $i++) {
	if ($x == $breaks[$i][0] and $y == $breaks[$i][1]) {
	    $found = defined;
	    splice(@breaks,$i,1);
	    last;
	}
    }
    # Add break and darken square
    if (defined $found) {
	$tmp->configure(-background => 'white');
    } else {
	push @breaks, [$x, $y];
	$tmp->configure(-background => 'grey');
    }
}
sub keypress {
    my ($w) = @_;
    my $e = $w->XEvent;
    if (defined $clicked_y and $e->A) {
	$src[$clicked_y][$clicked_x] = $e->A;
	my $tmp = $table->get( $clicked_y, $clicked_x );
	$tmp->configure(-text => $e->A );
    }
}