1#!/usr/local/bin/perl -w 2 3# tkcon.pl - a Perl/Tk "shell" companion for tkcon.tcl. 4# 5# Variable $MW is an object reference to the main window, from which you can 6# create and manipulate child widgets. Variable names beginning with an 7# underscore are reserved for this application. 8# 9# Stephen O. Lidie, 96/08/25 10 11require 5.002; 12use English; 13use Tk; 14use Tk::Pretty qw(Pretty); 15use Tk::Dialog; 16use strict; 17use subs qw(doit tkcon); 18my($MW, $_TKCON, $_VERSION, $_HELP, $_SHELL, $_TAB, $_PARA, @_ERRORS, $_MES); 19 20tkcon; # main 21 22sub doit { 23 24 # Eval some code without use strict constraints. 25 26 my($code) = @ARG; 27 28 { 29 no strict; 30 if ($_MES) { 31 $_MES->packForget; 32 $_MES->destroy; 33 $_MES = 0; 34 } 35 @_ERRORS = (); 36 $SIG{'__WARN__'} = sub {push @_ERRORS, @ARG}; 37 my $_res = eval $code; 38 push @_ERRORS, $EVAL_ERROR if $EVAL_ERROR; 39 push @_ERRORS, $_res; 40 } 41 42} # end doit 43 44sub tkcon { 45 46 # Nothing fancy here, just create the main window and the help dialog 47 # object, and display a pointer to the help. 48 49 $_TKCON = 'tkcon.pl'; 50 $_VERSION = '0.2'; 51 $_SHELL = '/bin/sh'; 52 $_SHELL = $ENV{'SHELL'} if $ENV{'SHELL'}; 53 $_TAB = 0; 54 $_PARA = ''; 55 56 $MW = MainWindow->new; 57 $MW->title($_TKCON); 58 $MW->iconname($_TKCON); 59 $_HELP = $MW->Dialog( 60 -title => "$_TKCON Help", 61 -font => 'fixed', 62 -wraplength => '6i', 63 -justify => 'left', 64 -text => 65 "? - this text.\n" . 66 "| - pass arguments to your shell (default /bin/sh).\n" . 67 "p - use Tk::Pretty to \"pretty-print\" arguments.\n" . 68 "+ - a tab starts/stops multiline input mode.\n" . 69 "exit - quit $_TKCON.\n" . 70 "\nOther input is assumed to be a Perl/Tk command.\n" . 71 "\n\$MW is the MainWindow.\n", 72 ); 73 $_HELP->configure(-foreground => 'blue'); 74 $_MES = $MW->Label(-text => "\nEnter ? for help.\n")->pack; 75 MainLoop; 76 77} # end tkcon 78 79sub Tk::Receive { 80 81 shift(); 82 $ARG = shift(); 83 if (/^\?(.*)/) { # help 84 $_HELP->Show; 85 } elsif (/^\|(.*)/) { # bang 86 @_ERRORS = (); 87 push @_ERRORS, `$_SHELL -c $1 2>&1`; 88 } elsif (/^\+$/) { 89 $_TAB++; 90 if ($_TAB % 2) { 91 @_ERRORS = (); 92 $_PARA = ''; 93 push @_ERRORS, '+'; 94 } else { 95 doit $_PARA; 96 } 97 } else { # Perl/Tk command 98 $ARG = "Pretty($1)" if (/^p\s(.*)$/); 99 if ($_TAB % 2) { 100 $_PARA .= $ARG; 101 push @_ERRORS, '+'; 102 } else { 103 doit $ARG; 104 } 105 } # ifend 106 107 return @_ERRORS; 108 109} # end Tk::Receive 110