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