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