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.3';
   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 and restored using an operating
  27 system specific command, in UNIX-like environments C<stty raw -echo>
  28 and C<stty -raw echo>.
  29
  30 The following command characters are defined:
  31
  32 =over 4
  33
  34 =item E<lt>tabE<gt>
  35
  36 Attempts word completion.
  37 Cannot be changed.
  38
  39 =item ^D
  40
  41 Prints completion list.
  42 Defined by I<$Term::Complete::complete>.
  43
  44 =item ^U
  45
  46 Erases the current input.
  47 Defined by I<$Term::Complete::kill>.
  48
  49 =item E<lt>delE<gt>, E<lt>bsE<gt>
  50
  51 Erases one character.
  52 Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
  53
  54 =back
  55
  56 =head1 DIAGNOSTICS
  57
  58 Bell sounds when word completion fails.
  59
  60 =head1 BUGS
  61
  62 The completion character E<lt>tabE<gt> cannot be changed.
  63
  64 =head1 AUTHOR
  65
  66 Wayne Thompson
  67
  68 =cut
  69
  70 our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore);
  71 CONFIG: {
  72     $complete = "\004";
  73     $kill     = "\025";
  74     $erase1 =   "\177";
  75     $erase2 =   "\010";
  76     foreach my $stty (qw(/bin/stty /usr/bin/stty)) {
  77         if (-x $stty) {
  78             $tty_raw_noecho = "$stty raw -echo";
  79             $tty_restore    = "$stty -raw echo";
  80             last;
  81         }
  82     }
  83 }
  84
  85 sub Complete {
  86     my($prompt, @cmp_lst, $cmp, $test, $l, @match);
  87     my ($return, $r) = ("", 0);
  88
  89     $return = "";
  90     $r      = 0;
  91
  92     $prompt = shift;
  93     if (ref $_[0] || $_[0] =~ /^\*/) {
  94         @cmp_lst = sort @{$_[0]};
  95     }
  96     else {
  97         @cmp_lst = sort(@_);
  98     }
  99
 100     system $tty_raw_noecho if defined $tty_raw_noecho;
 101     LOOP: {
 102         print($prompt, $return);
 103         while (($_ = getc(STDIN)) ne "\r") {
 104             CASE: {
 105                 # (TAB) attempt completion
 106                 $_ eq "\t" && do {
 107                     @match = grep(/^$return/, @cmp_lst);
 108                     unless ($#match < 0) {
 109                         $l = length($test = shift(@match));
 110                         foreach $cmp (@match) {
 111                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
 112                                 $l--;
 113                             }
 114                         }
 115                         print("\a");
 116                         print($test = substr($test, $r, $l - $r));
 117                         $r = length($return .= $test);
 118                     }
 119                     last CASE;
 120                 };
 121
 122                 # (^D) completion list
 123                 $_ eq $complete && do {
 124                     print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
 125                     redo LOOP;
 126                 };
 127
 128                 # (^U) kill
 129                 $_ eq $kill && do {
 130                     if ($r) {
 131                         $r      = 0;
 132                         $return = "";
 133                         print("\r\n");
 134                         redo LOOP;
 135                     }
 136                     last CASE;
 137                 };
 138
 139                 # (DEL) || (BS) erase
 140                 ($_ eq $erase1 || $_ eq $erase2) && do {
 141                     if($r) {
 142                         print("\b \b");
 143                         chop($return);
 144                         $r--;
 145                     }
 146                     last CASE;
 147                 };
 148
 149                 # printable char
 150                 ord >= 32 && do {
 151                     $return .= $_;
 152                     $r++;
 153                     print;
 154                     last CASE;
 155                 };
 156             }
 157         }
 158     }
 159     system $tty_restore if defined $tty_restore;
 160     print("\n");
 161     $return;
 162 }
 163
 164 1;
 165