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