#!/usr/local/bin/perl -w
#
# This script implements a simple remote-control mechanism for Tk applications.  It allows you to select an application and
# then type commands to that application.


require 5.001;
use English;
use lib ('blib');use Tk;
use Tk::ErrorDialog;
sub get_eval_status; sub prompt;

$top = MainWindow->new;
$top->title('Tk Remote Controller');
$top->iconname('Tk Remote');
$top->minsize(1, 1);
$top->ErrorDialog->configure('-cleanupcode' => \&prompt);

$app = "local";			# application name that we're sending to
$lastCommand = "";		# use this command if !! entered

# Create menu bar.  Arrange to recreate all the information in the applications sub-menu whenever it is cascaded to.

$menu = $top->Frame(-relief => 'raised', -bd => 2);
$menu_file = $menu->Menubutton(-text => "File", -underline => 0);
$SELECT_APPLICATION = 'Select Application';
$menu_file->cascade(-label => $SELECT_APPLICATION, -underline => 0);
$menu_file->command(-label => 'Quit', -command => ['destroy', $top], -underline => 0);
$menu_file_m = $menu_file->cget(-menu);
$menu_file_m_apps = $menu_file_m->Menu;
$menu_file_m->entryconfigure($SELECT_APPLICATION, -menu => $menu_file_m_apps);
$menu_file_m->configure(-postcommand => \&fillAppsMenu);
$menu->pack(-side => 'top', -fill => 'x');
$menu_file->pack(-side => 'left');

# Create text window and scrollbar.

$t = $top->Text(-relief => "raised", -borderwidth => 2, -setgrid => 1);
$s = $top->Scrollbar(-relief => "flat", -command => ['yview', $t]);
$t->configure(-yscrollcommand => ['set', $s]);
$s->pack(-side => 'right', -fill => 'both');
$t->pack(-side => 'left');

# Begin kludge code:  depends upon fact that we are running with -w.  After an `eval' see if STDERR has a non-zero size and
# insert in Text widget.  Then trunc the file for the next time around... ugly, but OK until I can do non-blocking Tk stuff.

open STDERR, "+>/tmp/err";

# Create a binding to forward commands to the target application, plus modify many of the built-in bindings so that only
# information in the current command can be deleted (can still set the cursor earlier in the text and select and insert;
# just can't delete).

$t->bindtags([$t, 'Tk::Text', $top, 'all']); # use *my* bindings before considering those of class Text
$t->bind('<Return>' => sub {
    my $t = shift;
    $t->mark('set', 'insert', 'end - 1c');
    $t->insert('insert', "\n");
    &invoke();
    $t->break;
});
$t->bind('<Delete>' => sub {
    my $t = shift;
    if (defined $t->tag('nextrange', 'sel', '1.0', 'end')) {
	$t->tag('remove', 'sel', 'sel.first', 'promptEnd');
    } else {
	$t->break if $t->compare('insert', '<', 'promptEnd');
    }
});
$t->bind('<BackSpace>' => sub {
    my $t = shift;
    if (defined $t->tag('nextrange', 'sel', '1.0', 'end')) {
	$t->tag('remove', 'sel', 'sel.first', 'promptEnd');
    } else {
	$t->break if $t->compare('insert', '<', 'promptEnd');
    }
});    
$t->bind('<Control-d>' => sub {
    my $t = shift;
    $t->break if $t->compare('insert', '<', 'promptEnd');
});
$t->bind('<Control-k>' => sub {
    my $t = shift;
    $t->mark('set', 'insert', 'promptEnd') if $t->compare('insert', '<', 'promptEnd');
});
$t->bind('<Control-t>' => sub {
    my $t = shift;
    $t->break if $t->compare('insert', '<', 'promptEnd');
});
$t->bind('<Meta-d>' => sub {
    my $t = shift;
    $t->break if $t->compare('insert', '<', 'promptEnd');
});
$t->bind('<Meta-BackSpace>' => sub {
    my $t = shift;
    $t->break if $t->compare('insert', '<', 'promptEnd');
});
$t->bind('<Control-h>' => sub {
    my $t = shift;
    $t->break if $t->compare('insert', '<', 'promptEnd');
});
$t->bind('<Control-x>' => sub {
    my $t = shift;
    $t->tag('remove', 'sel', 'sel.first', 'promptEnd');
});

$t->tag('configure', 'bold', -font => "*-Courier-Bold-R-Normal-*-120-*-*-*-*-*-*");
$app = $top->name;
prompt;
$t->focus();

MainLoop;



sub prompt {

    # This procedure is used to print out a prompt at the insertion point (which should be at the beginning of a line right now).

    $t->insert('insert', "$app: ");
    $t->mark('set', 'promptEnd', 'insert');
    $t->mark('gravity', 'promptEnd', 'left');
    $t->tag('add', 'bold', 'promptEnd linestart', 'promptEnd');

} # end prompt


sub invoke {

    # The procedure below executes a command (it takes everything on the current line after the prompt and either sends it to
    # the remote application or executes it locally, depending on "app".

    my $cmd = $t->get('promptEnd', 'insert');
    my $result = '';

    if($cmd eq "!!\n") {
	$cmd = $lastCommand;
    } else {
	$lastCommand = $cmd;
    }
    if($app eq "local") {
	eval $cmd; get_eval_status;
	$result = $EVAL_ERROR;
    } else {
	$result = $t->send($app,$cmd);
    }
    $t->insert('insert',"$result\n") if $result;
    prompt;
    $t->mark('set','promptEnd','insert');
    $t->yview(-pickplace => 'insert');

} # end invoke


sub newApp {

    # The following procedure is invoked to change the application that we're talking to, or update the current prompt.

    my $appName = shift;
    $app = $appName;
    $t->mark('gravity', 'promptEnd', 'right');
    $t->delete("promptEnd linestart", "promptEnd");
    $t->insert("promptEnd", "$appName: ");
    $t->tag("add", "bold", "promptEnd linestart", "promptEnd");
    $t->mark('gravity', 'promptEnd', 'left');
    return '';

} # end newApp


sub fillAppsMenu {

    # The procedure below will fill in the applications sub-menu with a list of all the applications that currently exist.

    my $i; eval {$menu_file_m_apps->delete(0, 'last')};
    foreach $i (sort $top->interps) {
	$menu_file_m_apps->add("command", -label => $i, -command => [sub { &newApp($ARG[0]);},$i]);
    }
    $menu_file_m_apps->add("command", -label => "local", -command => sub { &newApp("local"); });

} # end fillAppsMenu


sub get_eval_status {

    # A BIG kludge for now:  Perl likes to write some error messages to STDERR rather than returning them to $EVAL_ERROR.

    if (not $EVAL_ERROR and -s STDERR) {
	$EVAL_ERROR = `cat /tmp/err`;
	truncate STDERR, 0;
	open STDERR, "+>/tmp/err";
    }
    $EVAL_ERROR =~ s/\n;|\n$//g if $EVAL_ERROR;

} # end get_eval_status


sub Tk::receive {

    # For security you must roll you own `receive' command.

    my($window, $cmd) = @ARG;

    chop $cmd;
    eval $cmd; get_eval_status;
    return $EVAL_ERROR ? $EVAL_ERROR : '';

} # end receive

