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