lib/complete.pl

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