perl-tk 1:804.033-1+b3 / usr / bin / ptksh

#!/usr/bin/perl -w
#
# PTKSH 2.0
#
# A graphical user interface for testing Perl/Tk commands and scripts.
#
# VERSION HISTORY:
# ...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
#
# 2.01d2 6/7/98
#  - 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
#
# 2.01d3 6/8/98
#  - Remove "use Data::Dumper" line
#  - Put in hack for unix vs. win32 window manager focus problem
#  - Achim's pod and histfile patch
#
# 2.01d4 6/18/98
#  - 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
#
# For more history look at the various Changes files in the Perl/Tk
# distribution.

=head1 NAME

ptksh - Perl/Tk script to provide a graphical user interface for testing Perl/Tk
commands and scripts.

=head1 SYNOPSIS

  % ptksh  ?scriptfile?
  ... version information ...
  ptksh> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'})
  ptksh> $b->pack
  ptksh> o $b
  ... list of options ...
  ptksh> help
  ... help information ...
  ptksh> exit
  %


=head1 DESCRIPTION

ptksh is a perl/Tk shell to enter perl commands
interactively.  When one starts ptksh a L<MainWindow|Tk::MainWindow>
is automatically 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.)

=head1 FEATURES

=head2 History

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).

=head2 Debugging Support

ptksh provides some convenience function to make browsing
in perl/Tk widget easier:

=over 4

=item B<?>, or B<h>

displays a short help summary.

=item B<d>, or B<x> ?I<args>, ...?

Dumps recursively arguments to stdout. (see L<Data::Dumper>).
You must have <Data::Dumper> installed to support this feature.

B<x> was introduced for perl debugger compatibility.

=item B<p> ?I<arg>, ...?

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>.

=item B<u> ?I<class>?

If no argument is given it lists the modules loaded
by the commands you executed or since the last time you
called C<u>.

If argument is the empty string lists all modules that are
loaded by ptksh.

If argument is a string, ``text'' it tries to do a ``use Tk::Text;''.

=back

=head2 Packages

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
ptksh itself.

=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
command

  ptksh> do 'myscript';

   -- or  (at shell command prompt) --

  % ptksh myscript

Then use the perl/Tk commands to try out different operations on your script.

=head1 ENVIRONMENT

Looks for your .ptksh_history in the directory specified by
the $HOME environment variable ($HOMEPATH on Win32 systems).

=head1 FILES

=over 4

=item F<.ptksh_init>

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).

=back

=head1 PITFALLS

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).

=head1 BUGS

B<Tk::MainLoop> function interactively entered or sourced in a
init or script file will block ptksh.

=head1 SEE ALSO

L<Tk|Tk>
L<perldebug|perldebug>

=head1 VERSION

VERSION 2.03

=head1 AUTHORS

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.

=cut

package Tk::ptksh;
require 5.004;
use strict;
use Tk;

##### Constants

use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT $INITFILE);

$NAME = 'ptksh';
$VERSION = '2.03';
$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";
$HISTSAVE = 50;
$INITFILE = ".${NAME}_init";
$PROMPT = "$NAME> ";

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
package main;
$main::mw = Tk::MainWindow->new;
$main::mw->title('$mw');
$main::mw->geometry("+1+1");
package Tk::ptksh;

##### Set up ptksh windows
$mw = Tk::MainWindow->new if $WIN32;  # &&& hack to work around focus problem
$mw->title($NAME);
$st = $mw->Scrolled('Text', -scrollbars => 'osoe',
				-wrap => 'none',
				-width => 80, -height => 25, @FONT);
$t = $st->Subwidget('scrolled');
$st->pack(-fill => 'both', -expand => 'true');
# $mw_mapped assures that Center is only called exactly twice: first time
# will determine geometry of window, second time centering will work.
# I observed a couple of further <Map> events, which are now ignored
# and thus window creation seems to be faster now.
my $mw_mapped;
$mw->bind('<Map>', sub {return if $mw_mapped && $mw_mapped>=2; Center($mw); $mw_mapped++;} );

# Event bindings
$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')]);

my $default_font = $t->cget(-font);
my %default_font = $t->fontActual($default_font);
my $normal_font;
if (!$t->fontMetrics($default_font, '-fixed')) {
    $normal_font = $t->fontCreate(%default_font, -family => "courier");
    $t->configure(-font => $normal_font);
} else {
    $normal_font = $default_font;
}
my %normal_font = $t->fontActual($normal_font);
my $bold_font = $t->fontCreate(%normal_font, -weight => "bold");

# Set up different colors for the various window outputs
#$t->tagConfigure('prompt', -underline => 'true');
$t->tagConfigure('prompt', -foreground => 'blue', -font => $bold_font);
$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');

