home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / Term / Complete.pm < prev    next >
Text File  |  1997-05-19  |  4KB  |  153 lines
  1. package Term::Complete;
  2. require 5.000;
  3. require Exporter;
  4.  
  5. @ISA = qw(Exporter);
  6. @EXPORT = qw(Complete);
  7.  
  8. #      @(#)complete.pl,v1.1            (me@anywhere.EBay.Sun.COM) 09/23/91
  9.  
  10. =head1 NAME
  11.  
  12. Term::Complete - Perl word completion module
  13.  
  14. =head1 SYNOPSIS
  15.  
  16.     $input = complete('prompt_string', \@completion_list);
  17.     $input = complete('prompt_string', @completion_list);
  18.  
  19. =head1 DESCRIPTION
  20.  
  21. This routine provides word completion on the list of words in
  22. the array (or array ref).
  23.  
  24. The tty driver is put into raw mode using the system command
  25. C<stty raw -echo> and restored using C<stty -raw echo>.
  26.  
  27. The following command characters are defined:
  28.  
  29. =over 4
  30.  
  31. =item E<lt>tabE<gt>
  32.  
  33. Attempts word completion.
  34. Cannot be changed.
  35.  
  36. =item ^D
  37.  
  38. Prints completion list.
  39. Defined by I<$Term::Complete::complete>.
  40.  
  41. =item ^U
  42.  
  43. Erases the current input.
  44. Defined by I<$Term::Complete::kill>.
  45.  
  46. =item E<lt>delE<gt>, E<lt>bsE<gt>
  47.  
  48. Erases one character.
  49. Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
  50.  
  51. =back
  52.  
  53. =head1 DIAGNOSTICS
  54.  
  55. Bell sounds when word completion fails.
  56.  
  57. =head1 BUGS
  58.  
  59. The completion charater E<lt>tabE<gt> cannot be changed.
  60.  
  61. =head1 AUTHOR
  62.  
  63. Wayne Thompson
  64.  
  65. =cut
  66.  
  67. CONFIG: {
  68.     $complete = "\004";
  69.     $kill     = "\025";
  70.     $erase1 =   "\177";
  71.     $erase2 =   "\010";
  72.     $eol    = ($^O eq 'MacOS' ? "\n" : "\r");
  73.     $nl     = ($^O eq 'MacOS' ? "\n" : "\r\n");
  74. }
  75.  
  76. sub Complete {
  77.     my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
  78.  
  79.     $prompt = shift;
  80.     if (ref $_[0] || $_[0] =~ /^\*/) {
  81.     @cmp_lst = sort @{$_[0]};
  82.     }
  83.     else {
  84.     @cmp_lst = sort(@_);
  85.     }
  86.  
  87.     system('stty raw -echo');
  88.     LOOP: {
  89.         print($prompt, $return);
  90.         while (($_ = getc(STDIN)) ne $eol) {
  91.             CASE: {
  92.                 # (TAB) attempt completion
  93.                 $_ eq "\t" && do {
  94.                     @match = grep(/^$return/, @cmp_lst);
  95.                     $l = length($test = shift(@match));
  96.                     unless ($#match < 0) {
  97.                         foreach $cmp (@match) {
  98.                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
  99.                                 $l--;
  100.                             }
  101.                         }
  102.                         print("\a");
  103.                     }
  104.                     print($test = substr($test, $r, $l - $r));
  105.                     $r = length($return .= $test);
  106.                     last CASE;
  107.                 };
  108.  
  109.                 # (^D) completion list
  110.                 $_ eq $complete && do {
  111.                     print(join($nl, '', grep(/^$return/, @cmp_lst)), $nl);
  112.                     redo LOOP;
  113.                 };
  114.  
  115.                 # (^U) kill
  116.                 $_ eq $kill && do {
  117.                     if ($r) {
  118.                         undef $r;
  119.             undef $return;
  120.                         print($nl);
  121.                         redo LOOP;
  122.                     }
  123.                     last CASE;
  124.                 };
  125.  
  126.                 # (DEL) || (BS) erase
  127.                 ($_ eq $erase1 || $_ eq $erase2) && do {
  128.                     if($r) {
  129.                         print("\b \b");
  130.                         chop($return);
  131.                         $r--;
  132.                     }
  133.                     last CASE;
  134.                 };
  135.  
  136.                 # printable char
  137.                 ord >= 32 && do {
  138.                     $return .= $_;
  139.                     $r++;
  140.                     print;
  141.                     last CASE;
  142.                 };
  143.             }
  144.         }
  145.     }
  146.     system('stty -raw echo');
  147.     print("\n");
  148.     $return;
  149. }
  150.  
  151. 1;
  152.  
  153.