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