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
  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 }
  73
  74 sub Complete {
  75     my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
  76
  77     $return = "";
  78     $r      = 0;
  79
  80     $prompt = shift;
  81     if (ref $_[0] || $_[0] =~ /^\*/) {
  82         @cmp_lst = sort @{$_[0]};
  83     }
  84     else {
  85         @cmp_lst = sort(@_);
  86     }
  87
  88     system('stty raw -echo');
  89     LOOP: {
  90         print($prompt, $return);
  91         while (($_ = getc(STDIN)) ne "\r") {
  92             CASE: {
  93                 # (TAB) attempt completion
  94                 $_ eq "\t" && do {
  95                     @match = grep(/^$return/, @cmp_lst);
  96                     $l = length($test = shift(@match));
  97                     unless ($#match < 0) {
  98                         foreach $cmp (@match) {
  99                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
 100                                 $l--;
 101                             }
 102                         }
 103                         print("\a");
 104                     }
 105                     print($test = substr($test, $r, $l - $r));
 106                     $r = length($return .= $test);
 107                     last CASE;
 108                 };
 109
 110                 # (^D) completion list
 111                 $_ eq $complete && do {
 112                     print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
 113                     redo LOOP;
 114                 };
 115
 116                 # (^U) kill
 117                 $_ eq $kill && do {
 118                     if ($r) {
 119                         $r      = 0;
 120                         $return = "";
 121                         print("\r\n");
 122                         redo LOOP;
 123                     }
 124                     last CASE;
 125                 };
 126
 127                 # (DEL) || (BS) erase
 128                 ($_ eq $erase1 || $_ eq $erase2) && do {
 129                     if($r) {
 130                         print("\b \b");
 131                         chop($return);
 132                         $r--;
 133                     }
 134                     last CASE;
 135                 };
 136
 137                 # printable char
 138                 ord >= 32 && do {
 139                     $return .= $_;
 140                     $r++;
 141                     print;
 142                     last CASE;
 143                 };
 144             }
 145         }
 146     }
 147     system('stty -raw echo');
 148     print("\n");
 149     $return;
 150 }
 151
 152 1;
 153