1package Term::Complete; 2require 5.000; 3require Exporter; 4 5use strict; 6our @ISA = qw(Exporter); 7our @EXPORT = qw(Complete); 8our $VERSION = '1.401'; 9 10# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 11 12=head1 NAME 13 14Term::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 23This routine provides word completion on the list of words in 24the array (or array ref). 25 26The tty driver is put into raw mode and restored using an operating 27system specific command, in UNIX-like environments C<stty>. 28 29The following command characters are defined: 30 31=over 4 32 33=item E<lt>tabE<gt> 34 35Attempts word completion. 36Cannot be changed. 37 38=item ^D 39 40Prints completion list. 41Defined by I<$Term::Complete::complete>. 42 43=item ^U 44 45Erases the current input. 46Defined by I<$Term::Complete::kill>. 47 48=item E<lt>delE<gt>, E<lt>bsE<gt> 49 50Erases one character. 51Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>. 52 53=back 54 55=head1 DIAGNOSTICS 56 57Bell sounds when word completion fails. 58 59=head1 BUGS 60 61The completion character E<lt>tabE<gt> cannot be changed. 62 63=head1 AUTHOR 64 65Wayne Thompson 66 67=cut 68 69our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty, $tty_safe_restore); 70our($tty_saved_state) = ''; 71CONFIG: { 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 87sub 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 1871; 188