File Coverage

blib/lib/Term/GDBUI.pm
Criterion Covered Total %
statement 32 486 6.5
branch 3 248 1.2
condition 2 84 2.3
subroutine 6 44 13.6
pod 34 37 91.8
total 77 899 8.5


line stmt bran cond sub pod time code
1             # Term::GDBUI.pm
2             # Scott Bronson
3             # 3 Nov 2003
4              
5             # Makes it very easy to implement a GDB-like interface.
6              
7             package Term::GDBUI;
8              
9 1     1   34753 use strict;
  1         3  
  1         40  
10              
11 1     1   1314 use Term::ReadLine ();
  1         4957  
  1         24  
12 1     1   825 use Text::Shellwords::Cursor;
  1         3  
  1         45  
13              
14 1     1   9 use vars qw($VERSION);
  1         3  
  1         530  
15             $VERSION = '0.84';
16              
17              
18             =head1 NAME
19              
20             Term::GDBUI - A fully-featured shell-like command line environment
21              
22             =head1 SYNOPSIS
23              
24             use Term::GDBUI;
25             my $term = new Term::GDBUI(commands => get_commands());
26             # (see below for the code to get_commands)
27             $term->run();
28              
29              
30             =head1 DESCRIPTION
31              
32             Term::GDBUI uses the history and autocompletion features of L
33             to present a sophisticated command-line interface to the user. It tries to
34             make every feature you would expect to see in a fully interactive shell
35             trivial to implement.
36             You simply declare your command set and let GDBUI take
37             care of the heavy lifting.
38              
39             =head1 COMMAND SET
40              
41             A command set is the data structure that
42             describes your application's entire user interface.
43             It's easiest to illustrate with a working example.
44             We shall implement the following 6 Ls:
45              
46             =over 4
47              
48             =item help
49              
50             Prints the help for the given command.
51             With no arguments, prints a list and short summary of all available commands.
52              
53             =item h
54              
55             This is just a synonym for "help". We don't want to list it in the
56             possible completions.
57             Of course, pressing "h" will autocomplete to "help" and
58             then execute the help command. Including this command allows you to
59             simply type "h".
60              
61             =item exists
62              
63             This command shows how to use the
64             L
65             routines to complete on file names,
66             and how to provide more comprehensive help.
67              
68             =item show
69              
70             Demonstrates subcommands (like GDB's show command).
71             This makes it easy to implement commands like "show warranty"
72             and "show args".
73              
74             =item show args
75              
76             This shows more advanced argument processing.
77             First, it uses cusom argument completion: a static completion for the
78             first argument (either "create" or "delete") and the standard
79             file completion for the second. When executed, it echoes its own command
80             name followed by its arguments.
81              
82             =item quit
83              
84             How to nicely quit.
85             Term::GDBUI also follows Term::ReadLine's default of quitting
86             when Control-D is pressed.
87              
88             =back
89              
90             This code is fairly comprehensive because it attempts to
91             demonstrate most of Term::GDBUI's many features. You can find a working
92             version of this exact code titled "synopsis" in the examples directory.
93             For a more real-world example, see the fileman-example in the same
94             directory.
95              
96             sub get_commands
97             {
98             return {
99             "help" => {
100             desc => "Print helpful information",
101             args => sub { shift->help_args(undef, @_); },
102             meth => sub { shift->help_call(undef, @_); }
103             },
104             "h" => { syn => "help", exclude_from_completion=>1},
105             "exists" => {
106             desc => "List whether files exist",
107             args => sub { shift->complete_files(@_); },
108             proc => sub {
109             print "exists: " .
110             join(", ", map {-e($_) ? "<$_>":$_} @_) .
111             "\n";
112             },
113             doc => <
114             Comprehensive documentation for our ls command.
115             If a file exists, it is printed in .
116             The help can\nspan\nmany\nlines
117             EOL
118             },
119             "show" => {
120             desc => "An example of using subcommands",
121             cmds => {
122             "warranty" => { proc => "You have no warranty!\n" },
123             "args" => {
124             minargs => 2, maxargs => 2,
125             args => [ sub {qw(create delete)},
126             \&Term::GDBUI::complete_files ],
127             desc => "Demonstrate method calling",
128             meth => sub {
129             my $self = shift;
130             my $parms = shift;
131             print $self->get_cname($parms->{cname}) .
132             ": " . join(" ",@_), "\n";
133             },
134             },
135             },
136             },
137             "quit" => {
138             desc => "Quit using Fileman",
139             maxargs => 0,
140             meth => sub { shift->exit_requested(1); }
141             },
142             };
143             }
144              
145              
146             =head1 COMMAND
147              
148             This data structure describes a single command implemented
149             by your application.
150             "help", "exit", etc.
151             All fields are optional.
152             Commands are passed to Term::GDBUI using a L.
153              
154             =over 4
155              
156             =item desc
157              
158             A short, one-line description for the command. Normally this is
159             a simple string, but it may also be a subroutine that
160             will be called every time the description is printed.
161             The subroutine takes two arguments, $self (the Term::GDBUI object),
162             and $cmd (the command hash for the command), and returns the
163             command's description as a string.
164              
165             =item doc
166              
167             A comprehensive, many-line description for the command.
168             Like desc, this is normally a string but
169             if you store a reference to a subroutine in this field,
170             it will be called to calculate the documentation.
171             Your subroutine should accept three arguments: self (the Term::GDBUI object),
172             cmd (the command hash for the command), and the command's name.
173             It should return a string containing the command's documentation.
174             See examples/xmlexer to see how to read the doc
175             for a command out of the pod.
176              
177             =item minargs
178              
179             =item maxargs
180              
181             These set the minimum and maximum number of arguments that this
182             command will accept.
183              
184             =item proc
185              
186             This contains a reference to the subroutine that should be executed
187             when this command is called. Arguments are those passed on the
188             command line and the return value is the value returned by
189             call_cmd and process_a_cmd (i.e. it is ignored unless your
190             application makes use of it).
191              
192             If this field is a string instead of a subroutine ref, the string
193             is printed when the command is executed (good for things like
194             "Not implemented yet").
195             Examples of both subroutine and string procs can be seen in the example
196             above.
197              
198             =item meth
199              
200             Similar to proc, but passes more arguments. Where proc simply passes
201             the arguments for the command, meth also passes the Term::GDBUI object
202             and the command's parms object (see L
203             for more on parms). Most commands can be implemented entirely using
204             a simple proc procedure, but sometimes they require addtional information
205             supplied to the meth method. Like proc, meth may also be a string.
206              
207             =item args
208              
209             This tells how to complete the command's arguments. It is usually
210             a subroutine. See L for an reasonably simple
211             example, and the L routine for a description of the
212             arguments and cmpl data structure.
213              
214             Args can also be an arrayref. Each position in the array will be
215             used as the corresponding argument.
216             See "show args" in get_commands above for an example.
217             The last argument is repeated indefinitely (see L
218             for how to limit this).
219              
220             Finally, args can also be a string. The string is intended to
221             be a reminder and is printed whenever the user types tab twice
222             (i.e. "a number between 0 and 65536").
223             It does not affect completion at all.
224              
225             =item cmds
226              
227             Command sets can be recursive. This allows a command to have
228             subcommands (like GDB's info and show commands, and the
229             show command in the example above).
230             A command that has subcommands should only have two fields:
231             cmds (of course), and desc (briefly describe this collection of subcommands).
232             It may also implement doc, but GDBUI's default behavior of printing
233             a summary of the command's subcommands is usually sufficient.
234             Any other fields (args, meth, maxargs, etc) will be taken from
235             the subcommand.
236              
237             =item exclude_from_completion
238              
239             If this field exists, then the command will be excluded from command-line
240             completion. This is useful for one-letter abbreviations, such as
241             "h"->"help": including "h" in the completions just clutters up
242             the screen.
243              
244             =item exclude_from_history
245              
246             If this field exists, the command will never be stored in history.
247             This is useful for commands like help and quit.
248              
249             =back
250              
251             =head2 Default Command
252              
253             If your command set includes a command named '' (the empty
254             string), this pseudo-command will be called any time the actual
255             command cannot be found. Here's an example:
256              
257             '' => {
258             proc => "HA ha. No command here by that name\n",
259             desc => "HA ha. No help for unknown commands.",
260             doc => "Yet more taunting...\n",
261             },
262              
263             Note that minargs and maxargs for the default command are ignored.
264             meth and proc will be called no matter how many arguments the user
265             entered.
266              
267              
268             =head1 CATEGORIES
269              
270             Normally, when the user types 'help', she receives a short
271             summary of all the commands in the command set.
272             However, if your application has 30 or more commands, this can
273             result in information overload. To manage this, you can organize
274             your commands into help categories
275              
276             All help categories are assembled into a hash and passed to the
277             the default L and
278             L methods. If you don't
279             want to use help categories, simply pass undef for the categories.
280              
281             Here is an example of how to declare a collection of help categories:
282              
283             my $helpcats = {
284             breakpoints => {
285             desc => "Commands to halt the program",
286             cmds => qw(break tbreak delete disable enable),
287             },
288             data => {
289             desc => "Commands to examine data",
290             cmds => ['info', 'show warranty', 'show args'],
291             }
292             };
293              
294             "show warranty" and "show args" on the last line above
295             are examples of how to include
296             subcommands in a help category: separate the command and
297             subcommands with whitespace.
298              
299             =head1 CALLBACKS
300              
301             Callbacks are functions supplied by GDBUI but intended to be called by
302             your application.
303             They implement common functions like 'help' and 'history'.
304              
305             =over 4
306              
307             =item help_call(cats, parms, topic)
308              
309             Call this routine to implement your help routine. Pass
310             the help categories or undef, followed by the command-line
311             arguments:
312              
313             "help" => { desc => "Print helpful information",
314             args => sub { shift->help_args($helpcats, @_); },
315             meth => sub { shift->help_call($helpcats, @_); } },
316              
317             =cut
318              
319             sub help_call
320             {
321 0     0 1 0 my $self = shift;
322 0         0 my $cats = shift; # help categories to use
323 0         0 my $parms = shift; # data block passed to methods
324 0         0 my $topic = $_[0]; # topics or commands to get help on
325              
326 0         0 my $cset = $parms->{cset};
327 0         0 my $OUT = $self->{OUT};
328              
329 0 0       0 if(defined($topic)) {
    0          
330 0 0       0 if(exists $cats->{$topic}) {
331 0         0 print $OUT $self->get_category_help($cats->{$topic}, $cset);
332             } else {
333 0         0 print $OUT $self->get_cmd_help(\@_, $cset);
334             }
335             } elsif(defined($cats)) {
336             # no topic -- print a list of the categories
337 0         0 print $OUT "\nHelp categories:\n\n";
338 0         0 for(sort keys(%$cats)) {
339 0         0 print $OUT $self->get_category_summary($_, $cats->{$_});
340             }
341             } else {
342             # no categories -- print a summary of all commands
343 0         0 print $OUT $self->get_all_cmd_summaries($cset);
344             }
345             }
346              
347              
348             =item help_args
349              
350             This provides argument completion for help commands.
351             See the example above for how to call it.
352              
353             =cut
354              
355             sub help_args
356             {
357 0     0 1 0 my $self = shift;
358 0         0 my $helpcats = shift;
359 0         0 my $cmpl = shift;
360              
361 0         0 my $args = $cmpl->{'args'};
362 0         0 my $argno = $cmpl->{'argno'};
363 0         0 my $cset = $cmpl->{'cset'};
364              
365 0 0       0 if($argno == 0) {
366             # return both categories and commands if we're on the first argument
367 0         0 return $self->get_cset_completions($cset, keys(%$helpcats));
368             }
369              
370 0         0 my($scset, $scmd, $scname, $sargs) = $self->get_deep_command($cset, $args);
371              
372             # without this we'd complete with $scset for all further args
373 0 0       0 return [] if $argno >= @$scname;
374              
375 0         0 return $self->get_cset_completions($scset);
376             }
377              
378              
379              
380             =item complete_files
381              
382             Completes on filesystem objects (files, directories, etc).
383             Use either
384              
385             args => sub { shift->complete_files(@_) },
386              
387             or
388              
389             args => \&complete_files,
390              
391             Starts in the current directory.
392              
393             =cut
394              
395             sub complete_files
396             {
397 0     0 1 0 my $self = shift;
398 0         0 my $cmpl = shift;
399              
400 0         0 $self->suppress_completion_append_character();
401              
402 1     1   6 use File::Spec;
  1         2  
  1         8263  
403 0   0     0 my @path = File::Spec->splitdir($cmpl->{str} || ".");
404 0         0 my $dir = File::Spec->catdir(@path[0..$#path-1]);
405              
406             # eradicate non-matches immediately (this is important if
407             # completing in a directory with 3000+ files)
408 0         0 my $file = $path[$#path];
409 0 0       0 $file = '' unless $cmpl->{str};
410 0         0 my $flen = length($file);
411              
412 0         0 my @files = ();
413 0 0       0 if(opendir(DIR, length($dir) ? $dir : '.')) {
    0          
414 0         0 @files = grep { substr($_,0,$flen) eq $file } readdir DIR;
  0         0  
415 0         0 closedir DIR;
416             # eradicate dotfiles unless user's file begins with a dot
417 0 0       0 @files = grep { /^[^.]/ } @files unless $file =~ /^\./;
  0         0  
418             # reformat filenames to be exactly as user typed
419 0 0       0 @files = map { length($dir) ? ($dir eq '/' ? "/$_" : "$dir/$_") : $_ } @files;
  0 0       0  
420             } else {
421 0         0 $self->completemsg("Couldn't read dir: $!\n");
422             }
423              
424 0         0 return \@files;
425             }
426              
427              
428             =item complete_onlyfiles
429              
430             Like L
431             but excludes directories, device nodes, etc.
432             It returns regular files only.
433              
434             =cut
435              
436             sub complete_onlyfiles
437             {
438 0     0 1 0 my $self = shift;
439              
440             # need to do our own escaping because we want to add a space ourselves
441 0         0 $self->suppress_completion_escape();
442 0 0       0 my @c = grep { -f || -d } @{$self->complete_files(@_)};
  0         0  
  0         0  
443 0         0 $self->{parser}->parse_escape(\@c);
444             # append a space if we've completed a unique file
445 0 0       0 $c[0] .= (-f($c[0]) ? ' ' : '') if @c == 1;
    0          
446             # append a helpful slash to indicate directories
447 0 0       0 @c = map { -d($_) ? "$_/" : $_ } @c;
  0         0  
448 0         0 return \@c;
449             }
450              
451              
452             =item complete_onlydirs
453              
454             Like L,
455             but excludes files, device nodes, etc.
456             It returns only directories.
457             It I return the . and .. special directories so you'll need
458             to remove those manually if you don't want to see them:
459              
460             args = sub { grep { !/^\.?\.$/ } complete_onlydirs(@_) },
461              
462             =cut
463              
464             sub complete_onlydirs
465             {
466 0     0 1 0 my $self = shift;
467 0         0 my @c = grep { -d } @{$self->complete_files(@_)};
  0         0  
  0         0  
468 0 0       0 $c[0] .= '/' if @c == 1; # add a slash if it's a unique match
469 0         0 return \@c;
470             }
471              
472              
473             =item complete_history
474              
475             Believe it or not, GDBUI provides tab completion on command history.
476             To use this feature, specify the complete_history routine in
477             your default command handler. Because the default command handler
478             is run any time you enter an unrecognized command, it will be
479             called to perform completion (unless you actually do have commands
480             that begin with a bang).
481              
482             Here's an example of how you would add history completion to
483             your command set:
484              
485             my $cset = {
486             "" => { args => sub { shift->complete_history(@_) } },
487             # ... more commands go here
488             };
489              
490             To watch this in action, run your app, type a bang and then a tab ("!").
491              
492             There is one catch: if you start using completion, be sure to enter the ENTIRE
493             command. If you enter a partial command, Readline will unfortunately stop
494             looking for the match after just the first word (usually the command
495             name). This means that if you want to run "!abc def ghi", Readline will
496             execute the first command that begins with "abc", even though you
497             may have specified another command.
498             Entering the entire command works around this
499             limitation. (If Readline properly supported
500             $term->Attribs->{history_word_delimiters}='\n',
501             this limitation would go away).
502              
503             =cut
504              
505             sub complete_history
506             {
507 0     0 1 0 my $self = shift;
508 0         0 my $cmpl = shift;
509              
510 0 0       0 return undef if $self->{disable_history_expansion};
511              
512             # it's not a history command unless it starts with a bang.
513             #return undef unless $cmpl->{tokno} < @{$cmpl->{cname}};
514 0 0       0 return undef unless substr($cmpl->{tokens}->[0], 0, 1) eq '!';
515              
516 0 0       0 return undef unless $self->{term}->can('GetHistory');
517 0         0 my @history = $self->{term}->GetHistory();
518 0 0       0 return [] unless(@history);
519            
520 0         0 my %seen = (); # uniq history
521 0         0 @history = grep { !$seen{$_}++ } @history;
  0         0  
522              
523             # remove items that start with the wrong text
524 0         0 my $str = substr($cmpl->{rawline}, 1, $cmpl->{rawcursor}-1);
525 0         0 my $strlen = length($str);
526 0         0 @history = grep { substr($_,0,$strlen) eq $str } @history;
  0         0  
527              
528             # trim all tokens except for the one we're trying to complete
529             # (no need to do this for the first token -- just the rest)
530 0 0       0 if($cmpl->{tokno} > 0) {
531 0         0 my $rawstart = $cmpl->{rawstart} - 1; # no bang so -1
532 0         0 @history = map { substr($_, $rawstart) } @history;
  0         0  
533             }
534              
535             # put a bang on the front if it's the first token
536 0 0       0 @history = map { "!$_" } @history if $cmpl->{tokno} == 0;
  0         0  
537              
538             # otherwise the commands would be modified
539 0         0 $self->suppress_completion_escape();
540              
541 0         0 return \@history;
542             }
543              
544              
545             =item history_call
546              
547             You can use this callback to implement the standard bash
548             history command. This command supports:
549              
550             NUM display last N history items
551             (displays all history if N is omitted)
552             -c clear all history
553             -d NUM delete an item from the history
554              
555             Add it to your command set using something like this:
556              
557             "history" => { desc => "Prints the command history",
558             doc => "Specify a number to list the last N lines of history" .
559             "Pass -c to clear the command history, " .
560             "-d NUM to delete a single item\n",
561             args => "[-c] [-d] [number]",
562             meth => sub { shift->history_call(@_) },
563             },
564              
565             =cut
566              
567             sub history_call
568             {
569 0     0 1 0 my $self = shift;
570 0         0 my $parms = shift;
571 0         0 my $arg = shift;
572              
573             # clear history?
574 0 0 0     0 if($arg && $arg eq '-c') {
575 0         0 $self->{term}->clear_history();
576 0         0 return;
577             }
578 0 0 0     0 if($arg && $arg eq '-d') {
579 0 0       0 @_ or die "Need the indexes of the items to delete.\n";
580 0         0 for(@_) {
581 0 0       0 /^\d+$/ or die "'$_' needs to be numeric.\n";
582             # function is autoloaded so we can't use can('remove_history')
583             # to see if it exists. So, we'll eval it and pray...
584 0         0 eval { $self->{term}->remove_history($_); }
  0         0  
585             }
586 0         0 return;
587             }
588              
589             # number of lines to print (push maximum onto args if no arg supplied)
590 0         0 my $num = -1;
591 0 0 0     0 if($arg && $arg =~ /^(\d+)$/) {
592 0         0 $num = $1;
593 0         0 $arg = undef;
594             }
595 0 0       0 push @_, $arg if $arg;
596              
597 0 0       0 die "Unknown argument" . (@_==1?'':'s') . ": '" .
    0          
598             join("', '", @_) . "'\n" if @_;
599              
600 0 0       0 die "Your readline lib doesn't support history!\n"
601             unless $self->{term}->can('GetHistory');
602              
603             # argh, this has evolved badly... seems to work though.
604 0         0 my @history = $self->{term}->GetHistory();
605 0         0 my $where = @history;
606 0 0 0     0 $num = @history if $num == -1 || $num > @history;
607 0         0 @history = @history[@history-$num..$#history];
608 0 0       0 $where = $self->{term}->where_history()
609             if $self->{term}->can('where_history');
610 0         0 my $i = $where - @history;
611 0         0 for(@history) {
612 0         0 print "$i: $_\n";
613 0         0 $i += 1;
614             }
615             }
616              
617              
618             =back
619              
620             =head1 METHODS
621              
622             These are the routines that your application calls to create
623             and use a Term::GDBUI object.
624             Usually you simply call new() and then run() -- everything else
625             is handled automatically.
626             You only need to read this section if you wanted to do something out
627             of the ordinary.
628              
629             =over 4
630              
631             =item new Term::GDBUI(I>)
632              
633             Creates a new GDBUI object.
634              
635             It accepts the following named parameters:
636              
637             =over 3
638              
639             =item app
640              
641             The name of this application (will be passed to L).
642             Defaults to $0, the name of the current executable.
643              
644             =item term
645              
646             Usually Term::GDBUI uses its own Term::ReadLine object
647             (created with C). However, if
648             you can create a new Term::ReadLine object yourself and
649             supply it using the term argument.
650              
651             =item blank_repeats_cmd
652              
653             This tells Term::GDBUI what to do when the user enters a blank
654             line. Pass 0 (the default) to have it do nothing (like Bash),
655             or 1 to have it repeat the last command (like GDB).
656              
657             =item commands
658              
659             A hashref containing all the commands that GDBUI will respond to.
660             The format of this data structure can be found below in the
661             L documentation.
662             If you do not supply any commands to the constructor, you must call
663             the L method to provide at least a minimal command set before
664             using many of the following calls. You may add or delete commands or
665             even change the entire command set at any time.
666              
667             =item history_file
668              
669             If defined then the command history is saved to this file on exit.
670             It should probably specify a dotfile in the user's home directory.
671             Tilde expansion is performed, so something like
672             C<~/.myprog-history> is perfectly acceptable.
673              
674             =item history_max = 500
675              
676             This tells how many items to save to the history file.
677             The default is 500.
678              
679             Note that this parameter does not affect in-memory history. Term::GDBUI
680             makes no attemt to cull history so you're at the mercy
681             of the default of whatever ReadLine library you are using.
682             See L for one way to change this.
683              
684             =item disable_history_expansion
685              
686             Term::GDBUI supports the incredibly complex readline4 history expansion
687             (!! repeats last command, !$ is the last arg, etc).
688             It's turned on by default because it can be very useful.
689             If you want to disable it, pass C1>.
690              
691             =item keep_quotes
692              
693             Normally all unescaped, unnecessary quote marks are stripped.
694             If you specify C1>, however, they are preserved.
695             This is useful if your application uses quotes to delimit, say,
696             Perl-style strings.
697              
698             =item backslash_continues_command
699              
700             Normally commands don't respect backslash continuation. If you
701             pass backslash_continues_command=>1 to L, then whenever a line
702             ends with a backslash, Term::GDBUI will continue reading. The backslash
703             is replaced with a space, so
704             $ abc \
705             > def
706              
707             Will produce the command string 'abc def'.
708              
709             =item prompt
710              
711             This is the prompt that should be displayed for every request.
712             It can be changed at any time using the L method.
713             The default is S<<"$0> ">> (see L above).
714              
715             If you specify a code reference, then the coderef is executed and
716             its return value is set as the prompt. Two arguments are passed
717             to the coderef: the Term::GDBUI object, and the raw command.
718             The raw command is always "" unless you're using command completion,
719             where the raw command is the command line entered so far.
720              
721             For example, the following
722             line sets the prompt to "## > " where ## is the current number of history
723             items.
724              
725             $term->prompt(sub { $term->{term}->GetHistory() . " > " });
726              
727             If you specify an arrayref, then the first item is the normal prompt
728             and the second item is the prompt when the command is being continued.
729             For instance, this would emulate Bash's behavior ($ is the normal
730             prompt, but > is the prompt when continuing).
731              
732             $term->prompt(['$', '>']);
733              
734             Of course, you specify backslash_continues_command=>1 to to L to cause
735             commands to continue.
736              
737             And, of course, you can use an array of procs too.
738              
739             $term->prompt([sub {'$'}, sub {'<'}]);
740              
741             =item token_chars
742              
743             This argument specifies the characters that should be considered
744             tokens all by themselves. For instance, if I pass
745             token_chars=>'=', then 'ab=123' would be parsed to ('ab', '=', '123').
746             Without token_chars, 'ab=123' remains a single string.
747              
748             NOTE: you cannot change token_chars after the constructor has been
749             called! The regexps that use it are compiled once (m//o).
750             Also, until the Gnu Readline library can accept "=[]," without
751             diving into an endless loop, we will not tell history expansion
752             to use token_chars (it uses " \t\n()<>;&|" by default).
753              
754             =item display_summary_in_help
755              
756             Usually it's easier to have the command's summary (desc) printed first,
757             then follow it with the documentation (doc). However, if the doc
758             already contains its description (for instance, if you're reading it
759             from a podfile), you don't want the summary up there too. Pass 0
760             to prevent printing the desc above the doc. Defaults to 1.
761              
762             =back
763              
764             =cut
765              
766             sub new
767             {
768 1     1 1 28529 my $type = shift;
769 1         67 my %args = (
770             app => $0,
771             prompt => "$0> ",
772             commands => undef,
773             blank_repeats_cmd => 0,
774             backslash_continues_command => 0,
775             history_file => undef,
776             history_max => 500,
777             token_chars => '',
778             keep_quotes => 0,
779             debug_complete => 0,
780             disable_history_expansion => 0,
781             display_summary_in_help => 1,
782             @_
783             );
784              
785 1         5 my $self = {};
786 1         7 bless $self, $type;
787              
788 1         11 $self->{done} = 0;
789              
790             $self->{parser} = Text::Shellwords::Cursor->new(
791             token_chars => $args{token_chars},
792             keep_quotes => $args{keep_quotes},
793             debug => 0,
794 0     0   0 error => sub { shift; $self->error(@_); },
  0         0  
795 1         53 );
796              
797             # expand tildes in the history file
798 1 50       13 if($args{history_file}) {
799 0 0 0     0 $args{history_file} =~ s/^~([^\/]*)/$1?(getpwnam($1))[7]:
  0         0  
800             $ENV{HOME}||$ENV{LOGDIR}||(getpwuid($>))[7]/e;
801             }
802              
803 1         10 for(keys %args) {
804 13 100       29 next if $_ eq 'app'; # this param is not a member
805 12         26 $self->{$_} = $args{$_};
806             }
807              
808 1   33     34 $self->{term} ||= new Term::ReadLine($args{'app'});
809 1         10 $self->{term}->MinLine(0); # manually call AddHistory
810              
811 1         7 my $attrs = $self->{term}->Attribs;
812             # there appear to be catastrophic bugs with history_word_delimiters
813             # it goes into an infinite loop when =,[] are in token_chars
814             # $attrs->{history_word_delimiters} = " \t\n".$self->{token_chars};
815 1     0   11 $attrs->{completion_function} = sub { completion_function($self, @_); };
  0         0  
816              
817 1   50     5 $self->{OUT} = $self->{term}->OUT || \*STDOUT;
818 1         15 $self->{prevcmd} = ""; # cmd to run again if user hits return
819              
820 1         10 return $self;
821             }
822              
823              
824             =item process_a_cmd()
825              
826             Prompts for and returns the results from a single command.
827             Returns undef if no command was called.
828              
829             =cut
830              
831             sub process_a_cmd
832             {
833 0     0 1   my $self = shift;
834              
835 0           $self->{completeline} = "";
836 0           my $OUT = $self->{'OUT'};
837              
838 0           my $rawline = "";
839 0           for(;;) {
840 0           my $prompt = $self->prompt();
841 0 0         $prompt = $prompt->[length $rawline ? 1 : 0] if ref $prompt eq 'ARRAY';
    0          
842 0 0         $prompt = $prompt->($self, $rawline) if ref $prompt eq 'CODE';
843 0           my $newline = $self->{term}->readline($prompt);
844              
845             # EOF exits
846 0 0         unless(defined $newline) {
847 0           print $OUT "\n";
848 0           $self->exit_requested(1);
849 0           return undef;
850             }
851              
852 0           my $continued = ($newline =~ s/\\$//);
853 0 0         $rawline .= (length $rawline ? " " : "") . $newline;
854 0 0 0       last unless $self->{backslash_continues_command} && $continued;
855             }
856              
857             # is it a blank line?
858 0 0         if($rawline =~ /^\s*$/) {
859 0           $rawline = $self->blank_line();
860 0 0 0       return unless defined $rawline && $rawline !~ /^\s*$/;
861             }
862              
863 0           my $tokens;
864 0           my $expcode = 0;
865 0 0 0       if($rawline =~ /^\s*[!^]/ && !$self->{disable_history_expansion}) {
866             # check to see if this exact command is in the history.
867             # if so, user used history completion to enter it and therefore we
868             # won't subject it to history substitution.
869 0           my $match;
870 0 0         if($self->{term}->can('GetHistory')) {
871 0           my @history = $self->{term}->GetHistory();
872             # reformat line as it will appear in history
873 0           ($tokens) = $self->{parser}->parse_line(substr($rawline,1), messages=>1);
874 0 0         if($tokens) {
875 0           my $rawl = $self->{parser}->join_line($tokens);
876 0           $match = grep { $_ eq $rawl } @history;
  0            
877             }
878             }
879              
880 0 0         if(!$match) {
881 0           $tokens = undef; # need to re-parse the expanded line
882             # otherwise, we subject the line to history expansion
883             # $self->{term}->can('history_expand') returns false???
884             # it's probably autoloaded dammit -- dunno what to do about that.
885 0           ($expcode, $rawline) = $self->{term}->history_expand($rawline);
886 0 0         if($expcode == -1) {
887 0           $self->error($rawline."\n");
888 0           return undef;
889             }
890             }
891             }
892              
893 0           my $retval = undef;
894 0           my $str = $rawline;
895 0           my $save_to_history = 1;
896              
897             # parse the line unless it was already parsed as part of history expansion
898 0 0         ($tokens) = $self->{parser}->parse_line($rawline, messages=>1) unless $tokens;
899              
900 0 0         if(defined $tokens) {
901 0           $str = $self->{parser}->join_line($tokens);
902 0 0         if($expcode == 2) {
903             # user did an expansion that asked to be printed only
904 0           print $OUT "$str\n";
905             } else {
906 0 0         print $OUT "$str\n" if $expcode == 1;
907              
908 0           my($cset, $cmd, $cname, $args) = $self->get_deep_command($self->commands(), $tokens);
909              
910             # this is a subset of the cmpl data structure
911 0           my $parms = {
912             cset => $cset,
913             cmd => $cmd,
914             cname => $cname,
915             args => $args,
916             tokens => $tokens,
917             rawline => $rawline,
918             };
919              
920 0           $retval = $self->call_command($parms);
921              
922 0 0         if(exists $cmd->{exclude_from_history}) {
923 0           $save_to_history = 0;
924             }
925             }
926             }
927              
928             # Add to history unless it's a dupe of the previous command.
929 0 0 0       if($save_to_history && $str ne $self->{prevcmd}) {
930 0           $self->{term}->addhistory($str);
931             }
932 0           $self->{prevcmd} = $str;
933              
934 0           return $retval;
935             }
936              
937              
938             =item run()
939              
940             The main loop. Processes all commands until someone calls
941             C(true)>.
942              
943             =cut
944              
945             sub run
946             {
947 0     0 1   my $self = shift;
948              
949 0           $self->load_history();
950              
951 0           while(!$self->{done}) {
952 0           $self->process_a_cmd();
953             }
954              
955 0           $self->save_history();
956             }
957              
958              
959             # This is a utility function that implements a getter/setter.
960             # Pass the field to modify for $self, and the new value for that
961             # field (if any) in $new.
962              
963             sub getset
964             {
965 0     0 0   my $self = shift;
966 0           my $field = shift;
967 0           my $new = shift; # optional
968              
969 0           my $old = $self->{$field};
970 0 0         $self->{$field} = $new if defined $new;
971 0           return $old;
972             }
973              
974              
975             =item prompt(newprompt)
976              
977             If supplied with an argument, this method sets the command-line prompt.
978             Returns the old prompt.
979              
980             =cut
981              
982 0     0 1   sub prompt { return shift->getset('prompt', shift); }
983              
984              
985             =item commands(newcmds)
986              
987             If supplied with an argument, it sets the current command set.
988             This can be used to change the command set at any time.
989             Returns the old command set.
990              
991             =cut
992              
993 0     0 1   sub commands { return shift->getset('commands', shift); }
994              
995              
996             =item add_commands(newcmds)
997              
998             Takes a command set as its first argument.
999             Adds all the commands in it the current command set.
1000             It silently replaces any commands that have the same name.
1001              
1002             =cut
1003              
1004             sub add_commands
1005             {
1006 0     0 1   my $self = shift;
1007 0           my $cmds = shift;
1008              
1009 0   0       my $cset = $self->commands() || {};
1010 0           for (keys %$cmds) {
1011 0           $cset->{$_} = $cmds->{$_};
1012             }
1013             }
1014              
1015             =item exit_requested(exitflag)
1016              
1017             If supplied with an argument, sets Term::GDBUI's finished flag
1018             to the argument (1=exit, 0=don't exit). So, to get the
1019             interpreter to exit at the end of processing the current
1020             command, call C<$self-Eexit_requested(1)>. To cancel an exit
1021             request before the command is finished, C<$self-Eexit_requested(0)>.
1022             Returns the old state of the flag.
1023              
1024             =cut
1025              
1026 0     0 1   sub exit_requested { return shift->getset('done', shift); }
1027              
1028             =item get_cname(cname)
1029              
1030             This is a tiny utility function that turns the cname (array ref
1031             of names for this command as returned by L) into
1032             a human-readable string.
1033             This function exists only to ensure that we do this consistently.
1034              
1035             =cut
1036              
1037             sub get_cname
1038             {
1039 0     0 1   my $self = shift;
1040 0           my $cname = shift;
1041              
1042 0           return join(" ", @$cname);
1043             }
1044              
1045              
1046              
1047             =head1 OVERRIDES
1048              
1049             These are routines that probably already do the right thing.
1050             If not, however, they are designed to be overridden.
1051              
1052             =item blank_line()
1053              
1054             This routine is called when the user inputs a blank line.
1055             It returns a string specifying the command to run or
1056             undef if nothing should happen.
1057              
1058             By default, GDBUI simply presents another command line. Pass
1059             C1> to L to get GDBUI to repeat the previous
1060             command. Override this method to supply your own behavior.
1061              
1062             =cut
1063              
1064             sub blank_line
1065             {
1066 0     0 1   my $self = shift;
1067              
1068 0 0         if($self->{blank_repeats_cmd}) {
1069 0           my $OUT = $self->{OUT};
1070 0           print $OUT $self->{prevcmd}, "\n";
1071 0           return $self->{prevcmd};
1072             }
1073              
1074 0           return undef;
1075             }
1076              
1077              
1078             =item error(msg)
1079              
1080             Called when an error occurrs. By default, the routine simply
1081             prints the msg to stderr. Override it to change this behavior.
1082             It takes any number of arguments, cocatenates them together and
1083             prints them to stderr.
1084              
1085             =cut
1086              
1087             sub error
1088             {
1089 0     0 1   my $self = shift;
1090 0           print STDERR @_;
1091             }
1092              
1093              
1094              
1095             =head1 WRITING A COMPLETION ROUTINE
1096              
1097             Term::ReadLine makes writing a completion routine a
1098             notoriously difficult task.
1099             Term::GDBUI goes out of its way to make it as easy
1100             as possible. The best way to write a completion routine
1101             is to start with one that already does something similar to
1102             what you want (see the L section for the completion
1103             routines that come with GDBUI).
1104              
1105             Your routine returns either an arrayref of possible completions
1106             or undef if an error prevented any completions from being generated.
1107             Return an empty array if there are simply no applicable competions.
1108             Be careful; the distinction between no completions and an error
1109             can be significant.
1110              
1111             Your routine takes two arguments: a reference to the GDBUI
1112             object and cmpl, a data structure that contains all the information you need
1113             to calculate the completions. Set $term->{debug_complete}=5
1114             to see the contents of cmpl:
1115              
1116             =over 3
1117              
1118             =item str
1119              
1120             The exact string that needs completion. Often, for simple completions,
1121             you don't need anything more than this.
1122              
1123             NOTE: str does I respect token_chars! It is supplied unchanged
1124             from Readline and so uses whatever tokenizing it implements.
1125             Unfortunately, if you've changed token_chars, this will often
1126             be different from how Term::GDBUI would tokenize the same string.
1127              
1128             =item cset
1129              
1130             Command set for the deepest command found (see L).
1131             If no command was found then cset is set to the topmost command
1132             set ($self->commands()).
1133              
1134             =item cmd
1135              
1136             The command hash for deepest command found or
1137             undef if no command was found (see L).
1138             cset is the command set that contains cmd.
1139              
1140             =item cname
1141              
1142             The full name of deepest command found as an array of tokens
1143             (see L). Use L to convert
1144             this into a human-readable string.
1145              
1146             =item args
1147              
1148             The arguments (as a list of tokens) that should be passed to the command
1149             (see L). Valid only if cmd is non-null. Undef if no
1150             args were passed.
1151              
1152             =item argno
1153              
1154             The index of the argument (in args) containing the cursor.
1155             If the user is trying to complete on the command name, then
1156             argno is negative (because the cursor comes before the arguments).
1157              
1158             =item tokens
1159              
1160             The tokenized command-line.
1161              
1162             =item tokno
1163              
1164             The index of the token containing the cursor.
1165              
1166             =item tokoff
1167              
1168             The character offset of the cursor in the token.
1169              
1170             For instance, if the cursor is on the first character of the
1171             third token, tokno will be 2 and tokoff will be 0.
1172              
1173             =item twice
1174              
1175             True if user has hit tab twice in a row. This usually means that you
1176             should print a message explaining the possible completions.
1177              
1178             If you return your completions as a list, then $twice is handled
1179             for you automatically. You could use it, for instance, to display
1180             an error message (using L) telling why no completions
1181             could be found.
1182              
1183             =item rawline
1184              
1185             The command line as a string, exactly as entered by the user.
1186              
1187             =item rawstart
1188              
1189             The character position of the cursor in rawline.
1190              
1191             =back
1192              
1193             The following are utility routines that your completion function
1194             can call.
1195              
1196             =item completemsg(msg)
1197              
1198             your completion routine should call this to display text onscreen
1199             so that the command line being completed doesn't get messed up.
1200             If your completion routine prints text without calling completemsg,
1201             the cursor will no longer be displayed in the correct position.
1202              
1203             $self->completemsg("You cannot complete here!\n");
1204              
1205             =cut
1206              
1207             sub completemsg
1208             {
1209 0     0 1   my $self = shift;
1210 0           my $msg = shift;
1211              
1212 0           my $OUT = $self->{OUT};
1213 0           print $OUT $msg;
1214 0           $self->{term}->rl_on_new_line();
1215             }
1216              
1217              
1218             =item suppress_completion_append_character()
1219              
1220             When the ReadLine library finds a unique match among the list that
1221             you returned, it automatically appends a space. Normally this is
1222             what you want (i.e. when completing a command name, in help, etc.)
1223             However, if you're navigating the filesystem, this is definitely
1224             not desirable (picture having to hit backspace after completing
1225             each directory).
1226              
1227             Your completion function needs to call this routine every time it
1228             runs if it doesn't want a space automatically appended to the
1229             completions that it returns.
1230              
1231             =cut
1232              
1233             sub suppress_completion_append_character
1234             {
1235 0     0 1   shift->{term}->Attribs->{completion_suppress_append} = 1;
1236             }
1237              
1238             =item suppress_completion_escape()
1239              
1240             Normally everything returned by your completion routine
1241             is escaped so that it doesn't get destroyed by shell metacharacter
1242             interpretation (quotes, backslashes, etc). To avoid escaping
1243             twice (disastrous), a completion routine that does its own escaping
1244             (perhaps using Lparse_escape)
1245             must call suppress_completion_escape every time is called.
1246              
1247             =cut
1248              
1249             sub suppress_completion_escape
1250             {
1251 0     0 1   shift->{suppress_completion_escape} = 1;
1252             }
1253              
1254              
1255             =item force_to_string(cmpl, commmpletions, default_quote)
1256              
1257             If all the completions returned by your completion routine should be
1258             enclosed in single or double quotes, call force_to_string on them.
1259             You will most likely need this routine if L is 1.
1260             This is useful when completing a construct that you know must
1261             always be quoted.
1262              
1263             force_to_string surrounds all completions with the quotes supplied by the user
1264             or, if the user didn't supply any quotes, the quote passed in default_quote.
1265             If the programmer didn't supply a default_quote and the user didn't start
1266             the token with an open quote, then force_to_string won't change anything.
1267              
1268             Here's how to use it to force strings on two possible completions,
1269             aaa and bbb. If the user doesn't supply any quotes, the completions
1270             will be surrounded by double quotes.
1271              
1272             args => sub { shift->force_to_string(@_,['aaa','bbb'],'"') },
1273              
1274             Calling force_to_string escapes your completions (unless your callback
1275             calls suppress_completion_escape itself), then calls
1276             suppress_completion_escape to ensure the final quote isn't mangled.
1277              
1278             =cut
1279              
1280             sub force_to_string
1281             {
1282 0     0 1   my $self = shift;
1283 0           my $cmpl = shift;
1284 0           my $results = shift;
1285 0           my $bq = shift; # optional: this is the default quote to use if none
1286              
1287 0           my $fq = $bq;
1288 0           my $try = substr($cmpl->{rawline}, $cmpl->{rawstart}-1, 1);
1289 0 0 0       if($try eq '"' || $try eq "'") {
1290 0           $fq = '';
1291 0           $bq = $try;
1292             }
1293              
1294 0 0         if($bq) {
1295 0 0         $self->{parser}->parse_escape($results) unless $self->{suppress_completion_escape};
1296 0           for(@$results) {
1297 0           $_ = "$fq$_$bq";
1298             }
1299 0           $self->suppress_completion_escape();
1300             }
1301              
1302 0           return $results;
1303             }
1304              
1305             =head1 INTERNALS
1306              
1307             These commands are internal to GDBUI.
1308             They are documented here only for completeness -- you
1309             should never need to call them.
1310              
1311             =item get_deep_command
1312              
1313             Looks up the supplied command line in a command hash.
1314             Follows all synonyms and subcommands.
1315             Returns undef if the command could not be found.
1316              
1317             my($cset, $cmd, $cname, $args) =
1318             $self->get_deep_command($self->commands(), $tokens);
1319              
1320             This call takes two arguments:
1321              
1322             =over 3
1323              
1324             =item cset
1325              
1326             This is the command set to use. Pass $self->commands()
1327             unless you know exactly what you're doing.
1328              
1329             =item tokens
1330              
1331             This is the command line that the command should be read from.
1332             It is a reference to an array that has already been split
1333             on whitespace using L.
1334              
1335             =back
1336              
1337             and it returns a list of 4 values:
1338              
1339             =over 3
1340              
1341             =item 1.
1342              
1343             cset: the deepest command set found. Always returned.
1344              
1345             =item 2.
1346              
1347             cmd: the command hash for the command. Undef if no command was found.
1348              
1349             =item 3.
1350              
1351             cname: the full name of the command. This is an array of tokens,
1352             i.e. ('show', 'info'). Returns as deep as it could find commands
1353             even if the final command was not found.
1354              
1355             =item 4.
1356              
1357             args: the command's arguments (all remaining tokens after the
1358             command is found).
1359              
1360             =back
1361              
1362             =cut
1363              
1364             sub get_deep_command
1365             {
1366 0     0 1   my $self = shift;
1367 0           my $cset = shift;
1368 0           my $tokens = shift;
1369 0   0       my $curtok = shift || 0; # points to the command name
1370              
1371             #print "DBG get_deep_cmd: $#$tokens tokens: '" . join("', '", @$tokens) . "'\n";
1372             #print "DBG cset: (" . join(", ", keys %$cset) . ")\n";
1373              
1374 0           my $name = $tokens->[$curtok];
1375              
1376             # loop through all synonyms to find the actual command
1377 0   0       while(exists($cset->{$name}) && exists($cset->{$name}->{'syn'})) {
1378 0           $name = $cset->{$name}->{'syn'};
1379             }
1380              
1381 0           my $cmd = $cset->{$name};
1382              
1383             # update the tokens with the actual name of this command
1384 0           $tokens->[$curtok] = $name;
1385              
1386             # should we recurse into subcommands?
1387             #print "$cmd " . exists($cmd->{'subcmds'}) . " (" . join(",", keys %$cmd) . ") $curtok < $#$tokens\n";
1388 0 0 0       if($cmd && exists($cmd->{cmds}) && $curtok < $#$tokens) {
      0        
1389             #print "doing subcmd\n";
1390 0           my $subname = $tokens->[$curtok+1];
1391 0           my $subcmds = $cmd->{cmds};
1392 0           return $self->get_deep_command($subcmds, $tokens, $curtok+1);
1393             }
1394              
1395             #print "DBG splitting (" . join(",",@$tokens) . ") at curtok=$curtok\n";
1396              
1397             # split deep command name and its arguments into separate lists
1398 0           my @cname = @$tokens;
1399 0 0         my @args = ($#cname > $curtok ? splice(@cname, $curtok+1) : ());
1400              
1401             #print "DBG tokens (" . join(",",@$tokens) . ")\n";
1402             #print "DBG cname (" . join(",",@cname) . ")\n";
1403             #print "DBG args (" . join(",",@args) . ")\n";
1404              
1405 0           return ($cset, $cmd, \@cname, \@args);
1406             }
1407              
1408              
1409             =item get_cset_completions(cset)
1410              
1411             Returns a list of commands from the passed command set that are suitable
1412             for completing.
1413              
1414             =cut
1415              
1416             sub get_cset_completions
1417             {
1418 0     0 1   my $self = shift;
1419 0           my $cset = shift;
1420              
1421             # return all commands that aren't exluded from the completion
1422             # also exclude the default command ''.
1423 0 0         my @c = grep {$_ ne '' && !exists $cset->{$_}->{exclude_from_completion}} keys(%$cset);
  0            
1424              
1425 0           return \@c;
1426             }
1427              
1428              
1429             =item call_args
1430              
1431             Given a command set, does the correct thing at this stage in the
1432             completion (a surprisingly nontrivial task thanks to GDBUI's
1433             flexibility). Called by complete().
1434              
1435             =cut
1436              
1437             sub call_args
1438             {
1439 0     0 1   my $self = shift;
1440 0           my $cmpl = shift;
1441              
1442 0           my $cmd = $cmpl->{cmd};
1443              
1444 0           my $retval;
1445 0 0         if(exists($cmd->{args})) {
1446 0 0         if(ref($cmd->{args}) eq 'CODE') {
    0          
    0          
1447 0           $retval = eval { &{$cmd->{args}}($self, $cmpl) };
  0            
  0            
1448 0 0         $self->completemsg($@) if $@;
1449             } elsif(ref($cmd->{args}) eq 'ARRAY') {
1450             # each element in array is a string describing corresponding argument
1451 0           my $args = $cmd->{args};
1452 0           my $argno = $cmpl->{argno};
1453             # repeat last arg indefinitely (use maxargs to stop)
1454 0 0         $argno = $#$args if $#$args < $argno;
1455 0           my $arg = $args->[$argno];
1456 0 0         if(defined $arg) {
1457 0 0         if(ref($arg) eq 'CODE') {
    0          
1458             # it's a routine to call for this particular arg
1459 0           $retval = eval { &$arg($self, $cmpl) };
  0            
1460 0 0         $self->completemsg($@) if $@;
1461             } elsif(ref($arg) eq 'ARRAY') {
1462             # it's an array of possible completions
1463 0           $retval = @$arg;
1464             } else {
1465             # it's a string reiminder of what this arg is meant to be
1466 0 0         $self->completemsg("$arg\n") if $cmpl->{twice};
1467             }
1468             }
1469             } elsif(ref($cmd->{args}) eq 'HASH') {
1470             # not supported yet! (if ever...)
1471             } else {
1472             # this must be a string describing all arguments.
1473 0 0         $self->completemsg($cmd->{args} . "\n") if $cmpl->{twice};
1474             }
1475             }
1476              
1477 0           return $retval;
1478             }
1479              
1480             =item complete
1481              
1482             This routine figures out the command set of the completion routine
1483             that needs to be called, then calls call_args(). It is called
1484             by completion_function.
1485              
1486             You should override this routine if your application has custom
1487             completion needs (like non-trivial tokenizing, where you'll need
1488             to modify the cmpl data structure). If you override
1489             this routine, you will probably need to override
1490             L as well.
1491              
1492             =cut
1493              
1494             sub complete
1495             {
1496 0     0 1   my $self = shift;
1497 0           my $cmpl = shift;
1498              
1499 0           my $cset = $cmpl->{cset};
1500 0           my $cmd = $cmpl->{cmd};
1501              
1502 0           my $cr;
1503 0 0         if($cmpl->{tokno} < @{$cmpl->{cname}}) {
  0            
1504             # if we're still in the command, return possible command completions
1505             # make sure to still call the default arg handler of course
1506 0           $cr = $self->get_cset_completions($cset);
1507             # fix suggested by Erick Calder
1508 0 0         $cr = [ grep {/^$cmpl->{str}/ && $_} @$cr ];
  0            
1509             }
1510              
1511 0 0 0       if($cr || !defined $cmd) {
1512             # call default argument handler if it exists
1513 0 0         if(exists $cset->{''}) {
1514 0           my %c2 = %$cmpl;
1515 0           $c2{cmd} = $cset->{''};
1516 0           my $r2 = $self->call_args(\%c2);
1517 0 0         push @$cr, @$r2 if $r2;
1518             }
1519 0           return $cr;
1520             }
1521              
1522             # don't complete if user has gone past max # of args
1523 0 0 0       return () if exists($cmd->{maxargs}) && $cmpl->{argno} >= $cmd->{maxargs};
1524              
1525             # everything checks out -- call the command's argument handler
1526 0           return $self->call_args($cmpl);
1527             }
1528              
1529              
1530             =item completion_function
1531              
1532             This is the entrypoint to the ReadLine completion callback.
1533             It sets up a bunch of data, then calls L to calculate
1534             the actual completion.
1535              
1536             To watch and debug the completion process, you can set $self->{debug_complete}
1537             to 2 (print tokenizing), 3 (print tokenizing and results) or 4 (print
1538             everything including the cmpl data structure).
1539              
1540             Youu should never need to call or override this function. If
1541             you do (but, trust me, you don't), set
1542             $self->{term}->Attribs->{completion_function} to point to your own
1543             routine.
1544              
1545             See the L documentation for a description of the arguments.
1546              
1547             =cut
1548              
1549             sub completion_function
1550             {
1551 0     0 1   my $self = shift;
1552 0           my $text = shift; # the word directly to the left of the cursor
1553 0           my $line = shift; # the entire line
1554 0           my $start = shift; # the position in the line of the beginning of $text
1555              
1556 0           my $cursor = $start + length($text);
1557              
1558             # reset the suppress_append flag
1559             # completion routine must set it every time it's called
1560 0           $self->{term}->Attribs->{completion_suppress_append} = 0;
1561 0           $self->{suppress_completion_escape} = 0;
1562              
1563             # Twice is true if the user has hit tab twice on the same string
1564 0           my $twice = ($self->{completeline} eq $line);
1565 0           $self->{completeline} = $line;
1566              
1567 0           my($tokens, $tokno, $tokoff) = $self->{parser}->parse_line($line,
1568             messages=>0, cursorpos=>$cursor, fixclosequote=>1);
1569 0 0         return unless defined($tokens);
1570              
1571             # this just prints a whole bunch of completion/parsing debugging info
1572 0 0         if($self->{debug_complete} >= 1) {
1573 0           print "\ntext='$text', line='$line', start=$start, cursor=$cursor";
1574              
1575 0 0         print "\ntokens=(", join(", ", @$tokens), ") tokno=" .
    0          
1576             (defined($tokno) ? $tokno : 'undef') . " tokoff=" .
1577             (defined($tokoff) ? $tokoff : 'undef');
1578              
1579 0           print "\n";
1580 0           my $str = " ";
1581 0           print "<";
1582 0           my $i = 0;
1583 0           for(@$tokens) {
1584 0           my $s = (" " x length($_)) . " ";
1585 0 0         substr($s,$tokoff,1) = '^' if $i eq $tokno;
1586 0           $str .= $s;
1587 0           print $_;
1588 0           print ">";
1589 0 0         $str .= " ", print ", <" if $i != $#$tokens;
1590 0           $i += 1;
1591             }
1592 0           print "\n$str\n";
1593 0           $self->{term}->rl_on_new_line();
1594             }
1595              
1596 0           my $str = $text;
1597              
1598 0           my($cset, $cmd, $cname, $args) = $self->get_deep_command($self->commands(), $tokens);
1599              
1600             # this structure hopefully contains everything you'll ever
1601             # need to easily compute a match.
1602 0           my $cmpl = {
1603             str => $str, # the exact string that needs completion
1604             # (usually, you don't need anything more than this)
1605              
1606             cset => $cset, # cset of the deepest command found
1607             cmd => $cmd, # the deepest command or undef
1608             cname => $cname, # full name of deepest command
1609             args => $args, # anything that was determined to be an argument.
1610             argno => $tokno - @$cname, # the argument containing the cursor
1611              
1612             tokens => $tokens, # tokenized command-line (arrayref).
1613             tokno => $tokno, # the index of the token containing the cursor
1614             tokoff => $tokoff, # the character offset of the cursor in $tokno.
1615             twice => $twice, # true if user has hit tab twice in a row
1616              
1617             rawline => $line, # pre-tokenized command line
1618             rawstart => $start, # position in rawline of the start of str
1619             rawcursor => $cursor, # position in rawline of the cursor (end of str)
1620             };
1621              
1622 0 0         if($self->{debug_complete} >= 3) {
1623 0           print "tokens=(" . join(",", @$tokens) . ") tokno=$tokno tokoff=$tokoff str=$str twice=$twice\n";
1624 0 0         print "cset=$cset cmd=" . (defined($cmd) ? $cmd : "(undef)") .
1625             " cname=(" . join(",", @$cname) . ") args=(" . join(",", @$args) . ") argno=".$cmpl->{argno}."\n";
1626 0           print "rawline='$line' rawstart=$start rawcursor=$cursor\n";
1627             }
1628              
1629 0           my $retval = $self->complete($cmpl);
1630 0 0         $retval = [] unless defined($retval);
1631 0 0         die "User completion routine didn't return an arrayref: $retval\n"
1632             unless ref($retval) eq 'ARRAY';
1633              
1634 0 0         if($self->{debug_complete} >= 2) {
1635 0           print "returning (", join(", ", @$retval), ")\n";
1636             }
1637              
1638             # escape the completions so they're valid on the command line
1639 0 0         $self->{parser}->parse_escape($retval) unless $self->{suppress_completion_escape};
1640              
1641 0           return @$retval;
1642             }
1643              
1644              
1645             # Converts a field name into a text string.
1646             # All fields can be code, if so, then they're called to return string value.
1647             # You need to ensure that the field exists before calling this routine.
1648              
1649             sub get_field
1650             {
1651 0     0 0   my $self = shift;
1652 0           my $cmd = shift;
1653 0           my $field = shift;
1654 0           my $args = shift;
1655              
1656 0           my $val = $cmd->{$field};
1657              
1658 0 0         if(ref($val) eq 'CODE') {
1659 0           $val = eval { &$val($self, $cmd, @$args) };
  0            
1660 0 0         $self->error($@) if $@;
1661             }
1662              
1663 0           return $val;
1664             }
1665              
1666              
1667             =item get_cmd_summary(tokens, cset)
1668              
1669             Prints a one-line summary for the given command.
1670             Uses self->commands() if cset is not specified.
1671              
1672             =cut
1673              
1674             sub get_cmd_summary
1675             {
1676 0     0 1   my $self = shift;
1677 0           my $tokens = shift;
1678 0   0       my $topcset = shift || $self->commands();
1679              
1680             # print "DBG print_cmd_summary: cmd=$cmd args=(" . join(", ", @$args), ")\n";
1681              
1682 0           my($cset, $cmd, $cname, $args) = $self->get_deep_command($topcset, $tokens);
1683              
1684 0           my $desc;
1685 0 0         if(!$cmd) {
1686 0 0         if(exists $topcset->{''}) {
1687 0           $cmd = $topcset->{''};
1688             } else {
1689 0           return $self->get_cname($cname) . " doesn't exist.\n";
1690             }
1691             }
1692              
1693 0   0       $desc = $self->get_field($cmd, 'desc', $args) || "(no description)";
1694 0           return sprintf("%20s -- $desc\n", $self->get_cname($cname));
1695             }
1696              
1697             =item get_cmd_help(tokens, cset)
1698              
1699             Prints the full help text for the given command.
1700             Uses self->commands() if cset is not specified.
1701              
1702             =cut
1703              
1704             sub get_cmd_help
1705             {
1706 0     0 1   my $self = shift;
1707 0           my $tokens = shift;
1708 0   0       my $topcset = shift || $self->commands();
1709              
1710 0           my $str = "";
1711              
1712             # print "DBG print_cmd_help: cmd=$cmd args=(" . join(", ", @$args), ")\n";
1713              
1714 0           my($cset, $cmd, $cname, $args) = $self->get_deep_command($topcset, $tokens);
1715 0 0         if(!$cmd) {
1716 0 0         if(exists $topcset->{''}) {
1717 0           $cmd = $topcset->{''};
1718             } else {
1719 0           return $self->get_cname($cname) . " doesn't exist.\n";
1720             }
1721             }
1722              
1723 0 0         if($self->{display_summary_in_help}) {
1724 0 0         if(exists($cmd->{desc})) {
1725 0           $str .= $self->get_cname($cname).": ".$self->get_field($cmd,'desc',$args)."\n";
1726             } else {
1727 0           $str .= "No description for " . $self->get_cname($cname) . "\n";
1728             }
1729             }
1730              
1731 0 0         if(exists($cmd->{doc})) {
    0          
1732 0           $str .= $self->get_field($cmd, 'doc',
1733             [$self->get_cname($cname), @$args]);
1734             } elsif(exists($cmd->{cmds})) {
1735 0           $str .= $self->get_all_cmd_summaries($cmd->{cmds});
1736             } else {
1737             # no data -- do nothing
1738             }
1739              
1740 0           return $str;
1741             }
1742              
1743              
1744             =item get_category_summary(name, cats)
1745              
1746             Prints a one-line summary for the named category
1747             in the category hash specified in cats.
1748              
1749             =cut
1750              
1751             sub get_category_summary
1752             {
1753 0     0 1   my $self = shift;
1754 0           my $name = shift;
1755 0           my $cat = shift;
1756              
1757 0   0       my $title = $cat->{desc} || "(no description)";
1758 0           return sprintf("%20s -- $title\n", $name);
1759             }
1760              
1761             =item get_category_help(cat, cset)
1762              
1763             Returns a summary of the commands listed in cat.
1764             You must pass the command set that contains those commands in cset.
1765              
1766             =cut
1767              
1768             sub get_category_help
1769             {
1770 0     0 1   my $self = shift;
1771 0           my $cat = shift;
1772 0           my $cset = shift;
1773              
1774 0           my $str .= "\n" . $cat->{desc} . "\n\n";
1775 0           for my $name (@{$cat->{cmds}}) {
  0            
1776 0           my @line = split /\s+/, $name;
1777 0           $str .= $self->get_cmd_summary(\@line, $cset);
1778             }
1779 0           $str .= "\n";
1780              
1781 0           return $str;
1782             }
1783              
1784              
1785             =item get_all_cmd_summaries(cset)
1786              
1787             Pass it a command set, and it will return a string containing
1788             the summaries for each command in the set.
1789              
1790             =cut
1791              
1792             sub get_all_cmd_summaries
1793             {
1794 0     0 1   my $self = shift;
1795 0           my $cset = shift;
1796              
1797 0           my $str = "";
1798              
1799 0           for(sort keys(%$cset)) {
1800             # we now exclude synonyms from the command summaries.
1801             # hopefully this is the right thing to do...?
1802 0 0         next if exists $cset->{$_}->{syn};
1803             # don't show the default command in any summaries
1804 0 0         next if $_ eq '';
1805              
1806 0           $str .= $self->get_cmd_summary([$_], $cset);
1807             }
1808              
1809 0           return $str;
1810             }
1811              
1812             =item load_history()
1813              
1814             If $self->{history_file} is set (see L), this will load all
1815             history from that file. Called by L on startup. If you
1816             don't use run, you will need to call this command manually.
1817              
1818             =cut
1819              
1820             sub load_history
1821             {
1822 0     0 1   my $self = shift;
1823              
1824 0 0 0       return unless $self->{history_file} && $self->{history_max} > 0;
1825              
1826 0 0         if(open HIST, '<'.$self->{history_file}) {
1827 0           while() {
1828 0           chomp();
1829 0 0         next unless /\S/;
1830 0           $self->{term}->addhistory($_);
1831             }
1832 0           close HIST;
1833             }
1834             }
1835              
1836             =item save_history()
1837              
1838             If $self->{history_file} is set (see L), this will save all
1839             history to that file. Called by L on shutdown. If you
1840             don't use run, you will need to call this command manually.
1841              
1842             The history routines don't use ReadHistory and WriteHistory so they
1843             can be used even if other ReadLine libs are being used. save_history
1844             requires that the ReadLine lib supply a GetHistory call.
1845              
1846             =cut
1847              
1848             sub save_history
1849             {
1850 0     0 1   my $self = shift;
1851              
1852 0 0 0       return unless $self->{history_file} && $self->{history_max} > 0;
1853 0 0         return unless $self->{term}->can('GetHistory');
1854              
1855 0 0         if(open HIST, '>'.$self->{history_file}) {
1856 0           local $, = "\n";
1857 0           my @list = $self->{term}->GetHistory();
1858 0 0         if(@list) {
1859 0           my $max = $#list;
1860 0 0         $max = $self->{history_max}-1 if $self->{history_max}-1 < $max;
1861 0           print HIST @list[$#list-$max..$#list];
1862 0           print HIST "\n";
1863             }
1864 0           close HIST;
1865             } else {
1866 0           $self->error("Could not open ".$self->{history_file}." for writing $!\n");
1867             }
1868             }
1869              
1870             =item call_command(parms)
1871              
1872             Executes a command and returns the result. It takes a single
1873             argument: the parms data structure.
1874              
1875             parms is a subset of the cmpl data structure (see the L
1876             routine for more). Briefly, it contains:
1877             cset, cmd, cname, args (see L),
1878             tokens and rawline (the tokenized and untokenized command lines).
1879             See L for full descriptions of these fields.
1880              
1881             This call should be overridden if you have exotic command
1882             processing needs. If you override this routine, you will probably
1883             need to override the L routine too.
1884              
1885             =cut
1886              
1887              
1888             # This is the low-level version of call_command. It does nothing but call.
1889             # Use call_command -- it's much smarter.
1890              
1891             sub call_cmd
1892             {
1893 0     0 0   my $self = shift;
1894 0           my $parms = shift;
1895              
1896 0           my $cmd = $parms->{cmd};
1897 0           my $OUT = $self->{OUT};
1898              
1899 0           my $retval = undef;
1900 0 0         if(exists $cmd->{meth}) {
    0          
1901             # if meth is a code ref, call it, else it's a string, print it.
1902 0 0         if(ref($cmd->{meth}) eq 'CODE') {
1903 0           $retval = eval { &{$cmd->{meth}}($self, $parms, @{$parms->{args}}) };
  0            
  0            
  0            
1904 0 0         $self->error($@) if $@;
1905             } else {
1906 0           print $OUT $cmd->{meth};
1907             }
1908             } elsif(exists $cmd->{proc}) {
1909             # if proc is a code ref, call it, else it's a string, print it.
1910 0 0         if(ref($cmd->{proc}) eq 'CODE') {
1911 0           $retval = eval { &{$cmd->{proc}}(@{$parms->{args}}) };
  0            
  0            
  0            
1912 0 0         $self->error($@) if $@;
1913             } else {
1914 0           print $OUT $cmd->{proc};
1915             }
1916             } else {
1917 0 0         if(exists $cmd->{cmds}) {
1918             # if not, but it has subcommands, then print a summary
1919 0           print $OUT $self->get_all_cmd_summaries($cmd->{cmds});
1920             } else {
1921 0           $self->error($self->get_cname($parms->{cname}) . " has nothing to do!\n");
1922             }
1923             }
1924              
1925 0           return $retval;
1926             }
1927              
1928              
1929             sub call_command
1930             {
1931 0     0 1   my $self = shift;
1932 0           my $parms = shift;
1933              
1934 0 0         if(!$parms->{cmd}) {
1935 0 0 0       if( exists $parms->{cset}->{''} &&
      0        
1936             (exists($parms->{cset}->{''}->{proc}) ||
1937             exists($parms->{cset}->{''}->{meth}) )
1938             ) {
1939             # default command exists and is callable
1940 0           my $save = $parms->{cmd};
1941 0           $parms->{cmd} = $parms->{cset}->{''};
1942 0           my $retval = $self->call_cmd($parms);
1943 0           $parms->{cmd} = $save;
1944 0           return $retval;
1945             }
1946              
1947 0           $self->error( $self->get_cname($parms->{cname}) . ": unknown command\n");
1948 0           return undef;
1949             }
1950              
1951 0           my $cmd = $parms->{cmd};
1952              
1953             # check min and max args if they exist
1954 0 0 0       if(exists($cmd->{minargs}) && @{$parms->{args}} < $cmd->{minargs}) {
  0            
1955 0           $self->error("Too few args! " . $cmd->{minargs} . " minimum.\n");
1956 0           return undef;
1957             }
1958 0 0 0       if(exists($cmd->{maxargs}) && @{$parms->{args}} > $cmd->{maxargs}) {
  0            
1959 0           $self->error("Too many args! " . $cmd->{maxargs} . " maximum.\n");
1960 0           return undef;
1961             }
1962              
1963             # everything checks out -- call the command
1964 0           return $self->call_cmd($parms);
1965             }
1966              
1967             =back
1968              
1969             =head1 BUGS
1970              
1971             History expansion does not respect token_chars. To make it do
1972             so would require either adding this feature to the readline
1973             library or re-writing history_expand in Perl -- neither of which
1974             sounds very realistic.
1975              
1976             =head1 LICENSE
1977              
1978             Copyright (c) 2003-2006 Scott Bronson, all rights reserved.
1979             This program is free software; you can redistribute it and/or modify
1980             it under the same terms as Perl itself.
1981              
1982             =head1 AUTHOR
1983              
1984             Scott Bronson Ebronson@rinspin.comE
1985              
1986             =cut
1987              
1988             1;