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