Commit | Line | Data |
---|---|---|
920dae64 AT |
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; |