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             chomp $tty_saved_state;
 110             $tty_restore = qq($stty "$tty_saved_state");
 111         }
 112     }
 113     system $tty_raw_noecho if defined $tty_raw_noecho;
 114     LOOP: {
 115         print($prompt, $return);
 116         while (($_ = getc(STDIN)) ne "\r") {
 117             CASE: {
 118                 # (TAB) attempt completion
 119                 $_ eq "\t" && do {
 120                     @match = grep(/^\Q$return/, @cmp_lst);
 121                     unless ($#match < 0) {
 122                         $l = length($test = shift(@match));
 123                         foreach $cmp (@match) {
 124                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
 125                                 $l--;
 126                             }
 127                         }
 128                         print("\a");
 129                         print($test = substr($test, $r, $l - $r));
 130                         $r = length($return .= $test);
 131                     }
 132                     last CASE;
 133                 };
 134
 135                 # (^D) completion list
 136                 $_ eq $complete && do {
 137                     print(join("\r\n", '', grep(/^\Q$return/, @cmp_lst)), "\r\n");
 138                     redo LOOP;
 139                 };
 140
 141                 # (^U) kill
 142                 $_ eq $kill && do {
 143                     if ($r) {
 144                         $r      = 0;
 145                         $return = "";
 146                         print("\r\n");
 147                         redo LOOP;
 148                     }
 149                     last CASE;
 150                 };
 151
 152                 # (DEL) || (BS) erase
 153                 ($_ eq $erase1 || $_ eq $erase2) && do {
 154                     if($r) {
 155                         print("\b \b");
 156                         chop($return);
 157                         $r--;
 158                     }
 159                     last CASE;
 160                 };
 161
 162                 # printable char
 163                 ord >= 32 && do {
 164                     $return .= $_;
 165                     $r++;
 166                     print;
 167                     last CASE;
 168                 };
 169             }
 170         }
 171     }
 172     system $tty_restore if defined $tty_restore;
 173     print("\n");
 174     $return;
 175 }
 176
 177 1;
 178