#!/usr/local/bin/perl -wT
#
# 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.002;
use English;

use Tk;
use Tk::ErrorDialog;
use strict;

sub get_eval_status; sub prompt;

$ENV{HOME} = '/home/bug';

my $MW = MainWindow->new;
$MW->minsize(1, 1);
$MW->ErrorDialog->configure('-cleanupcode' => \&prompt);

my $app = "local";		# application name that we're sending to
my $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.

my $menu = $MW->Frame(-relief => 'raised', -bd => 2);
my $menu_file = $menu->Menubutton(-text => "File", -underline => 0);
my $SELECT_APPLICATION = 'Select Application';
$menu_file->cascade(-label => $SELECT_APPLICATION, -underline => 0);
$menu_file->command(-label => 'Quit', -command => \&exit, -underline => 0);
my $menu_file_m = $menu_file->cget(-menu);
my $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.

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

# Perl -w handler to fill text widget with eval errors.

$SIG{'__WARN__'} = \&get_eval_status;

# 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', $MW, '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 = $MW->name;
$MW->title("Tk Remote Controller - $app");
$MW->iconname($app);
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;
    } else {
	$t->send($app,$cmd);
    }
    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 $MW->interps) {
	$menu_file_m_apps->add("command", 
            -label   => $i, 
            -command => [sub { &newApp($_[0]);},$i],
        );
    }
    $menu_file_m_apps->add("command", 
        -label   => "local", 
        -command => sub { &newApp("local"); },
    );

} # end fillAppsMenu

sub get_eval_status {

    # Inform user of any eval errors.

    chomp ($EVAL_ERROR, @_);
    my $errors = join '', $EVAL_ERROR, @_;
    $t->insert('insert',"$errors\n") if $errors;
    $EVAL_ERROR = '';		# prevent $t->break error for local app

} # end get_eval_status

sub Tk::Receive {

    # For security you must roll you own `receive' command, run with
    # taint checks on and untaint the received data.

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

    chop $cmd;
    $cmd =~ /(.*)/;
    $cmd = $1;
    eval $cmd; get_eval_status;

} # end receive