# redirect stdout
#tie (*STDOUT, 'Tk::Text', $t);
tie (*STDOUT, 'Tk::ptksh');
#tie (*STDERR, 'Tk::ptksh');

# Print banner
print "$NAME V$VERSION";
print " perl V$] Tk V$Tk::VERSION  MainWindow -> \$mw\n";
print "\n\t\@INC:\n";
foreach (@INC) { print "\t  $_\n" };
print "Type 'h<Return>' at the prompt for help\n";

##### Read .ptkshinit
if ( -r $INITFILE)
  {
    print "Reading $INITFILE ...\n";
    package main;
    do $Tk::ptksh::INITFILE;
    package Tk::ptksh;
  }

###### Source the file if given as argument 0
if (defined($ARGV[0]) && -r $ARGV[0])
  {
    print "Reading $ARGV[0] ...\n";
    package main;
    do $ARGV[0];
    package Tk::ptksh;
  }

##### Read history
@hist = ();
if ( -r $HISTFILE and open(HIST, $HISTFILE) ) {
	print "Reading history ...\n";
	my $c = "";
	while (<HIST>) {
		chomp;
		$c .= $_;
		if ($_ !~ /\\$/) { #end of command if no trailing "\"
			push @hist, $c;
			$c = "";
		} else {
			chop $c;	# kill trailing "\"
			$c .= "\n";
		}
	}
    close HIST;
}

##### Initial prompt
Prompt($PROMPT);
$Tk::ptksh::mw->focus;
$t->focus;
#$mw->after(1000, sub {print STDERR "now\n"; $mw->focus; $t->focus;});

##### Now enter main loop
#$mw->afterIdle(sub {Center($mw);});
MainLoop();

####### Callbacks/etc.

