Commit | Line | Data |
a0d0e21e |
1 | package Term::Complete; |
2 | require 5.000; |
3 | require Exporter; |
4 | |
5 | @ISA = qw(Exporter); |
6 | @EXPORT = qw(Complete); |
7 | |
a0d0e21e |
8 | # @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 |
cb1a09d0 |
9 | |
10 | =head1 NAME |
11 | |
12 | Term::Complete - Perl word completion module |
13 | |
14 | =head1 SYNOPSIS |
15 | |
16 | $input = complete('prompt_string', \@completion_list); |
17 | $input = complete('prompt_string', @completion_list); |
18 | |
19 | =head1 DESCRIPTION |
20 | |
21 | This routine provides word completion on the list of words in |
22 | the array (or array ref). |
23 | |
24 | The tty driver is put into raw mode using the system command |
25 | C<stty raw -echo> and restored using C<stty -raw echo>. |
26 | |
27 | The following command characters are defined: |
28 | |
29 | =over 4 |
30 | |
1fef88e7 |
31 | =item E<lt>tabE<gt> |
cb1a09d0 |
32 | Attempts word completion. |
33 | Cannot be changed. |
34 | |
35 | =item ^D |
36 | |
37 | Prints completion list. |
38 | Defined by I<$Term::Complete::complete>. |
39 | |
40 | =item ^U |
41 | |
42 | Erases the current input. |
43 | Defined by I<$Term::Complete::kill>. |
44 | |
1fef88e7 |
45 | =item E<lt>delE<gt>, E<lt>bsE<gt> |
cb1a09d0 |
46 | |
47 | Erases one character. |
48 | Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>. |
49 | |
50 | =back |
51 | |
52 | =head1 DIAGNOSTICS |
53 | |
54 | Bell sounds when word completion fails. |
55 | |
56 | =head1 BUGS |
57 | |
1fef88e7 |
58 | The completion charater E<lt>tabE<gt> cannot be changed. |
cb1a09d0 |
59 | |
60 | =head1 AUTHOR |
61 | |
62 | Wayne Thompson |
63 | |
64 | =cut |
a0d0e21e |
65 | |
66 | CONFIG: { |
67 | $complete = "\004"; |
68 | $kill = "\025"; |
69 | $erase1 = "\177"; |
70 | $erase2 = "\010"; |
71 | } |
72 | |
f06db76b |
73 | sub Complete { |
55497cff |
74 | my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r); |
75 | |
a0d0e21e |
76 | $prompt = shift; |
77 | if (ref $_[0] || $_[0] =~ /^\*/) { |
78 | @cmp_lst = sort @{$_[0]}; |
79 | } |
80 | else { |
81 | @cmp_lst = sort(@_); |
82 | } |
83 | |
84 | system('stty raw -echo'); |
85 | LOOP: { |
86 | print($prompt, $return); |
87 | while (($_ = getc(STDIN)) ne "\r") { |
88 | CASE: { |
89 | # (TAB) attempt completion |
90 | $_ eq "\t" && do { |
91 | @match = grep(/^$return/, @cmp_lst); |
92 | $l = length($test = shift(@match)); |
93 | unless ($#match < 0) { |
94 | foreach $cmp (@match) { |
95 | until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { |
96 | $l--; |
97 | } |
98 | } |
99 | print("\a"); |
100 | } |
101 | print($test = substr($test, $r, $l - $r)); |
102 | $r = length($return .= $test); |
103 | last CASE; |
104 | }; |
105 | |
106 | # (^D) completion list |
107 | $_ eq $complete && do { |
108 | print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); |
109 | redo LOOP; |
110 | }; |
111 | |
112 | # (^U) kill |
113 | $_ eq $kill && do { |
114 | if ($r) { |
40da2db3 |
115 | undef $r; |
116 | undef $return; |
a0d0e21e |
117 | print("\r\n"); |
118 | redo LOOP; |
119 | } |
120 | last CASE; |
121 | }; |
122 | |
123 | # (DEL) || (BS) erase |
124 | ($_ eq $erase1 || $_ eq $erase2) && do { |
125 | if($r) { |
126 | print("\b \b"); |
127 | chop($return); |
128 | $r--; |
129 | } |
130 | last CASE; |
131 | }; |
132 | |
133 | # printable char |
134 | ord >= 32 && do { |
135 | $return .= $_; |
136 | $r++; |
137 | print; |
138 | last CASE; |
139 | }; |
140 | } |
141 | } |
142 | } |
143 | system('stty -raw echo'); |
144 | print("\n"); |
145 | $return; |
146 | } |
147 | |
148 | 1; |
149 | |