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