1 | ;#
|
---|
2 | #
|
---|
3 | # This library is no longer being maintained, and is included for backward
|
---|
4 | # compatibility with Perl 4 programs which may require it.
|
---|
5 | #
|
---|
6 | # In particular, this should not be used as an example of modern Perl
|
---|
7 | # programming techniques.
|
---|
8 | #
|
---|
9 | # Suggested alternative: Term::Complete
|
---|
10 | #
|
---|
11 | ;# @(#)complete.pl,v1.1 ([email protected]) 09/23/91
|
---|
12 | ;#
|
---|
13 | ;# Author: Wayne Thompson
|
---|
14 | ;#
|
---|
15 | ;# Description:
|
---|
16 | ;# This routine provides word completion.
|
---|
17 | ;# (TAB) attempts word completion.
|
---|
18 | ;# (^D) prints completion list.
|
---|
19 | ;# (These may be changed by setting $Complete'complete, etc.)
|
---|
20 | ;#
|
---|
21 | ;# Diagnostics:
|
---|
22 | ;# Bell when word completion fails.
|
---|
23 | ;#
|
---|
24 | ;# Dependencies:
|
---|
25 | ;# The tty driver is put into raw mode.
|
---|
26 | ;#
|
---|
27 | ;# Bugs:
|
---|
28 | ;#
|
---|
29 | ;# Usage:
|
---|
30 | ;# $input = &Complete('prompt_string', *completion_list);
|
---|
31 | ;# or
|
---|
32 | ;# $input = &Complete('prompt_string', @completion_list);
|
---|
33 | ;#
|
---|
34 |
|
---|
35 | CONFIG: {
|
---|
36 | package Complete;
|
---|
37 |
|
---|
38 | $complete = "\004";
|
---|
39 | $kill = "\025";
|
---|
40 | $erase1 = "\177";
|
---|
41 | $erase2 = "\010";
|
---|
42 | }
|
---|
43 |
|
---|
44 | sub Complete {
|
---|
45 | package Complete;
|
---|
46 |
|
---|
47 | local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
|
---|
48 | if ($_[1] =~ /^StB\0/) {
|
---|
49 | ($prompt, *_) = @_;
|
---|
50 | }
|
---|
51 | else {
|
---|
52 | $prompt = shift(@_);
|
---|
53 | }
|
---|
54 | @cmp_lst = sort(@_);
|
---|
55 |
|
---|
56 | system('stty raw -echo');
|
---|
57 | LOOP: {
|
---|
58 | print($prompt, $return);
|
---|
59 | while (($_ = getc(STDIN)) ne "\r") {
|
---|
60 | CASE: {
|
---|
61 | # (TAB) attempt completion
|
---|
62 | $_ eq "\t" && do {
|
---|
63 | @match = grep(/^$return/, @cmp_lst);
|
---|
64 | $l = length($test = shift(@match));
|
---|
65 | unless ($#match < 0) {
|
---|
66 | foreach $cmp (@match) {
|
---|
67 | until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
|
---|
68 | $l--;
|
---|
69 | }
|
---|
70 | }
|
---|
71 | print("\a");
|
---|
72 | }
|
---|
73 | print($test = substr($test, $r, $l - $r));
|
---|
74 | $r = length($return .= $test);
|
---|
75 | last CASE;
|
---|
76 | };
|
---|
77 |
|
---|
78 | # (^D) completion list
|
---|
79 | $_ eq $complete && do {
|
---|
80 | print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
|
---|
81 | redo LOOP;
|
---|
82 | };
|
---|
83 |
|
---|
84 | # (^U) kill
|
---|
85 | $_ eq $kill && do {
|
---|
86 | if ($r) {
|
---|
87 | undef $r;
|
---|
88 | undef $return;
|
---|
89 | print("\r\n");
|
---|
90 | redo LOOP;
|
---|
91 | }
|
---|
92 | last CASE;
|
---|
93 | };
|
---|
94 |
|
---|
95 | # (DEL) || (BS) erase
|
---|
96 | ($_ eq $erase1 || $_ eq $erase2) && do {
|
---|
97 | if($r) {
|
---|
98 | print("\b \b");
|
---|
99 | chop($return);
|
---|
100 | $r--;
|
---|
101 | }
|
---|
102 | last CASE;
|
---|
103 | };
|
---|
104 |
|
---|
105 | # printable char
|
---|
106 | ord >= 32 && do {
|
---|
107 | $return .= $_;
|
---|
108 | $r++;
|
---|
109 | print;
|
---|
110 | last CASE;
|
---|
111 | };
|
---|
112 | }
|
---|
113 | }
|
---|
114 | }
|
---|
115 | system('stty -raw echo');
|
---|
116 | print("\n");
|
---|
117 | $return;
|
---|
118 | }
|
---|
119 |
|
---|
120 | 1;
|
---|