Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # |
2 | # $Id: PCompletion.pm,v 1.20 2003/01/16 19:21:17 gregor Exp $ | |
3 | # | |
4 | # Copyright (c) 2000-2003 Hiroo Hayashi. All Rights Reserved. | |
5 | # | |
6 | # This program is free software; you can redistribute it and/or | |
7 | # modify it under the same terms as Perl itself. | |
8 | ||
9 | package Psh::PCompletion; | |
10 | ||
11 | use strict; | |
12 | use vars qw(%COMPSPEC %ACTION @ISA @EXPORT_OK); | |
13 | require Exporter; | |
14 | require Psh::Completion; | |
15 | require Psh::Parser; | |
16 | ||
17 | $Psh::PCompletion::LOADED=1; # tell other packages which optionally want to call us that we're here now | |
18 | ||
19 | @ISA = qw(Exporter); | |
20 | @EXPORT_OK = qw(compgen); | |
21 | ||
22 | # for COMPSPEC actions | |
23 | # borrowed from bash-2.04 | |
24 | sub CA_ALIAS { 1<<0; } | |
25 | sub CA_ARRAYVAR { 1<<1; } | |
26 | sub CA_BINDING { 1<<2; } | |
27 | sub CA_BUILTIN { 1<<3; } | |
28 | sub CA_COMMAND { 1<<4; } | |
29 | sub CA_DIRECTORY { 1<<5; } | |
30 | sub CA_DISABLED { 1<<6; } | |
31 | sub CA_ENABLED { 1<<7; } | |
32 | sub CA_EXPORT { 1<<8; } | |
33 | sub CA_FILE { 1<<9; } | |
34 | sub CA_FUNCTION { 1<<10; } | |
35 | sub CA_HELPTOPIC { 1<<11; } | |
36 | sub CA_HOSTNAME { 1<<12; } | |
37 | sub CA_JOB { 1<<13; } | |
38 | sub CA_KEYWORD { 1<<14; } | |
39 | sub CA_RUNNING { 1<<15; } | |
40 | sub CA_SETOPT { 1<<16; } | |
41 | sub CA_SHOPT { 1<<17; } | |
42 | sub CA_SIGNAL { 1<<18; } | |
43 | sub CA_STOPPED { 1<<19; } | |
44 | sub CA_USER { 1<<20; } | |
45 | sub CA_VARIABLE { 1<<21; } | |
46 | # psh original | |
47 | sub CA_HASH { 1<<22; } | |
48 | ||
49 | # pursing argments | |
50 | BEGIN { | |
51 | %ACTION | |
52 | = (alias => CA_ALIAS, | |
53 | arrayvar => CA_ARRAYVAR, # Perl array variable | |
54 | binding => CA_BINDING, | |
55 | builtin => CA_BUILTIN, | |
56 | command => CA_COMMAND, | |
57 | directory => CA_DIRECTORY, | |
58 | disabled => CA_DISABLED, # not implemented yet | |
59 | enabled => CA_ENABLED, # not implemented yet | |
60 | export => CA_EXPORT, | |
61 | file => CA_FILE, | |
62 | function => CA_FUNCTION, # Perl function | |
63 | helptopic => CA_HELPTOPIC, | |
64 | hostname => CA_HOSTNAME, | |
65 | job => CA_JOB, | |
66 | keyword => CA_KEYWORD, | |
67 | running => CA_RUNNING, | |
68 | setopt => CA_SETOPT, # not implemented yet | |
69 | shopt => CA_SHOPT, # not implemented yet | |
70 | signal => CA_SIGNAL, | |
71 | stopped => CA_STOPPED, | |
72 | user => CA_USER, | |
73 | variable => CA_VARIABLE, # Perl variable | |
74 | hashvar => CA_HASH, # Perl hash variable | |
75 | ); | |
76 | } | |
77 | ||
78 | my($__line, $__start, $__cmd); | |
79 | ||
80 | # global variables for compgen() | |
81 | #use vars qw($__line $__start $__cmd); | |
82 | ||
83 | # convert from bash (and ksh?) extglob to Perl regular expression | |
84 | sub glob2regexp { | |
85 | local ($_) = @_; | |
86 | ||
87 | # ?(...), *(...), +(...) -> ()?, ()*, ()? | |
88 | s/([^\\])([?*+])\(([^)]*)\)/$1($3)$2/g; | |
89 | s/^([?*+])\(([^)]*)\)/($2)$1/g; | |
90 | ||
91 | # @(...) -> (...) | |
92 | s/([^\\])@\(([^)]*)\)/$1($2)/g; | |
93 | s/^@\(([^)]*)\)/($1)/g; | |
94 | ||
95 | # `!(...)' is not supported yet. | |
96 | ||
97 | # '.' -> '\.' | |
98 | s/([^\\])\./$1\\./g; | |
99 | s/^\./\\./g; | |
100 | ||
101 | # '*' -> '.*' | |
102 | s/([^\\)])\*/$1.*/g; | |
103 | s/^\*/.*/g; | |
104 | ||
105 | # '$' -> '\$' | |
106 | s/\$/\\\$/g; | |
107 | ||
108 | return '^' . $_ . '$'; | |
109 | } | |
110 | ||
111 | sub pcomp_list { | |
112 | my ($cs, $text, $line, $start, $cmd) = @_; | |
113 | my @l; | |
114 | ||
115 | return () unless $line; | |
116 | my ($pretext) = substr($line, 0, $start) =~ /(\S*)$/; | |
117 | ||
118 | # actions | |
119 | if ($cs->{action} & CA_ALIAS and !$pretext) { | |
120 | if (Psh::Strategy::active('built_in')) { | |
121 | push(@l, grep { /^\Q$text/ } Psh::Support::Alias::get_alias_commands()); | |
122 | } | |
123 | } | |
124 | if ($cs->{action} & CA_BINDING and !$pretext) { | |
125 | # only Term::ReadLine::Gnu 1.09 and later support funmap_names() | |
126 | # use `eval' for other versions | |
127 | eval { push(@l, grep { /^\Q$text/ } $Psh::term->funmap_names) }; | |
128 | Psh::Util::print_debug_class('e',"Error: $@") if $@; | |
129 | } | |
130 | if ($cs->{action} & CA_BUILTIN || $cs->{action} & CA_HELPTOPIC) { | |
131 | if (Psh::Strategy::active('built_in')) { | |
132 | push(@l, grep { /^\Q$text/ } Psh::Support::Builtins::get_builtin_commands()); | |
133 | } | |
134 | } | |
135 | if ($cs->{action} & CA_COMMAND and !$pretext) { | |
136 | push(@l, Psh::Completion::cmpl_executable($text)); | |
137 | } | |
138 | if ($cs->{action} & CA_DIRECTORY) { | |
139 | push(@l, Psh::Completion::cmpl_directories($pretext . $text)); | |
140 | } | |
141 | if ($cs->{action} & CA_EXPORT and !$pretext) { | |
142 | push(@l, grep { /^\Q$text/ } keys %ENV); | |
143 | } | |
144 | if ($cs->{action} & CA_FILE) { | |
145 | my @f = Psh::Completion::cmpl_filenames($pretext . $text); | |
146 | if (defined $cs->{ffilterpat}) { | |
147 | my $pat = $cs->{ffilterpat}; | |
148 | if ($pat =~ /^!/) { | |
149 | $pat = glob2regexp(substr($pat, 1)); | |
150 | @f = grep(/$pat/, @f); | |
151 | } else { | |
152 | $pat = glob2regexp($pat); | |
153 | @f = grep(! /$pat/, @f); | |
154 | } | |
155 | } | |
156 | push(@l, @f); | |
157 | push(@l, Psh::Completion::cmpl_directories($pretext . $text)); | |
158 | } | |
159 | if ($cs->{action} & CA_HOSTNAME and !$pretext) { | |
160 | push(@l, grep { /^\Q$text/ } Psh::Completion::bookmarks()); | |
161 | } | |
162 | if ($cs->{action} & CA_KEYWORD and !$pretext) { | |
163 | push(@l, grep { /^\Q$text/ } @Psh::Completion::keyword); | |
164 | } | |
165 | if ($cs->{action} & CA_SIGNAL and !$pretext) { | |
166 | push(@l, grep { /^\Q$text/ } grep(!/^__/, keys %SIG)); | |
167 | } | |
168 | if ($cs->{action} & CA_USER and !$pretext) { | |
169 | # Why are usernames in @user_completion prepended by `~'? | |
170 | push(@l, map { substr($_, 1) } | |
171 | grep { /^~\Q$text/ } Psh::OS::get_all_users()); | |
172 | } | |
173 | # job list | |
174 | if ($cs->{action} & CA_JOB and !$pretext) { | |
175 | push(@l, | |
176 | map { $_->{call} } | |
177 | grep { $_->{call} =~ /^\Q$text/ } | |
178 | Psh::Joblist::list_jobs()); | |
179 | } | |
180 | if ($cs->{action} & CA_RUNNING and !$pretext) { | |
181 | push(@l, | |
182 | map { $_->{call} } | |
183 | grep { $_->{running} && $_->{call} =~ /^\Q$text/ } | |
184 | Psh::Joblist::list_jobs()); | |
185 | } | |
186 | if ($cs->{action} & CA_STOPPED and !$pretext) { | |
187 | push(@l, | |
188 | map { $_->{call} } | |
189 | grep { ! $_->{running} && $_->{call} =~ /^\Q$text/ } | |
190 | Psh::Joblist::list_jobs()); | |
191 | } | |
192 | ||
193 | # Perl Symbol completions | |
194 | # printf "[$text,%08x]\n", $cs->{action}; | |
195 | my $pkg = $Psh::PerlEval::current_package.'::'; | |
196 | if ($cs->{action} & CA_VARIABLE and !$pretext) { | |
197 | no strict 'refs'; | |
198 | push(@l, grep { /^\w+$/ && /^\Q$text/ | |
199 | && eval "defined \$$pkg$_" } keys %$pkg); | |
200 | } | |
201 | if ($cs->{action} & CA_ARRAYVAR and !$pretext) { | |
202 | my $sym; | |
203 | no strict 'refs'; | |
204 | @l = grep {($sym = $pkg . $_, defined *$sym{ARRAY}) | |
205 | } keys %$pkg; | |
206 | push(@l, | |
207 | grep { /^\Q$text/ } | |
208 | grep { /^\w+$/ && ($sym = $pkg . $_, defined *$sym{ARRAY}) | |
209 | } keys %$pkg); | |
210 | } | |
211 | if ($cs->{action} & CA_HASH and !$pretext) { | |
212 | my $sym; | |
213 | no strict 'refs'; | |
214 | push(@l, grep { /^\w+$/ && /^\Q$text/ | |
215 | && ($sym = $pkg . $_, defined *$sym{HASH}) | |
216 | } keys %$pkg); | |
217 | } | |
218 | if ($cs->{action} & CA_FUNCTION and !$pretext) { | |
219 | my $sym; | |
220 | no strict 'refs'; | |
221 | push(@l, grep { /^\w+$/ && /^\Q$text/ | |
222 | && ($sym = $pkg . $_, defined *$sym{CODE}) | |
223 | } keys %$pkg); | |
224 | } | |
225 | ||
226 | # -G glob | |
227 | # This does not work without modifying the specification of | |
228 | # Term::ReadLine::Perl::completion_function, which matches again | |
229 | # with globpattern. | |
230 | # if (defined $cs->{globpat}) { | |
231 | # my $pat = glob2regexp($cs->{globpat}); | |
232 | # my $dir = $pretext || '.'; | |
233 | # opendir DIR, $dir | |
234 | # or warn "cannot open directory `$dir': $!\n", return (); | |
235 | # my @d = readdir DIR; | |
236 | # push(@l, grep(/$pat/, @d)); | |
237 | # closedir(DIR); | |
238 | # } | |
239 | ||
240 | # -W word list | |
241 | push(@l, grep { /^\Q$text/ } split(' ', $cs->{wordlist})) | |
242 | if defined $cs->{wordlist} and !$pretext; | |
243 | ||
244 | # -F function | |
245 | if (defined $cs->{function} and !$pretext) { | |
246 | # warn "[$text,$line,$start,$cmd]\n"; | |
247 | $__line = $line; $__start = $start; $__cmd = $cmd; # for compgen() | |
248 | if ($cs->{function} =~/^(.*)\:\:[^:]+$/) { | |
249 | # Function is in a package, so try autoloading it | |
250 | my $package= $1; | |
251 | eval "require $package;"; | |
252 | } | |
253 | my @t = eval { | |
254 | no strict 'refs'; | |
255 | &{$cs->{functionpackage}.'::'.$cs->{function}}($text, $line, $start, $cmd); | |
256 | }; | |
257 | if ($@) { | |
258 | warn $@; | |
259 | } else { | |
260 | push(@l, grep { /^\Q$text/ } @t); | |
261 | } | |
262 | } | |
263 | ||
264 | # -C command | |
265 | if (defined $cs->{command} and !$pretext) { | |
266 | # $ENV{COMP_LINE} = $line; | |
267 | # $ENV{COMP_POINT} = $start; | |
268 | my $cmd = "$cs->{command}"; | |
269 | # remove surrounding quotes | |
270 | $cmd =~ s/^\s*'(.*)'\s*$/$1/; | |
271 | $cmd =~ s/^\s*"(.*)"\s*$/$1/; | |
272 | push(@l, grep { chomp, /^\Q$text/ } | |
273 | `$cmd "$text" "$line" "$start" "$cmd"`); | |
274 | warn "$0: $cs->{command}: command not found\n" if $?; | |
275 | # $ENV{COMP_LINE} = $ENV{COMP_POINT} = undef; | |
276 | } | |
277 | ||
278 | # -X filter | |
279 | if (defined $cs->{filterpat}) { | |
280 | my $pat = $cs->{filterpat}; | |
281 | #warn "[$pat"; | |
282 | if ($pat =~ /^!/) { | |
283 | $pat = glob2regexp(substr($pat, 1)); | |
284 | @l = grep(/$pat/, @l); | |
285 | } else { | |
286 | $pat = glob2regexp($pat); | |
287 | @l = grep(! /$pat/, @l); | |
288 | } | |
289 | #warn "->$pat]\n"; | |
290 | } | |
291 | ||
292 | # -P prefix | |
293 | @l = map { $cs->{prefix} . $_ } @l if defined $cs->{prefix}; | |
294 | ||
295 | # -S suffix | |
296 | @l = map { $_ . $cs->{suffix} } @l if defined $cs->{suffix}; | |
297 | ||
298 | unshift @l,''; | |
299 | return @l; | |
300 | } | |
301 | ||
302 | ######################################################################## | |
303 | ||
304 | sub pcomp_getopts { | |
305 | my $ar = $_[0]; # reference to an array of arguments | |
306 | my %cs; | |
307 | $cs{action} = 0; | |
308 | ||
309 | while (defined ($ar->[0]) and $_ = $ar->[0], /^-/) { | |
310 | shift @{$ar}; | |
311 | last if /^--$/; | |
312 | if (/^-a/) { | |
313 | $cs{action} |= CA_ALIAS; | |
314 | } elsif (/^-b/) { | |
315 | $cs{action} |= CA_BUILTIN; | |
316 | } elsif (/^-c/) { | |
317 | $cs{action} |= CA_COMMAND; | |
318 | } elsif (/^-d/) { | |
319 | $cs{action} |= CA_DIRECTORY; | |
320 | } elsif (/^-e/) { | |
321 | $cs{action} |= CA_EXPORT; | |
322 | } elsif (/^-f/) { | |
323 | $cs{action} |= CA_FILE; | |
324 | } elsif (/^-j/) { | |
325 | $cs{action} |= CA_JOB; | |
326 | } elsif (/^-k/) { | |
327 | $cs{action} |= CA_KEYWORD; | |
328 | } elsif (/^-u/) { | |
329 | $cs{action} |= CA_USER; | |
330 | } elsif (/^-v/) { | |
331 | $cs{action} |= CA_VARIABLE; | |
332 | } elsif (/^-o/) { | |
333 | $cs{option} = Psh::Parser::unquote(shift @{$ar}); | |
334 | } elsif (/^-A/) { | |
335 | $_ = Psh::Parser::unquote(shift @{$ar}) || return undef; | |
336 | $cs{action} |= $ACTION{$_}; | |
337 | } elsif (/^-G/) { | |
338 | $cs{globpat} = Psh::Parser::unquote(shift @{$ar}); | |
339 | } elsif (/^-W/) { | |
340 | $cs{wordlist} = Psh::Parser::unquote(shift @{$ar}); | |
341 | } elsif (/^-C/) { | |
342 | $cs{command} = Psh::Parser::unquote(shift @{$ar}); | |
343 | } elsif (/^-F/) { | |
344 | $cs{function} = Psh::Parser::unquote(shift @{$ar}); | |
345 | $cs{function_package}= $Psh::PerlEval::current_package; | |
346 | } elsif (/^-X/) { | |
347 | $cs{filterpat} = Psh::Parser::unquote(shift @{$ar}); | |
348 | } elsif (/^-x/) { # psh specific (at least now) | |
349 | $cs{ffilterpat} = Psh::Parser::unquote(shift @{$ar}); | |
350 | } elsif (/^-P/) { | |
351 | $cs{prefix} = Psh::Parser::unquote(shift @{$ar}); | |
352 | } elsif (/^-S/) { | |
353 | $cs{suffix} = Psh::Parser::unquote(shift @{$ar}); | |
354 | } elsif (/^-p/) { | |
355 | $cs{print} = 1; | |
356 | } elsif (/^-r/) { | |
357 | $cs{remove} = 1; | |
358 | } else { | |
359 | return undef; | |
360 | } | |
361 | } | |
362 | return \%cs; | |
363 | } | |
364 | ||
365 | sub _redir_op { | |
366 | local $_ = shift; | |
367 | return 0 if /'[<>]'/; | |
368 | return 1 if /[<>]/; | |
369 | return 0; | |
370 | } | |
371 | ||
372 | sub redir_test { | |
373 | my($cur, $prev) = @_; | |
374 | ||
375 | if (_redir_op($cur)) { | |
376 | return compgen('-f', $cur); | |
377 | } elsif (_redir_op($prev)) { | |
378 | return compgen('-f', $cur); | |
379 | } else { | |
380 | return (); | |
381 | } | |
382 | } | |
383 | ||
384 | sub compgen { | |
385 | if (!@_ or !$_[0]) { | |
386 | usage_compgen(); | |
387 | return undef; | |
388 | } | |
389 | my $cs = pcomp_getopts($_[0]) or usage_compgen(), return ; | |
390 | @_ = @{$_[0]}; | |
391 | usage_compgen() if $cs->{print} or $cs->{remove} or $#_ > 1; | |
392 | ||
393 | pcomp_list($cs, $_[0] || '', $__line, $__start, $__cmd); | |
394 | } | |
395 | ||
396 | sub usage_compgen { | |
397 | print STDERR <<EOM; | |
398 | compgen [-abcdefjkvu] [-A ACTION] [-G GLOBPAT] [-W WORDLIST] | |
399 | [-P PREFIX] [-S SUFFIX] [-X FILTERPAT] [-x FILTERPAT] | |
400 | [-F FUNCTION] [-C COMMAND] [WORD] | |
401 | EOM | |
402 | } | |
403 | ||
404 | package main; | |
405 | ||
406 | # compgen() routine is called by function which is assigned by `-F' option | |
407 | # of complete command. | |
408 | sub compgen { | |
409 | Psh::PCompletion::compgen(\@_); | |
410 | } | |
411 | ||
412 | 1; | |
413 | __END__ |