contrib/perl5/lib/complete.pl

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