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.4';
   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>.
  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, $tty_raw_noecho, $tty_restore, $stty);
  70 our($tty_saved_state) = '';
  71 CONFIG: {
  72     $complete = "\004";
  73     $kill     = "\025";
  74     $erase1 =   "\177";
  75     $erase2 =   "\010";
  76     foreach my $s (qw(/bin/stty /usr/bin/stty)) {
  77         if (-x $s) {
  78             $tty_raw_noecho = "$s raw -echo";
  79             $tty_restore    = "$s -raw echo";
  80             $stty = $s;
  81             last;
  82         }
  83     }
  84 }
  85
  86 sub Complete {
  87     my($prompt, @cmp_lst, $cmp, $test, $l, @match);
  88     my ($return, $r) = ("", 0);
  89
  90     $return = "";
  91     $r      = 0;
  92
  93     $prompt = shift;
  94     if (ref $_[0] || $_[0] =~ /^\*/) {
  95         @cmp_lst = sort @{$_[0]};
  96     }
  97     else {
  98         @cmp_lst = sort(@_);
  99     }
 100
 101     # Attempt to save the current stty state, to be restored later
 102     if (defined $stty && defined $tty_saved_state && $tty_saved_state eq '') {
 103         $tty_saved_state = qx($stty -g 2>/dev/null);
 104         if ($?) {
 105             # stty -g not supported
 106             $tty_saved_state = undef;
 107         }
 108         else {
 109             $tty_restore = qq($stty "$tty_saved_state");
 110         }
 111     }
 112     system $tty_raw_noecho if defined $tty_raw_noecho;
 113     LOOP: {
 114         print($prompt, $return);
 115         while (($_ = getc(STDIN)) ne "\r") {
 116             CASE: {
 117                 # (TAB) attempt completion
 118                 $_ eq "\t" && do {
 119                     @match = grep(/^$return/, @cmp_lst);
 120                     unless ($#match < 0) {
 121                         $l = length($test = shift(@match));
 122                         foreach $cmp (@match) {
 123                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
 124                                 $l--;
 125                             }
 126                         }
 127                         print("\a");
 128                         print($test = substr($test, $r, $l - $r));
 129                         $r = length($return .= $test);
 130                     }
 131                     last CASE;
 132                 };
 133
 134                 # (^D) completion list
 135                 $_ eq $complete && do {
 136                     print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
 137                     redo LOOP;
 138                 };
 139
 140                 # (^U) kill
 141                 $_ eq $kill && do {
 142                     if ($r) {
 143                         $r      = 0;
 144                         $return = "";
 145                         print("\r\n");
 146                         redo LOOP;
 147                     }
 148                     last CASE;
 149                 };
 150
 151                 # (DEL) || (BS) erase
 152                 ($_ eq $erase1 || $_ eq $erase2) && do {
 153                     if($r) {
 154                         print("\b \b");
 155                         chop($return);
 156                         $r--;
 157                     }
 158                     last CASE;
 159                 };
 160
 161                 # printable char
 162                 ord >= 32 && do {
 163                     $return .= $_;
 164                     $r++;
 165                     print;
 166                     last CASE;
 167                 };
 168             }
 169         }
 170     }
 171     system $tty_restore if defined $tty_restore;
 172     print("\n");
 173     $return;
 174 }
 175
 176 1;
 177