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