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 #
   9 #      @(#)complete.pl,v1.1            (me@anywhere.EBay.Sun.COM) 09/23/91
  10 #
  11 # Author: Wayne Thompson
  12 #
  13 # Description:
  14 #     This routine provides word completion.
  15 #     (TAB) attempts word completion.
  16 #     (^D)  prints completion list.
  17 #      (These may be changed by setting $Complete::complete, etc.)
  18 #
  19 # Diagnostics:
  20 #     Bell when word completion fails.
  21 #
  22 # Dependencies:
  23 #     The tty driver is put into raw mode.
  24 #
  25 # Bugs:
  26 #
  27 # Usage:
  28 #     $input = complete('prompt_string', \@completion_list);
  29 #         or
  30 #     $input = complete('prompt_string', @completion_list);
  31 #
  32
  33 CONFIG: {
  34     $complete = "\004";
  35     $kill     = "\025";
  36     $erase1 =   "\177";
  37     $erase2 =   "\010";
  38 }
  39
  40 sub Complete {
  41     $prompt = shift;
  42     if (ref $_[0] || $_[0] =~ /^\*/) {
  43         @cmp_lst = sort @{$_[0]};
  44     }
  45     else {
  46         @cmp_lst = sort(@_);
  47     }
  48
  49     system('stty raw -echo');
  50     LOOP: {
  51         print($prompt, $return);
  52         while (($_ = getc(STDIN)) ne "\r") {
  53             CASE: {
  54                 # (TAB) attempt completion
  55                 $_ eq "\t" && do {
  56                     @match = grep(/^$return/, @cmp_lst);
  57                     $l = length($test = shift(@match));
  58                     unless ($#match < 0) {
  59                         foreach $cmp (@match) {
  60                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
  61                                 $l--;
  62                             }
  63                         }
  64                         print("\a");
  65                     }
  66                     print($test = substr($test, $r, $l - $r));
  67                     $r = length($return .= $test);
  68                     last CASE;
  69                 };
  70
  71                 # (^D) completion list
  72                 $_ eq $complete && do {
  73                     print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
  74                     redo LOOP;
  75                 };
  76
  77                 # (^U) kill
  78                 $_ eq $kill && do {
  79                     if ($r) {
  80                         undef($r, $return);
  81                         print("\r\n");
  82                         redo LOOP;
  83                     }
  84                     last CASE;
  85                 };
  86
  87                 # (DEL) || (BS) erase
  88                 ($_ eq $erase1 || $_ eq $erase2) && do {
  89                     if($r) {
  90                         print("\b \b");
  91                         chop($return);
  92                         $r--;
  93                     }
  94                     last CASE;
  95                 };
  96
  97                 # printable char
  98                 ord >= 32 && do {
  99                     $return .= $_;
 100                     $r++;
 101                     print;
 102                     last CASE;
 103                 };
 104             }
 105         }
 106     }
 107     system('stty -raw echo');
 108     print("\n");
 109     $return;
 110 }
 111
 112 1;
 113