lib/complete.pl

   1 ;#
   2 #
   3 # This library is no longer being maintained, and is included for backward
   4 # compatibility with Perl 4 programs which may require it.
   5 # This legacy library is deprecated and will be removed in a future
   6 # release of perl.
   7 #
   8 # In particular, this should not be used as an example of modern Perl
   9 # programming techniques.
  10 #
  11 # Suggested alternative: Term::Complete
  12
  13 ;#      @(#)complete.pl,v1.1            (me@anywhere.EBay.Sun.COM) 09/23/91
  14 ;#
  15 ;# Author: Wayne Thompson
  16 ;#
  17 ;# Description:
  18 ;#     This routine provides word completion.
  19 ;#     (TAB) attempts word completion.
  20 ;#     (^D)  prints completion list.
  21 ;#      (These may be changed by setting $Complete'complete, etc.)
  22 ;#
  23 ;# Diagnostics:
  24 ;#     Bell when word completion fails.
  25 ;#
  26 ;# Dependencies:
  27 ;#     The tty driver is put into raw mode.
  28 ;#
  29 ;# Bugs:
  30 ;#
  31 ;# Usage:
  32 ;#     $input = &Complete('prompt_string', *completion_list);
  33 ;#         or
  34 ;#     $input = &Complete('prompt_string', @completion_list);
  35 ;#
  36
  37 CONFIG: {
  38     package Complete;
  39
  40     $complete = "\004";
  41     $kill     = "\025";
  42     $erase1 =   "\177";
  43     $erase2 =   "\010";
  44 }
  45
  46 sub Complete {
  47     package Complete;
  48
  49     local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
  50     if ($_[1] =~ /^StB\0/) {
  51         ($prompt, *_) = @_;
  52     }
  53     else {
  54         $prompt = shift(@_);
  55     }
  56     @cmp_lst = sort(@_);
  57
  58     system('stty raw -echo');
  59     LOOP: {
  60         print($prompt, $return);
  61         while (($_ = getc(STDIN)) ne "\r") {
  62             CASE: {
  63                 # (TAB) attempt completion
  64                 $_ eq "\t" && do {
  65                     @match = grep(/^$return/, @cmp_lst);
  66                     $l = length($test = shift(@match));
  67                     unless ($#match < 0) {
  68                         foreach $cmp (@match) {
  69                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
  70                                 $l--;
  71                             }
  72                         }
  73                         print("\a");
  74                     }
  75                     print($test = substr($test, $r, $l - $r));
  76                     $r = length($return .= $test);
  77                     last CASE;
  78                 };
  79
  80                 # (^D) completion list
  81                 $_ eq $complete && do {
  82                     print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
  83                     redo LOOP;
  84                 };
  85
  86                 # (^U) kill
  87                 $_ eq $kill && do {
  88                     if ($r) {
  89                         undef $r;
  90                         undef $return;
  91                         print("\r\n");
  92                         redo LOOP;
  93                     }
  94                     last CASE;
  95                 };
  96
  97                 # (DEL) || (BS) erase
  98                 ($_ eq $erase1 || $_ eq $erase2) && do {
  99                     if($r) {
 100                         print("\b \b");
 101                         chop($return);
 102                         $r--;
 103                     }
 104                     last CASE;
 105                 };
 106
 107                 # printable char
 108                 ord >= 32 && do {
 109                     $return .= $_;
 110                     $r++;
 111                     print;
 112                     last CASE;
 113                 };
 114             }
 115         }
 116     }
 117     system('stty -raw echo');
 118     print("\n");
 119     $return;
 120 }
 121
 122 1;