lib/Term/Complete.pm

   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 Attempts word completion.
  33 Cannot be changed.
  34
  35 =item ^D
  36
  37 Prints completion list.
  38 Defined by I<$Term::Complete::complete>.
  39
  40 =item ^U
  41
  42 Erases the current input.
  43 Defined by I<$Term::Complete::kill>.
  44
  45 =item E<lt>delE<gt>, E<lt>bsE<gt>
  46
  47 Erases one character.
  48 Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
  49
  50 =back
  51
  52 =head1 DIAGNOSTICS
  53
  54 Bell sounds when word completion fails.
  55
  56 =head1 BUGS
  57
  58 The completion charater E<lt>tabE<gt> cannot be changed.
  59
  60 =head1 AUTHOR
  61
  62 Wayne Thompson
  63
  64 =cut
  65
  66 CONFIG: {
  67     $complete = "\004";
  68     $kill     = "\025";
  69     $erase1 =   "\177";
  70     $erase2 =   "\010";
  71 }
  72
  73 sub Complete {
  74     my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
  75
  76     $prompt = shift;
  77     if (ref $_[0] || $_[0] =~ /^\*/) {
  78         @cmp_lst = sort @{$_[0]};
  79     }
  80     else {
  81         @cmp_lst = sort(@_);
  82     }
  83
  84     system('stty raw -echo');
  85     LOOP: {
  86         print($prompt, $return);
  87         while (($_ = getc(STDIN)) ne "\r") {
  88             CASE: {
  89                 # (TAB) attempt completion
  90                 $_ eq "\t" && do {
  91                     @match = grep(/^$return/, @cmp_lst);
  92                     $l = length($test = shift(@match));
  93                     unless ($#match < 0) {
  94                         foreach $cmp (@match) {
  95                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
  96                                 $l--;
  97                             }
  98                         }
  99                         print("\a");
 100                     }
 101                     print($test = substr($test, $r, $l - $r));
 102                     $r = length($return .= $test);
 103                     last CASE;
 104                 };
 105
 106                 # (^D) completion list
 107                 $_ eq $complete && do {
 108                     print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
 109                     redo LOOP;
 110                 };
 111
 112                 # (^U) kill
 113                 $_ eq $kill && do {
 114                     if ($r) {
 115                         undef($r, $return);
 116                         print("\r\n");
 117                         redo LOOP;
 118                     }
 119                     last CASE;
 120                 };
 121
 122                 # (DEL) || (BS) erase
 123                 ($_ eq $erase1 || $_ eq $erase2) && do {
 124                     if($r) {
 125                         print("\b \b");
 126                         chop($return);
 127                         $r--;
 128                     }
 129                     last CASE;
 130                 };
 131
 132                 # printable char
 133                 ord >= 32 && do {
 134                     $return .= $_;
 135                     $r++;
 136                     print;
 137                     last CASE;
 138                 };
 139             }
 140         }
 141     }
 142     system('stty -raw echo');
 143     print("\n");
 144     $return;
 145 }
 146
 147 1;
 148