Commit | Line | Data |
a0d0e21e |
1 | package Term::Complete; |
2 | require 5.000; |
3 | require Exporter; |
4 | |
b75c8c73 |
5 | use strict; |
6 | our @ISA = qw(Exporter); |
7 | our @EXPORT = qw(Complete); |
25f74a49 |
8 | our $VERSION = '1.4'; |
a0d0e21e |
9 | |
df4a00a5 |
10 | # @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 |
cb1a09d0 |
11 | |
12 | =head1 NAME |
13 | |
14 | Term::Complete - Perl word completion module |
15 | |
16 | =head1 SYNOPSIS |
17 | |
2ab1b485 |
18 | $input = Complete('prompt_string', \@completion_list); |
19 | $input = Complete('prompt_string', @completion_list); |
cb1a09d0 |
20 | |
21 | =head1 DESCRIPTION |
22 | |
23 | This routine provides word completion on the list of words in |
24 | the array (or array ref). |
25 | |
c680dfd8 |
26 | The tty driver is put into raw mode and restored using an operating |
25f74a49 |
27 | system specific command, in UNIX-like environments C<stty>. |
cb1a09d0 |
28 | |
29 | The following command characters are defined: |
30 | |
31 | =over 4 |
32 | |
1fef88e7 |
33 | =item E<lt>tabE<gt> |
3fe9a6f1 |
34 | |
cb1a09d0 |
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 | |
1fef88e7 |
48 | =item E<lt>delE<gt>, E<lt>bsE<gt> |
cb1a09d0 |
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 | |
8dcee03e |
61 | The completion character E<lt>tabE<gt> cannot be changed. |
cb1a09d0 |
62 | |
63 | =head1 AUTHOR |
64 | |
65 | Wayne Thompson |
66 | |
67 | =cut |
a0d0e21e |
68 | |
25f74a49 |
69 | our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty); |
70 | our($tty_saved_state) = ''; |
a0d0e21e |
71 | CONFIG: { |
72 | $complete = "\004"; |
73 | $kill = "\025"; |
74 | $erase1 = "\177"; |
75 | $erase2 = "\010"; |
25f74a49 |
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; |
c680dfd8 |
81 | last; |
82 | } |
83 | } |
a0d0e21e |
84 | } |
85 | |
f06db76b |
86 | sub Complete { |
b75c8c73 |
87 | my($prompt, @cmp_lst, $cmp, $test, $l, @match); |
df4a00a5 |
88 | my ($return, $r) = ("", 0); |
55497cff |
89 | |
2ab1b485 |
90 | $return = ""; |
91 | $r = 0; |
92 | |
a0d0e21e |
93 | $prompt = shift; |
94 | if (ref $_[0] || $_[0] =~ /^\*/) { |
95 | @cmp_lst = sort @{$_[0]}; |
96 | } |
97 | else { |
98 | @cmp_lst = sort(@_); |
99 | } |
100 | |
25f74a49 |
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 | } |
c680dfd8 |
112 | system $tty_raw_noecho if defined $tty_raw_noecho; |
a0d0e21e |
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(/^$return/, @cmp_lst); |
a0d0e21e |
120 | unless ($#match < 0) { |
df4a00a5 |
121 | $l = length($test = shift(@match)); |
a0d0e21e |
122 | foreach $cmp (@match) { |
123 | until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { |
124 | $l--; |
125 | } |
126 | } |
127 | print("\a"); |
df4a00a5 |
128 | print($test = substr($test, $r, $l - $r)); |
129 | $r = length($return .= $test); |
a0d0e21e |
130 | } |
a0d0e21e |
131 | last CASE; |
132 | }; |
133 | |
134 | # (^D) completion list |
135 | $_ eq $complete && do { |
136 | print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); |
137 | redo LOOP; |
138 | }; |
139 | |
140 | # (^U) kill |
141 | $_ eq $kill && do { |
142 | if ($r) { |
2ab1b485 |
143 | $r = 0; |
144 | $return = ""; |
a0d0e21e |
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 | } |
c680dfd8 |
171 | system $tty_restore if defined $tty_restore; |
a0d0e21e |
172 | print("\n"); |
173 | $return; |
174 | } |
175 | |
176 | 1; |
177 | |