home *** CD-ROM | disk | FTP | other *** search
/ PC World 2004 November / PCWorld_2004-11_cd.bin / software / topware / activeperl / ActivePerl-5.8.4.810-MSWin32-x86.exe / ActivePerl-5.8.4.810 / Perl / bin / ptksh.bat < prev    next >
DOS Batch File  |  2004-06-01  |  19KB  |  723 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl
  6. :WinNT
  7. perl -x -S %0 %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  11. goto endofperl
  12. @rem ';
  13. #!perl -w
  14. #line 15
  15. #
  16. # PTKSH 2.0
  17. #
  18. # A graphical user interface for testing Perl/Tk commands and scripts.
  19. #
  20. # VERSION HISTORY:
  21. # ...truncated earlier stuff...
  22. # 4/23/98  V1.7    Achim Bohnet  -- some fixes to "o" command
  23. # 6/08/98  V2.01  M. Beller -- merge in GUI code for "wish"-like interface
  24. #
  25. # 2.01d1 6/6/98 First development version
  26. #
  27. # 2.01d2 6/7/98
  28. #  - apply A.B. patch for pod and -option
  29. #  - fix "use of uninitialized variable" in END{ } block (for -c option)
  30. #  - support h and ? only for help
  31. #  - misc. pod fixes (PITFALLS)
  32. #  - use default fonts and default colors  ## NOT YET--still working on it
  33. #  - get rid of Data::Dumper for history
  34. #
  35. # 2.01d3 6/8/98
  36. #  - Remove "use Data::Dumper" line
  37. #  - Put in hack for unix vs. win32 window manager focus problem
  38. #  - Achim's pod and histfile patch
  39. #
  40. # 2.01d4 6/18/98
  41. #  - Slaven's patch to make <Home> work properly
  42. #  - Add help message to banner (per Steve Lydie)
  43. #  - Fix horizontal scrolling (turn off wrapping in console window)
  44. #  - Clarify <Up> in docs and help means "up arrow"
  45. #  - Use HOMEDRIVE/HOMEPATH on Win32
  46. #
  47.  
  48. =head1 NAME
  49.  
  50. ptksh - Perl/Tk script to provide a graphical user interface for testing Perl/Tk
  51. commands and scripts.
  52.  
  53. =head1 SYNOPSIS
  54.  
  55.   % ptksh  ?scriptfile?
  56.   ... version information ...
  57.   ptksh> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'})
  58.   ptksh> $b->pack
  59.   ptksh> o $b
  60.   ... list of options ...
  61.   ptksh> help
  62.   ... help information ...
  63.   ptksh> exit
  64.   %
  65.  
  66.  
  67. =head1 DESCRIPTION
  68.  
  69. ptksh is a perl/Tk shell to enter perl commands
  70. interactively.  When one starts ptksh a L<MainWindow|Tk::MainWindow>
  71. is automaticly created, along with a ptksh command window.
  72. One can access the main window by typing commands using the
  73. variable $mw at the 'ptksh> ' prompt of the command window.
  74.  
  75. ptksh supports command line editing and history.  Just type "<Up>" at
  76. the command prompt to see a history list.  The last 50 commands entered
  77. are saved, then reloaded into history list the next time you start ptksh.
  78.  
  79. ptksh supports some convenient commands for inspecting Tk widgets.  See below.
  80.  
  81. To exit ptksh use: C<exit>.
  82.  
  83. ptksh is B<*not*> a full symbolic debugger.
  84. To debug perl/Tk programs at a low level use the more powerful
  85. L<perl debugger|perldebug>.  (Just enter ``O tk'' on debuggers
  86. command line to start the Tk eventloop.)
  87.  
  88. =head1 FEATURES
  89.  
  90. =head2 History
  91.  
  92. Press <Up> (the Up Arrow) in the perlwish window to obtain a gui-based history list.
  93. Press <Enter> on any history line to enter it into the perlwish window.
  94. Then hit return.  So, for example, repeat last command is <Up><Enter><Enter>.
  95. You can quit the history window with <Escape>.  NOTE: history is only saved
  96. if exit is "graceful" (i.e. by the "exit" command from the console or by
  97. quitting all main windows--NOT by interrupt).
  98.  
  99. =head2 Debugging Support
  100.  
  101. ptksh provides some convenience function to make browsing
  102. in perl/Tk widget easier:
  103.  
  104. =over 4
  105.  
  106. =item B<?>, or B<h>
  107.  
  108. displays a short help summary.
  109.  
  110. =item B<d> ?I<args>, ...?
  111.  
  112. Dumps recursively arguments to stdout. (see L<Data::Dumper>).
  113. You must have <Data::Dumper> installed to support this feature.
  114.  
  115. =item B<p> ?I<arg>, ...?
  116.  
  117. appends "|\n" to each of it's arguments and prints it.
  118. If value is B<undef>, '(undef)' is printed to stdout.
  119.  
  120. =item B<o> I<$widget> ?I<-option> ...?
  121.  
  122. prints the option(s) of I<$widget> one on each line.
  123. If no options are given all options of the widget are
  124. listed.  See L<Tk::options> for more details on the
  125. format and contents of the returned list.
  126.  
  127. =item B<o> I<$widget> B</>I<regexp>B</>
  128.  
  129. Lists options of I<$widget> matching the
  130. L<regular expression|perlre> I<regexp>.
  131.  
  132. =item B<u> ?I<class>?
  133.  
  134. If no argument is given it lists the modules loaded
  135. by the commands you executed or since the last time you
  136. called C<u>.
  137.  
  138. If argument is the empty string lists all modules that are
  139. loaded by ptksh.
  140.  
  141. If argument is a string, ``text'' it tries to do a ``use Tk::Text;''.
  142.  
  143. =back
  144.  
  145. =head2 Packages
  146.  
  147. Ptksh compiles into package Tk::ptksh.  Your code is eval'ed into package
  148. main.  The coolness of this is that your eval code should not interfere with
  149. ptksh itself.
  150.  
  151. =head2 Multiline Commands
  152.  
  153. ptksh will accept multiline commands.  Simply put a "\" character immediately
  154. before the newline, and ptksh will continue your command onto the next line.
  155.  
  156. =head2 Source File Support
  157.  
  158. If you have a perl/Tk script that you want to do debugging on, try running the
  159. command
  160.  
  161.   ptksh> do 'myscript';
  162.  
  163.    -- or  (at shell command prompt) --
  164.  
  165.   % ptksh myscript
  166.  
  167. Then use the perl/Tk commands to try out different operations on your script.
  168.  
  169. =head1 ENVIRONMENT
  170.  
  171. Looks for your .ptksh_history in the directory specified by
  172. the $HOME environment variable ($HOMEPATH on Win32 systems).
  173.  
  174. =head1 FILES
  175.  
  176. =over 4
  177.  
  178. =item F<.ptksh_init>
  179.  
  180. If found in current directory it is read in an evaluated
  181. after the mainwindow I<$mw> is created. F<.ptksh_init>
  182. can contain any valid perl code.
  183.  
  184. =item F<~/.ptksh_history>
  185.  
  186. Contains the last 50 lines entered in ptksh session(s).
  187.  
  188. =back
  189.  
  190. =head1 PITFALLS
  191.  
  192. It is best not to use "my" in the commands you type into ptksh.
  193. For example "my $v" will make $v local just to the command or commands
  194. entered until <Return> is pressed.
  195. For a related reason, there are no file-scopy "my" variables in the
  196. ptksh code itself (else the user might trounce on them by accident).
  197.  
  198. =head1 BUGS
  199.  
  200. B<Tk::MainLoop> function interactively entered or sourced in a
  201. init or script file will block ptksh.
  202.  
  203. =head1 SEE ALSO
  204.  
  205. L<Tk|Tk>
  206. L<perldebug|perldebug>
  207.  
  208. =head1 VERSION
  209.  
  210. VERSION 2.02
  211.  
  212. =head1 AUTHORS
  213.  
  214. Mike Beller <beller@penvision.com>,
  215. Achim Bohnet <ach@mpe.mpg.de>
  216.  
  217. Copyright (c) 1996 - 1998 Achim Bohnet and Mike Beller. All rights reserved.
  218. This program is free software; you can redistribute it and/or modify it
  219. under the same terms as Perl itself.
  220.  
  221. =cut
  222.  
  223. package Tk::ptksh;
  224. require 5.004;
  225. use strict;
  226. use Tk;
  227.  
  228. ##### Constants
  229.  
  230. use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT $INITFILE);
  231.  
  232. $NAME = 'ptksh';
  233. $VERSION = '2.02';
  234. $WIN32 = 1 if $^O =~ /Win32/;
  235. $HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH}) || 'C:\\' : $ENV{HOME} . "/";
  236. @FONT = ($WIN32 ? (-font => 'systemfixed') : () );
  237. #@FONT = ($WIN32 ? (-font => ['courier', 9, 'normal']) : () );
  238. $HISTFILE = "${HOME}.${NAME}_history";
  239. $HISTSAVE = 50;
  240. $INITFILE = ".${NAME}_init";
  241. $PROMPT = "$NAME> ";
  242.  
  243. sub Win32Fix { my $p = shift; $p =~ s'\\'/'g; $p =~ s'/$''; return $p }
  244.  
  245. use vars qw($mw $st $t @hist $hist $list $isStartOfCommand);
  246.  
  247. # NOTE: mainwindow creation order seems to impact who gets focus, and
  248. # order is different on Win32 & *nix!!  So hack is to create the windows
  249. # in an order dependent on the OS!
  250.  
  251. $mw = Tk::MainWindow->new unless $WIN32;  # &&& hack to work around focus problem
  252.  
  253. ##### set up user's main window
  254. package main;
  255. $main::mw = Tk::MainWindow->new;
  256. $main::mw->title('$mw');
  257. $main::mw->geometry("+1+1");
  258. package Tk::ptksh;
  259.  
  260. ##### Set up ptksh windows
  261. $mw = Tk::MainWindow->new if $WIN32;  # &&& hack to work around focus problem
  262. $mw->title($NAME);
  263. $st = $mw->Scrolled('Text', -scrollbars => 'osoe',
  264.                 -wrap => 'none',
  265.                 -width => 80, -height => 25, @FONT);
  266. $t = $st->Subwidget('scrolled');
  267. $st->pack(-fill => 'both', -expand => 'true');
  268. $mw->bind('<Map>', sub {Center($mw);} );
  269.  
  270. # Event bindings
  271. $t->bindtags([$t, ref($t), $t->toplevel, 'all']); # take first crack at events
  272. $t->bind('<Return>', \&EvalInput);
  273. $t->bind('<BackSpace>', \&BackSpace);
  274. $t->bind('<Escape>', \&HistKill);
  275. $t->bind('<Up>', \&History);
  276. $t->bind('<Control-a>', \&BeginLine);
  277. $t->bind('<Home>', \&BeginLine);
  278. $t->bind('<Any-KeyPress>', [\&Key, Tk::Ev('K'), Tk::Ev('A')]);
  279.  
  280. # Set up different colors for the various window outputs
  281. #$t->tagConfigure('prompt', -underline => 'true');
  282. $t->tagConfigure('prompt', -foreground => 'blue');
  283. $t->tagConfigure('result', -foreground => 'purple');
  284. $t->tagConfigure('error', -foreground => 'red');
  285. $t->tagConfigure('output', -foreground => 'blue');
  286.  
  287. # The tag 'limit' is the beginning of the input command line
  288. $t->markSet('limit', 'insert');
  289. $t->markGravity('limit', 'left');
  290.  
  291. # redirect stdout
  292. #tie (*STDOUT, 'Tk::Text', $t);
  293. tie (*STDOUT, 'Tk::ptksh');
  294. #tie (*STDERR, 'Tk::ptksh');
  295.  
  296. # Print banner
  297. print "$NAME V$VERSION";
  298. print " perl V$] Tk V$Tk::VERSION  MainWindow -> \$mw\n";
  299. print "\n\t\@INC:\n";
  300. foreach (@INC) { print "\t  $_\n" };
  301. print "Type 'h<Return>' at the prompt for help\n";
  302.  
  303. ##### Read .ptkshinit
  304. if ( -r $INITFILE)
  305.   {
  306.     print "Reading $INITFILE ...\n";
  307.     package main;
  308.     do $Tk::ptksh::INITFILE;
  309.     package Tk::ptksh;
  310.   }
  311.  
  312. ###### Source the file if given as argument 0
  313. if (defined($ARGV[0]) && -r $ARGV[0])
  314.   {
  315.     print "Reading $ARGV[0] ...\n";
  316.     package main;
  317.     do $ARGV[0];
  318.     package Tk::ptksh;
  319.   }
  320.  
  321. ##### Read history
  322. @hist = ();
  323. if ( -r $HISTFILE and open(HIST, $HISTFILE) ) {
  324.     print "Reading history ...\n";
  325.     my $c = "";
  326.     while (<HIST>) {
  327.         chomp;
  328.         $c .= $_;
  329.         if ($_ !~ /\\$/) { #end of command if no trailing "\"
  330.             push @hist, $c;
  331.             $c = "";
  332.         } else {
  333.             chop $c;    # kill trailing "\"
  334.             $c .= "\n";
  335.         }
  336.     }
  337.     close HIST;
  338. }
  339.  
  340. ##### Initial prompt
  341. Prompt($PROMPT);
  342. $Tk::ptksh::mw->focus;
  343. $t->focus;
  344. #$mw->after(1000, sub {print STDERR "now\n"; $mw->focus; $t->focus;});
  345.  
  346. ##### Now enter main loop
  347. MainLoop();
  348.  
  349. ####### Callbacks/etc.
  350.  
  351. # EvalInput -- Eval the input area (between 'limit' and 'insert')
  352. #              in package main;
  353. use vars qw($command $result); # use globals instead of "my" to avoid conflict w/ 'eval'
  354. sub EvalInput {
  355.     # If return is hit when not inside the command entry range, reprompt
  356.     if ($t->compare('insert', '<=', 'limit')) {
  357.         $t->markSet('insert', 'end');
  358.         Prompt($PROMPT);
  359.         Tk->break;
  360.     }
  361.  
  362.     # Support multi-line commands
  363.     if ($t->get('insert-1c', 'insert') eq "\\") {
  364.         $t->insert('insert', "\n");
  365.         $t->insert('insert', "> ", 'prompt'); # must use this pattern for continue
  366.         $t->see('insert');
  367.         Tk->break;
  368.     }
  369.  
  370.     # Get the command and strip out continuations
  371.     $command = $t->get('limit','end');
  372.     $t->markSet('insert','end');
  373.     $command =~ s/\\\n>\s/\n/mg;
  374.  
  375.     # Eval it
  376.     if ( $command !~ /^\s*$/) {
  377.         chomp $command;
  378.         push(@hist, $command)
  379.             unless @hist && ($command eq $hist[$#hist]); #could elim more redundancy
  380.  
  381.         $t->insert('insert', "\n");
  382.  
  383.         $isStartOfCommand = 1;
  384.  
  385.         $command = PtkshCommand($command);
  386.  
  387.         exit if ($command eq 'exit');
  388.  
  389.         package main;
  390.         no strict;
  391.         $Tk::ptksh::result = eval "local \$^W=0; $Tk::ptksh::command;";
  392.         use strict;
  393.         package Tk::ptksh;
  394.  
  395.         if ($t->compare('insert', '!=', 'insert linestart')) {
  396.             $t->insert('insert', "\n");
  397.         }
  398.         if ($@) {
  399.             $t->insert('insert', '## ' . $@, 'error');
  400.         } else {
  401.             $result = "" if !defined($result);
  402.             $t->insert('insert', '# ' . $result, 'result');
  403.         }
  404.     }
  405.  
  406.     Prompt($PROMPT);
  407.  
  408.     Tk->break;
  409. }
  410.  
  411. sub Prompt {
  412.     my $pr = shift;
  413.  
  414.     if ($t->compare('insert', '!=', 'insert linestart')) {
  415.         $t->insert('insert', "\n");
  416.     }
  417.  
  418.     $t->insert('insert', $pr, 'prompt');
  419.     $t->see('insert');
  420.     $t->markSet('limit', 'insert');
  421.  
  422. }
  423.  
  424. sub BackSpace {
  425.     if ($t->tagNextrange('sel', '1.0', 'end')) {
  426.         $t->delete('sel.first', 'sel.last');
  427.         } elsif ($t->compare('insert', '>', 'limit')) {
  428.             $t->delete('insert-1c');
  429.             $t->see('insert');
  430.         }
  431.         Tk->break;
  432. }
  433.  
  434. sub BeginLine {
  435.        $t->SetCursor('limit');
  436.        $t->break;
  437. }
  438.  
  439. sub Key {
  440.     my ($self, $k, $a) = @_;
  441.     #print "key event: ", $k, "\n";
  442.     if ($t->compare('insert', '<', 'limit')) {
  443.         $t->markSet('insert', 'end');
  444.     }
  445.     #$t->break; #for testing bindtags
  446. }
  447.  
  448. sub History {
  449.     Tk->break if defined($hist);
  450.  
  451.     $hist = $mw->Toplevel;
  452.     $hist->title('History');
  453.     $list = $hist->ScrlListbox(-scrollbars => 'oe',
  454.               -width => 30, -height => 10, @FONT)->pack;
  455.     Center($hist);
  456.     $list->insert('end', @hist);
  457.     $list->see('end');
  458.     $list->activate('end');
  459.     $hist->bind('<Double-1>', \&HistPick);
  460.     $hist->bind('<Return>', \&HistPick);
  461.     $hist->bind('<Escape>', \&HistKill);
  462.     $hist->bind('<Map>', sub {Center($hist);} );
  463.     $hist->bind('<Destroy>', \&HistDestroy);
  464.     $hist->focus;
  465.     $list->focus;
  466.     $hist->grab;
  467.     Tk->break;
  468. }
  469.  
  470. sub HistPick {
  471.     my $item = $list->get('active');
  472.     return if (!$item);
  473.     $t->markSet('insert', 'end');
  474.     $t->insert('insert',$item);
  475.     $t->see('insert');
  476.     $mw->focus;
  477.     $t->focus;
  478.     HistKill();
  479. }
  480.  
  481. sub HistKill {
  482.     if ($hist) {
  483.         $hist->grabRelease;
  484.         $hist->destroy;
  485.     }
  486. }
  487.  
  488. # Called from destroy event mapping
  489. sub HistDestroy {
  490.     if (defined($hist) && (shift == $hist)) {
  491.         $hist = undef;
  492.         $mw->focus;
  493.         $t->focus;
  494.     }
  495. }
  496.  
  497. sub LastCommand {
  498.     if ($t->compare('insert', '==', 'limit')) {
  499.         $t->insert('insert', $hist[$#hist]);
  500.         $t->break;
  501.     }
  502. }
  503.  
  504. # Center a toplevel on screen or above parent
  505. sub Center {
  506.     my $w = shift;
  507.     my ($x, $y);
  508.  
  509.     if ($w->parent) {
  510.         #print STDERR $w->screenwidth, " ", $w->width, "\n";
  511.         $x = $w->parent->x + ($w->parent->width - $w->width)/2;
  512.         $y = $w->parent->y + ($w->parent->height - $w->height)/2;
  513.     } else {
  514.         #print STDERR $w->screenwidth, " ", $w->width, "\n";
  515.         $x = ($w->screenwidth - $w->width)/2;
  516.         $y = ($w->screenheight - $w->height)/2;
  517.     }
  518.     $x = int($x);
  519.     $y = int($y);
  520.     my $g = "+$x+$y";
  521.     #print STDERR "Setting geometry to $g\n";
  522.     $w->geometry($g);
  523. }
  524.  
  525. # To deal with "TIE".
  526. # We have to make sure the prints don't go into the command entry range.
  527.  
  528. sub TIEHANDLE {    # just to capture the tied calls
  529.     my $self = [];
  530.     return bless $self;
  531.  
  532. }
  533.  
  534. sub PRINT {
  535.     my ($bogus) = shift;
  536.  
  537.     $t->markSet('insert', 'end');
  538.  
  539.     if ($isStartOfCommand) {  # Then no prints have happened in this command yet so...
  540.         if ($t->compare('insert', '!=', 'insert linestart')) {
  541.             $t->insert('insert', "\n");
  542.         }
  543.         # set flag so we know at least one print happened in this eval
  544.         $isStartOfCommand = 0;
  545.     }
  546.  
  547.     while (@_) {
  548.         $t->insert('end', shift, 'output');
  549.     }
  550.  
  551.     $t->see('insert');
  552.  
  553.     $t->markSet('limit', 'insert'); # don't interpret print as an input command
  554. }
  555.  
  556. sub PRINTF
  557. {
  558.  my $w = shift;
  559.  $w->PRINT(sprintf(shift,@_));
  560. }
  561.  
  562. ###
  563. ### Utility function
  564. ###
  565.  
  566. sub _o
  567.   {
  568.     my $w = shift;
  569.     my $what = shift;
  570.  
  571.     $what =~ s/^\s+//;
  572.     $what =~ s/\s+$//;
  573.     my (@opt) = split " ", $what;
  574.  
  575.     print 'o(', join('|', @opt), ")\n";
  576.     require Tk::Pretty;
  577.  
  578.     # check for regexp
  579.     if ($opt[0] =~ s|^/(.*)/$|$1|)
  580.       {
  581.     print "options matching /$opt[0]/:\n";
  582.         foreach ($w->configure())
  583.           {
  584.             print Tk::Pretty::Pretty($_),"\n" if $_->[0] =~ /\Q$opt[0]\E/;
  585.           }
  586.         return;
  587.     }
  588.  
  589.     # list of options (allow as bar words)
  590.     foreach (@opt)
  591.       {
  592.     s/^['"]//;
  593.     s/,$//;
  594.     s/['"]$//;
  595.     s/^([^-])/-$1/;
  596.       }
  597.     if (length $what)
  598.       {
  599.        foreach (@opt)
  600.           {
  601.             print Tk::Pretty::Pretty($w->configure($_)),"\n";
  602.           }
  603.       }
  604.     else
  605.       {
  606.         foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" }
  607.       }
  608.   }
  609.  
  610. sub _p {
  611.     foreach (@_) { print $_, "|\n"; }
  612. }
  613.  
  614. use vars qw($u_init %u_last $u_cnt);
  615. $u_init = 0;
  616. %u_last = ();
  617. sub _u {
  618.     my $module = shift;
  619.     if (defined($module) and $module ne '') {
  620.     $module = "Tk/".ucfirst($module).".pm" unless $module =~ /^Tk/;
  621.     print " --- Loading $module ---\n";
  622.     require "$module";
  623.     print $@ if $@;
  624.     } else {
  625.         %u_last = () if defined $module;
  626.     $u_cnt = 0;
  627.     foreach (sort keys %INC) {
  628.         next if exists $u_last{$_};
  629.             $u_cnt++;
  630.             $u_last{$_} = 1;
  631.         #next if m,^/, and m,\.ix$,; # Ignore autoloader files
  632.         #next if m,\.ix$,; # Ignore autoloader files
  633.  
  634.         if (length($_) < 20 ) {
  635.         printf "%-20s -> %s\n", $_, $INC{$_};
  636.         } else {
  637.         print "$_ -> $INC{$_}\n";
  638.         }
  639.         }
  640.     print STDERR "No modules loaded since last 'u' command (or startup)\n"
  641.         unless $u_cnt;
  642.     }
  643. }
  644.  
  645. sub _d
  646.   {
  647.     require Data::Dumper;
  648.     local $Data::Dumper::Deparse;
  649.     $Data::Dumper::Deparse = 1;
  650.     print Data::Dumper::Dumper(@_);
  651.   }
  652.  
  653. sub _h
  654.   {
  655.     print <<'EOT';
  656.  
  657.   ? or h          print this message
  658.   d arg,...       calls Data::Dumper::Dumper
  659.   p arg,...       print args, each on a line and "|\n"
  660.   o $w /regexp/   print options of widget matching regexp
  661.   o $w [opt ...]  print (all) options of widget
  662.   u xxx           xxx = string : load Tk::Xxx
  663.                    = ''     : list all modules loaded
  664.                    = undef  : list modules loaded since last u call
  665.                               (or after ptksh startup)
  666.  
  667.   Press <Up> (the "up arrow" key) for command history
  668.   Press <Escape> to leave command history window
  669.   Type "exit" to quit (saves history)
  670.   Type \<Return> for continuation of command to following line
  671.  
  672. EOT
  673. }
  674.  
  675.  
  676. # Substitute our special commands into the command line
  677. sub PtkshCommand {
  678.     $_ = shift;
  679.  
  680.     foreach ($_) {
  681.         last if s/^\?\s*$/Tk::ptksh::_h /;
  682.         last if s/^h\s*$/Tk::ptksh::_h /;
  683.         last if s/^u(\s+|$)/Tk::ptksh::_u /;
  684.         last if s/^d\s+/Tk::ptksh::_d /;
  685.         last if s/^u\s+(\S+)/Tk::ptksh::_u('$1')/;
  686.         last if s/^p\s+(.*)$/Tk::ptksh::_p $1;/;
  687.         last if s/^o\s+(\S+)\s*?$/Tk::ptksh::_o $1;/;
  688.         last if s/^o\s+(\S+)\s*,?\s+(.*)?$/Tk::ptksh::_o $1, '$2';/;
  689.     }
  690.     %u_last = %INC unless $u_init++;
  691.  
  692.     # print STDERR "Command is: $_\n";
  693.  
  694.     $_;
  695. }
  696.  
  697. ###
  698. ### Save History -- use Data::Dumper to preserve multiline commands
  699. ###
  700.  
  701. END {
  702.     if ($HISTFILE) {  # because this is probably perl -c if $HISTFILE is not set
  703.         $#hist-- if $hist[-1] =~ /^(q$|x$|\s*exit\b)/; # chop off the exit command
  704.  
  705.         @hist = @hist[($#hist-$HISTSAVE)..($#hist)] if $#hist > $HISTSAVE;
  706.  
  707.         if( open HIST, ">$HISTFILE" ) {
  708.             while ($_ = shift(@hist)) {
  709.                 s/\n/\\\n/mg;
  710.                 print HIST "$_\n";
  711.             }
  712.             close HIST;
  713.         } else {
  714.             print STDERR "Error: Unable to open history file '$HISTFILE'\n";
  715.         }
  716.     }
  717. }
  718.  
  719. 1;  # just in case we decide to be "use"'able in the future.
  720.  
  721. __END__
  722. :endofperl
  723.