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