| 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__ |