—#!perl -w
#
# $Id: ptktrl 1.9 Mon, 06 Jul 1998 20:44:48 +0200 ach $
#
# POD documentation after __END__
require
5.004;
$| = 1;
use
strict;
$VERSION
=
substr
q$Revision: 1.9 $
, 10;
use
Tk;
use
Term::ReadLine;
my
$name
=
'ptktrl'
;
$mw
= MainWindow->new;
$mw
->geometry(
'+20+20'
);
"\n $name V$VERSION"
;
my
$prj
= $0;
$prj
=~ s|[^/]+$|tkach.prj|;
# in my devel area?
"(devel) "
if
-e
$prj
;
" perl V$] Tk V$Tk::VERSION MainWindow -> \$mw\n"
;
"\n\t\@INC:\n"
;
foreach
(
@INC
) {
"\t $_\n"
};
"\n"
;
if
( -r
".${name}_init"
)
{
"Reading .${name}_init ...\n"
;
do
".${name}_init"
;
}
if
(
defined
(
$ARGV
[0]) && -r
$ARGV
[0])
{
"Reading $ARGV[0] ...\n"
;
do
$ARGV
[0];
}
my
$term
= new Term::ReadLine
$name
;
die
$term
->ReadLine() .
" does not support Tk loop\n"
unless
${
$term
->Features}{tkRunning};
$term
->tkRunning(1);
if
(${
$term
->Features}{ornaments})
{
local
$^W=0;
$term
->ornaments(
'md,me,,'
);
}
## test if Tk is not blocked.
#sub ptksh_test {
# print STDERR "I'm working behing the scene\n";
# $mw->after(1500,\&ptksh_test);
#}
#$mw->after(1500,\&ptksh_test);
###
### Loading history
###
my
$histfile
=
"$ENV{HOME}/.${name}_history"
;
if
( -r
$histfile
and
open
(HIST,
"<$histfile"
) ) {
while
(<HIST>) {
chomp
$_
;
$term
->addhistory(
$_
);
}
close
HIST;
}
###
### Utility function
###
sub
ptksh::_o
{
my
$w
=
shift
;
my
$what
=
shift
;
$what
=~ s/^\s+//;
$what
=~ s/\s+$//;
my
(
@opt
) =
split
" "
,
$what
;
# check for regexp
if
(
$opt
[0] =~ s|^/(.*)/$|$1|)
{
"options matching /$opt[0]/:\n"
;
foreach
(
$w
->configure())
{
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
)
{
Tk::Pretty::Pretty(
$w
->configure(
$_
)),
"\n"
;
}
}
else
{
foreach
(
$w
->configure()) {
Tk::Pretty::Pretty(
$_
),
"\n"
}
}
return
;
}
sub
ptksh::_p {
foreach
(
@_
) {
$_
,
"|\n"
; }
}
my
$u_init
= 0;
my
%u_last
= ();
my
$u_cnt
;
sub
ptksh::_u {
my
$module
=
shift
;
if
(
defined
(
$module
) and
$module
ne
''
) {
$module
=
"Tk/"
.
ucfirst
(
$module
).
".pm"
unless
$module
=~ /^Tk/;
" --- Loading $module ---\n"
;
require
"$module"
;
$@
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
{
"$_ -> $INC{$_}\n"
;
}
}
STDERR
"No modules loaded since last 'u' command (or startup)\n"
unless
$u_cnt
;
}
return
;
}
sub
ptksh::_d
{
Data::Dumper::Dumper(
@_
);
return
;
}
sub
ptksh::_h
{
<<'EOT';
? 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 [option ...] 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 ptktrl startup)
EOT
return
;
}
###
### Read and evaluate line from terminal
###
my
(
$line
,
$last
) = (
''
,
''
);
LINE:
while
(
defined
(
$line
=
$term
->
readline
(
"$name> "
)) ) {
foreach
(
$line
) {
last
LINE
if
/^s*(
exit
)\b/;
last
LINE
if
/^\s.*$/;
#$term->add_history($_) if $last ne $_;
#$last = $_;
last
if
s/^\?\s*$/ptksh::_h /;
last
if
s/^u(\s+|$)/ptksh::_u /;
last
if
s/^d\s+/ptksh::_d /;
last
if
s/^u\s+(\S+)/ptksh::_u(
'$1'
)/;
last
if
s/^p\s+(.*)$/ptksh::_p $1;/;
last
if
s/^o\s+(\S+)\s*?$/ptksh::_o $1;/;
last
if
s/^o\s+(\S+)\s*,?\s+(.*)?$/ptksh::_o $1,
'$2'
;/;
}
#print "Line: ($line)\n";
%u_last
=
%INC
unless
$u_init
++;
my
$result
=
eval
"{no strict; local \$^W=0; $line;}"
;
if
($@) {
"$@\n"
;
}
elsif
(
$result
) {
$result
,
"\n"
;
}
}
"\n"
unless
defined
$line
;
###
### Save History
###
END {
my
$features
=
$term
->Features;
if
(
exists
$features
->{getHistory} &&
$features
->{getHistory})
{
my
@a
=
$term
->GetHistory();
$#a
--
if
$a
[-1] =~ /^(
q$|x$
|\s
*exit
\b)/; #
chop
off the
exit
command
@a
=
@a
[(
$#a
-50)..(
$#a
)]
if
$#a
> 50 ;
if
(
open
HIST,
">$histfile"
)
{
HIST
join
(
"\n"
,
@a
),
"\n"
;
close
HIST;
}
else
{
"Error: Unable to open history to '$histfile'\n"
;
}
}
else
{
$term
->ReadLine,
" does not support a history records :-(\n"
;
}
}
__END__
=head1 NAME
ptktrl - Simple perl/Tk shell with cmd line editing and a persistent history
=head1 SYNOPSIS
% ptktrl ?I<scriptfile>?
... version informations ...
ptktrl> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'})
ptktrl> $b->grid
ptktrl> o $b
... list of options ...
ptktrl> ...
ptktrl> ^D
%
=head1 DESCRIPTION
ptktrl is a simple perl/Tk shell to enter perl commands
interactively. When one starts ptktrl a L<MainWindow|Tk::MainWindow>
is automaticly created. One can access it with I<$mw> on the command line.
ptktrl supports command line editing and history via ReadLine interface
(see L<Term::ReadLine>). The last 50 commands entered are saved on
exit to F<~/.ptktrl_history>. The history file is loaded into history
cache the next time you start ptktrl.
To exit ptktrl use: C<^D, exit,> or C<quit>.
The primary target of ptktrl is to experiment with perl/Tk
widgets. To debug perl/Tk programs use the more powerful the
L<perl debugger|perldebug>. Just enter ``O tk'' on debuggers
command line to start the Tk eventloop. The only advantage
ptktrl has is that history file support and that
a MainWindow is automaticly created.
=head1 DEBUGGING SUPPORT
ptktrl provides some convenience function to make browsing
in perl/Tk widgets easier:
=over 4
=item B<?>
displays a short help summary.
=item B<d> ?I<args>, ...?
Dumps recursicely arguments to stdout. (see L<Data::Dumper>).
=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 ptktrl.
If argument is a string, ``text'' it tried does a ``use Tk::Text''.
=back
=head1 ENVIRONMENT
Same as for Term::ReadLine and perl. See L<Term::ReadLine> and
L<perlrun/"ENVIRONMENT"> for further details.
=head1 FILES
=over 4
=item F<.ptktrl_init>
If found in current directory it is read in an evaluated
after the mainwindow I<$mw> is created. F<.ptktrl_init>
can contain any valid perl code.
=item F<~/.ptktrl_history>
Contains the last 50 lines entered in ptktrl session(s).
=back
=head1 BUGS
Work only on Unix systems.
Term::Readline::Perl command line history is broken when used
in conjunction with perl/Tk. Term::ReadLine::Gnu has no
problems.
B<Tk::MainLoop> function interactively entered or sourced in a
init or script file will block ptktrl.
=head1 SEE ALSO
L<Tk|Tk>
L<Term::ReadLine|Term::ReadLine>
L<perldebug|perldebug>
=head1 AUTHOR
Achim Bohnet <F<ach@mpe.mpg.de>>
Copyright (c) 1996-1998 Achim Bohnet. All rights reserved. This program
is free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
=cut