home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _fdaed7ce8771461a862596ff32ffa264 < prev    next >
Encoding:
Text File  |  2004-06-01  |  23.4 KB  |  907 lines
  1. package PPM::Term::Shell;
  2.  
  3. use strict;
  4. use Data::Dumper;
  5. use Term::ReadLine;
  6. use vars qw($VERSION);
  7.  
  8. $VERSION = '0.02';
  9.  
  10. #=============================================================================
  11. # Term::Shell API methods
  12. #=============================================================================
  13. sub new {
  14.     my $cls = shift;
  15.     my %args = (
  16.     term => ['shell'],
  17.     pager => 'internal',
  18.     @_,
  19.     );
  20.     my $o = bless {
  21.     term    => eval {
  22.         Term::ReadLine->new(@{$args{term}});
  23.     } || undef,
  24.     }, ref($cls) || $cls;
  25.  
  26.     # Set up the API hash:
  27.     $o->{command} = {};
  28.     $o->{API} = {
  29.     args        => \%args,
  30.     case_ignore    => ($^O eq 'MSWin32' ? 1 : 0),
  31.     check_idle    => 0,    # changing this isn't supported
  32.     class        => $cls,
  33.     command        => $o->{command},
  34.     cmd        => $o->{command}, # shorthand
  35.     match_uniq    => 1,
  36.     pager        => $args{pager},
  37.     readline    => eval { $o->term->ReadLine } || 'none',
  38.     script        => (caller(0))[1],
  39.     version        => $VERSION,
  40.     };
  41.  
  42.     # Note: the rl_completion_function doesn't pass an object as the first
  43.     # argument, so we have to use a closure. This has the unfortunate effect
  44.     # of preventing two instances of Term::ReadLine from coexisting.
  45.     my $completion_handler = sub {
  46.     $o->rl_complete(@_);
  47.     };
  48.     if ($o->{API}{readline} eq 'Term::ReadLine::Gnu') {
  49.     my $attribs = $o->term->Attribs;
  50.     $attribs->{completion_function} = $completion_handler;
  51.     }
  52.     elsif ($o->{API}{readline} eq 'Term::ReadLine::Perl') {
  53.     $readline::rl_completion_function = 
  54.     $readline::rl_completion_function = $completion_handler;
  55.     }
  56.     $o->find_handlers;
  57.     $o->init;
  58.     $o;
  59. }
  60.  
  61. sub DESTROY {
  62.     my $o = shift;
  63.     $o->fini;
  64. }
  65.  
  66. sub cmd {
  67.     my $o = shift;
  68.     $o->{line} = shift;
  69.     if ($o->line =~ /\S/) {
  70.     my ($cmd, @args) = $o->line_parsed;
  71.     $o->run($cmd, @args);
  72.     unless ($o->{command}{run}{found}) {
  73.         my @c = sort $o->possible_actions($cmd, 'run', 1);
  74.         if (@c) {
  75.         print $o->msg_ambiguous_cmd($cmd, @c);
  76.         }
  77.         else {
  78.         print $o->msg_unknown_cmd($cmd);
  79.         }
  80.     }
  81.     }
  82.     else {
  83.     $o->run('');
  84.     }
  85. }
  86.  
  87. sub stoploop { $_[0]->{stop}++ }
  88. sub cmdloop {
  89.     my $o = shift;
  90.     $o->{stop} = 0;
  91.     $o->preloop;
  92.     while (defined (my $line = $o->readline($o->prompt_str))) {
  93.     $o->cmd($line);
  94.     last if $o->{stop};
  95.     }
  96.     $o->postloop;
  97. }
  98. *mainloop = \&cmdloop;
  99.  
  100. sub readline {
  101.     my $o = shift;
  102.     my $prompt = shift;
  103.     return $o->term->readline($prompt)
  104.     if $o->{API}{check_idle} == 0
  105.         or not defined $o->term->IN;
  106.  
  107.     # They've asked for idle-time running of some user command.
  108.     local $Term::ReadLine::toloop = 1;
  109.     local *Tk::fileevent = sub {
  110.     my $cls = shift;
  111.     my ($file, $boring, $callback) = @_;
  112.     $o->{fh} = $file;    # save the filehandle!
  113.     $o->{cb} = $callback;    # save the callback!
  114.     };
  115.     local *Tk::DoOneEvent = sub {
  116.     # We'll totally cheat and do a select() here -- the timeout will be
  117.     # $o->{API}{check_idle}; if the handle is ready, we'll call &$cb;
  118.     # otherwise we'll call $o->idle(), which can do some processing.
  119.     my $timeout = $o->{API}{check_idle};
  120.     use IO::Select;
  121.     if (IO::Select->new($o->{fh})->can_read($timeout)) {
  122.         # Input is ready: stop the event loop.
  123.         $o->{cb}->();
  124.     }
  125.     else {
  126.         $o->idle;
  127.     }
  128.     };
  129.     $o->term->readline($prompt);
  130. }
  131.  
  132. sub term { $_[0]->{term} }
  133.  
  134. # These are likely candidates for overriding in subclasses
  135. sub init { }        # called last in the ctor
  136. sub fini { }        # called first in the dtor
  137. sub preloop { }
  138. sub postloop { }
  139. sub precmd { }
  140. sub postcmd { }
  141. sub prompt_str { 'shell> ' }
  142. sub idle { }
  143. sub cmd_prefix { '' }
  144. sub cmd_suffix { '' }
  145.  
  146. #=============================================================================
  147. # The pager
  148. #=============================================================================
  149. sub page {
  150.     my $o         = shift;
  151.     my $text      = shift;
  152.     my $terminfo  = $o->termsize;
  153.     my $maxlines  = shift || $terminfo->{rows};
  154.     my $pager     = $o->{API}{pager};
  155.  
  156.     # First, wrap the text to the width of the screen (so our line-count is
  157.     # correct):
  158.     eval {
  159.     require Text::Wrap;
  160.     Text::Wrap->import('wrap');
  161.     local $Text::Wrap::columns = $terminfo->{cols};
  162.     $text = wrap('', '', $text);
  163.     };
  164.  
  165.     # Count the number of lines in the text:
  166.     my $lines = ($text =~ tr/\n//);
  167.  
  168.     # If there are fewer lines than the page-lines, just print it.
  169.     if ($lines < $maxlines or $maxlines == 0 or $pager eq 'none') {
  170.     print $text;
  171.     }
  172.     # If there are more, page it, either using the external pager...
  173.     elsif ($pager and $pager ne 'internal') {
  174.     require File::Temp;
  175.     my ($handle, $name) = File::Temp::tempfile();
  176.     select((select($handle), $| = 1)[0]);
  177.     print $handle $text;
  178.     close $handle;
  179.     system($pager, $name) == 0
  180.         or print <<END;
  181. Warning: can't run external pager '$pager': $!.
  182. END
  183.     unlink $name;
  184.     }
  185.     # ... or the internal one
  186.     else {
  187.     my $togo = $lines;
  188.     my $line = 0;
  189.     my @lines = split '^', $text;
  190.     while ($togo > 0) {
  191.         my @text = @lines[$line .. $#lines];
  192.         my $ret = $o->page_internal(\@text, $maxlines, $togo, $line);
  193.         last if $ret == -1;
  194.         $line += $ret;
  195.         $togo -= $ret;
  196.     }
  197.     return $line;
  198.     }
  199.     return $lines
  200. }
  201.  
  202. sub page_internal {
  203.     my $o           = shift;
  204.     my $lines       = shift;
  205.     my $maxlines    = shift;
  206.     my $togo        = shift;
  207.     my $start       = shift;
  208.  
  209.     my $line = 1;
  210.     local $| = 1;
  211.     while ($_ = shift @$lines) {
  212.     print;
  213.     last if $line >= ($maxlines - 1); # leave room for the prompt
  214.     $line++;
  215.     }
  216.     my $lines_left = $togo - $line;
  217.     my $current_line = $start + $line;
  218.     my $total_lines = $togo + $start;
  219.  
  220.     my $instructions;
  221.     if ($o->have_readkey) {
  222.     $instructions = "any key for more, or q to quit";
  223.     }
  224.     else {
  225.     $instructions = "enter for more, or q to quit";
  226.     }
  227.     
  228.     if ($lines_left > 0) {
  229.     local $| = 1;
  230.     my $l = "---line $current_line/$total_lines ($instructions)---";
  231.     my $b = ' ' x length($l);
  232.     print $l;
  233.     my $ans = $o->readkey;
  234.     print "\r$b\r" if $o->have_readkey();
  235.     print "\n" if $ans =~ /q/i or not $o->have_readkey();
  236.     $line = -1 if $ans =~ /q/i;
  237.     }
  238.     $line;
  239. }
  240.  
  241. #=============================================================================
  242. # Run actions
  243. #=============================================================================
  244. sub run {
  245.     my $o = shift;
  246.     my $action = shift;
  247.     my @args = @_;
  248.     $o->do_action($action, \@args, 'run')
  249. }
  250.  
  251. sub complete {
  252.     my $o = shift;
  253.     my $action = shift;
  254.     my @args = @_;
  255.     my @compls = $o->do_action($action, \@args, 'comp');
  256.     return () unless $o->{command}{comp}{found};
  257.     return @compls;
  258. }
  259.  
  260. sub help {
  261.     my $o = shift;
  262.     my $topic = shift;
  263.     my @subtopics = @_;
  264.     $o->do_action($topic, \@subtopics, 'help')
  265. }
  266.  
  267. sub summary {
  268.     my $o = shift;
  269.     my $topic = shift;
  270.     $o->do_action($topic, [], 'smry')
  271. }
  272.  
  273. #=============================================================================
  274. # Manually add & remove handlers
  275. #=============================================================================
  276. sub add_handlers {
  277.     my $o = shift;
  278.     # The sort in the following line guarantees that "alias_xxx" will be sorted
  279.     # first.  Otherwise the remaining entries won't be applied to all aliases.
  280.     for my $hnd (sort @_) {
  281.     next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
  282.     my $t = $1;
  283.     my $a = substr($hnd, length($t) + 1);
  284.     # Add on the prefix and suffix if the command is defined
  285.     if (length $a) {
  286.         substr($a, 0, 0) = $o->cmd_prefix;
  287.         $a .= $o->cmd_suffix;
  288.     }
  289.     $o->{handlers}{$a}{$t} = $hnd;
  290.     if ($o->has_aliases($a)) {
  291.         my @a = $o->get_aliases($a);
  292.         for my $alias (@a) {
  293.         substr($alias, 0, 0) = $o->cmd_prefix;
  294.         $alias .= $o->cmd_suffix;
  295.         $o->{handlers}{$alias}{$t} = $hnd;
  296.         }
  297.     }
  298.     }
  299. }
  300.  
  301. sub add_commands {
  302.     my $o = shift;
  303.     while (@_) {
  304.     my ($cmd, $hnd) = (shift, shift);
  305.     $o->{handlers}{$cmd} = $hnd;
  306.     }
  307. }
  308.  
  309. sub remove_handlers {
  310.     my $o = shift;
  311.     for my $hnd (@_) {
  312.     next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
  313.     my $t = $1;
  314.     my $a = substr($hnd, length($t) + 1);
  315.     # Add on the prefix and suffix if the command is defined
  316.     if (length $a) {
  317.         substr($a, 0, 0) = $o->cmd_prefix;
  318.         $a .= $o->cmd_suffix;
  319.     }
  320.     delete $o->{handlers}{$a}{$t};
  321.     }
  322. }
  323.  
  324. sub remove_commands {
  325.     my $o = shift;
  326.     for my $name (@_) {
  327.     delete $o->{handlers}{$name};
  328.     }
  329. }
  330.  
  331. *add_handler = \&add_handlers;
  332. *add_command = \&add_commands;
  333. *remove_handler = \&remove_handlers;
  334. *remove_command = \&remove_commands;
  335.  
  336. #=============================================================================
  337. # Utility methods
  338. #=============================================================================
  339. sub termsize {
  340.     my $o = shift;
  341.     my ($rows, $cols) = (24, 80);
  342.     return { rows => $rows, cols => $cols } unless -t STDOUT;
  343.     my $OUT = ref($o) ? $o->term->OUT : \*STDOUT;
  344.     my $TERM = ref($o) ? $o->term : undef;
  345.     if ($TERM and $o->{API}{readline} eq 'Term::ReadLine::Gnu') {
  346.     ($rows, $cols) = $TERM->get_screen_size;
  347.     }
  348.     elsif (ref($o) and $^O eq 'MSWin32' and eval { require Win32::Console }) {
  349.     Win32::Console->import;
  350.     # Win32::Console's DESTROY does a CloseHandle(), so save the object:
  351.     $o->{win32_stdout} ||= Win32::Console->new(STD_OUTPUT_HANDLE());
  352.     my @info = $o->{win32_stdout}->Info;
  353.     $cols = $info[7] - $info[5] + 1; # right - left + 1
  354.     $rows = $info[8] - $info[6] + 1; # bottom - top + 1
  355.     }
  356.     elsif (eval { require Term::Size }) {
  357.     ($cols, $rows) = Term::Size::chars($OUT);
  358.     }
  359.     elsif (eval { require Term::ReadKey }) {
  360.     ($cols, $rows) = Term::ReadKey::GetTerminalSize($OUT);
  361.     }
  362.     elsif (eval { require Term::Screen }) {
  363.     my $screen = Term::Screen->new;
  364.     ($rows, $cols) = @$screen{qw(ROWS COLS)};
  365.     }
  366.     elsif ($ENV{LINES} or $ENV{ROWS} or $ENV{COLUMNS}) {
  367.     $rows = $ENV{LINES} || $ENV{ROWS} || $rows;
  368.     $cols = $ENV{COLUMNS} || $cols;
  369.     }
  370.     else {
  371.     local $^W;
  372.     local *STTY;
  373.     open (STTY, "stty size |") and do {
  374.         my $l = <STTY>;
  375.         ($rows, $cols) = split /\s+/, $l;
  376.         close STTY;
  377.     };
  378.     }
  379.     { rows => $rows, cols => $cols};
  380. }
  381.  
  382. sub readkey {
  383.     my $o = shift;
  384.     $o->{readkey}->();
  385. }
  386.  
  387. sub have_readkey {
  388.     my $o = shift;
  389.     return 1 if $o->{have_readkey};
  390.     my $IN = $o->term->IN;
  391.     my $t = -t $IN;
  392.     if ($t and $^O ne 'MSWin32' and eval { require Term::InKey }) {
  393.     $o->{readkey} = \&Term::InKey::ReadKey;
  394.     }
  395.     elsif ($t and $^O eq 'MSWin32' and eval { require Win32::Console }) {
  396.     $o->{readkey} = sub {
  397.         my $c;
  398.         # from Term::InKey:
  399.         eval {
  400.         Win32::Console->import;
  401.         $o->{win32_stdin} ||= Win32::Console->new(STD_INPUT_HANDLE());
  402.         my $mode = my $orig = $o->{win32_stdin}->Mode or die $^E;
  403.         $mode &= ~(ENABLE_LINE_INPUT() | ENABLE_ECHO_INPUT());
  404.         $o->{win32_stdin}->Mode($mode) or die $^E;
  405.  
  406.         $o->{win32_stdin}->Flush or die $^E;
  407.         $c = $o->{win32_stdin}->InputChar(1);
  408.         die $^E unless defined $c;
  409.         $o->{win32_stdin}->Mode($orig) or die $^E;
  410.         };
  411.         die "Not implemented on $^O: $@" if $@;
  412.         $c;
  413.     };
  414.     }
  415.     elsif ($t and eval { require Term::ReadKey }) {
  416.     $o->{readkey} = sub {
  417.         Term::ReadKey::ReadMode(4, $IN);
  418.         my $c = getc($IN);
  419.         Term::ReadKey::ReadMode(0, $IN);
  420.         $c;
  421.     };
  422.     }
  423.     else {
  424.     $o->{readkey} = sub { scalar <$IN> };
  425.     return $o->{have_readkey} = 0;
  426.     }
  427.     return $o->{have_readkey} = 1;
  428. }
  429. *has_readkey = \&have_readkey;
  430.  
  431. sub prompt {
  432.     my $o = shift;
  433.     my ($prompt, $default, $completions, $casei) = @_;
  434.  
  435.     # A closure to read the line.
  436.     my $line;
  437.     my $readline = sub {
  438.     my ($sh, $gh) = @{$o->term->Features}{qw(setHistory getHistory)};
  439.     my @history = $o->term->GetHistory if $gh;
  440.     $o->term->SetHistory() if $sh;
  441.     $line = $o->readline($prompt);
  442.     $line = $default
  443.         if ((not defined $line or $line =~ /^\s*$/) and defined $default);
  444.     # Restore the history
  445.     $o->term->SetHistory(@history) if $sh;
  446.     $line;
  447.     };
  448.     # A closure to complete the line.
  449.     my $complete = sub {
  450.     my ($word, $line, $start) = @_;
  451.     return $o->completions($word, $completions, $casei);
  452.     };
  453.     if ($o->term->ReadLine eq 'Term::ReadLine::Gnu') {
  454.     my $attribs = $o->term->Attribs;
  455.     local $attribs->{completion_function} = $complete;
  456.     &$readline;
  457.     }
  458.     elsif ($o->term->ReadLine eq 'Term::ReadLine::Perl') {
  459.     local $readline::rl_completion_function = $complete;
  460.     &$readline;
  461.     }
  462.     else {
  463.     &$readline;
  464.     }
  465.     $line;
  466. }
  467.  
  468. sub format_pairs {
  469.     my $o    = shift;
  470.     my @keys = @{shift(@_)};
  471.     my @vals = @{shift(@_)};
  472.     my $sep  = shift || ": ";
  473.     my $left = shift || 0;
  474.     my $ind  = shift || "";
  475.     my $len  = shift || 0;
  476.     my $wrap = shift || 0;
  477.     if ($wrap) {
  478.     eval {
  479.         require Text::Autoformat;
  480.         Text::Autoformat->import(qw(autoformat));
  481.     };
  482.     if ($@) {
  483.         warn (
  484.         "Term::Shell::format_pairs(): Text::Autoformat is required " .
  485.         "for wrapping. Wrapping disabled"
  486.         ) if $^W;
  487.         $wrap = 0;
  488.     }
  489.     }
  490.     my $cols = shift || $o->termsize->{cols};
  491.     $len < length($_) and $len = length($_) for @keys;
  492.     my @text;
  493.     for my $i (0 .. $#keys) {
  494.     next unless defined $vals[$i];
  495.     my $sz   = ($len - length($keys[$i]));
  496.     my $lpad = $left ? "" : " " x $sz;
  497.     my $rpad = $left ? " " x $sz : "";
  498.     my $l = "$ind$lpad$keys[$i]$rpad$sep";
  499.     my $wrap = $wrap & ($vals[$i] =~ /\s/ and $vals[$i] !~ /^\d/);
  500.     my $form = (
  501.         $wrap
  502.         ? autoformat(
  503.         "$vals[$i]", # force stringification
  504.         { left => length($l)+1, right => $cols, all => 1 },
  505.         )
  506.         : "$l$vals[$i]\n"
  507.     );
  508.     substr($form, 0, length($l), $l);
  509.     push @text, $form;
  510.     }
  511.     my $text = join '', @text;
  512.     return wantarray ? ($text, $len) : $text;
  513. }
  514.  
  515. sub print_pairs {
  516.     my $o = shift;
  517.     my ($text, $len) = $o->format_pairs(@_);
  518.     $o->page($text);
  519.     return $len;
  520. }
  521.  
  522. # Handle backslash translation; doesn't do anything complicated yet.
  523. sub process_esc {
  524.     my $o = shift;
  525.     my $c = shift;
  526.     my $q = shift;
  527.     my $n;
  528.     return '\\' if $c eq '\\';
  529.     return $q if $c eq $q;
  530.     return "\\$c";
  531. }
  532.  
  533. # Parse a quoted string
  534. sub parse_quoted {
  535.     my $o = shift;
  536.     my $raw = shift;
  537.     my $quote = shift;
  538.     my $i=1;
  539.     my $string = '';
  540.     my $c;
  541.     while($i <= length($raw) and ($c=substr($raw, $i, 1)) ne $quote) {
  542.     if ($c eq '\\') {
  543.         $string .= $o->process_esc(substr($raw, $i+1, 1), $quote);
  544.         $i++;
  545.     }
  546.     else {
  547.         $string .= substr($raw, $i, 1);
  548.     }
  549.     $i++;
  550.     }
  551.     return ($string, $i);
  552. };
  553.  
  554. sub line {
  555.     my $o = shift;
  556.     $o->{line}
  557. }
  558. sub line_args {
  559.     my $o = shift;
  560.     my $line = shift || $o->line;
  561.     $o->line_parsed($line);
  562.     $o->{line_args} || '';
  563. }
  564. sub line_parsed {
  565.     my $o = shift;
  566.     my $args = shift || $o->line || return ();
  567.     my @args;
  568.  
  569.     # Parse an array of arguments. Whitespace separates, unless quoted.
  570.     my $arg = undef;
  571.     $o->{line_args} = undef;
  572.     for(my $i=0; $i<length($args); $i++) {
  573.     my $c = substr($args, $i, 1);
  574.     if ($c =~ /\S/ and @args == 1) {
  575.         $o->{line_args} ||= substr($args, $i);
  576.     }
  577.     if ($c =~ /['"]/) {
  578.         my ($str, $n) = $o->parse_quoted(substr($args,$i),$c);
  579.         $i += $n;
  580.         $arg = (defined($arg) ? $arg : '') . $str;
  581.     }
  582. # We do not parse outside of strings
  583. #    elsif ($c eq '\\') {
  584. #        $arg = (defined($arg) ? $arg : '') 
  585. #          . $o->process_esc(substr($args,$i+1,1));
  586. #        $i++;
  587. #    }
  588.     elsif ($c =~ /\s/) {
  589.         push @args, $arg if defined $arg;
  590.         $arg = undef
  591.     } 
  592.     else {
  593.         $arg .= substr($args,$i,1);
  594.     }
  595.     }
  596.     push @args, $arg if defined($arg);
  597.     return @args;
  598. }
  599.  
  600. sub handler {
  601.     my $o = shift;
  602.     my ($command, $type, $args, $preserve_args) = @_;
  603.  
  604.     # First try finding the standard handler, then fallback to the
  605.     # catch_$type method. The columns represent "action", "type", and "push",
  606.     # which control whether the name of the command should be pushed onto the
  607.     # args.
  608.     my @tries = (
  609.     [$command, $type, 0],
  610.     [$o->cmd_prefix . $type . $o->cmd_suffix, 'catch', 1],
  611.     );
  612.  
  613.     # The user can control whether or not to search for "unique" matches,
  614.     # which means calling $o->possible_actions(). We always look for exact
  615.     # matches.
  616.     my @matches = qw(exact_action);
  617.     push @matches, qw(possible_actions) if $o->{API}{match_uniq};
  618.  
  619.     for my $try (@tries) {
  620.     my ($cmd, $type, $add_cmd_name) = @$try;
  621.     for my $match (@matches) {
  622.         my @handlers = $o->$match($cmd, $type);
  623.         next unless @handlers == 1;
  624.         unshift @$args, $command
  625.         if $add_cmd_name and not $preserve_args;
  626.         return $o->unalias($handlers[0], $type)
  627.     }
  628.     }
  629.     return undef;
  630. }
  631.  
  632. sub completions {
  633.     my $o = shift;
  634.     my $action = shift;
  635.     my $compls = shift || [];
  636.     my $casei  = shift;
  637.     $casei = $o->{API}{case_ignore} unless defined $casei;
  638.     $casei = $casei ? '(?i)' : '';
  639.     return grep { $_ =~ /$casei^\Q$action\E/ } @$compls;
  640. }
  641.  
  642. #=============================================================================
  643. # Term::Shell error messages
  644. #=============================================================================
  645. sub msg_ambiguous_cmd {
  646.     my ($o, $cmd, @c) = @_;
  647.     local $" = "\n\t";
  648.     <<END;
  649. Ambiguous command '$cmd': possible commands:
  650.     @c
  651. END
  652. }
  653.  
  654. sub msg_unknown_cmd {
  655.     my ($o, $cmd) = @_;
  656.     <<END;
  657. Unknown command '$cmd'; type 'help' for a list of commands.
  658. END
  659. }
  660.  
  661. #=============================================================================
  662. # Term::Shell private methods
  663. #=============================================================================
  664. sub do_action {
  665.     my $o = shift;
  666.     my $cmd = shift;
  667.     my $args = shift || [];
  668.     my $type = shift || 'run';
  669.     my $handler = $o->handler($cmd, $type, $args);
  670.     $o->{command}{$type} = {
  671.     name    => $cmd,
  672.     found    => defined $handler ? 1 : 0,
  673.     handler    => $handler,
  674.     };
  675.     if (defined $handler) {
  676.     # We've found a handler. Set up a value which will call the postcmd()
  677.     # action as the subroutine leaves. Then call the precmd(), then return
  678.     # the result of running the handler.
  679.     $o->precmd(\$handler, \$cmd, $args);
  680.     my $postcmd = Term::Shell::OnScopeLeave->new(sub {
  681.         $o->postcmd(\$handler, \$cmd, $args);
  682.     });
  683.     return $o->$handler(@$args);
  684.     }
  685. }
  686.  
  687. sub uniq {
  688.     my $o = shift;
  689.     my %seen;
  690.     $seen{$_}++ for @_;
  691.     my @ret;
  692.     for (@_) { push @ret, $_ if $seen{$_}-- == 1 }
  693.     @ret;
  694. }
  695.  
  696. sub possible_actions {
  697.     my $o = shift;
  698.     my $action = shift;
  699.     my $type = shift;
  700.     my $strip = shift || 0;
  701.     my $casei = $o->{API}{case_ignore} ? '(?i)' : '';
  702.     my @keys =    grep { $_ =~ /$casei^\Q$action\E/ } 
  703.         grep { exists $o->{handlers}{$_}{$type} }
  704.         keys %{$o->{handlers}};
  705.     return @keys if $strip;
  706.     return map { "${type}_$_" } @keys;
  707. }
  708.  
  709. sub exact_action {
  710.     my $o = shift;
  711.     my $action = shift;
  712.     my $type = shift;
  713.     my $strip = shift || 0;
  714.     my $casei = $o->{API}{case_ignore} ? '(?i)' : '';
  715.     my @key = grep { $action =~ /$casei^\Q$_\E$/ } keys %{$o->{handlers}};
  716.     return () unless @key == 1;
  717.     return () unless exists $o->{handlers}{$key[0]}{$type};
  718.     my $handler = $o->{handlers}{$key[0]}{$type};
  719.     $handler =~ s/\Q${type}_\E// if $strip;
  720.     return $handler;
  721. }
  722.  
  723. sub is_alias {
  724.     my $o = shift;
  725.     my $action = shift;
  726.     exists $o->{handlers}{$action}{alias} ? 1 : 0;
  727. }
  728.  
  729. sub has_aliases {
  730.     my $o = shift;
  731.     my $action = shift;
  732.     my @a = $o->get_aliases($action);
  733.     @a ? 1 : 0;
  734. }
  735.  
  736. sub get_aliases {
  737.     my $o = shift;
  738.     my $action = shift;
  739.     my @a = eval {
  740.     my $hndlr = $o->{handlers}{$action}{alias};
  741.     return () unless $hndlr;
  742.     $o->$hndlr();
  743.     };
  744.     $o->{aliases}{$_} = $action for @a;
  745.     @a;
  746. }
  747.  
  748. sub unalias {
  749.     my $o = shift;
  750.     my $alias = shift;
  751.     my $type  = shift;
  752.     return $alias unless $type;
  753.     my @stuff = split '_', $alias;
  754.     $stuff[1] ||= '';
  755.     return $alias unless $stuff[0] eq $type;
  756.     return $alias unless exists $o->{aliases}{$stuff[1]};
  757.     return $type . '_' . $o->{aliases}{$stuff[1]};
  758. }
  759.  
  760. sub find_handlers {
  761.     my $o = shift;
  762.     my $pkg = shift || $o->{API}{class};
  763.  
  764.     # Find the handlers in the given namespace:
  765.     my %handlers;
  766.     {
  767.     no strict 'refs';
  768.     my @r = keys %{ $pkg . "::" };
  769.     $o->add_handlers(@r);
  770.     }
  771.  
  772.     # Find handlers in its base classes.
  773.     {
  774.     no strict 'refs';
  775.     my @isa = @{ $pkg . "::ISA" };
  776.     for my $pkg (@isa) {
  777.         $o->find_handlers($pkg);
  778.     }
  779.     }
  780. }
  781.  
  782. sub rl_complete {
  783.     my $o = shift;
  784.     my ($word, $line, $start) = @_;
  785.  
  786.     # If it's a command, complete 'run_':
  787.     if ($start == 0 or substr($line, 0, $start) =~ /^\s*$/) {
  788.     my @compls = $o->complete('', $word, $line, $start);
  789.     return @compls if $o->{command}{comp}{found};
  790.     }
  791.  
  792.     # If it's a subcommand, send it to any custom completion function for the
  793.     # function:
  794.     else {
  795.     my $command = ($o->line_parsed($line))[0];
  796.     my @compls = $o->complete($command, $word, $line, $start);
  797.     return @compls if $o->{command}{comp}{found};
  798.     }
  799.  
  800.     ()
  801. }
  802.  
  803. #=============================================================================
  804. # Two action handlers provided by default: help and exit.
  805. #=============================================================================
  806. sub smry_exit { "exits the program" }
  807. sub help_exit {
  808.     <<'END';
  809. Exits the program.
  810. END
  811. }
  812. sub run_exit {
  813.     my $o = shift;
  814.     $o->stoploop;
  815. }
  816.  
  817. sub smry_help { "prints this screen, or help on 'command'" }
  818. sub help_help {
  819.     <<'END'
  820. Provides help on commands...
  821. END
  822. }
  823. sub comp_help {
  824.     my ($o, $word, $line, $start) = @_;
  825.     my @words = $o->line_parsed($line);
  826.     return []
  827.       if (@words > 2 or @words == 2 and $start == length($line));
  828.     sort $o->possible_actions($word, 'help', 1);
  829. }
  830. sub run_help {
  831.     my $o = shift;
  832.     my $cmd = shift;
  833.     if ($cmd) {
  834.     my $txt = $o->help($cmd, @_);
  835.     if ($o->{command}{help}{found}) {
  836.         $o->page($txt)
  837.     }
  838.     else {
  839.         my @c = sort $o->possible_actions($cmd, 'help', 1);
  840.         if (@c) {
  841.         local $" = "\n\t";
  842.         print <<END;
  843. Ambiguous help topic '$cmd': possible help topics:
  844.     @c
  845. END
  846.         }
  847.         else {
  848.         print <<END;
  849. Unknown help topic '$cmd'; type 'help' for a list of help topics.
  850. END
  851.         }
  852.     }
  853.     }
  854.     else {
  855.     print "Type 'help command' for more detailed help on a command.\n";
  856.     my (%cmds, %docs);
  857.     my %done;
  858.     my %handlers;
  859.     for my $h (keys %{$o->{handlers}}) {
  860.         next unless length($h);
  861.         next unless grep{defined$o->{handlers}{$h}{$_}} qw(run smry help);
  862.         my $dest = exists $o->{handlers}{$h}{run} ? \%cmds : \%docs;
  863.         my $smry = exists $o->{handlers}{$h}{smry}
  864.         ? $o->summary($h)
  865.         : "undocumented";
  866.         my $help = exists $o->{handlers}{$h}{help}
  867.         ? (exists $o->{handlers}{$h}{smry}
  868.             ? ""
  869.             : " - but help available")
  870.         : " - no help available";
  871.         $dest->{"    $h"} = "$smry$help";
  872.     }
  873.     my @t;
  874.     push @t, "  Commands:\n" if %cmds;
  875.     push @t, scalar $o->format_pairs(
  876.         [sort keys %cmds], [map {$cmds{$_}} sort keys %cmds], ' - ', 1
  877.     );
  878.     push @t, "  Extra Help Topics: (not commands)\n" if %docs;
  879.     push @t, scalar $o->format_pairs(
  880.         [sort keys %docs], [map {$docs{$_}} sort keys %docs], ' - ', 1
  881.     );
  882.     $o->page(join '', @t);
  883.     }
  884. }
  885.  
  886. sub run_ { }
  887. sub comp_ {
  888.     my ($o, $word, $line, $start) = @_;
  889.     my @comp = grep { length($_) } sort $o->possible_actions($word, 'run', 1);
  890.     return @comp;
  891. }
  892.  
  893. package Term::Shell::OnScopeLeave;
  894.  
  895. sub new {
  896.     return bless [@_[1 .. $#_]], ref($_[0]) || $_[0];
  897. }
  898.  
  899. sub DESTROY {
  900.     my $o = shift;
  901.     for my $c (@$o) {
  902.     &$c;
  903.     }
  904. }
  905.  
  906. 1;
  907.