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