home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _fdaed7ce8771461a862596ff32ffa264 < prev    next >
Encoding:
Text File  |  2004-04-13  |  23.2 KB  |  905 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.     for my $hnd (@_) {
  279.     next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
  280.     my $t = $1;
  281.     my $a = substr($hnd, length($t) + 1);
  282.     # Add on the prefix and suffix if the command is defined
  283.     if (length $a) {
  284.         substr($a, 0, 0) = $o->cmd_prefix;
  285.         $a .= $o->cmd_suffix;
  286.     }
  287.     $o->{handlers}{$a}{$t} = $hnd;
  288.     if ($o->has_aliases($a)) {
  289.         my @a = $o->get_aliases($a);
  290.         for my $alias (@a) {
  291.         substr($alias, 0, 0) = $o->cmd_prefix;
  292.         $alias .= $o->cmd_suffix;
  293.         $o->{handlers}{$alias}{$t} = $hnd;
  294.         }
  295.     }
  296.     }
  297. }
  298.  
  299. sub add_commands {
  300.     my $o = shift;
  301.     while (@_) {
  302.     my ($cmd, $hnd) = (shift, shift);
  303.     $o->{handlers}{$cmd} = $hnd;
  304.     }
  305. }
  306.  
  307. sub remove_handlers {
  308.     my $o = shift;
  309.     for my $hnd (@_) {
  310.     next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
  311.     my $t = $1;
  312.     my $a = substr($hnd, length($t) + 1);
  313.     # Add on the prefix and suffix if the command is defined
  314.     if (length $a) {
  315.         substr($a, 0, 0) = $o->cmd_prefix;
  316.         $a .= $o->cmd_suffix;
  317.     }
  318.     delete $o->{handlers}{$a}{$t};
  319.     }
  320. }
  321.  
  322. sub remove_commands {
  323.     my $o = shift;
  324.     for my $name (@_) {
  325.     delete $o->{handlers}{$name};
  326.     }
  327. }
  328.  
  329. *add_handler = \&add_handlers;
  330. *add_command = \&add_commands;
  331. *remove_handler = \&remove_handlers;
  332. *remove_command = \&remove_commands;
  333.  
  334. #=============================================================================
  335. # Utility methods
  336. #=============================================================================
  337. sub termsize {
  338.     my $o = shift;
  339.     my ($rows, $cols) = (24, 78);
  340.     my $OUT = ref($o) ? $o->term->OUT : \*STDOUT;
  341.     my $TERM = ref($o) ? $o->term : undef;
  342.     return { rows => $rows, cols => $cols } unless -t $OUT;
  343.     if ($TERM and $o->{API}{readline} eq 'Term::ReadLine::Gnu') {
  344.     ($rows, $cols) = $TERM->get_screen_size;
  345.     }
  346.     elsif (ref($o) and $^O eq 'MSWin32' and eval { require Win32::Console }) {
  347.     Win32::Console->import;
  348.     # Win32::Console's DESTROY does a CloseHandle(), so save the object:
  349.     $o->{win32_stdout} ||= Win32::Console->new(STD_OUTPUT_HANDLE());
  350.     my @info = $o->{win32_stdout}->Info;
  351.     $cols = $info[7] - $info[5] + 1; # right - left + 1
  352.     $rows = $info[8] - $info[6] + 1; # bottom - top + 1
  353.     }
  354.     elsif (eval { require Term::Size }) {
  355.     ($cols, $rows) = Term::Size::chars($OUT);
  356.     }
  357.     elsif (eval { require Term::ReadKey }) {
  358.     ($cols, $rows) = Term::ReadKey::GetTerminalSize($OUT);
  359.     }
  360.     elsif (eval { require Term::Screen }) {
  361.     my $screen = Term::Screen->new;
  362.     ($rows, $cols) = @$screen{qw(ROWS COLS)};
  363.     }
  364.     elsif ($ENV{LINES} or $ENV{ROWS} or $ENV{COLUMNS}) {
  365.     $rows = $ENV{LINES} || $ENV{ROWS} || $rows;
  366.     $cols = $ENV{COLUMNS} || $cols;
  367.     }
  368.     else {
  369.     local $^W;
  370.     local *STTY;
  371.     open (STTY, "stty size |") and do {
  372.         my $l = <STTY>;
  373.         ($rows, $cols) = split /\s+/, $l;
  374.         close STTY;
  375.     };
  376.     }
  377.     { rows => $rows, cols => $cols};
  378. }
  379.  
  380. sub readkey {
  381.     my $o = shift;
  382.     $o->{readkey}->();
  383. }
  384.  
  385. sub have_readkey {
  386.     my $o = shift;
  387.     return 1 if $o->{have_readkey};
  388.     my $IN = $o->term->IN;
  389.     my $t = -t $IN;
  390.     if ($t and eval { require Term::InKey }) {
  391.     $o->{readkey} = \&Term::InKey::ReadKey;
  392.     }
  393.     elsif ($t and $^O eq 'MSWin32' and eval { require Win32::Console }) {
  394.     $o->{readkey} = sub {
  395.         my $c;
  396.         # from Term::InKey:
  397.         eval {
  398.         Win32::Console->import;
  399.         $o->{win32_stdin} ||= Win32::Console->new(STD_INPUT_HANDLE());
  400.         my $mode = my $orig = $o->{win32_stdin}->Mode or die $^E;
  401.         $mode &= ~(ENABLE_LINE_INPUT() | ENABLE_ECHO_INPUT());
  402.         $o->{win32_stdin}->Mode($mode) or die $^E;
  403.  
  404.         $o->{win32_stdin}->Flush or die $^E;
  405.         $c = $o->{win32_stdin}->InputChar(1);
  406.         die $^E unless defined $c;
  407.         $o->{win32_stdin}->Mode($orig) or die $^E;
  408.         };
  409.         die "Not implemented on $^O: $@" if $@;
  410.         $c;
  411.     };
  412.     }
  413.     elsif ($t and eval { require Term::ReadKey }) {
  414.     $o->{readkey} = sub {
  415.         Term::ReadKey::ReadMode(4, $IN);
  416.         my $c = getc($IN);
  417.         Term::ReadKey::ReadMode(0, $IN);
  418.         $c;
  419.     };
  420.     }
  421.     else {
  422.     $o->{readkey} = sub { scalar <$IN> };
  423.     return $o->{have_readkey} = 0;
  424.     }
  425.     return $o->{have_readkey} = 1;
  426. }
  427. *has_readkey = \&have_readkey;
  428.  
  429. sub prompt {
  430.     my $o = shift;
  431.     my ($prompt, $default, $completions, $casei) = @_;
  432.  
  433.     # A closure to read the line.
  434.     my $line;
  435.     my $readline = sub {
  436.     my ($sh, $gh) = @{$o->term->Features}{qw(setHistory getHistory)};
  437.     my @history = $o->term->GetHistory if $gh;
  438.     $o->term->SetHistory() if $sh;
  439.     $line = $o->readline($prompt);
  440.     $line = $default
  441.         if ((not defined $line or $line =~ /^\s*$/) and defined $default);
  442.     # Restore the history
  443.     $o->term->SetHistory(@history) if $sh;
  444.     $line;
  445.     };
  446.     # A closure to complete the line.
  447.     my $complete = sub {
  448.     my ($word, $line, $start) = @_;
  449.     return $o->completions($word, $completions, $casei);
  450.     };
  451.     if ($o->term->ReadLine eq 'Term::ReadLine::Gnu') {
  452.     my $attribs = $o->term->Attribs;
  453.     local $attribs->{completion_function} = $complete;
  454.     &$readline;
  455.     }
  456.     elsif ($o->term->ReadLine eq 'Term::ReadLine::Perl') {
  457.     local $readline::rl_completion_function = $complete;
  458.     &$readline;
  459.     }
  460.     else {
  461.     &$readline;
  462.     }
  463.     $line;
  464. }
  465.  
  466. sub format_pairs {
  467.     my $o    = shift;
  468.     my @keys = @{shift(@_)};
  469.     my @vals = @{shift(@_)};
  470.     my $sep  = shift || ": ";
  471.     my $left = shift || 0;
  472.     my $ind  = shift || "";
  473.     my $len  = shift || 0;
  474.     my $wrap = shift || 0;
  475.     if ($wrap) {
  476.     eval {
  477.         require Text::Autoformat;
  478.         Text::Autoformat->import(qw(autoformat));
  479.     };
  480.     if ($@) {
  481.         warn (
  482.         "Term::Shell::format_pairs(): Text::Autoformat is required " .
  483.         "for wrapping. Wrapping disabled"
  484.         ) if $^W;
  485.         $wrap = 0;
  486.     }
  487.     }
  488.     my $cols = shift || $o->termsize->{cols};
  489.     $len < length($_) and $len = length($_) for @keys;
  490.     my @text;
  491.     for my $i (0 .. $#keys) {
  492.     next unless defined $vals[$i];
  493.     my $sz   = ($len - length($keys[$i]));
  494.     my $lpad = $left ? "" : " " x $sz;
  495.     my $rpad = $left ? " " x $sz : "";
  496.     my $l = "$ind$lpad$keys[$i]$rpad$sep";
  497.     my $wrap = $wrap & ($vals[$i] =~ /\s/ and $vals[$i] !~ /^\d/);
  498.     my $form = (
  499.         $wrap
  500.         ? autoformat(
  501.         "$vals[$i]", # force stringification
  502.         { left => length($l)+1, right => $cols, all => 1 },
  503.         )
  504.         : "$l$vals[$i]\n"
  505.     );
  506.     substr($form, 0, length($l), $l);
  507.     push @text, $form;
  508.     }
  509.     my $text = join '', @text;
  510.     return wantarray ? ($text, $len) : $text;
  511. }
  512.  
  513. sub print_pairs {
  514.     my $o = shift;
  515.     my ($text, $len) = $o->format_pairs(@_);
  516.     $o->page($text);
  517.     return $len;
  518. }
  519.  
  520. # Handle backslash translation; doesn't do anything complicated yet.
  521. sub process_esc {
  522.     my $o = shift;
  523.     my $c = shift;
  524.     my $q = shift;
  525.     my $n;
  526.     return '\\' if $c eq '\\';
  527.     return $q if $c eq $q;
  528.     return "\\$c";
  529. }
  530.  
  531. # Parse a quoted string
  532. sub parse_quoted {
  533.     my $o = shift;
  534.     my $raw = shift;
  535.     my $quote = shift;
  536.     my $i=1;
  537.     my $string = '';
  538.     my $c;
  539.     while($i <= length($raw) and ($c=substr($raw, $i, 1)) ne $quote) {
  540.     if ($c eq '\\') {
  541.         $string .= $o->process_esc(substr($raw, $i+1, 1), $quote);
  542.         $i++;
  543.     }
  544.     else {
  545.         $string .= substr($raw, $i, 1);
  546.     }
  547.     $i++;
  548.     }
  549.     return ($string, $i);
  550. };
  551.  
  552. sub line {
  553.     my $o = shift;
  554.     $o->{line}
  555. }
  556. sub line_args {
  557.     my $o = shift;
  558.     my $line = shift || $o->line;
  559.     $o->line_parsed($line);
  560.     $o->{line_args} || '';
  561. }
  562. sub line_parsed {
  563.     my $o = shift;
  564.     my $args = shift || $o->line || return ();
  565.     my @args;
  566.  
  567.     # Parse an array of arguments. Whitespace separates, unless quoted.
  568.     my $arg = undef;
  569.     $o->{line_args} = undef;
  570.     for(my $i=0; $i<length($args); $i++) {
  571.     my $c = substr($args, $i, 1);
  572.     if ($c =~ /\S/ and @args == 1) {
  573.         $o->{line_args} ||= substr($args, $i);
  574.     }
  575.     if ($c =~ /['"]/) {
  576.         my ($str, $n) = $o->parse_quoted(substr($args,$i),$c);
  577.         $i += $n;
  578.         $arg = (defined($arg) ? $arg : '') . $str;
  579.     }
  580. # We do not parse outside of strings
  581. #    elsif ($c eq '\\') {
  582. #        $arg = (defined($arg) ? $arg : '') 
  583. #          . $o->process_esc(substr($args,$i+1,1));
  584. #        $i++;
  585. #    }
  586.     elsif ($c =~ /\s/) {
  587.         push @args, $arg if defined $arg;
  588.         $arg = undef
  589.     } 
  590.     else {
  591.         $arg .= substr($args,$i,1);
  592.     }
  593.     }
  594.     push @args, $arg if defined($arg);
  595.     return @args;
  596. }
  597.  
  598. sub handler {
  599.     my $o = shift;
  600.     my ($command, $type, $args, $preserve_args) = @_;
  601.  
  602.     # First try finding the standard handler, then fallback to the
  603.     # catch_$type method. The columns represent "action", "type", and "push",
  604.     # which control whether the name of the command should be pushed onto the
  605.     # args.
  606.     my @tries = (
  607.     [$command, $type, 0],
  608.     [$o->cmd_prefix . $type . $o->cmd_suffix, 'catch', 1],
  609.     );
  610.  
  611.     # The user can control whether or not to search for "unique" matches,
  612.     # which means calling $o->possible_actions(). We always look for exact
  613.     # matches.
  614.     my @matches = qw(exact_action);
  615.     push @matches, qw(possible_actions) if $o->{API}{match_uniq};
  616.  
  617.     for my $try (@tries) {
  618.     my ($cmd, $type, $add_cmd_name) = @$try;
  619.     for my $match (@matches) {
  620.         my @handlers = $o->$match($cmd, $type);
  621.         next unless @handlers == 1;
  622.         unshift @$args, $command
  623.         if $add_cmd_name and not $preserve_args;
  624.         return $o->unalias($handlers[0], $type)
  625.     }
  626.     }
  627.     return undef;
  628. }
  629.  
  630. sub completions {
  631.     my $o = shift;
  632.     my $action = shift;
  633.     my $compls = shift || [];
  634.     my $casei  = shift;
  635.     $casei = $o->{API}{case_ignore} unless defined $casei;
  636.     $casei = $casei ? '(?i)' : '';
  637.     return grep { $_ =~ /$casei^\Q$action\E/ } @$compls;
  638. }
  639.  
  640. #=============================================================================
  641. # Term::Shell error messages
  642. #=============================================================================
  643. sub msg_ambiguous_cmd {
  644.     my ($o, $cmd, @c) = @_;
  645.     local $" = "\n\t";
  646.     <<END;
  647. Ambiguous command '$cmd': possible commands:
  648.     @c
  649. END
  650. }
  651.  
  652. sub msg_unknown_cmd {
  653.     my ($o, $cmd) = @_;
  654.     <<END;
  655. Unknown command '$cmd'; type 'help' for a list of commands.
  656. END
  657. }
  658.  
  659. #=============================================================================
  660. # Term::Shell private methods
  661. #=============================================================================
  662. sub do_action {
  663.     my $o = shift;
  664.     my $cmd = shift;
  665.     my $args = shift || [];
  666.     my $type = shift || 'run';
  667.     my $handler = $o->handler($cmd, $type, $args);
  668.     $o->{command}{$type} = {
  669.     name    => $cmd,
  670.     found    => defined $handler ? 1 : 0,
  671.     handler    => $handler,
  672.     };
  673.     if (defined $handler) {
  674.     # We've found a handler. Set up a value which will call the postcmd()
  675.     # action as the subroutine leaves. Then call the precmd(), then return
  676.     # the result of running the handler.
  677.     $o->precmd(\$handler, \$cmd, $args);
  678.     my $postcmd = Term::Shell::OnScopeLeave->new(sub {
  679.         $o->postcmd(\$handler, \$cmd, $args);
  680.     });
  681.     return $o->$handler(@$args);
  682.     }
  683. }
  684.  
  685. sub uniq {
  686.     my $o = shift;
  687.     my %seen;
  688.     $seen{$_}++ for @_;
  689.     my @ret;
  690.     for (@_) { push @ret, $_ if $seen{$_}-- == 1 }
  691.     @ret;
  692. }
  693.  
  694. sub possible_actions {
  695.     my $o = shift;
  696.     my $action = shift;
  697.     my $type = shift;
  698.     my $strip = shift || 0;
  699.     my $casei = $o->{API}{case_ignore} ? '(?i)' : '';
  700.     my @keys =    grep { $_ =~ /$casei^\Q$action\E/ } 
  701.         grep { exists $o->{handlers}{$_}{$type} }
  702.         keys %{$o->{handlers}};
  703.     return @keys if $strip;
  704.     return map { "${type}_$_" } @keys;
  705. }
  706.  
  707. sub exact_action {
  708.     my $o = shift;
  709.     my $action = shift;
  710.     my $type = shift;
  711.     my $strip = shift || 0;
  712.     my $casei = $o->{API}{case_ignore} ? '(?i)' : '';
  713.     my @key = grep { $action =~ /$casei^\Q$_\E$/ } keys %{$o->{handlers}};
  714.     return () unless @key == 1;
  715.     return () unless exists $o->{handlers}{$key[0]}{$type};
  716.     my $handler = $o->{handlers}{$key[0]}{$type};
  717.     $handler =~ s/\Q${type}_\E// if $strip;
  718.     return $handler;
  719. }
  720.  
  721. sub is_alias {
  722.     my $o = shift;
  723.     my $action = shift;
  724.     exists $o->{handlers}{$action}{alias} ? 1 : 0;
  725. }
  726.  
  727. sub has_aliases {
  728.     my $o = shift;
  729.     my $action = shift;
  730.     my @a = $o->get_aliases($action);
  731.     @a ? 1 : 0;
  732. }
  733.  
  734. sub get_aliases {
  735.     my $o = shift;
  736.     my $action = shift;
  737.     my @a = eval {
  738.     my $hndlr = $o->{handlers}{$action}{alias};
  739.     return () unless $hndlr;
  740.     $o->$hndlr();
  741.     };
  742.     $o->{aliases}{$_} = $action for @a;
  743.     @a;
  744. }
  745.  
  746. sub unalias {
  747.     my $o = shift;
  748.     my $alias = shift;
  749.     my $type  = shift;
  750.     return $alias unless $type;
  751.     my @stuff = split '_', $alias;
  752.     $stuff[1] ||= '';
  753.     return $alias unless $stuff[0] eq $type;
  754.     return $alias unless exists $o->{aliases}{$stuff[1]};
  755.     return $type . '_' . $o->{aliases}{$stuff[1]};
  756. }
  757.  
  758. sub find_handlers {
  759.     my $o = shift;
  760.     my $pkg = shift || $o->{API}{class};
  761.  
  762.     # Find the handlers in the given namespace:
  763.     my %handlers;
  764.     {
  765.     no strict 'refs';
  766.     my @r = keys %{ $pkg . "::" };
  767.     $o->add_handlers(@r);
  768.     }
  769.  
  770.     # Find handlers in its base classes.
  771.     {
  772.     no strict 'refs';
  773.     my @isa = @{ $pkg . "::ISA" };
  774.     for my $pkg (@isa) {
  775.         $o->find_handlers($pkg);
  776.     }
  777.     }
  778. }
  779.  
  780. sub rl_complete {
  781.     my $o = shift;
  782.     my ($word, $line, $start) = @_;
  783.  
  784.     # If it's a command, complete 'run_':
  785.     if ($start == 0 or substr($line, 0, $start) =~ /^\s*$/) {
  786.     my @compls = $o->complete('', $word, $line, $start);
  787.     return @compls if $o->{command}{comp}{found};
  788.     }
  789.  
  790.     # If it's a subcommand, send it to any custom completion function for the
  791.     # function:
  792.     else {
  793.     my $command = ($o->line_parsed($line))[0];
  794.     my @compls = $o->complete($command, $word, $line, $start);
  795.     return @compls if $o->{command}{comp}{found};
  796.     }
  797.  
  798.     ()
  799. }
  800.  
  801. #=============================================================================
  802. # Two action handlers provided by default: help and exit.
  803. #=============================================================================
  804. sub smry_exit { "exits the program" }
  805. sub help_exit {
  806.     <<'END';
  807. Exits the program.
  808. END
  809. }
  810. sub run_exit {
  811.     my $o = shift;
  812.     $o->stoploop;
  813. }
  814.  
  815. sub smry_help { "prints this screen, or help on 'command'" }
  816. sub help_help {
  817.     <<'END'
  818. Provides help on commands...
  819. END
  820. }
  821. sub comp_help {
  822.     my ($o, $word, $line, $start) = @_;
  823.     my @words = $o->line_parsed($line);
  824.     return []
  825.       if (@words > 2 or @words == 2 and $start == length($line));
  826.     sort $o->possible_actions($word, 'help', 1);
  827. }
  828. sub run_help {
  829.     my $o = shift;
  830.     my $cmd = shift;
  831.     if ($cmd) {
  832.     my $txt = $o->help($cmd, @_);
  833.     if ($o->{command}{help}{found}) {
  834.         $o->page($txt)
  835.     }
  836.     else {
  837.         my @c = sort $o->possible_actions($cmd, 'help', 1);
  838.         if (@c) {
  839.         local $" = "\n\t";
  840.         print <<END;
  841. Ambiguous help topic '$cmd': possible help topics:
  842.     @c
  843. END
  844.         }
  845.         else {
  846.         print <<END;
  847. Unknown help topic '$cmd'; type 'help' for a list of help topics.
  848. END
  849.         }
  850.     }
  851.     }
  852.     else {
  853.     print "Type 'help command' for more detailed help on a command.\n";
  854.     my (%cmds, %docs);
  855.     my %done;
  856.     my %handlers;
  857.     for my $h (keys %{$o->{handlers}}) {
  858.         next unless length($h);
  859.         next unless grep{defined$o->{handlers}{$h}{$_}} qw(run smry help);
  860.         my $dest = exists $o->{handlers}{$h}{run} ? \%cmds : \%docs;
  861.         my $smry = exists $o->{handlers}{$h}{smry}
  862.         ? $o->summary($h)
  863.         : "undocumented";
  864.         my $help = exists $o->{handlers}{$h}{help}
  865.         ? (exists $o->{handlers}{$h}{smry}
  866.             ? ""
  867.             : " - but help available")
  868.         : " - no help available";
  869.         $dest->{"    $h"} = "$smry$help";
  870.     }
  871.     my @t;
  872.     push @t, "  Commands:\n" if %cmds;
  873.     push @t, scalar $o->format_pairs(
  874.         [sort keys %cmds], [map {$cmds{$_}} sort keys %cmds], ' - ', 1
  875.     );
  876.     push @t, "  Extra Help Topics: (not commands)\n" if %docs;
  877.     push @t, scalar $o->format_pairs(
  878.         [sort keys %docs], [map {$docs{$_}} sort keys %docs], ' - ', 1
  879.     );
  880.     $o->page(join '', @t);
  881.     }
  882. }
  883.  
  884. sub run_ { }
  885. sub comp_ {
  886.     my ($o, $word, $line, $start) = @_;
  887.     my @comp = grep { length($_) } sort $o->possible_actions($word, 'run', 1);
  888.     return @comp;
  889. }
  890.  
  891. package Term::Shell::OnScopeLeave;
  892.  
  893. sub new {
  894.     return bless [@_[1 .. $#_]], ref($_[0]) || $_[0];
  895. }
  896.  
  897. sub DESTROY {
  898.     my $o = shift;
  899.     for my $c (@$o) {
  900.     &$c;
  901.     }
  902. }
  903.  
  904. 1;
  905.