# EvalInput -- Eval the input area (between 'limit' and 'insert')
#              in package main;
use vars qw($command $result); # use globals instead of "my" to avoid conflict w/ 'eval'
sub EvalInput {
	# If return is hit when not inside the command entry range, reprompt
	if ($t->compare('insert', '<=', 'limit')) {
		$t->markSet('insert', 'end');
		Prompt($PROMPT);
		Tk->break;
	}

	# 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
		$t->see('insert');
		Tk->break;
	}

	# Get the command and strip out continuations
	$command = $t->get('limit','end');
	$t->markSet('insert','end');
	$command =~ s/\\\n>\s/\n/mg;

	# Eval it
	if ( $command !~ /^\s*$/) {
		chomp $command;
		push(@hist, $command)
			unless @hist && ($command eq $hist[$#hist]); #could elim more redundancy

		$t->insert('insert', "\n");

		$isStartOfCommand = 1;

		$command = PtkshCommand($command);

		exit if ($command eq 'exit');

		package main;
		no strict;
		$Tk::ptksh::result = eval "local \$^W=0; $Tk::ptksh::command;";
		use strict;
		package Tk::ptksh;

		if ($t->compare('insert', '!=', 'insert linestart')) {
			$t->insert('insert', "\n");
		}
		if ($@) {
			$t->insert('insert', '## ' . $@, 'error');
		} else {
			$result = "" if !defined($result);
			$t->insert('insert', '# ' . $result, 'result');
		}
	}

	Prompt($PROMPT);

	Tk->break;
}

sub Prompt {
	my $pr = shift;

	if ($t->compare('insert', '!=', 'insert linestart')) {
		$t->insert('insert', "\n");
	}

	$t->insert('insert', $pr, 'prompt');
	$t->see('insert');
	$t->markSet('limit', 'insert');

}

sub BackSpace {
	if ($t->tagNextrange('sel', '1.0', 'end')) {
		$t->delete('sel.first', 'sel.last');
		} elsif ($t->compare('insert', '>', 'limit')) {
			$t->delete('insert-1c');
			$t->see('insert');
		}
		Tk->break;
}

sub BeginLine {
       $t->SetCursor('limit');
       $t->break;
}

sub Key {
	my ($self, $k, $a) = @_;
	#print "key event: ", $k, "\n";
	if ($t->compare('insert', '<', 'limit')) {
		$t->markSet('insert', 'end');
	}
	#$t->break; #for testing bindtags
}

sub History {
	Tk->break if defined($hist);

	$hist = $mw->Toplevel;
	$hist->title('History');
	$list = $hist->ScrlListbox(-scrollbars => 'oe',
              -width => 30, -height => 10, @FONT)->pack(qw(-fill both -expand 1));
	Center($hist);
	$list->insert('end', @hist);
	$list->see('end');
	$list->activate('end');
	$hist->bind('<Double-1>', \&HistPick);
	$hist->bind('<Return>', \&HistPick);
	$hist->bind('<Escape>', \&HistKill);
	my $hist_mapped; # see above for $mw_mapped
	$hist->bind('<Map>', sub {return if $hist_mapped && $hist_mapped>=2; Center($hist); $hist_mapped++;} );
	$hist->bind('<Destroy>', \&HistDestroy);
	$hist->focus;
	$list->focus;
	$hist->grab;
	#$mw->afterIdle(sub {Center($hist);});
	Tk->break;
}

sub HistPick {
	my $item = $list->get('active');
	return if (!$item);
	$t->markSet('insert', 'end');
	$t->insert('insert',$item);
	$t->see('insert');
	$mw->focus;
	$t->focus;
	HistKill();
}

sub HistKill {
	if ($hist) {
		$hist->grabRelease;
		$hist->destroy;
	}
}

# Called from destroy event mapping
sub HistDestroy {
	if (defined($hist) && (shift == $hist)) {
		$hist = undef;
		$mw->focus;
		$t->focus;
	}
}

sub LastCommand {
	if ($t->compare('insert', '==', 'limit')) {
		$t->insert('insert', $hist[$#hist]);
		$t->break;
	}
}

# Center a toplevel on screen or above parent
sub Center {
	my $w = shift;
	my ($x, $y);

	if ($w->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;
	} else {
		#print STDERR $w->screenwidth, " ", $w->width, "\n";
		$x = ($w->screenwidth - $w->width)/2;
		$y = ($w->screenheight - $w->height)/2;
	}
	$x = int($x);
	$y = int($y);
	my $g = "+$x+$y";
	#print STDERR "Setting geometry to $g\n";
	$w->geometry($g);
}

# To deal with "TIE".
# We have to make sure the prints don't go into the command entry range.

sub TIEHANDLE {	# just to capture the tied calls
	my $self = [];
	return bless $self;

}

sub PRINT {
	my ($bogus) = shift;

	$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
		$isStartOfCommand = 0;
	}

	while (@_) {
		$t->insert('end', shift, 'output');
	}

	$t->see('insert');

	$t->markSet('limit', 'insert'); # don't interpret print as an input command
}

sub PRINTF
{
 my $w = shift;
 $w->PRINT(sprintf(shift,@_));
}

###
### Utility function
###

sub _o
  {
    my $w = shift;
    my $what = shift;

    $what =~ s/^\s+//;
    $what =~ s/\s+$//;
    my (@opt) = split " ", $what;

    print 'o(', join('|', @opt), ")\n";
    require Tk::Pretty;

    # check for regexp
    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/;
          }
        return;
    }

    # list of options (allow as bar words)
    foreach (@opt)
      {
	s/^['"]//;
	s/,$//;
	s/['"]$//;
	s/^([^-])/-$1/;
      }
    if (length $what)
      {
       foreach (@opt)
          {
            print Tk::Pretty::Pretty($w->configure($_)),"\n";
          }
      }
    else
      {
        foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" }
      }
  }

sub _p {
    foreach (@_) { print $_, "|\n"; }
}

use vars qw($u_init %u_last $u_cnt);
$u_init = 0;
%u_last = ();
sub _u {
    my $module = shift;
    if (defined($module) and $module ne '') {
	$module = "Tk/".ucfirst($module).".pm" unless $module =~ /^Tk/;
	print " --- Loading $module ---\n";
	require "$module";
	print $@ if $@;
    } else {
        %u_last = () if defined $module;
	$u_cnt = 0;
	foreach (sort keys %INC) {
	    next if exists $u_last{$_};
            $u_cnt++;
            $u_last{$_} = 1;
	    #next if m,^/, and m,\.ix$,; # Ignore autoloader files
	    #next if m,\.ix$,; # Ignore autoloader files

	    if (length($_) < 20 ) {
		printf "%-20s -> %s\n", $_, $INC{$_};
	    } else {
		print "$_ -> $INC{$_}\n";
	    }
        }
	print STDERR "No modules loaded since last 'u' command (or startup)\n"
		unless $u_cnt;
    }
}

sub _d
  {
    require Data::Dumper;
    local $Data::Dumper::Deparse;
    $Data::Dumper::Deparse = 1;
    print Data::Dumper::Dumper(@_);
  }

sub _h
  {
    print <<'EOT';

  ? or h          print this message
  d or x 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
				              (or after ptksh startup)

  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

EOT
}


# Substitute our special commands into the command line
sub PtkshCommand {
	$_ = shift;

	foreach ($_) {
		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/^[dx]\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
###

END {
	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)) {
				s/\n/\\\n/mg;
				print HIST "$_\n";
			}
			close HIST;
		} else {
			print STDERR "Error: Unable to open history file '$HISTFILE'\n";
		}
	}
}

1;  # just in case we decide to be "use"'able in the future.