extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / lib / complete.pl
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
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;