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