lib/Term/Complete.pm

   1 package Term::Complete;
   2 require 5.000;
   3 require Exporter;
   4
   5 use strict;
   6 our @ISA = qw(Exporter);
   7 our @EXPORT = qw(Complete);
   8 our $VERSION = '1.2';
   9
  10 #      @(#)complete.pl,v1.2            (me@anywhere.EBay.Sun.COM) 09/23/91
  11
  12 =head1 NAME
  13
  14 Term::Complete - Perl word completion module
  15
  16 =head1 SYNOPSIS
  17
  18     $input = Complete('prompt_string', \@completion_list);
  19     $input = Complete('prompt_string', @completion_list);
  20
  21 =head1 DESCRIPTION
  22
  23 This routine provides word completion on the list of words in
  24 the array (or array ref).
  25
  26 The tty driver is put into raw mode using the system command
  27 C<stty raw -echo> and restored using C<stty -raw echo>.
  28
  29 The following command characters are defined:
  30
  31 =over 4
  32
  33 =item E<lt>tabE<gt>
  34
  35 Attempts word completion.
  36 Cannot be changed.
  37
  38 =item ^D
  39
  40 Prints completion list.
  41 Defined by I<$Term::Complete::complete>.
  42
  43 =item ^U
  44
  45 Erases the current input.
  46 Defined by I<$Term::Complete::kill>.
  47
  48 =item E<lt>delE<gt>, E<lt>bsE<gt>
  49
  50 Erases one character.
  51 Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
  52
  53 =back
  54
  55 =head1 DIAGNOSTICS
  56
  57 Bell sounds when word completion fails.
  58
  59 =head1 BUGS
  60
  61 The completion character E<lt>tabE<gt> cannot be changed.
  62
  63 =head1 AUTHOR
  64
  65 Wayne Thompson
  66
  67 =cut
  68
  69 our($complete, $kill, $erase1, $erase2);
  70 CONFIG: {
  71     $complete = "\004";
  72     $kill     = "\025";
  73     $erase1 =   "\177";
  74     $erase2 =   "\010";
  75 }
  76
  77 sub Complete {
  78     my($prompt, @cmp_lst, $cmp, $test, $l, @match);
  79     my ($return, $r) = ("", 0);
  80
  81     $return = "";
  82     $r      = 0;
  83
  84     $prompt = shift;
  85     if (ref $_[0] || $_[0] =~ /^\*/) {
  86         @cmp_lst = sort @{$_[0]};
  87     }
  88     else {
  89         @cmp_lst = sort(@_);
  90     }
  91
  92     system('stty raw -echo');
  93     LOOP: {
  94         print($prompt, $return);
  95         while (($_ = getc(STDIN)) ne "\r") {
  96             CASE: {
  97                 # (TAB) attempt completion
  98                 $_ eq "\t" && do {
  99                     @match = grep(/^$return/, @cmp_lst);
 100                     unless ($#match < 0) {
 101                         $l = length($test = shift(@match));
 102                         foreach $cmp (@match) {
 103                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
 104                                 $l--;
 105                             }
 106                         }
 107                         print("\a");
 108                         print($test = substr($test, $r, $l - $r));
 109                         $r = length($return .= $test);
 110                     }
 111                     last CASE;
 112                 };
 113
 114                 # (^D) completion list
 115                 $_ eq $complete && do {
 116                     print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
 117                     redo LOOP;
 118                 };
 119
 120                 # (^U) kill
 121                 $_ eq $kill && do {
 122                     if ($r) {
 123                         $r      = 0;
 124                         $return = "";
 125                         print("\r\n");
 126                         redo LOOP;
 127                     }
 128                     last CASE;
 129                 };
 130
 131                 # (DEL) || (BS) erase
 132                 ($_ eq $erase1 || $_ eq $erase2) && do {
 133                     if($r) {
 134                         print("\b \b");
 135                         chop($return);
 136                         $r--;
 137                     }
 138                     last CASE;
 139                 };
 140
 141                 # printable char
 142                 ord >= 32 && do {
 143                     $return .= $_;
 144                     $r++;
 145                     print;
 146                     last CASE;
 147                 };
 148             }
 149         }
 150     }
 151     system('stty -raw echo');
 152     print("\n");
 153     $return;
 154 }
 155
 156 1;
 157