diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-18 18:04:50 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-18 18:04:50 (GMT) |
commit | 4e1e70fc5d5f5083a33a532fa4fc7868a33e3855 (patch) | |
tree | ecf5a4804f77ad4fed32caf4d3818b47c755c2c0 /tkcon/docs/perl.txt | |
parent | 39e34335fb6eb6eaf2b7ee51ccf172006dd46fbb (diff) | |
parent | 64d1425f65568851a1004cbdac170780e95720a2 (diff) | |
download | blt-4e1e70fc5d5f5083a33a532fa4fc7868a33e3855.zip blt-4e1e70fc5d5f5083a33a532fa4fc7868a33e3855.tar.gz blt-4e1e70fc5d5f5083a33a532fa4fc7868a33e3855.tar.bz2 |
Merge commit '64d1425f65568851a1004cbdac170780e95720a2' as 'tkcon'
Diffstat (limited to 'tkcon/docs/perl.txt')
-rwxr-xr-x | tkcon/docs/perl.txt | 109 |
1 files changed, 109 insertions, 0 deletions
diff --git a/tkcon/docs/perl.txt b/tkcon/docs/perl.txt new file mode 100755 index 0000000..37463b5 --- /dev/null +++ b/tkcon/docs/perl.txt @@ -0,0 +1,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 |