[Summary view] [Print] [Text view]

   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;