source: trunk/tkcon/docs/perl.txt

#!/usr/local/bin/perl -w
 
# tkcon.pl - a Perl/Tk  "shell" companion for tkcon.tcl.
#
# Variable $MW is an object reference to the main window, from which you can
# create and manipulate child widgets.  Variable names beginning with an
# underscore are reserved for this application.
#
# Stephen O. Lidie, 96/08/25
 
require 5.002;
use English;
use Tk;
use Tk::Pretty qw(Pretty);
use Tk::Dialog;
use strict;
use subs qw(doit tkcon);
my($MW, $_TKCON, $_VERSION, $_HELP, $_SHELL, $_TAB, $_PARA, @_ERRORS, $_MES);
 
tkcon;                          # main
 
sub doit {
 
    # Eval some code without use strict constraints.
 
    my($code) = @ARG;
 
    {
        no strict;
        if ($_MES) {
            $_MES->packForget;
            $_MES->destroy;
            $_MES = 0;
        }
        @_ERRORS = ();
        $SIG{'__WARN__'} = sub {push @_ERRORS, @ARG};
        my $_res = eval $code;
        push @_ERRORS, $EVAL_ERROR if $EVAL_ERROR;
        push @_ERRORS, $_res;
    }
 
} # end doit
 
sub tkcon {
 
    # Nothing fancy here, just create the main window and the help dialog
    # object, and display a pointer to the help.
 
    $_TKCON = 'tkcon.pl';
    $_VERSION = '0.2';
    $_SHELL = '/bin/sh';
    $_SHELL = $ENV{'SHELL'} if $ENV{'SHELL'};
    $_TAB = 0;
    $_PARA = '';
 
    $MW = MainWindow->new;
    $MW->title($_TKCON);
    $MW->iconname($_TKCON);
    $_HELP = $MW->Dialog(
        -title      => "$_TKCON Help",
        -font       => 'fixed',
        -wraplength => '6i',
        -justify    => 'left',
        -text       =>
            "?    - this text.\n" .
            "|    - pass arguments to your shell (default /bin/sh).\n" .
            "p    - use Tk::Pretty to \"pretty-print\" arguments.\n" .
            "+    - a tab starts/stops multiline input mode.\n" .
            "exit - quit $_TKCON.\n" .
            "\nOther input is assumed to be a Perl/Tk command.\n" .
            "\n\$MW is the MainWindow.\n",
                         );
    $_HELP->configure(-foreground => 'blue');
    $_MES = $MW->Label(-text => "\nEnter ? for help.\n")->pack;
    MainLoop;
 
} # end tkcon
 
sub Tk::Receive {
 
    shift();
    $ARG = shift();
    if (/^\?(.*)/) {            # help
        $_HELP->Show;
    } elsif (/^\|(.*)/) {       # bang
        @_ERRORS = ();
        push @_ERRORS, `$_SHELL -c $1 2>&1`;
    } elsif (/^\+$/) {
        $_TAB++;
        if ($_TAB % 2) {
            @_ERRORS = ();
            $_PARA = '';
            push @_ERRORS, '+';
        } else {
            doit $_PARA;
        }
    } else {                    # Perl/Tk command
        $ARG = "Pretty($1)" if (/^p\s(.*)$/);
        if ($_TAB % 2) {
            $_PARA .= $ARG;
            push @_ERRORS, '+';
        } else {
            doit $ARG;
        }
    } # ifend
 
    return @_ERRORS;
 
} # end Tk::Receive