#!/import/bw/tools/local/perl-5.8.0/bin/perl -w
eval 'exec /import/bw/tools/local/perl-5.8.0/bin/perl -w -S $0 ${1+"$@"}'
if 0; # not running under some shell
# A graphical user interface for testing Perl/Tk commands and scripts.
# ...truncated earlier stuff...
# 4/23/98 V1.7 Achim Bohnet -- some fixes to "o" command
# 6/08/98 V2.01 M. Beller -- merge in GUI code for "wish"-like interface
# 2.01d1 6/6/98 First development version
# - apply A.B. patch for pod and -option
# - fix "use of uninitialized variable" in END{ } block (for -c option)
# - support h and ? only for help
# - misc. pod fixes (PITFALLS)
# - use default fonts and default colors ## NOT YET--still working on it
# - get rid of Data::Dumper for history
# - Remove "use Data::Dumper" line
# - Put in hack for unix vs. win32 window manager focus problem
# - Achim's pod and histfile patch
# - Slaven's patch to make <Home> work properly
# - Add help message to banner (per Steve Lydie)
# - Fix horizontal scrolling (turn off wrapping in console window)
# - Clarify <Up> in docs and help means "up arrow"
# - Use HOMEDRIVE/HOMEPATH on Win32
ptksh - Perl/Tk script to provide a graphical user interface for testing Perl/Tk
... version information ...
ptksh> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'})
ptksh is a perl/Tk shell to enter perl commands
interactively. When one starts ptksh a L<MainWindow|Tk::MainWindow>
is automaticly created, along with a ptksh command window.
One can access the main window by typing commands using the
variable $mw at the 'ptksh> ' prompt of the command window.
ptksh supports command line editing and history. Just type "<Up>" at
the command prompt to see a history list. The last 50 commands entered
are saved, then reloaded into history list the next time you start ptksh.
ptksh supports some convenient commands for inspecting Tk widgets. See below.
To exit ptksh use: C<exit>.
ptksh is B<*not*> a full symbolic debugger.
To debug perl/Tk programs at a low level use the more powerful
L<perl debugger|perldebug>. (Just enter ``O tk'' on debuggers
command line to start the Tk eventloop.)
Press <Up> (the Up Arrow) in the perlwish window to obtain a gui-based history list.
Press <Enter> on any history line to enter it into the perlwish window.
Then hit return. So, for example, repeat last command is <Up><Enter><Enter>.
You can quit the history window with <Escape>. NOTE: history is only saved
if exit is "graceful" (i.e. by the "exit" command from the console or by
quitting all main windows--NOT by interrupt).
ptksh provides some convenience function to make browsing
in perl/Tk widget easier:
displays a short help summary.
=item B<d> ?I<args>, ...?
Dumps recursively arguments to stdout. (see L<Data::Dumper>).
You must have <Data::Dumper> installed to support this feature.
appends "|\n" to each of it's arguments and prints it.
If value is B<undef>, '(undef)' is printed to stdout.
=item B<o> I<$widget> ?I<-option> ...?
prints the option(s) of I<$widget> one on each line.
If no options are given all options of the widget are
listed. See L<Tk::options> for more details on the
format and contents of the returned list.
=item B<o> I<$widget> B</>I<regexp>B</>
Lists options of I<$widget> matching the
L<regular expression|perlre> I<regexp>.
If no argument is given it lists the modules loaded
by the commands you executed or since the last time you
If argument is the empty string lists all modules that are
If argument is a string, ``text'' it tries to do a ``use Tk::Text;''.
Ptksh compiles into package Tk::ptksh. Your code is eval'ed into package
main. The coolness of this is that your eval code should not interfere with
=head2 Multiline Commands
ptksh will accept multiline commands. Simply put a "\" character immediately
before the newline, and ptksh will continue your command onto the next line.
=head2 Source File Support
If you have a perl/Tk script that you want to do debugging on, try running the
-- or (at shell command prompt) --
Then use the perl/Tk commands to try out different operations on your script.
Looks for your .ptksh_history in the directory specified by
the $HOME environment variable ($HOMEPATH on Win32 systems).
If found in current directory it is read in an evaluated
after the mainwindow I<$mw> is created. F<.ptksh_init>
can contain any valid perl code.
=item F<~/.ptksh_history>
Contains the last 50 lines entered in ptksh session(s).
It is best not to use "my" in the commands you type into ptksh.
For example "my $v" will make $v local just to the command or commands
entered until <Return> is pressed.
For a related reason, there are no file-scopy "my" variables in the
ptksh code itself (else the user might trounce on them by accident).
B<Tk::MainLoop> function interactively entered or sourced in a
init or script file will block ptksh.
Mike Beller <beller@penvision.com>,
Achim Bohnet <ach@mpe.mpg.de>
Copyright (c) 1996 - 1998 Achim Bohnet and Mike Beller. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT $INITFILE);
$WIN32 = 1 if $^O =~ /Win32/;
$HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH}) || 'C:\\' : $ENV{HOME} . "/";
@FONT = ($WIN32 ? (-font => 'systemfixed') : () );
#@FONT = ($WIN32 ? (-font => ['courier', 9, 'normal']) : () );
$HISTFILE = "${HOME}.${NAME}_history";
$INITFILE = ".${NAME}_init";
sub Win32Fix { my $p = shift; $p =~ s'\\'/'g; $p =~ s'/$''; return $p }
use vars qw($mw $st $t @hist $hist $list $isStartOfCommand);
# NOTE: mainwindow creation order seems to impact who gets focus, and
# order is different on Win32 & *nix!! So hack is to create the windows
# in an order dependent on the OS!
$mw = Tk::MainWindow->new unless $WIN32; # &&& hack to work around focus problem
##### set up user's main window
$main::mw = Tk::MainWindow->new;
$main::mw->geometry("+1+1");
##### Set up ptksh windows
$mw = Tk::MainWindow->new if $WIN32; # &&& hack to work around focus problem
$st = $mw->Scrolled('Text', -scrollbars => 'osoe',
-width => 80, -height => 25, @FONT);
$t = $st->Subwidget('scrolled');
$st->pack(-fill => 'both', -expand => 'true');
$mw->bind('<Map>', sub {Center($mw);} );
$t->bindtags([$t, ref($t), $t->toplevel, 'all']); # take first crack at events
$t->bind('<Return>', \&EvalInput);
$t->bind('<BackSpace>', \&BackSpace);
$t->bind('<Escape>', \&HistKill);
$t->bind('<Up>', \&History);
$t->bind('<Control-a>', \&BeginLine);
$t->bind('<Home>', \&BeginLine);
$t->bind('<Any-KeyPress>', [\&Key, Tk::Ev('K'), Tk::Ev('A')]);
# Set up different colors for the various window outputs
#$t->tagConfigure('prompt', -underline => 'true');
$t->tagConfigure('prompt', -foreground => 'blue');
$t->tagConfigure('result', -foreground => 'purple');
$t->tagConfigure('error', -foreground => 'red');
$t->tagConfigure('output', -foreground => 'blue');
# The tag 'limit' is the beginning of the input command line
$t->markSet('limit', 'insert');
$t->markGravity('limit', 'left');
#tie (*STDOUT, 'Tk::Text', $t);
tie (*STDOUT, 'Tk::ptksh');
#tie (*STDERR, 'Tk::ptksh');
print " perl V$] Tk V$Tk::VERSION MainWindow -> \$mw\n";
foreach (@INC) { print "\t $_\n" };
print "Type 'h<Return>' at the prompt for help\n";
print "Reading $INITFILE ...\n";
###### Source the file if given as argument 0
if (defined($ARGV[0]) && -r $ARGV[0])
print "Reading $ARGV[0] ...\n";
if ( -r $HISTFILE and open(HIST, $HISTFILE) ) {
print "Reading history ...\n";
if ($_ !~ /\\$/) { #end of command if no trailing "\"
chop $c; # kill trailing "\"
#$mw->after(1000, sub {print STDERR "now\n"; $mw->focus; $t->focus;});
##### Now enter main loop
# EvalInput -- Eval the input area (between 'limit' and 'insert')
use vars qw($command $result); # use globals instead of "my" to avoid conflict w/ 'eval'
# If return is hit when not inside the command entry range, reprompt
if ($t->compare('insert', '<=', 'limit')) {
$t->markSet('insert', 'end');
# Support multi-line commands
if ($t->get('insert-1c', 'insert') eq "\\") {
$t->insert('insert', "\n");
$t->insert('insert', "> ", 'prompt'); # must use this pattern for continue
# Get the command and strip out continuations
$command = $t->get('limit','end');
$t->markSet('insert','end');
$command =~ s/\\\n>\s/\n/mg;
if ( $command !~ /^\s*$/) {
unless @hist && ($command eq $hist[$#hist]); #could elim more redundancy
$t->insert('insert', "\n");
$command = PtkshCommand($command);
exit if ($command eq 'exit');
$Tk::ptksh::result = eval "local \$^W=0; $Tk::ptksh::command;";
if ($t->compare('insert', '!=', 'insert linestart')) {
$t->insert('insert', "\n");
$t->insert('insert', '## ' . $@, 'error');
$result = "" if !defined($result);
$t->insert('insert', '# ' . $result, 'result');
if ($t->compare('insert', '!=', 'insert linestart')) {
$t->insert('insert', "\n");
$t->insert('insert', $pr, 'prompt');
$t->markSet('limit', 'insert');
if ($t->tagNextrange('sel', '1.0', 'end')) {
$t->delete('sel.first', 'sel.last');
} elsif ($t->compare('insert', '>', 'limit')) {
#print "key event: ", $k, "\n";
if ($t->compare('insert', '<', 'limit')) {
$t->markSet('insert', 'end');
#$t->break; #for testing bindtags
Tk->break if defined($hist);
$list = $hist->ScrlListbox(-scrollbars => 'oe',
-width => 30, -height => 10, @FONT)->pack;
$list->insert('end', @hist);
$hist->bind('<Double-1>', \&HistPick);
$hist->bind('<Return>', \&HistPick);
$hist->bind('<Escape>', \&HistKill);
$hist->bind('<Map>', sub {Center($hist);} );
$hist->bind('<Destroy>', \&HistDestroy);
my $item = $list->get('active');
$t->markSet('insert', 'end');
$t->insert('insert',$item);
# Called from destroy event mapping
if (defined($hist) && (shift == $hist)) {
if ($t->compare('insert', '==', 'limit')) {
$t->insert('insert', $hist[$#hist]);
# Center a toplevel on screen or above parent
#print STDERR $w->screenwidth, " ", $w->width, "\n";
$x = $w->parent->x + ($w->parent->width - $w->width)/2;
$y = $w->parent->y + ($w->parent->height - $w->height)/2;
#print STDERR $w->screenwidth, " ", $w->width, "\n";
$x = ($w->screenwidth - $w->width)/2;
$y = ($w->screenheight - $w->height)/2;
#print STDERR "Setting geometry to $g\n";
# We have to make sure the prints don't go into the command entry range.
sub TIEHANDLE { # just to capture the tied calls
$t->markSet('insert', 'end');
if ($isStartOfCommand) { # Then no prints have happened in this command yet so...
if ($t->compare('insert', '!=', 'insert linestart')) {
$t->insert('insert', "\n");
# set flag so we know at least one print happened in this eval
$t->insert('end', shift, 'output');
$t->markSet('limit', 'insert'); # don't interpret print as an input command
$w->PRINT(sprintf(shift,@_));
my (@opt) = split " ", $what;
print 'o(', join('|', @opt), ")\n";
if ($opt[0] =~ s|^/(.*)/$|$1|)
print "options matching /$opt[0]/:\n";
foreach ($w->configure())
print Tk::Pretty::Pretty($_),"\n" if $_->[0] =~ /\Q$opt[0]\E/;
# list of options (allow as bar words)
print Tk::Pretty::Pretty($w->configure($_)),"\n";
foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" }
foreach (@_) { print $_, "|\n"; }
use vars qw($u_init %u_last $u_cnt);
if (defined($module) and $module ne '') {
$module = "Tk/".ucfirst($module).".pm" unless $module =~ /^Tk/;
print " --- Loading $module ---\n";
%u_last = () if defined $module;
foreach (sort keys %INC) {
next if exists $u_last{$_};
#next if m,^/, and m,\.ix$,; # Ignore autoloader files
#next if m,\.ix$,; # Ignore autoloader files
printf "%-20s -> %s\n", $_, $INC{$_};
print "$_ -> $INC{$_}\n";
print STDERR "No modules loaded since last 'u' command (or startup)\n"
print Data::Dumper::Dumper(@_);
? or h print this message
d arg,... calls Data::Dumper::Dumper
p arg,... print args, each on a line and "|\n"
o $w /regexp/ print options of widget matching regexp
o $w [opt ...] print (all) options of widget
u xxx xxx = string : load Tk::Xxx
= '' : list all modules loaded
= undef : list modules loaded since last u call
Press <Up> (the "up arrow" key) for command history
Press <Escape> to leave command history window
Type "exit" to quit (saves history)
Type \<Return> for continuation of command to following line
# Substitute our special commands into the command line
last if s/^\?\s*$/Tk::ptksh::_h /;
last if s/^h\s*$/Tk::ptksh::_h /;
last if s/^u(\s+|$)/Tk::ptksh::_u /;
last if s/^d\s+/Tk::ptksh::_d /;
last if s/^u\s+(\S+)/Tk::ptksh::_u('$1')/;
last if s/^p\s+(.*)$/Tk::ptksh::_p $1;/;
last if s/^o\s+(\S+)\s*?$/Tk::ptksh::_o $1;/;
last if s/^o\s+(\S+)\s*,?\s+(.*)?$/Tk::ptksh::_o $1, '$2';/;
%u_last = %INC unless $u_init++;
# print STDERR "Command is: $_\n";
### Save History -- use Data::Dumper to preserve multiline commands
if ($HISTFILE) { # because this is probably perl -c if $HISTFILE is not set
$#hist-- if $hist[-1] =~ /^(q$|x$|\s*exit\b)/; # chop off the exit command
@hist = @hist[($#hist-$HISTSAVE)..($#hist)] if $#hist > $HISTSAVE;
if( open HIST, ">$HISTFILE" ) {
while ($_ = shift(@hist)) {
print STDERR "Error: Unable to open history file '$HISTFILE'\n";
1; # just in case we decide to be "use"'able in the future.