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