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            (me@anywhere.EBay.Sun.COM) 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
35CONFIG: {
36    package Complete;
37
38    $complete = "\004";
39    $kill     = "\025";
40    $erase1 =   "\177";
41    $erase2 =   "\010";
42}
43
44sub 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
1201;
121