Term-ShellUI-0.92/0000755000175000017500000000000011713021206013571 5ustar bronsonbronsonTerm-ShellUI-0.92/MANIFEST0000644000175000017500000000044111713017754014736 0ustar bronsonbronsonChanges Makefile.PL MANIFEST README lib/Term/ShellUI.pm lib/Text/Shellwords/Cursor.pm t/parse.t t/test-line-parse t/Parse.pm examples/synopsis examples/synopsis-big examples/fileman-example examples/tui-sample META.yml Module meta-data (added by MakeMaker) Term-ShellUI-0.92/examples/0000755000175000017500000000000011713021205015406 5ustar bronsonbronsonTerm-ShellUI-0.92/examples/tui-sample0000755000175000017500000000441711713017754017440 0ustar bronsonbronson#!/usr/bin/perl -w # tui-sample Scott Bronson 16 Dec 2003 # This shows the similarities between Term::TUI (see the sample.pl file) # and Term::ShellUI. This example allows you to enter any number of arguments # (except for subs of course). # This file is released under the MIT license. use strict; use lib '../lib'; use Term::ShellUI; my $term = new Term::ShellUI(commands => get_commands()); $term->run(); sub get_commands { return { "abort" => { alias => "quit" }, "help" => { desc => "Print helpful information", args => sub { shift->help_args(undef, @_); }, method => sub { shift->help_call(undef, @_); } }, "quit" => { desc => "Quit using this program", maxargs => 0, method => sub { shift->exit_requested(1); } }, "math" => { desc => "A simple calculator", cmds => { "add" => { args => "(any number of decimal numbers)", desc => "Add numbers together", proc => sub { print "Total=" . add(@_) . "\n" }, }, "mult" => { args => "(any number of decimal numbers)", desc => "Multiply numbers together", proc => sub { print "Total=" . mult(@_) . "\n" }, }, "hex" => { desc => "Do math in hex", cmds => { "add" => { args => "(any number of hexadecimal numbers)", desc => "Add numbers together, result in hex", proc => sub { print "Total=" . ashex(\&add,@_) . "\n" }, }, "mult" => { args => "(any number of hexadecimal numbers)", desc => "Multiply numbers together, result in hex", proc => sub { print "Total=" . ashex(\&mult,@_) . "\n" }, }, }, }, }, }, "string" => { desc => "String operations", cmds => { "subs" => { args => ["(string)", "(pos)", "(len)"], desc => "Take STRING,POS,LEN and return a substring.", minargs => 1, maxargs => 3, proc => sub { print "Substring=".substr(shift,shift||0,shift||0)."\n" }, }, "len" => { args => "(any number of strings)", desc => "Calculate length of arguments", proc => sub { print "Length=" . join(", ", map { length } @_) . "\n" }, }, }, }, }; } sub add { my $sum=0; for(@_) { $sum+=$_; } return $sum; } sub mult { my $prod=1; for(@_) { $prod*=$_; } return $prod; } sub ashex { my $sub = shift; return sprintf("%x", &$sub(map { hex } @_)); } Term-ShellUI-0.92/examples/fileman-example0000755000175000017500000000730211713017754020420 0ustar bronsonbronson#!/usr/bin/perl -w # fileman # Scott Bronson # 8 Dec 2003 # This file shows how to use Term::ShellUI to create a simple # command-line environment. It is similar to fileman.c, the # example that comes with the GNU Readline library. # This file is released under the MIT license. use strict; use lib '../lib'; use Term::ShellUI; use File::stat qw(:FIELDS); use Cwd; # Prevents us from doing anything harmful. # Have it return 1 to live on the edge. sub danger { print "Not performing task -- too dangerous!\n"; return 0; } my $term = new Term::ShellUI(commands => get_commands()); $term->prompt(sub { getcwd() . " FM> " }); $term->run(); sub get_commands { return { "cd" => { desc => "Change to directory DIR", args => sub { shift->complete_onlydirs(@_); }, maxargs => 1, proc => sub { chdir($_[0] || $ENV{HOME} || $ENV{LOGDIR}) or print("Could not cd: $!\n") } }, "delete" => { desc => "Delete FILEs", args => sub { shift->complete_onlyfiles(@_); }, minargs => 1, proc => sub { danger() && (unlink(@_) or warn "Could not delete: $!\n") } }, "?" => { syn => "help" }, "help" => { desc => "Print helpful information", args => sub { shift->help_args(undef, @_); }, meth => sub { shift->help_call(undef, @_); } }, "ls" => { syn => "list" }, "dir" => { syn => "ls" }, "list" => { desc => "List files in DIRs", args => sub { shift->complete_onlydirs(@_); }, proc => sub { system('ls', '-FClg', @_); } }, "pwd" => { desc => "Print the current working directory", maxargs => 0, proc => sub { system('pwd'); } }, "quit" => { desc => "Quit using Fileman", maxargs => 0, meth => sub { shift->exit_requested(1); } }, "rename" => { desc => "Rename FILE to NEWNAME", args => sub { shift->complete_files(@_); }, minargs => 2, maxargs => 2, proc => sub { danger() && system('mv', @_); } }, "stat" => { desc => "Print out statistics on FILEs", args => sub { shift->complete_files(@_); }, proc => \&print_stats }, "cat" => { syn => "view" }, "view" => { desc => "View the contents of FILEs", args => sub { shift->complete_onlyfiles(@_); }, proc => sub { system('cat', @_); } }, # these demonstrate how parts of Term::ShellUI work: echo => { desc => "Echoes the command-line arguments", proc => sub { print join(" ", @_), "\n"; } }, tok => { desc => "Print command-line arguments with clear separations", proc => sub { print "<" . join(">, <", @_), ">\n"; } }, debug_complete => { desc => "Turn on completion debugging", minargs => 1, maxargs => 1, args => "0=off 1=some, 2=more, 3=tons", proc => sub { $term->{debug_complete} = $_[0] }, }, }; } sub print_stats { for my $file (@_) { stat($file) or die "No $file: $!\n"; # die only stops this command print "$file has $st_nlink link" . ($st_nlink==1?"":"s") . ", and is $st_size byte" . ($st_size==1?"":"s") . " in length.\n"; print "Inode Last change at: " . localtime($st_ctime) . "\n"; print " Last access at: " . localtime($st_atime) . "\n"; print " Last modified at: " . localtime($st_mtime) . "\n"; } } Term-ShellUI-0.92/examples/synopsis0000755000175000017500000000152711713017754017246 0ustar bronsonbronson#!/usr/bin/perl -w # Example code from the module's POD to ensure that it actually works. # Just three simple commands to show argument handling and completion. # This file is released under the MIT license. use strict; use lib '../lib'; use Term::ShellUI; my $term = new Term::ShellUI( commands => { "cd" => { desc => "Change to directory DIR", maxargs => 1, args => sub { shift->complete_onlydirs(@_); }, proc => sub { chdir($_[0] || $ENV{HOME} || $ENV{LOGDIR}); }, }, "pwd" => { desc => "Print the current working directory", maxargs => 0, proc => sub { system('pwd'); }, }, "quit" => { desc => "Quit using Fileman", maxargs => 0, method => sub { shift->exit_requested(1); }, }}, history_file => '~/.shellui-synopsis-history', ); print 'Using '.$term->{term}->ReadLine."\n"; $term->run(@ARGV); Term-ShellUI-0.92/examples/synopsis-big0000755000175000017500000000513411713017754020003 0ustar bronsonbronson#!/usr/bin/perl -w # This was originally the example code from Term::ShellUI's documentation # but it grew too big. Now it's intended to demonstrate most of the # available features and still be easy to read. # This file is released under the MIT license. use strict; use lib '../lib'; use Term::ShellUI; my $term = new Term::ShellUI( commands => get_commands(), history_file => '~/.shellui-synopsis-history', ); $term->add_eof_exit_hook(sub {print "Type 'quit' to quit.\n"; return 1;}); print 'Using '.$term->{term}->ReadLine."\n"; $term->run(@ARGV); sub get_commands { return { "h" => { alias => "help", exclude_from_completion => 1 }, "?" => { alias => "help", exclude_from_completion =>1 }, "help" => { desc => "Print helpful information", args => sub { shift->help_args(undef, @_); }, method => sub { shift->help_call(undef, @_); } }, "history" => { desc => "Prints the command history", doc => "Specify a number to list the last N lines of history\n" . "Pass -c to clear the command history, " . "-d NUM to delete a single item\n", args => "[-c] [-d] [number]", method => sub { shift->history_call(@_) }, exclude_from_history => 1, }, "exit" => { desc => "Exits the program.", maxargs => 0, method => sub { shift->exit_requested(1); }, }, "exists" => { desc => "Shows whether files exist", args => sub { shift->complete_files(@_); }, proc => sub { print "exists: " . join(", ", map {-e($_) ? "<$_>":$_} @_) . "\n"; }, doc => <. This detailed doc can\nspan\nmany\nlines EOL }, "show" => { desc => "An example of using subcommands", cmds => { "warranty" => { proc => "You have no warranty!\n" }, "args" => { args => [ sub {['create', 'delete']}, \&Term::ShellUI::complete_files ], desc => "Print the passed arguments", method => sub { my $self = shift; my $parms = shift; print $self->get_cname($parms->{cname}) . ": " . join(" ",@_), "\n"; }, }, }, }, "quit" => { desc => "Quit using Fileman", maxargs => 0, method => sub { shift->exit_requested(1); }, }, # Term::ShellUI normally displays "asdf: unknown command". # This shows how to use the default command. If the user # types an unknown command, ShellUI calls '' if it exists. '' => { proc => "No command here by that name!\n", desc => "No help for unknown commands.", doc => "Well, here's a little help: don't type them.\n", }, }; } Term-ShellUI-0.92/t/0000755000175000017500000000000011713021205014033 5ustar bronsonbronsonTerm-ShellUI-0.92/t/Parse.pm0000644000175000017500000000657511713017754015476 0ustar bronsonbronson# This file contains all the tests used to exercise the parser. package Parse; use strict; use vars qw(%Tests); # format: # fields are separated by colons. # First: 3-digit test number # Second: cursor position # Third: test string # Result # The tests to run # Format: "index:cursorpos:inputstring" => result %Tests = ( "000::" => [[], undef, undef], "001:: " => [[], undef, undef], "002:0:" => [[''], 0, 0], "003:0: " => [[''], 0, 0], "004:2: " => [[''], 0, 0], "005::abcde" => [['abcde'], undef, undef], "006::abc def" => [['abc', 'def'], undef, undef], # check whitespace trimming "010::big space" => [['big', 'space'], undef, undef], "011:: trim beg" => [['trim', 'beg'], undef, undef], "012::trim end " => [['trim', 'end'], undef, undef], "013:: trim both " => [['trim', 'both'], undef, undef], "014:: trim all extra ws " => [['trim', 'all', 'extra', 'ws'], undef, undef], # whitespace trimming with cursor "021:1: trim beg" => [['', 'trim', 'beg'], 0, 0], "022:4:t e " => [['t', 'e', ''], 2, 0], "023:0: " => [[''], 0, 0], "024:2: " => [[''], 0, 0], "025:3:a b" => [['a', '', 'b'], 1, 0], # putting the cursor inside tokens "030:0:abc" => [['abc'], 0, 0], "031:1:abc" => [['abc'], 0, 1], "032:3: abc" => [['abc'], 0, 0], "033:5: abc" => [['abc'], 0, 2], # putting the cursor after tokens "040:1:a" => [['a'], 0, 1], "041:3:a b" => [['a', 'b'], 1, 1], "042:3:a b " => [['a', 'b'], 1, 1], "043:3:'' " => [['', ''], 1, 0], # cursor when removing double quotes "050:0:\"b\"" => [['b'], 0, 0], "051:1:\"b\"" => [['b'], 0, 0], "052:2:\"b\"" => [['b'], 0, 1], "053:3:\"b\"" => [['b'], 0, 1], "054:2:\"ab\"" => [['ab'], 0, 1], "055:3:\"ab\"" => [['ab'], 0, 2], "056:4:\"ab\"" => [['ab'], 0, 2], "057:1: \"b\"" => [['b'], 0, 0], "058:1:\"\\\"\\\"\"" => [['""'], 0, 0], "059:3: \"\\\"\\\"\"" => [['""'], 0, 0], "060:3:\"\\\"\\\"\" " => [['""'], 0, 1], "061:6: \"\\\"\\\"\"" => [['""'], 0, 1], "062:5:\"\\\"\\\"\" " => [['""'], 0, 2], "063:7:\" \\\"\\\"\"" => [[' ""'], 0, 3], "064:2:\"\\'\\'\" " => [['\'\''], 0, 0], "065:2:\" \" \" " => [undef, undef, undef], "066:3: \"\"\"\" " => [['', ''], 0, 0], # make sure it gravitates to the left-most token # cursor when removing single quotes "070:0:'b'" => [['b'], 0, 0], "071:1:'b'" => [['b'], 0, 0], "072:2:'b'" => [['b'], 0, 1], "073:3:'b'" => [['b'], 0, 1], "074:2:'ab'" => [['ab'], 0, 1], "075:3:'ab'" => [['ab'], 0, 2], "076:4:'ab'" => [['ab'], 0, 2], "077:1: 'b'" => [['b'], 0, 0], "078:1:'\\'\\''" => [['\'\''], 0, 0], "079:2: '\\'\\''" => [['\'\''], 0, 0], "080:3:'\\'\\'' " => [['\'\''], 0, 1], "081:6: '\\'\\''" => [['\'\''], 0, 1], "082:5:'\\'\\'' " => [['\'\''], 0, 2], "083:7:' \\'\\''" => [[' \'\''], 0, 3], "084:2:'\\\"\\\"' " => [['\"\"'], 0, 1], "085:2:' ' ' " => [undef, undef, undef], "086:3: '''' " => [['', ''], 0, 0], # cursor when removing backslash escapes "090:0:\\b" => [['b'], 0, 0], "091:1:\\b" => [['b'], 0, 0], "092:2:\\b" => [['b'], 0, 1], "093:1: \\b" => [['b'], 0, 0], "094:2:\\a\\b\\c" => [['abc'], 0, 1], # random "100::this is \"a test\" of\\ quotewords \\\"for you" => [['this', 'is', 'a test', 'of quotewords', '"for', 'you'], undef, undef], ); 1; Term-ShellUI-0.92/t/test-line-parse0000755000175000017500000000314111713017754017012 0ustar bronsonbronson#!/usr/bin/perl -w # Tests the Term::ShellUI tokenizer/parser. # Pass the indexes of the tests you want to run as arguments. # If no arguments supplied, runs all tests. # If arguments supplied, verbosely displays results. use strict; use lib '.'; use Parse; use lib '../lib'; use Text::Shellwords::Cursor; use FreezeThaw qw(freeze cmpStr); use YAML qw(Dump); my $parser = Text::Shellwords::Cursor->new(); die "No parser" unless $parser; # Parse cmdline args my %seltest; for(@ARGV) { $seltest{$_} = 1; } my $verbose = 1, $parser->{debug} = 1 if @ARGV; print "\nTest Result\n---------------------------------\n" unless $verbose; my($ntests, $nfail) = (0,0); for my $input (sort keys %Parse::Tests) { my($index,$cpos,$test) = $input =~ /^(\d+):(\d*):(.*)$/; die "No test in item $index: $input\n" unless defined $test; next if %seltest && !exists($seltest{0+$index}); my($toks, $tokno, $tokoff) = $parser->parse_line($test, messages=>$verbose, cursorpos=>$cpos); my $result = [$toks, $tokno, $tokoff]; my $eq = 0 == cmpStr($result, $Parse::Tests{$input}); if($verbose) { print "\nTest $index: $test cursor=$cpos\n"; print "Expected output: " . freeze($Parse::Tests{$input}) . "\n"; print Dump($Parse::Tests{$input}); print "Received output: " . freeze($result) . "\n"; print Dump($result); } else { printf("%2d: %s $test\n", $index, ($eq ? 'OK ' : 'FAIL')); } $ntests++; $nfail++ unless $eq; } print "\n\n$ntests test" . ($ntests == 1 ? "" : "s") ." run, "; print "$nfail failure" . ($nfail == 1 ? "" : "s") . ".\n\n"; Term-ShellUI-0.92/t/parse.t0000644000175000017500000000251011713017754015346 0ustar bronsonbronson#!/usr/bin/env perl -Tw use strict; use lib 't'; use Parse; use Test::Simple tests => 0+keys(%Parse::Tests); use Text::Shellwords::Cursor; my $parser = new Text::Shellwords::Cursor; die "No parser" unless $parser; for my $input (sort keys %Parse::Tests) { my($index,$cpos,$test) = $input =~ /^(\d+):(\d*):(.*)$/; die "No test in item $index: $input\n" unless defined $test; my($toks, $tokno, $tokoff) = $parser->parse_line($test, messages=>0, cursorpos=>$cpos); my $result = [$toks, $tokno, $tokoff]; ok(0 == cmp_deep($result, $Parse::Tests{$input}), "Test $index"); } # Tries to return a valid comparison # If the data types don't match, claims a>b. ' sub cmp_deep { my($a,$b) = @_; my $refa = ref $a; my $refb = ref $b; return 1 if $refa ne $refb; if(not $refa) { return $a cmp $b if defined($a) && defined($b); return 1 if !defined($a) && defined($b); return -1 if defined($a) && !defined($b); return 0; } elsif($refa eq 'SCALAR') { return cmp_deep($$a, $$b); } elsif($refa eq 'ARRAY') { return @$a <=> @$b if @$a <=> @$b; for(my $i=0; $i < @$a; $i++) { my $res = cmp_deep($a->[$i], $b->[$i]); return $res if $res; } } else { die "Can't compare a: $a '$refa'\n"; } return 0; } Term-ShellUI-0.92/Changes0000644000175000017500000001010411713020245015062 0ustar bronsonbronson0.92: 03 Feb 2012 - Cleanups and fixes for Debian packaging by Boris Peck. 0.91: 17 May 2011 - Support calling commands noninteractively (patch by Christian Kuelker) - Support calling $term->run() multiple times (patch by Ryan Gies) - Now clients can call process_a_cmd manually (patch by Martin Kluge) - Undeprecate Term::ReadLine::Perl since it works better on Windows. 0.9: 20 Mar 2011 - Relicensed from the somewhat ambiguous Perl license to the MIT license. - Add eof_exit_hooks, patch by Lester Hightower - Remove complete_history callback. It was an odd, ShellUI-specific feature. - Remove history expansion (!!, !$, ^o^n). That implementation was too buggy. - Fix bug: completion suggestion wasn't printed with Term::ReadLine::Gnu. - Deprecate Term::ReadLine::Perl. Use Term::ReadLine::Gnu. 0.86: 26 Apr 2007 - Removed the use.t test. Bugs in Term::ReadLine::X would cause this test to fail randomly and always seemed to evade my workarounds. - Renamed 'syn' to 'alias'. 'syn' will continue to work indefinitely. - If a completion routine returns a string, the string will now be printed. Before we would just error out ungracefully. - Fixed http://rt.cpan.org/Ticket/Display.html?id=26692 reported by Erik Sherk 0.85: 7 June 2006 - Renamed 'meth' to 'method'. 'meth' will continue to work indefinitely so there's no need to change your code. - Renamed the module to ShellUI. A simple s/GDBUI/ShellUI/g should be all that's required to continue to use this module. 0.84: 27 Apr 2006 - Added two features suggested by Don Rodgers: - backslash_continues_command to support command continuation. - exclude_from_history to prevent a command from being stored in the history. 0.83: - Re-enable ornaments by default. (Term::GDBUI turned ornaments off because it was exposing Term::ReadLine::Gnu bugs that have since been fixed). 0.821: 27 Dec 2004 - Print the ReadLine lib being used in the synopsis script - Turn off tainting in use.t. Term::ReadKey (and therefore Term::ReadLine::Perl) can't handle it. 0.82: 23 Dec 2004 - You can now supply an anonymous sub as a prompt (see fileman-example). - Fix from Erick Calder to fix completion when using Term::ReadLine::Perl. - Try to fix "Cannot open /dev/tty" errors when running automated tests. - Convert tabs in most files to spaces. - A few doc fixups. 0.811: 02 Feb 2004 - 'make test' used to require FreezeThaw. I didn't realize the barrage of testing errors that would cause. Rewritten to be self-sufficient. 0.81: 31 Jan 2004 - somehow I left the pm_to_blib file in the tarball, breaking builds. Removed. - it turns out CPAN indexes the namespace in the examples directory too. Arg. Changed all private Connection::BLAH modules to be RPC::Connection::BLAH. 0.8: rev 40 30 Jan 2004 This release introduced one possible compatibility issue. - fixed a few bugs where the default command ('') wasn't being called. - made all method calling print an error if method can't be found - doc subroutines now get the command name as an argument - history quick substitution ^search^repl now works - split the parser off into Text::Shellwords::Cursor - now join_line puts space on both sides of token_chars chars - fixed save hist bug: GDBUI was saving the first 500 cmds instead of the last. - now repeats the last arg in a [] arg list forever (or until maxargs) - fixed off-by-one in parser (only when using keep_quotes option) - Added the force_to_string completion helper routine - raised default maximum saved history from 64 to 500 - added default command and argument handlers (if the cmd couldn't be found) - provide bang completion, but you must enable it in your command set - added a default history command: history_call * completion returns an arrayref so it can return undef to highlight an error in your completion routines: return [@result]; instead of return @result; - we now support automatic bang history - we now sort help summaries - made file completion work with absolute pathnames - reorg'd pod, putting most important stuff at top - we now put a final newline on the command history file 0.61: 16 Dec 2003 - initial release Term-ShellUI-0.92/lib/0000755000175000017500000000000011713021205014336 5ustar bronsonbronsonTerm-ShellUI-0.92/lib/Text/0000755000175000017500000000000011713021205015262 5ustar bronsonbronsonTerm-ShellUI-0.92/lib/Text/Shellwords/0000755000175000017500000000000011713021205017410 5ustar bronsonbronsonTerm-ShellUI-0.92/lib/Text/Shellwords/Cursor.pm0000644000175000017500000004227611713017754021254 0ustar bronsonbronson# Text::Shellwords::Cursor.pm # Scott Bronson # 27 Jan 2003 # Covered by the MIT license. package Text::Shellwords::Cursor; use strict; use vars qw($VERSION); $VERSION = '0.81'; =head1 NAME Text::Shellwords::Cursor - Parse a string into tokens =head1 SYNOPSIS use Text::Shellwords::Cursor; my $parser = Text::Shellwords::Cursor->new(); my $str = 'ab cdef "ghi" j"k\"l "'; my ($tok1) = $parser->parse_line($str); $tok1 = ['ab', 'cdef', 'ghi', 'j', 'k"l '] my ($tok2, $tokno, $tokoff) = $parser->parse_line($str, cursorpos => 6); as above, but $tokno=1, $tokoff=3 (under the 'f') DESCRIPTION This module is very similar to Text::Shellwords and Text::ParseWords. However, it has one very significant difference: it keeps track of a character position in the line it's parsing. For instance, if you pass it ("zq fmgb", cursorpos=>6), it would return (['zq', 'fmgb'], 1, 3). The cursorpos parameter tells where in the input string the cursor resides (just before the 'b'), and the result tells you that the cursor was on token 1 ('fmgb'), character 3 ('b'). This is very useful when computing command-line completions involving quoting, escaping, and tokenizing characters (like '(' or '='). A few helper utilities are included as well. You can escape a string to ensure that parsing it will produce the original string (L). You can also reassemble the tokens with a visually pleasing amount of whitespace between them (L). This module started out as an integral part of Term::GDBUI using code loosely based on Text::ParseWords. However, it is now basically a ground-up reimplementation. It was split out of Term::GDBUI for version 0.8. =head1 METHODS =over 3 =item new Creates a new parser. Takes named arguments on the command line. =over 4 =item keep_quotes Normally all unescaped, unnecessary quote marks are stripped. If you specify C1>, however, they are preserved. This is useful if you need to know whether the string was quoted or not (string constants) or what type of quotes was around it (affecting variable interpolation, for instance). =item token_chars This argument specifies the characters that should be considered tokens all by themselves. For instance, if I pass token_chars=>'=', then 'ab=123' would be parsed to ('ab', '=', '123'). Without token_chars, 'ab=123' remains a single string. NOTE: you cannot change token_chars after the constructor has been called! The regexps that use it are compiled once (m//o). Also, until the Gnu Readline library can accept "=[]," without diving into an endless loop, we will not tell history expansion to use token_chars (it uses " \t\n()<>;&|" by default). =item debug Turns on rather copious debugging to try to show what the parser is thinking at every step. =item space_none =item space_before =item space_after These variables affect how whitespace in the line is normalized and it is reassembled into a string. See the L routine. =item error This is a reference to a routine that should be called to display a parse error. The routine takes two arguments: a reference to the parser, and the error message to display as a string. =cut sub new { my $type = shift; bless { keep_quotes => 0, token_chars => '', debug => 0, space_none => '(', space_before => '[{', space_after => ',)]}', error => undef, @_ }, $type } =item parsebail(msg) If the parsel routine or any of its subroutines runs into a fatal error, they call parsebail to present a very descriptive diagnostic. =cut sub parsebail { my $self = shift; my $msg = shift; die "$msg at char " . pos() . ":\n", " $_\n " . (' ' x pos()) . '^' . "\n"; } =item parsel This is the heinous routine that actually does the parsing. You should never need to call it directly. Call L instead. =cut sub parsel { my $self = shift; $_ = shift; my $cursorpos = shift; my $fixclosequote = shift; my $deb = $self->{debug}; my $tchrs = $self->{token_chars}; my $usingcp = (defined($cursorpos) && $cursorpos ne ''); my $tokno = undef; my $tokoff = undef; my $oldpos; my @pieces = (); # Need to special case the empty string. None of the patterns below # will match it yet we need to return an empty token for the cursor. return ([''], 0, 0) if $usingcp && $_ eq ''; /^/gc; # force scanning to the beginning of the line do { $deb && print "-- top, pos=" . pos() . ($usingcp ? " cursorpos=$cursorpos" : "") . "\n"; # trim whitespace from the beginning if(/\G(\s+)/gc) { $deb && print "trimmed " . length($1) . " whitespace chars, " . ($usingcp ? "cursorpos=$cursorpos" : "") . "\n"; # if pos passed cursorpos, then we know that the cursor was # surrounded by ws and we need to create an empty token for it. if($usingcp && (pos() >= $cursorpos)) { # if pos == cursorpos and we're not yet at EOL, let next token accept cursor unless(pos() == $cursorpos && pos() < length($_)) { # need to special-case at end-of-line as there are no more tokens # to take care of the cursor so we must create an empty one. $deb && print "adding bogus token to handle cursor.\n"; push @pieces, ''; $tokno = $#pieces; $tokoff = 0; $usingcp = 0; } } } # if there's a quote, then suck to the close quote $oldpos = pos(); if(/\G(['"])/gc) { my $quote = $1; my $adjust = 0; # keeps track of tokoff bumps due to subs, etc. my $s; $deb && print "Found open quote [$quote] oldpos=$oldpos\n"; # adjust tokoff unless the cursor sits directly on the open quote if($usingcp && pos()-1 < $cursorpos) { $deb && print " lead quote increment pos=".pos()." cursorpos=$cursorpos\n"; $adjust += 1; } if($quote eq '"') { if(/\G((?:\\.|(?!["])[^\\])*)["]/gc) { $s = $1; # string without quotes } else { unless($fixclosequote) { pos() -= 1; $self->parsebail("need closing quote [\"]"); } /\G(.*)$/gc; # if no close quote, just suck to the end of the string $s = $1; # string without quotes if($usingcp && pos() == $cursorpos) { $adjust -= 1; } # make cursor think cq was there } $deb && print " quoted string is \"$s\"\n"; while($s =~ /\\./g) { my $ps = pos($s) - 2; # points to the start of the sub $deb && print " doing substr at $ps on '$s' oldpos=$oldpos adjust=$adjust\n"; $adjust += 1 if $usingcp && $ps < $cursorpos - $oldpos - $adjust; substr($s, $ps, 1) = ''; pos($s) = $ps + 1; $deb && print " s='$s' usingcp=$usingcp pos(s)=" . pos($s) . " cursorpos=$cursorpos oldpos=$oldpos adjust=$adjust\n"; } } else { if(/\G((?:\\.|(?!['])[^\\])*)[']/gc) { $s = $1; # string without quotes } else { unless($fixclosequote) { pos() -= 1; $self->parsebail("need closing quote [']"); } /\G(.*)$/gc; # if no close quote, just suck to the end of the string $s = $1; if($usingcp && pos() == $cursorpos) { $adjust -= 1; } # make cursor think cq was there } $deb && print " quoted string is '$s'\n"; while($s =~ /\\[\\']/g) { my $ps = pos($s) - 2; # points to the start of the sub $deb && print " doing substr at $ps on '$s' oldpos=$oldpos adjust=$adjust\n"; $adjust += 1 if $usingcp && $ps < $cursorpos - $oldpos - $adjust; substr($s, $ps, 1) = ''; pos($s) = $ps + 1; $deb && print " s='$s' usingcp=$usingcp pos(s)=" . pos($s) . " cursorpos=$cursorpos oldpos=$oldpos adjust=$adjust\n"; } } # adjust tokoff if the cursor if it sits directly on the close quote if($usingcp && pos() == $cursorpos) { $deb && print " trail quote increment pos=".pos()." cursorpos=$cursorpos\n"; $adjust += 1; } $deb && print " Found close, pushing '$s' oldpos=$oldpos\n"; if($self->{keep_quotes}) { $adjust -= 1; # need to move right 1 for opening quote $s = $quote.$s.$quote; } push @pieces, $s; # Set tokno and tokoff if this token contained the cursor if($usingcp && pos() >= $cursorpos) { # Previous block contains the cursor $tokno = $#pieces; $tokoff = $cursorpos - $oldpos - $adjust; $usingcp = 0; } } # suck up as much unquoted text as we can $oldpos = pos(); if(/\G((?:\\.|[^\s\\"'\Q$tchrs\E])+)/gco) { my $s = $1; # the unquoted string my $adjust = 0; # keeps track of tokoff bumps due to subs, etc. $deb && print "Found unquoted string '$s'\n"; while($s =~ /\\./g) { my $ps = pos($s) - 2; # points to the start of substitution $deb && print " doing substr at $ps on '$s' oldpos=$oldpos adjust=$adjust\n"; $adjust += 1 if $usingcp && $ps < $cursorpos - $oldpos - $adjust; substr($s, $ps, 1) = ''; pos($s) = $ps + 1; $deb && print " s='$s' usingcp=$usingcp pos(s)=" . pos($s) . " cursorpos=$cursorpos oldpos=$oldpos adjust=$adjust\n"; } $deb && print " pushing '$s'\n"; push @pieces, $s; # Set tokno and tokoff if this token contained the cursor if($usingcp && pos() >= $cursorpos) { # Previous block contains the cursor $tokno = $#pieces; $tokoff = $cursorpos - $oldpos - $adjust; $usingcp = 0; } } if(length($tchrs) && /\G([\Q$tchrs\E])/gco) { my $s = $1; # the token char $deb && print " pushing '$s'\n"; push @pieces, $s; if($usingcp && pos() == $cursorpos) { # Previous block contains the cursor $tokno = $#pieces; $tokoff = 0; $usingcp = 0; } } } until(pos() >= length($_)); $deb && print "Result: (", join(", ", @pieces), ") " . (defined($tokno) ? $tokno : 'undef') . " " . (defined($tokoff) ? $tokoff : 'undef') . "\n"; return ([@pieces], $tokno, $tokoff); } =item parse_line(line, I) This is the entrypoint to this module's parsing functionality. It converts a line into tokens, respecting quoted text, escaped characters, etc. It also keeps track of a cursor position on the input text, returning the token number and offset within the token where that position can be found in the output. This routine originally bore some resemblance to Text::ParseWords. It has changed almost completely, however, to support keeping track of the cursor position. It also has nicer failure modes, modular quoting, token characters (see token_chars in L), etc. This routine now does much more. Arguments: =over 3 =item line This is a string containing the command-line to parse. =back This routine also accepts the following named parameters: =over 3 =item cursorpos This is the character position in the line to keep track of. Pass undef (by not specifying it) or the empty string to have the line processed with cursorpos ignored. Note that passing undef is I the same as passing some random number and ignoring the result! For instance, if you pass 0 and the line begins with whitespace, you'll get a 0-length token at the beginning of the line to represent the cursor in the middle of the whitespace. This allows command completion to work even when the cursor is not near any tokens. If you pass undef, all whitespace at the beginning and end of the line will be trimmed as you would expect. If it is ambiguous whether the cursor should belong to the previous token or to the following one (i.e. if it's between two quoted strings, say "a""b" or a token_char), it always gravitates to the previous token. This makes more sense when completing. =item fixclosequote Sometimes you want to try to recover from a missing close quote (for instance, when calculating completions), but usually you want a missing close quote to be a fatal error. fixclosequote=>1 will implicitly insert the correct quote if it's missing. fixclosequote=>0 is the default. =item messages parse_line is capable of printing very informative error messages. However, sometimes you don't care enough to print a message (like when calculating completions). Messages are printed by default, so pass messages=>0 to turn them off. =back This function returns a reference to an array containing three items: =over 3 =item tokens A the tokens that the line was separated into (ref to an array of strings). =item tokno The number of the token (index into the previous array) that contains cursorpos. =item tokoff The character offet into tokno of cursorpos. =back If the cursor is at the end of the token, tokoff will point to 1 character past the last character in tokno, a non-existant character. If the cursor is between tokens (surrounded by whitespace), a zero-length token will be created for it. =cut sub parse_line { my $self = shift; my $line = shift; my %args = ( messages => 1, # true if we should print errors, etc. cursorpos => undef, # cursor to keep track of, undef to ignore. fixclosequote => 0, @_ ); my @result = eval { $self->parsel($line, $args{'cursorpos'}, $args{'fixclosequote'}) }; if($@) { $self->{error}->($self, $@) if $args{'messages'} && $self->{error}; @result = (undef, undef, undef); } return @result; } =item parse_escape(lines) Escapes characters that would be otherwise interpreted by the parser. Will accept either a single string or an arrayref of strings (which will be modified in-place). =cut sub parse_escape { my $self = shift; my $arr = shift; # either a string or an arrayref of strings my $wantstr = 0; if(ref($arr) ne 'ARRAY') { $arr = [$arr]; $wantstr = 1; } foreach(@$arr) { my $quote; if($self->{keep_quotes} && /^(['"])(.*)\1$/) { ($quote, $_) = ($1, $2); } s/([ \\"'])/\\$1/g; $_ = $quote.$_.$quote if $quote; } return $wantstr ? $arr->[0] : $arr; } =item join_line(tokens) This routine does a somewhat intelligent job of joining tokens back into a command line. If token_chars (see L) is empty (the default), then it just escapes backslashes and quotes, and joins the tokens with spaces. However, if token_chars is nonempty, it tries to insert a visually pleasing amount of space between the tokens. For instance, rather than 'a ( b , c )', it tries to produce 'a (b, c)'. It won't reformat any tokens that aren't found in $self->{token_chars}, of course. To change the formatting, you can redefine the variables $self->{space_none}, $self->{space_before}, and $self->{space_after}. Each variable is a string containing all characters that should not be surrounded by whitespace, should have whitespace before, and should have whitespace after, respectively. Any character found in token_chars, but non in any of these space_ variables, will have space placed both before and after. =cut sub join_line { my $self = shift; my $intoks = shift; my $tchrs = $self->{token_chars}; my $s_none = $self->{space_none}; my $s_before = $self->{space_before}; my $s_after = $self->{space_after}; # copy the input array so we don't modify it my $tokens = $self->parse_escape([@$intoks]); my $str = ''; my $sw = 0; # space if space wanted after token. my $sf = 0; # space if space should be forced after token. for(@$tokens) { if(length == 1 && index($tchrs,$_) >= 0) { if(index($s_none,$_) >= 0) { $str .= $_; $sw=0; next; } if(index($s_before,$_) >= 0) { $str .= $sw.$_; $sw=0; next; } if(index($s_after,$_) >= 0) { $str .= $_; $sw=1; next; } # default: force space on both sides of operator. $str .= " $_ "; $sw = 0; next; } $str .= ($sw ? ' ' : '') . $_; $sw = 1; } return $str; } =back =back =head1 BUGS None known. =head1 LICENSE Copyright (c) 2003-2011 Scott Bronson, all rights reserved. This program is covered by the MIT license. =head1 AUTHOR Scott Bronson Ebronson@rinspin.comE =cut 1; Term-ShellUI-0.92/lib/Term/0000755000175000017500000000000011713021205015245 5ustar bronsonbronsonTerm-ShellUI-0.92/lib/Term/ShellUI.pm0000644000175000017500000015754411713020432017131 0ustar bronsonbronson# Term::ShellUI.pm # Scott Bronson # 3 Nov 2003 # Covered by the MIT license. # Makes it very easy to implement a GDB-like interface. package Term::ShellUI; use strict; use Term::ReadLine (); use Text::Shellwords::Cursor; use vars qw($VERSION); $VERSION = '0.92'; =head1 NAME Term::ShellUI - A fully-featured shell-like command line environment =head1 SYNOPSIS use Term::ShellUI; my $term = new Term::ShellUI( commands => { "cd" => { desc => "Change to directory DIR", maxargs => 1, args => sub { shift->complete_onlydirs(@_); }, proc => sub { chdir($_[0] || $ENV{HOME} || $ENV{LOGDIR}); }, }, "chdir" => { alias => 'cd' }, "pwd" => { desc => "Print the current working directory", maxargs => 0, proc => sub { system('pwd'); }, }, "quit" => { desc => "Quit this program", maxargs => 0, method => sub { shift->exit_requested(1); }, }}, history_file => '~/.shellui-synopsis-history', ); print 'Using '.$term->{term}->ReadLine."\n"; $term->run(); =head1 DESCRIPTION Term::ShellUI uses the history and autocompletion features of L to present a sophisticated command-line interface to the user. It tries to make every feature that one would expect to see in a fully interactive shell trivial to implement. You simply declare your command set and let ShellUI take care of the heavy lifting. This module was previously called L. =head1 COMMAND SET A command set is the data structure that describes your application's entire user interface. It's easiest to illustrate with a working example. We shall implement the following 6 Ls: =over 4 =item help Prints the help for the given command. With no arguments, prints a list and short summary of all available commands. =item h This is just a synonym for "help". We don't want to list it in the possible completions. Of course, pressing "h" will autocomplete to "help" and then execute the help command. Including this command allows you to simply type "h". The 'alias' directive used to be called 'syn' (for synonym). Either term works. =item exists This command shows how to use the L routines to complete on file names, and how to provide more comprehensive help. =item show Demonstrates subcommands (like GDB's show command). This makes it easy to implement commands like "show warranty" and "show args". =item show args This shows more advanced argument processing. First, it uses cusom argument completion: a static completion for the first argument (either "create" or "delete") and the standard file completion for the second. When executed, it echoes its own command name followed by its arguments. =item quit How to nicely quit. Term::ShellUI also follows Term::ReadLine's default of quitting when Control-D is pressed. =back This code is fairly comprehensive because it attempts to demonstrate most of Term::ShellUI's many features. You can find a working version of this exact code titled "synopsis" in the examples directory. For a more real-world example, see the fileman-example in the same directory. sub get_commands { return { "help" => { desc => "Print helpful information", args => sub { shift->help_args(undef, @_); }, method => sub { shift->help_call(undef, @_); } }, "h" => { alias => "help", exclude_from_completion=>1}, "exists" => { desc => "List whether files exist", args => sub { shift->complete_files(@_); }, proc => sub { print "exists: " . join(", ", map {-e($_) ? "<$_>":$_} @_) . "\n"; }, doc => <. The help can\nspan\nmany\nlines EOL }, "show" => { desc => "An example of using subcommands", cmds => { "warranty" => { proc => "You have no warranty!\n" }, "args" => { minargs => 2, maxargs => 2, args => [ sub {qw(create delete)}, \&Term::ShellUI::complete_files ], desc => "Demonstrate method calling", method => sub { my $self = shift; my $parms = shift; print $self->get_cname($parms->{cname}) . ": " . join(" ",@_), "\n"; }, }, }, }, "quit" => { desc => "Quit using Fileman", maxargs => 0, method => sub { shift->exit_requested(1); } }, "q" => { alias => 'quit', exclude_from_completion => 1 }, }; } =head1 COMMAND This data structure describes a single command implemented by your application. "help", "exit", etc. All fields are optional. Commands are passed to Term::ShellUI using a L. =over 4 =item desc A short, one-line description for the command. Normally this is a simple string, but it may also be a subroutine that will be called every time the description is printed. The subroutine takes two arguments, $self (the Term::ShellUI object), and $cmd (the command hash for the command), and returns the command's description as a string. =item doc A comprehensive, many-line description for the command. Like desc, this is normally a string but if you store a reference to a subroutine in this field, it will be called to calculate the documentation. Your subroutine should accept three arguments: self (the Term::ShellUI object), cmd (the command hash for the command), and the command's name. It should return a string containing the command's documentation. See examples/xmlexer to see how to read the doc for a command out of the pod. =item minargs =item maxargs These set the minimum and maximum number of arguments that this command will accept. =item proc This contains a reference to the subroutine that should be executed when this command is called. Arguments are those passed on the command line and the return value is the value returned by call_cmd and process_a_cmd (i.e. it is ignored unless your application makes use of it). If this field is a string instead of a subroutine ref, the string is printed when the command is executed (good for things like "Not implemented yet"). Examples of both subroutine and string procs can be seen in the example above. =item method Similar to proc, but passes more arguments. Where proc simply passes the arguments for the command, method also passes the Term::ShellUI object and the command's parms object (see L for more on parms). Most commands can be implemented entirely using a simple proc procedure, but sometimes they require addtional information supplied to the method. Like proc, method may also be a string. =item args This tells how to complete the command's arguments. It is usually a subroutine. See L for an reasonably simple example, and the L routine for a description of the arguments and cmpl data structure. Args can also be an arrayref. Each position in the array will be used as the corresponding argument. See "show args" in get_commands above for an example. The last argument is repeated indefinitely (see L for how to limit this). Finally, args can also be a string. The string is intended to be a reminder and is printed whenever the user types tab twice (i.e. "a number between 0 and 65536"). It does not affect completion at all. =item cmds Command sets can be recursive. This allows a command to have subcommands (like GDB's info and show commands, and the show command in the example above). A command that has subcommands should only have two fields: cmds (of course), and desc (briefly describe this collection of subcommands). It may also implement doc, but ShellUI's default behavior of printing a summary of the command's subcommands is usually sufficient. Any other fields (args, method, maxargs, etc) will be taken from the subcommand. =item exclude_from_completion If this field exists, then the command will be excluded from command-line completion. This is useful for one-letter abbreviations, such as "h"->"help": including "h" in the completions just clutters up the screen. =item exclude_from_history If this field exists, the command will never be stored in history. This is useful for commands like help and quit. =back =head2 Default Command If your command set includes a command named '' (the empty string), this pseudo-command will be called any time the actual command cannot be found. Here's an example: '' => { proc => "HA ha. No command here by that name\n", desc => "HA ha. No help for unknown commands.", doc => "Yet more taunting...\n", }, Note that minargs and maxargs for the default command are ignored. method and proc will be called no matter how many arguments the user entered. =head1 CATEGORIES Normally, when the user types 'help', she receives a short summary of all the commands in the command set. However, if your application has 30 or more commands, this can result in information overload. To manage this, you can organize your commands into help categories All help categories are assembled into a hash and passed to the the default L and L methods. If you don't want to use help categories, simply pass undef for the categories. Here is an example of how to declare a collection of help categories: my $helpcats = { breakpoints => { desc => "Commands to halt the program", cmds => qw(break tbreak delete disable enable), }, data => { desc => "Commands to examine data", cmds => ['info', 'show warranty', 'show args'], } }; "show warranty" and "show args" on the last line above are examples of how to include subcommands in a help category: separate the command and subcommands with whitespace. =head1 CALLBACKS Callbacks are functions supplied by ShellUI but intended to be called by your application. They implement common functions like 'help' and 'history'. =over 4 =item help_call(cats, parms, topic) Call this routine to implement your help routine. Pass the help categories or undef, followed by the command-line arguments: "help" => { desc => "Print helpful information", args => sub { shift->help_args($helpcats, @_); }, method => sub { shift->help_call($helpcats, @_); } }, =cut sub help_call { my $self = shift; my $cats = shift; # help categories to use my $parms = shift; # data block passed to methods my $topic = $_[0]; # topics or commands to get help on my $cset = $parms->{cset}; my $OUT = $self->{OUT}; if(defined($topic)) { if(exists $cats->{$topic}) { print $OUT $self->get_category_help($cats->{$topic}, $cset); } else { print $OUT $self->get_cmd_help(\@_, $cset); } } elsif(defined($cats)) { # no topic -- print a list of the categories print $OUT "\nHelp categories:\n\n"; for(sort keys(%$cats)) { print $OUT $self->get_category_summary($_, $cats->{$_}); } } else { # no categories -- print a summary of all commands print $OUT $self->get_all_cmd_summaries($cset); } } =item help_args This provides argument completion for help commands. See the example above for how to call it. =cut sub help_args { my $self = shift; my $helpcats = shift; my $cmpl = shift; my $args = $cmpl->{'args'}; my $argno = $cmpl->{'argno'}; my $cset = $cmpl->{'cset'}; if($argno == 0) { # return both categories and commands if we're on the first argument return $self->get_cset_completions($cset, keys(%$helpcats)); } my($scset, $scmd, $scname, $sargs) = $self->get_deep_command($cset, $args); # without this we'd complete with $scset for all further args return [] if $argno >= @$scname; return $self->get_cset_completions($scset); } =item complete_files Completes on filesystem objects (files, directories, etc). Use either args => sub { shift->complete_files(@_) }, or args => \&complete_files, Starts in the current directory. =cut sub complete_files { my $self = shift; my $cmpl = shift; $self->suppress_completion_append_character(); use File::Spec; my @path = File::Spec->splitdir($cmpl->{str} || "."); my $dir = File::Spec->catdir(@path[0..$#path-1]); # eradicate non-matches immediately (this is important if # completing in a directory with 3000+ files) my $file = $path[$#path]; $file = '' unless $cmpl->{str}; my $flen = length($file); my @files = (); if(opendir(DIR, length($dir) ? $dir : '.')) { @files = grep { substr($_,0,$flen) eq $file } readdir DIR; closedir DIR; # eradicate dotfiles unless user's file begins with a dot @files = grep { /^[^.]/ } @files unless $file =~ /^\./; # reformat filenames to be exactly as user typed @files = map { length($dir) ? ($dir eq '/' ? "/$_" : "$dir/$_") : $_ } @files; } else { $self->completemsg("Couldn't read dir: $!\n"); } return \@files; } =item complete_onlyfiles Like L but excludes directories, device nodes, etc. It returns regular files only. =cut sub complete_onlyfiles { my $self = shift; # need to do our own escaping because we want to add a space ourselves $self->suppress_completion_escape(); my @c = grep { -f || -d } @{$self->complete_files(@_)}; $self->{parser}->parse_escape(\@c); # append a space if we've completed a unique file $c[0] .= (-f($c[0]) ? ' ' : '') if @c == 1; # append a helpful slash to indicate directories @c = map { -d($_) ? "$_/" : $_ } @c; return \@c; } =item complete_onlydirs Like L, but excludes files, device nodes, etc. It returns only directories. It I return the . and .. special directories so you'll need to remove those manually if you don't want to see them: args = sub { grep { !/^\.?\.$/ } complete_onlydirs(@_) }, =cut sub complete_onlydirs { my $self = shift; my @c = grep { -d } @{$self->complete_files(@_)}; $c[0] .= '/' if @c == 1; # add a slash if it's a unique match return \@c; } =item history_call You can use this callback to implement the standard bash history command. This command supports: NUM display last N history items (displays all history if N is omitted) -c clear all history -d NUM delete an item from the history Add it to your command set using something like this: "history" => { desc => "Prints the command history", doc => "Specify a number to list the last N lines of history" . "Pass -c to clear the command history, " . "-d NUM to delete a single item\n", args => "[-c] [-d] [number]", method => sub { shift->history_call(@_) }, }, =cut sub history_call { my $self = shift; my $parms = shift; my $arg = shift; # clear history? if($arg && $arg eq '-c') { $self->{term}->clear_history(); return; } if($arg && $arg eq '-d') { @_ or die "Need the indexes of the items to delete.\n"; for(@_) { /^\d+$/ or die "'$_' needs to be numeric.\n"; # function is autoloaded so we can't use can('remove_history') # to see if it exists. So, we'll eval it and pray... eval { $self->{term}->remove_history($_); } } return; } # number of lines to print (push maximum onto args if no arg supplied) my $num = -1; if($arg && $arg =~ /^(\d+)$/) { $num = $1; $arg = undef; } push @_, $arg if $arg; die "Unknown argument" . (@_==1?'':'s') . ": '" . join("', '", @_) . "'\n" if @_; die "Your readline lib doesn't support history!\n" unless $self->{term}->can('GetHistory'); # argh, this has evolved badly... seems to work though. my @history = $self->{term}->GetHistory(); my $where = @history; $num = @history if $num == -1 || $num > @history; @history = @history[@history-$num..$#history]; $where = $self->{term}->where_history() if $self->{term}->can('where_history'); my $i = $where - @history; for(@history) { print "$i: $_\n"; $i += 1; } } =back =head1 METHODS These are the routines that your application calls to create and use a Term::ShellUI object. Usually you simply call new() and then run() -- everything else is handled automatically. You only need to read this section if you wanted to do something out of the ordinary. =over 4 =item new Term::ShellUI(I>) Creates a new ShellUI object. It accepts the following named parameters: =over 3 =item app The name of this application (will be passed to L). Defaults to $0, the name of the current executable. =item term Usually Term::ShellUI uses its own Term::ReadLine object (created with C). However, if you can create a new Term::ReadLine object yourself and supply it using the term argument. =item blank_repeats_cmd This tells Term::ShellUI what to do when the user enters a blank line. Pass 0 (the default) to have it do nothing (like Bash), or 1 to have it repeat the last command (like GDB). =item commands A hashref containing all the commands that ShellUI will respond to. The format of this data structure can be found below in the L documentation. If you do not supply any commands to the constructor, you must call the L method to provide at least a minimal command set before using many of the following calls. You may add or delete commands or even change the entire command set at any time. =item history_file If defined then the command history is saved to this file on exit. It should probably specify a dotfile in the user's home directory. Tilde expansion is performed, so something like C<~/.myprog-history> is perfectly acceptable. =item history_max = 500 This tells how many items to save to the history file. The default is 500. Note that this parameter does not affect in-memory history. Term::ShellUI makes no attemt to cull history so you're at the mercy of the default of whatever ReadLine library you are using. See L for one way to change this. =item keep_quotes Normally all unescaped, unnecessary quote marks are stripped. If you specify C1>, however, they are preserved. This is useful if your application uses quotes to delimit, say, Perl-style strings. =item backslash_continues_command Normally commands don't respect backslash continuation. If you pass backslash_continues_command=>1 to L, then whenever a line ends with a backslash, Term::ShellUI will continue reading. The backslash is replaced with a space, so $ abc \ > def Will produce the command string 'abc def'. =item prompt This is the prompt that should be displayed for every request. It can be changed at any time using the L method. The default is S<<"$0> ">> (see L above). If you specify a code reference, then the coderef is executed and its return value is set as the prompt. Two arguments are passed to the coderef: the Term::ShellUI object, and the raw command. The raw command is always "" unless you're using command completion, where the raw command is the command line entered so far. For example, the following line sets the prompt to "## > " where ## is the current number of history items. $term->prompt(sub { $term->{term}->GetHistory() . " > " }); If you specify an arrayref, then the first item is the normal prompt and the second item is the prompt when the command is being continued. For instance, this would emulate Bash's behavior ($ is the normal prompt, but > is the prompt when continuing). $term->prompt(['$', '>']); Of course, you specify backslash_continues_command=>1 to to L to cause commands to continue. And, of course, you can use an array of procs too. $term->prompt([sub {'$'}, sub {'<'}]); =item token_chars This argument specifies the characters that should be considered tokens all by themselves. For instance, if I pass token_chars=>'=', then 'ab=123' would be parsed to ('ab', '=', '123'). Without token_chars, 'ab=123' remains a single string. NOTE: you cannot change token_chars after the constructor has been called! The regexps that use it are compiled once (m//o). =item display_summary_in_help Usually it's easier to have the command's summary (desc) printed first, then follow it with the documentation (doc). However, if the doc already contains its description (for instance, if you're reading it from a podfile), you don't want the summary up there too. Pass 0 to prevent printing the desc above the doc. Defaults to 1. =back =cut sub new { my $type = shift; my %args = ( app => $0, prompt => "$0> ", commands => undef, blank_repeats_cmd => 0, backslash_continues_command => 0, history_file => undef, history_max => 500, token_chars => '', keep_quotes => 0, debug_complete => 0, display_summary_in_help => 1, @_ ); my $self = {}; bless $self, $type; $self->{done} = 0; $self->{parser} = Text::Shellwords::Cursor->new( token_chars => $args{token_chars}, keep_quotes => $args{keep_quotes}, debug => 0, error => sub { shift; $self->error(@_); }, ); # expand tildes in the history file if($args{history_file}) { $args{history_file} =~ s/^~([^\/]*)/$1?(getpwnam($1))[7]: $ENV{HOME}||$ENV{LOGDIR}||(getpwuid($>))[7]/e; } for(keys %args) { next if $_ eq 'app'; # this param is not a member $self->{$_} = $args{$_}; } $self->{term} ||= new Term::ReadLine($args{'app'}); $self->{term}->MinLine(0); # manually call AddHistory my $attrs = $self->{term}->Attribs; # there appear to be catastrophic bugs with history_word_delimiters # it goes into an infinite loop when =,[] are in token_chars # $attrs->{history_word_delimiters} = " \t\n".$self->{token_chars}; $attrs->{completion_function} = sub { completion_function($self, @_); }; $self->{OUT} = $self->{term}->OUT || \*STDOUT; $self->{prevcmd} = ""; # cmd to run again if user hits return @{$self->{eof_exit_hooks}} = (); return $self; } =item process_a_cmd([cmd]) Runs the specified command or prompts for it if no arguments are supplied. Returns the result or undef if no command was called. =cut sub process_a_cmd { my ($self, $incmd) = @_; $self->{completeline} = ""; my $OUT = $self->{'OUT'}; my $rawline = ""; if($incmd) { $rawline = $incmd; } else { INPUT_LOOP: for(;;) { my $prompt = $self->prompt(); $prompt = $prompt->[length $rawline ? 1 : 0] if ref $prompt eq 'ARRAY'; $prompt = $prompt->($self, $rawline) if ref $prompt eq 'CODE'; my $newline = $self->{term}->readline($prompt); # EOF exits unless(defined $newline) { # If we have eof_exit_hooks let them have a say if(scalar(@{$self->{eof_exit_hooks}})) { foreach my $sub (@{$self->{eof_exit_hooks}}) { if(&$sub()) { next INPUT_LOOP; } } } print $OUT "\n"; $self->exit_requested(1); return undef; } my $continued = ($newline =~ s/\\$//); $rawline .= (length $rawline ? " " : "") . $newline; last unless $self->{backslash_continues_command} && $continued; } } # is it a blank line? if($rawline =~ /^\s*$/) { $rawline = $self->blank_line(); return unless defined $rawline && $rawline !~ /^\s*$/; } my $tokens; my $expcode = 0; my $retval = undef; my $str = $rawline; my $save_to_history = 1; ($tokens) = $self->{parser}->parse_line($rawline, messages=>1); if(defined $tokens) { $str = $self->{parser}->join_line($tokens); if($expcode == 2) { # user did an expansion that asked to be printed only print $OUT "$str\n"; } else { print $OUT "$str\n" if $expcode == 1; my($cset, $cmd, $cname, $args) = $self->get_deep_command($self->commands(), $tokens); # this is a subset of the cmpl data structure my $parms = { cset => $cset, cmd => $cmd, cname => $cname, args => $args, tokens => $tokens, rawline => $rawline, }; $retval = $self->call_command($parms); if(exists $cmd->{exclude_from_history}) { $save_to_history = 0; } } } # Add to history unless it's a dupe of the previous command. if($save_to_history && $str ne $self->{prevcmd}) { $self->{term}->addhistory($str); } $self->{prevcmd} = $str; return $retval; } =item run() The main loop. Processes all commands until someone calls C(true)>. If you pass arguments, they are joined and run once. For instance, $term->run(@ARGV) allows your program to be run interactively or noninteractively: =over =item myshell help Runs the help command and exits. =item myshell Invokes an interactive Term::ShellUI. =back =cut sub run { my $self = shift; my $incmd = join " ", @_; $self->load_history(); $self->getset('done', 0); while(!$self->{done}) { $self->process_a_cmd($incmd); last if $incmd; # only loop if we're prompting for commands } $self->save_history(); } # This is a utility function that implements a getter/setter. # Pass the field to modify for $self, and the new value for that # field (if any) in $new. sub getset { my $self = shift; my $field = shift; my $new = shift; # optional my $old = $self->{$field}; $self->{$field} = $new if defined $new; return $old; } =item prompt(newprompt) If supplied with an argument, this method sets the command-line prompt. Returns the old prompt. =cut sub prompt { return shift->getset('prompt', shift); } =item commands(newcmds) If supplied with an argument, it sets the current command set. This can be used to change the command set at any time. Returns the old command set. =cut sub commands { return shift->getset('commands', shift); } =item add_commands(newcmds) Takes a command set as its first argument. Adds all the commands in it the current command set. It silently replaces any commands that have the same name. =cut sub add_commands { my $self = shift; my $cmds = shift; my $cset = $self->commands() || {}; for (keys %$cmds) { $cset->{$_} = $cmds->{$_}; } } =item exit_requested(exitflag) If supplied with an argument, sets Term::ShellUI's finished flag to the argument (1=exit, 0=don't exit). So, to get the interpreter to exit at the end of processing the current command, call C<$self-Eexit_requested(1)>. To cancel an exit request before the command is finished, C<$self-Eexit_requested(0)>. Returns the old state of the flag. =cut sub exit_requested { return shift->getset('done', shift); } =item add_eof_exit_hook(subroutine_reference) Call this method to add a subroutine as a hook into Term::ShellUI's "exit on EOF" (Ctrl-D) functionality. When a user enters Ctrl-D, Term::ShellUI will call each function in this hook list, in order, and will exit only if all of them return 0. The first function to return a non-zero value will stop further processing of these hooks and prevent the program from exiting. The return value of this method is the placement of the hook routine in the hook list (1 is first) or 0 (zero) on failure. =cut sub add_eof_exit_hook { my $self = shift @_; my $refcode = shift @_; if(ref($refcode) eq 'CODE') { push(@{$self->{eof_exit_hooks}}, $refcode); return scalar @{$self->{eof_exit_hooks}}; } return 0; } =item get_cname(cname) This is a tiny utility function that turns the cname (array ref of names for this command as returned by L) into a human-readable string. This function exists only to ensure that we do this consistently. =cut sub get_cname { my $self = shift; my $cname = shift; return join(" ", @$cname); } =back =head1 OVERRIDES These are routines that probably already do the right thing. If not, however, they are designed to be overridden. =over =item blank_line() This routine is called when the user inputs a blank line. It returns a string specifying the command to run or undef if nothing should happen. By default, ShellUI simply presents another command line. Pass C1> to L to get ShellUI to repeat the previous command. Override this method to supply your own behavior. =cut sub blank_line { my $self = shift; if($self->{blank_repeats_cmd}) { my $OUT = $self->{OUT}; print $OUT $self->{prevcmd}, "\n"; return $self->{prevcmd}; } return undef; } =item error(msg) Called when an error occurrs. By default, the routine simply prints the msg to stderr. Override it to change this behavior. It takes any number of arguments, cocatenates them together and prints them to stderr. =cut sub error { my $self = shift; print STDERR @_; } =back =head1 WRITING A COMPLETION ROUTINE Term::ReadLine makes writing a completion routine a notoriously difficult task. Term::ShellUI goes out of its way to make it as easy as possible. The best way to write a completion routine is to start with one that already does something similar to what you want (see the L section for the completion routines that come with ShellUI). Your routine returns an arrayref of possible completions, a string conaining a short but helpful note, or undef if an error prevented any completions from being generated. Return an empty array if there are simply no applicable competions. Be careful; the distinction between no completions and an error can be significant. Your routine takes two arguments: a reference to the ShellUI object and cmpl, a data structure that contains all the information you need to calculate the completions. Set $term->{debug_complete}=5 to see the contents of cmpl: =over 3 =item str The exact string that needs completion. Often, for simple completions, you don't need anything more than this. NOTE: str does I respect token_chars! It is supplied unchanged from Readline and so uses whatever tokenizing it implements. Unfortunately, if you've changed token_chars, this will often be different from how Term::ShellUI would tokenize the same string. =item cset Command set for the deepest command found (see L). If no command was found then cset is set to the topmost command set ($self->commands()). =item cmd The command hash for deepest command found or undef if no command was found (see L). cset is the command set that contains cmd. =item cname The full name of deepest command found as an array of tokens (see L). Use L to convert this into a human-readable string. =item args The arguments (as a list of tokens) that should be passed to the command (see L). Valid only if cmd is non-null. Undef if no args were passed. =item argno The index of the argument (in args) containing the cursor. If the user is trying to complete on the command name, then argno is negative (because the cursor comes before the arguments). =item tokens The tokenized command-line. =item tokno The index of the token containing the cursor. =item tokoff The character offset of the cursor in the token. For instance, if the cursor is on the first character of the third token, tokno will be 2 and tokoff will be 0. =item twice True if user has hit tab twice in a row. This usually means that you should print a message explaining the possible completions. If you return your completions as a list, then $twice is handled for you automatically. You could use it, for instance, to display an error message (using L) telling why no completions could be found. =item rawline The command line as a string, exactly as entered by the user. =item rawstart The character position of the cursor in rawline. =back The following are utility routines that your completion function can call. =over =item completemsg(msg) Allows your completion routine to print to the screen while completing (i.e. to offer suggestions or print debugging info -- see debug_complete). If it just blindly calls print, the prompt will be corrupted and things will be confusing until the user redraws the screen (probably by hitting Control-L). $self->completemsg("You cannot complete here!\n"); Note that Term::ReadLine::Perl doesn't support this so the user will always have to hit Control-L after printing. If your completion routine returns a string rather than calling completemsg() then it should work everywhere. =cut sub completemsg { my $self = shift; my $msg = shift; my $OUT = $self->{OUT}; print $OUT $msg; # Now we need to tell the readline library to redraw the entire # command line. Term::ReadLine::Gnu offers rl_on_new_line() but, # because it's XS, it can't be detected using can(). # So, we just eval it and ignore any errors. If it doesn't exist # then the prompt is corrupted. Oh well, best we can do! eval { $self->{term}->rl_on_new_line() }; } =item suppress_completion_append_character() When the ReadLine library finds a unique match among the list that you returned, it automatically appends a space. Normally this is what you want (i.e. when completing a command name, in help, etc.) However, if you're navigating the filesystem, this is definitely not desirable (picture having to hit backspace after completing each directory). Your completion function needs to call this routine every time it runs if it doesn't want a space automatically appended to the completions that it returns. =cut sub suppress_completion_append_character { shift->{term}->Attribs->{completion_suppress_append} = 1; } =item suppress_completion_escape() Normally everything returned by your completion routine is escaped so that it doesn't get destroyed by shell metacharacter interpretation (quotes, backslashes, etc). To avoid escaping twice (disastrous), a completion routine that does its own escaping (perhaps using Lparse_escape) must call suppress_completion_escape every time is called. =cut sub suppress_completion_escape { shift->{suppress_completion_escape} = 1; } =item force_to_string(cmpl, commmpletions, default_quote) If all the completions returned by your completion routine should be enclosed in single or double quotes, call force_to_string on them. You will most likely need this routine if L is 1. This is useful when completing a construct that you know must always be quoted. force_to_string surrounds all completions with the quotes supplied by the user or, if the user didn't supply any quotes, the quote passed in default_quote. If the programmer didn't supply a default_quote and the user didn't start the token with an open quote, then force_to_string won't change anything. Here's how to use it to force strings on two possible completions, aaa and bbb. If the user doesn't supply any quotes, the completions will be surrounded by double quotes. args => sub { shift->force_to_string(@_,['aaa','bbb'],'"') }, Calling force_to_string escapes your completions (unless your callback calls suppress_completion_escape itself), then calls suppress_completion_escape to ensure the final quote isn't mangled. =cut sub force_to_string { my $self = shift; my $cmpl = shift; my $results = shift; my $bq = shift; # optional: this is the default quote to use if none my $fq = $bq; my $try = substr($cmpl->{rawline}, $cmpl->{rawstart}-1, 1); if($try eq '"' || $try eq "'") { $fq = ''; $bq = $try; } if($bq) { $self->{parser}->parse_escape($results) unless $self->{suppress_completion_escape}; for(@$results) { $_ = "$fq$_$bq"; } $self->suppress_completion_escape(); } return $results; } =back =head1 INTERNALS These commands are internal to ShellUI. They are documented here only for completeness -- you should never need to call them. =over =item get_deep_command Looks up the supplied command line in a command hash. Follows all synonyms and subcommands. Returns undef if the command could not be found. my($cset, $cmd, $cname, $args) = $self->get_deep_command($self->commands(), $tokens); This call takes two arguments: =over 3 =item cset This is the command set to use. Pass $self->commands() unless you know exactly what you're doing. =item tokens This is the command line that the command should be read from. It is a reference to an array that has already been split on whitespace using L. =back and it returns a list of 4 values: =over 3 =item 1. cset: the deepest command set found. Always returned. =item 2. cmd: the command hash for the command. Undef if no command was found. =item 3. cname: the full name of the command. This is an array of tokens, i.e. ('show', 'info'). Returns as deep as it could find commands even if the final command was not found. =item 4. args: the command's arguments (all remaining tokens after the command is found). =back =cut sub get_deep_command { my $self = shift; my $cset = shift; my $tokens = shift; my $curtok = shift || 0; # points to the command name #print "DBG get_deep_cmd: $#$tokens tokens: '" . join("', '", @$tokens) . "'\n"; #print "DBG cset: (" . join(", ", keys %$cset) . ")\n"; my $name = $tokens->[$curtok]; # loop through all synonyms to find the actual command while(exists($cset->{$name}) && ( exists($cset->{$name}->{'alias'}) || exists($cset->{$name}->{'syn'}) )) { $name = $cset->{$name}->{'alias'} || $cset->{$name}->{'syn'}; } my $cmd = $cset->{$name}; # update the tokens with the actual name of this command $tokens->[$curtok] = $name; # should we recurse into subcommands? #print "$cmd " . exists($cmd->{'subcmds'}) . " (" . join(",", keys %$cmd) . ") $curtok < $#$tokens\n"; if($cmd && exists($cmd->{cmds}) && $curtok < $#$tokens) { #print "doing subcmd\n"; my $subname = $tokens->[$curtok+1]; my $subcmds = $cmd->{cmds}; return $self->get_deep_command($subcmds, $tokens, $curtok+1); } #print "DBG splitting (" . join(",",@$tokens) . ") at curtok=$curtok\n"; # split deep command name and its arguments into separate lists my @cname = @$tokens; my @args = ($#cname > $curtok ? splice(@cname, $curtok+1) : ()); #print "DBG tokens (" . join(",",@$tokens) . ")\n"; #print "DBG cname (" . join(",",@cname) . ")\n"; #print "DBG args (" . join(",",@args) . ")\n"; return ($cset, $cmd, \@cname, \@args); } =item get_cset_completions(cset) Returns a list of commands from the passed command set that are suitable for completing. =cut sub get_cset_completions { my $self = shift; my $cset = shift; # return all commands that aren't exluded from the completion # also exclude the default command ''. my @c = grep {$_ ne '' && !exists $cset->{$_}->{exclude_from_completion}} keys(%$cset); return \@c; } =item call_args Given a command set, does the correct thing at this stage in the completion (a surprisingly nontrivial task thanks to ShellUI's flexibility). Called by complete(). =cut sub call_args { my $self = shift; my $cmpl = shift; my $cmd = $cmpl->{cmd}; my $retval; if(exists($cmd->{args})) { if(ref($cmd->{args}) eq 'CODE') { $retval = eval { &{$cmd->{args}}($self, $cmpl) }; $self->completemsg($@) if $@; } elsif(ref($cmd->{args}) eq 'ARRAY') { # each element in array is a string describing corresponding argument my $args = $cmd->{args}; my $argno = $cmpl->{argno}; # repeat last arg indefinitely (use maxargs to stop) $argno = $#$args if $#$args < $argno; my $arg = $args->[$argno]; if(defined $arg) { if(ref($arg) eq 'CODE') { # it's a routine to call for this particular arg $retval = eval { &$arg($self, $cmpl) }; $self->completemsg($@) if $@; } elsif(ref($arg) eq 'ARRAY') { # it's an array of possible completions $retval = @$arg; } else { # it's a string reiminder of what this arg is meant to be $self->completemsg("$arg\n") if $cmpl->{twice}; } } } elsif(ref($cmd->{args}) eq 'HASH') { # not supported yet! (if ever...) } else { # this must be a string describing all arguments. $self->completemsg($cmd->{args} . "\n") if $cmpl->{twice}; } } return $retval; } =item complete This routine figures out the command set of the completion routine that needs to be called, then calls call_args(). It is called by completion_function. You should override this routine if your application has custom completion needs (like non-trivial tokenizing, where you'll need to modify the cmpl data structure). If you override this routine, you will probably need to override L as well. =cut sub complete { my $self = shift; my $cmpl = shift; my $cset = $cmpl->{cset}; my $cmd = $cmpl->{cmd}; my $cr; if($cmpl->{tokno} < @{$cmpl->{cname}}) { # if we're still in the command, return possible command completions # make sure to still call the default arg handler of course $cr = $self->get_cset_completions($cset); # fix suggested by Erick Calder $cr = [ grep {/^$cmpl->{str}/ && $_} @$cr ]; } if($cr || !defined $cmd) { # call default argument handler if it exists if(exists $cset->{''}) { my %c2 = %$cmpl; $c2{cmd} = $cset->{''}; my $r2 = $self->call_args(\%c2); push @$cr, @$r2 if $r2; } return $cr; } # don't complete if user has gone past max # of args return () if exists($cmd->{maxargs}) && $cmpl->{argno} >= $cmd->{maxargs}; # everything checks out -- call the command's argument handler return $self->call_args($cmpl); } =item completion_function This is the entrypoint to the ReadLine completion callback. It sets up a bunch of data, then calls L to calculate the actual completion. To watch and debug the completion process, you can set $self->{debug_complete} to 2 (print tokenizing), 3 (print tokenizing and results) or 4 (print everything including the cmpl data structure). Youu should never need to call or override this function. If you do (but, trust me, you don't), set $self->{term}->Attribs->{completion_function} to point to your own routine. See the L documentation for a description of the arguments. =cut sub completion_function { my $self = shift; my $text = shift; # the word directly to the left of the cursor my $line = shift; # the entire line my $start = shift; # the position in the line of the beginning of $text my $cursor = $start + length($text); # reset the suppress_append flag # completion routine must set it every time it's called $self->{term}->Attribs->{completion_suppress_append} = 0; $self->{suppress_completion_escape} = 0; # Twice is true if the user has hit tab twice on the same string my $twice = ($self->{completeline} eq $line); $self->{completeline} = $line; my($tokens, $tokno, $tokoff) = $self->{parser}->parse_line($line, messages=>0, cursorpos=>$cursor, fixclosequote=>1); return unless defined($tokens); # this just prints a whole bunch of completion/parsing debugging info if($self->{debug_complete} >= 1) { print "\ntext='$text', line='$line', start=$start, cursor=$cursor"; print "\ntokens=(", join(", ", @$tokens), ") tokno=" . (defined($tokno) ? $tokno : 'undef') . " tokoff=" . (defined($tokoff) ? $tokoff : 'undef'); print "\n"; my $str = " "; print "<"; my $i = 0; for(@$tokens) { my $s = (" " x length($_)) . " "; substr($s,$tokoff,1) = '^' if $i eq $tokno; $str .= $s; print $_; print ">"; $str .= " ", print ", <" if $i != $#$tokens; $i += 1; } $self->completemsg("\n$str\n"); } my $str = $text; my($cset, $cmd, $cname, $args) = $self->get_deep_command($self->commands(), $tokens); # this structure hopefully contains everything you'll ever # need to easily compute a match. my $cmpl = { str => $str, # the exact string that needs completion # (usually, you don't need anything more than this) cset => $cset, # cset of the deepest command found cmd => $cmd, # the deepest command or undef cname => $cname, # full name of deepest command args => $args, # anything that was determined to be an argument. argno => $tokno - @$cname, # the argument containing the cursor tokens => $tokens, # tokenized command-line (arrayref). tokno => $tokno, # the index of the token containing the cursor tokoff => $tokoff, # the character offset of the cursor in $tokno. twice => $twice, # true if user has hit tab twice in a row rawline => $line, # pre-tokenized command line rawstart => $start, # position in rawline of the start of str rawcursor => $cursor, # position in rawline of the cursor (end of str) }; if($self->{debug_complete} >= 3) { print "tokens=(" . join(",", @$tokens) . ") tokno=$tokno tokoff=$tokoff str=$str twice=$twice\n"; print "cset=$cset cmd=" . (defined($cmd) ? $cmd : "(undef)") . " cname=(" . join(",", @$cname) . ") args=(" . join(",", @$args) . ") argno=".$cmpl->{argno}."\n"; print "rawline='$line' rawstart=$start rawcursor=$cursor\n"; } my $retval = $self->complete($cmpl); $retval = [] unless defined($retval); unless(ref($retval) eq 'ARRAY') { $self->completemsg("$retval\n") if $cmpl->{twice}; $retval = []; } if($self->{debug_complete} >= 2) { print "returning (", join(", ", @$retval), ")\n"; } # escape the completions so they're valid on the command line $self->{parser}->parse_escape($retval) unless $self->{suppress_completion_escape}; return @$retval; } # Converts a field name into a text string. # All fields can be code, if so, then they're called to return string value. # You need to ensure that the field exists before calling this routine. sub get_field { my $self = shift; my $cmd = shift; my $field = shift; my $args = shift; my $val = $cmd->{$field}; if(ref($val) eq 'CODE') { $val = eval { &$val($self, $cmd, @$args) }; $self->error($@) if $@; } return $val; } =item get_cmd_summary(tokens, cset) Prints a one-line summary for the given command. Uses self->commands() if cset is not specified. =cut sub get_cmd_summary { my $self = shift; my $tokens = shift; my $topcset = shift || $self->commands(); # print "DBG print_cmd_summary: cmd=$cmd args=(" . join(", ", @$args), ")\n"; my($cset, $cmd, $cname, $args) = $self->get_deep_command($topcset, $tokens); my $desc; if(!$cmd) { if(exists $topcset->{''}) { $cmd = $topcset->{''}; } else { return $self->get_cname($cname) . " doesn't exist.\n"; } } $desc = $self->get_field($cmd, 'desc', $args) || "(no description)"; return sprintf("%20s -- $desc\n", $self->get_cname($cname)); } =item get_cmd_help(tokens, cset) Prints the full help text for the given command. Uses self->commands() if cset is not specified. =cut sub get_cmd_help { my $self = shift; my $tokens = shift; my $topcset = shift || $self->commands(); my $str = ""; # print "DBG print_cmd_help: cmd=$cmd args=(" . join(", ", @$args), ")\n"; my($cset, $cmd, $cname, $args) = $self->get_deep_command($topcset, $tokens); if(!$cmd) { if(exists $topcset->{''}) { $cmd = $topcset->{''}; } else { return $self->get_cname($cname) . " doesn't exist.\n"; } } if($self->{display_summary_in_help}) { if(exists($cmd->{desc})) { $str .= $self->get_cname($cname).": ".$self->get_field($cmd,'desc',$args)."\n"; } else { $str .= "No description for " . $self->get_cname($cname) . "\n"; } } if(exists($cmd->{doc})) { $str .= $self->get_field($cmd, 'doc', [$self->get_cname($cname), @$args]); } elsif(exists($cmd->{cmds})) { $str .= $self->get_all_cmd_summaries($cmd->{cmds}); } else { # no data -- do nothing } return $str; } =item get_category_summary(name, cats) Prints a one-line summary for the named category in the category hash specified in cats. =cut sub get_category_summary { my $self = shift; my $name = shift; my $cat = shift; my $title = $cat->{desc} || "(no description)"; return sprintf("%20s -- $title\n", $name); } =item get_category_help(cat, cset) Returns a summary of the commands listed in cat. You must pass the command set that contains those commands in cset. =cut sub get_category_help { my $self = shift; my $cat = shift; my $cset = shift; my $str .= "\n" . $cat->{desc} . "\n\n"; for my $name (@{$cat->{cmds}}) { my @line = split /\s+/, $name; $str .= $self->get_cmd_summary(\@line, $cset); } $str .= "\n"; return $str; } =item get_all_cmd_summaries(cset) Pass it a command set, and it will return a string containing the summaries for each command in the set. =cut sub get_all_cmd_summaries { my $self = shift; my $cset = shift; my $str = ""; for(sort keys(%$cset)) { # we now exclude synonyms from the command summaries. # hopefully this is the right thing to do...? next if exists $cset->{$_}->{alias} || exists $cset->{$_}->{syn}; # don't show the default command in any summaries next if $_ eq ''; $str .= $self->get_cmd_summary([$_], $cset); } return $str; } =item load_history() If $self->{history_file} is set (see L), this will load all history from that file. Called by L on startup. If you don't use run, you will need to call this command manually. =cut sub load_history { my $self = shift; return unless $self->{history_file} && $self->{history_max} > 0; if(open HIST, '<'.$self->{history_file}) { while() { chomp(); next unless /\S/; $self->{term}->addhistory($_); } close HIST; } } =item save_history() If $self->{history_file} is set (see L), this will save all history to that file. Called by L on shutdown. If you don't use run, you will need to call this command manually. The history routines don't use ReadHistory and WriteHistory so they can be used even if other ReadLine libs are being used. save_history requires that the ReadLine lib supply a GetHistory call. =cut sub save_history { my $self = shift; return unless $self->{history_file} && $self->{history_max} > 0; return unless $self->{term}->can('GetHistory'); if(open HIST, '>'.$self->{history_file}) { local $, = "\n"; my @list = $self->{term}->GetHistory(); if(@list) { my $max = $#list; $max = $self->{history_max}-1 if $self->{history_max}-1 < $max; print HIST @list[$#list-$max..$#list]; print HIST "\n"; } close HIST; } else { $self->error("Could not open ".$self->{history_file}." for writing $!\n"); } } =item call_command(parms) Executes a command and returns the result. It takes a single argument: the parms data structure. parms is a subset of the cmpl data structure (see the L routine for more). Briefly, it contains: cset, cmd, cname, args (see L), tokens and rawline (the tokenized and untokenized command lines). See L for full descriptions of these fields. This call should be overridden if you have exotic command processing needs. If you override this routine, you will probably need to override the L routine too. =cut # This is the low-level version of call_command. It does nothing but call. # Use call_command -- it's much smarter. sub call_cmd { my $self = shift; my $parms = shift; my $cmd = $parms->{cmd}; my $OUT = $self->{OUT}; my $retval = undef; if(exists $cmd->{meth} || exists $cmd->{method}) { my $meth = $cmd->{meth} || $cmd->{method}; # if meth is a code ref, call it, else it's a string, print it. if(ref($meth) eq 'CODE') { $retval = eval { &$meth($self, $parms, @{$parms->{args}}) }; $self->error($@) if $@; } else { print $OUT $meth; } } elsif(exists $cmd->{proc}) { # if proc is a code ref, call it, else it's a string, print it. if(ref($cmd->{proc}) eq 'CODE') { $retval = eval { &{$cmd->{proc}}(@{$parms->{args}}) }; $self->error($@) if $@; } else { print $OUT $cmd->{proc}; } } else { if(exists $cmd->{cmds}) { # if not, but it has subcommands, then print a summary print $OUT $self->get_all_cmd_summaries($cmd->{cmds}); } else { $self->error("The ". $self->get_cname($parms->{cname}) . " command has no proc or method to call!\n"); } } return $retval; } sub call_command { my $self = shift; my $parms = shift; if(!$parms->{cmd}) { if( exists $parms->{cset}->{''} && (exists($parms->{cset}->{''}->{proc}) || exists($parms->{cset}->{''}->{meth}) || exists($parms->{cset}->{''}->{method}) ) ) { # default command exists and is callable my $save = $parms->{cmd}; $parms->{cmd} = $parms->{cset}->{''}; my $retval = $self->call_cmd($parms); $parms->{cmd} = $save; return $retval; } $self->error( $self->get_cname($parms->{cname}) . ": unknown command\n"); return undef; } my $cmd = $parms->{cmd}; # check min and max args if they exist if(exists($cmd->{minargs}) && @{$parms->{args}} < $cmd->{minargs}) { $self->error("Too few args! " . $cmd->{minargs} . " minimum.\n"); return undef; } if(exists($cmd->{maxargs}) && @{$parms->{args}} > $cmd->{maxargs}) { $self->error("Too many args! " . $cmd->{maxargs} . " maximum.\n"); return undef; } # everything checks out -- call the command return $self->call_cmd($parms); } =back =head1 LICENSE Copyright (c) 2003-2011 Scott Bronson, all rights reserved. This program is free software released under the MIT license. =head1 AUTHORS Scott Bronson Ebronson@rinspin.comE Lester Hightower Ehightowe@cpan.orgE Ryan Gies Eryan@livesite.netE Martin Kluge Emk@elxsi.deE =cut 1; Term-ShellUI-0.92/README0000644000175000017500000000352211713017754014470 0ustar bronsonbronson Term::ShellUI Term::ShellUI makes it easy to implement a comprehensive Bash or GDB-like command line user interface. It supports history, autocompletion, quoting, escaping, pretty much everything you would expect of a decent shell. Homepage: http://github.com/bronson/Term-ShellUI CPAN: http://search.cpan.org/search?query=Term%3A%3AShellUI CODE Git: git clone git://github.com/bronson/Term-ShellUI.git Svn: svn co http://svn.github.com/bronson/Term-ShellUI.git Term-ShellUI PREREQUISITES None! It runs just fine with Perl's default Term::ReadLine. However, unless you install Term::ReadLine::GNU, basic functionality like completion, line editing, and history will not work. If you're on Windows then Term::ReadLine::Perl will be easier to install and work almost as well. The only limitation is that it can't print hints for the user during completion (the completemsg call). INSTALLATION perl Makefile.PL make make test make install USAGE Run examples/synopsis-big. Type 'help' to display the available commands or 'help exists' to show detailed help for the exists command. Notice how everything can be tab-completed. Try passing the wrong number of arguments to a command. Scroll back through history using the up arrow or Control-R. Also try using the history command. Run 'perldoc lib/Term/ShellUI.pm' to see the API documentation. Report bugs and submit patches via GitHub. ALTERNATIVES Term::CiscoCLI http://ciscocli.sourceforge.net/ A fork/rewrite to make the command line feel like a Cisco (Stanford) style CLI. Also adds a bunch of useful features. Term::TUI Presents a hierarchical command line interface. LICENSE Copyright (c) 2003-2011 Scott Bronson, all rights reserved. All the code in this archive is covered by the MIT license. AUTHOR Scott Bronson bronson@rinspin.com Term-ShellUI-0.92/Makefile.PL0000644000175000017500000000025211713017754015557 0ustar bronsonbronsonuse ExtUtils::MakeMaker; WriteMakefile( NAME => "Term::ShellUI", AUTHOR => 'Scott Bronson (brons_cpan@rinspin.com)', VERSION_FROM => 'lib/Term/ShellUI.pm' ); Term-ShellUI-0.92/META.yml0000664000175000017500000000077711713021206015057 0ustar bronsonbronson--- #YAML:1.0 name: Term-ShellUI version: 0.92 abstract: ~ author: - Scott Bronson (brons_cpan@rinspin.com) license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: {} no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4