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