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;
 116                         undef $return;
 117                         print("\r\n");
 118                         redo LOOP;
 119                     }
 120                     last CASE;
 121                 };
 122
 123                 # (DEL) || (BS) erase
 124                 ($_ eq $erase1 || $_ eq $erase2) && do {
 125                     if($r) {
 126                         print("\b \b");
 127                         chop($return);
 128                         $r--;
 129                     }
 130                     last CASE;
 131                 };
 132
 133                 # printable char
 134                 ord >= 32 && do {
 135                     $return .= $_;
 136                     $r++;
 137                     print;
 138                     last CASE;
 139                 };
 140             }
 141         }
 142     }
 143     system('stty -raw echo');
 144     print("\n");
 145     $return;
 146 }
 147
 148 1;
 149