1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
#!/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
|
