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