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 ([email protected]) 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;
|
---|