use
5.010001;
our
$AUTHORITY
=
'cpan:PERLANCAR'
;
our
$DATE
=
'2022-10-07'
;
our
$DIST
=
'App-shcompgen'
;
our
$VERSION
=
'0.325'
;
our
%SPEC
;
my
$re_progname
=
qr/\A[A-Za-z0-9_.,:-]+\z/
;
$SPEC
{
':package'
} = {
v
=> 1.1,
summary
=>
'Generate shell completion scripts'
,
};
my
$_complete_prog
=
sub
{
my
%args
=
@_
;
my
$word
=
$args
{word} //
''
;
if
(
$word
=~ m!/!) {
return
{
words
=> Complete::File::complete_file(
word
=>
$word
,
filter
=>
'd|rxf'
),
path_sep
=>
'/'
,
};
}
else
{
Complete::Program::complete_program(
word
=>
$word
);
}
};
our
@supported_shells
=
qw(bash fish zsh tcsh)
;
our
%shell_arg
= (
shell
=> {
summary
=>
'Override guessing and select shell manually'
,
schema
=> [
'str*'
, {
in
=>\
@supported_shells
}],
tags
=> [
'common'
],
cmdline_aliases
=> {
fish
=> {
summary
=>
"Shortcut for --shell=fish"
,
is_flag
=>1,
code
=>
sub
{
$_
[0]{shell} =
"fish"
}},
zsh
=> {
summary
=>
"Shortcut for --shell=zsh"
,
is_flag
=>1,
code
=>
sub
{
$_
[0]{shell} =
"zsh"
}},
tcsh
=> {
summary
=>
"Shortcut for --shell=tcsh"
,
is_flag
=>1,
code
=>
sub
{
$_
[0]{shell} =
"tcsh"
}},
},
},
);
our
%common_args
= (
%shell_arg
,
global
=> {
summary
=>
'Use global completions directory'
,
schema
=> [
'bool*'
],
cmdline_aliases
=> {
per_user
=> {
is_flag
=> 1,
code
=>
sub
{
$_
[0]{global} = 0 },
summary
=>
'Alias for --no-global'
,
},
},
description
=>
<<'_',
Shell has global (system-wide) completions directory as well as per-user. For
example, in fish the global directory is by default `/etc/fish/completions` and
the per-user directory is `~/.config/fish/completions`.
By default, if running as root, the global is chosen. And if running as normal
user, per-user directory is chosen. Using `--global` or `--per-user` overrides
that and manually select which.
_
tags
=> [
'common'
],
},
bash_global_dir
=> {
summary
=>
'Directory to put completions scripts'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
default
=> [
'/etc/bash/completions'
],
tags
=> [
'common'
],
},
bash_per_user_dir
=> {
summary
=>
'Directory to put completions scripts'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
tags
=> [
'common'
],
},
fish_global_dir
=> {
summary
=>
'Directory to put completions scripts'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
default
=> [
'/etc/fish/completions'
],
tags
=> [
'common'
],
},
fish_per_user_dir
=> {
summary
=>
'Directory to put completions scripts'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
tags
=> [
'common'
],
},
tcsh_global_dir
=> {
summary
=>
'Directory to put completions scripts'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
default
=> [
'/etc/tcsh/completions'
],
tags
=> [
'common'
],
},
tcsh_per_user_dir
=> {
summary
=>
'Directory to put completions scripts'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
tags
=> [
'common'
],
},
zsh_global_dir
=> {
summary
=>
'Directory to put completions scripts'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
default
=> [
'/usr/local/share/zsh/site-functions'
],
tags
=> [
'common'
],
},
zsh_per_user_dir
=> {
summary
=>
'Directory to put completions scripts'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
tags
=> [
'common'
],
},
helper_global_dir
=> {
summary
=>
'Directory to put helper scripts'
,
schema
=> [
'str*'
],
default
=>
'/etc/shcompgen/helpers'
,
tags
=> [
'common'
],
},
helper_per_user_dir
=> {
summary
=>
'Directory to put helper scripts'
,
schema
=> [
'str*'
],
tags
=> [
'common'
],
},
per_option
=> {
summary
=>
'Create per-option completion script if possible'
,
description
=>
<<'_',
If set to true, then attempt to create completion script that register each
option. This creates nicer completion in some shells, e.g. fish and zsh. For
example, option description can be shown.
This is possible for only some types of scripts, e.g. <pm:Perinci::CmdLine>-
(that does not have subcommands) or <pm:Getopt::Long::Descriptive>-based ones.
_
schema
=>
'bool'
,
},
);
sub
_all_exec_in_PATH {
my
@res
;
for
my
$dir
(
split
/:/,
$ENV
{PATH}) {
opendir
my
(
$dh
),
$dir
or
next
;
for
my
$f
(
readdir
$dh
) {
next
if
$f
eq
'.'
||
$f
eq
'..'
;
next
if
$f
=~ /~\z/;
next
unless
((-f
"$dir/$f"
) && (-x _));
push
@res
,
"$dir/$f"
;
}
}
\
@res
;
}
sub
_set_args_defaults {
my
$args
=
shift
;
if
(!
$args
->{shell}) {
my
$sh
= Shell::Guess->running_shell;
my
$n
=
$sh
->{name};
$n
=
"zsh"
if
$n
eq
'z'
;
$n
=
"tcsh"
if
$n
eq
'c'
;
$n
=
"bash"
if
$n
eq
'bourne'
;
$args
->{shell} =
$n
;
}
unless
(
grep
{
$_
eq
$args
->{shell} }
@supported_shells
) {
return
[412,
"Unsupported shell '$args->{shell}'"
];
}
$args
->{global} //= ($> ? 0:1);
$args
->{bash_global_dir} //= [
'/etc/bash/completions'
];
$args
->{bash_per_user_dir} //= [
"$ENV{HOME}/.config/bash/completions"
];
$args
->{fish_global_dir} //= [
'/etc/fish/completions'
];
$args
->{fish_per_user_dir} //= [
"$ENV{HOME}/.config/fish/completions"
];
$args
->{tcsh_global_dir} //= [
'/etc/tcsh/completions'
];
$args
->{tcsh_per_user_dir} //= [
"$ENV{HOME}/.config/tcsh/completions"
];
$args
->{zsh_global_dir} //= [
'/usr/local/share/zsh/site-functions'
];
$args
->{zsh_per_user_dir} //= [
"$ENV{HOME}/.config/zsh/completions"
];
$args
->{helper_global_dir} //=
'/etc/shcompgen/helpers'
;
$args
->{helper_per_user_dir} //=
"$ENV{HOME}/.config/shcompgen/helpers"
;
[200];
}
sub
_tcsh_init_script_path {
my
%args
=
@_
;
if
(
$args
{global}) {
return
"/etc/shcompgen.tcshrc"
;
}
else
{
return
"$ENV{HOME}/.config/shcompgen.tcshrc"
;
}
}
sub
_gen_tcsh_init_script {
my
%args
=
@_
;
my
$dirs
=
$args
{global} ?
$args
{tcsh_global_dir} :
$args
{tcsh_per_user_dir};
my
@defs
;
for
my
$dir
(
@$dirs
) {
next
unless
-d
$dir
;
for
my
$file
(
glob
"$dir/*"
) {
open
my
$fh
,
"<"
,
$file
or
do
{
warn
"Can't open '$file': $!, skipped\n"
;
next
;
};
my
$line
= <
$fh
>;
$line
.=
"\n"
unless
$line
=~ /\n\z/;
push
@defs
,
$line
;
close
$fh
;
}
}
join
(
""
,
"# Generated by shcompgen on "
,
scalar
(
localtime
),
"\n"
,
@defs
,
);
}
sub
_gen_completion_script {
my
%args
=
@_
;
my
$detres
=
$args
{detect_res};
my
$shell
=
$args
{shell};
my
$prog
=
$detres
->[3]{
'func.completee'
} //
$args
{prog};
my
$progpath
=
$args
{progpath};
my
$qprog
= String::ShellQuote::shell_quote(
$prog
);
my
$comp
=
$detres
->[3]{
'func.completer_command'
};
my
$qcomp
= String::ShellQuote::shell_quote(
$comp
);
my
$args
=
$detres
->[3]{
'func.completer_command_args'
};
my
$qargs
;
$qargs
= String::ShellQuote::shell_quote(
$args
)
if
defined
$args
;
my
$header_at_bottom
;
my
$script
;
my
@helper_scripts
;
if
((
$detres
->[3]{
'func.completer_type'
} //
''
) =~ /\A(?:
CLI::MetaUtil::Getopt::Long |
Getopt::Long(?:::EvenLess|::Descriptive)?
)\z/x) {
my
$content
;
my
$dump_res
;
if
(
$detres
->[3]{
'func.completer_type'
} eq
'Getopt::Long::EvenLess'
) {
$dump_res
= Getopt::Long::EvenLess::Dump::dump_getopt_long_evenless_script(
filename
=>
$progpath
,
skip_detect
=> 1,
);
}
else
{
$dump_res
= Getopt::Long::Dump::dump_getopt_long_script(
filename
=>
$progpath
,
skip_detect
=> 1,
);
}
if
(
$dump_res
->[0] != 200) {
log_error(
"Can't dump Getopt::Long script '%s': %s"
,
$progpath
,
$dump_res
);
$script
=
"# Can't dump Getopt::Long script '$progpath': $dump_res->[0] - $dump_res->[1]\n"
;
goto
L1;
}
$content
=
join
(
""
,
"#!$^X\n"
,
"use Getopt::Long::Complete;\n"
,
"my \$spec = "
, Data::Dmp::dmp(
$dump_res
->[2]),
";\n"
,
"GetOptions(\@\$spec);\n"
,
);
$comp
= (
$args
{global} ?
$args
{helper_global_dir} :
$args
{helper_per_user_dir}) .
"/$prog"
;
$qcomp
= String::ShellQuote::shell_quote(
$comp
);
push
@helper_scripts
, {
path
=>
$comp
,
content
=>
$content
,
};
}
if
((
$detres
->[3]{
'func.completer_type'
} //
''
) =~ /\AGetopt::Std\z/) {
my
$content
;
my
$dump_res
= Getopt::Std::Dump::dump_getopt_std_script(
filename
=>
$progpath
,
skip_detect
=> 1,
);
if
(
$dump_res
->[0] != 200) {
log_error(
"Can't dump Getopt::Std script '%s': %s"
,
$progpath
,
$dump_res
);
$script
=
"# Can't dump Getopt::Std script '$progpath': $dump_res->[0] - $dump_res->[1]\n"
;
goto
L1;
}
$content
=
join
(
""
,
"#!$^X\n"
,
"use Getopt::Long::Complete;\n"
,
"my \$spec = "
, Data::Dmp::dmp(
Getopt::Long::Util::gen_getopt_long_spec_from_getopt_std_spec(
is_getopt
=>
$dump_res
->[2][0] eq
'getopt'
? 1:0,
spec
=>
$dump_res
->[2][1])
),
";\n"
,
"GetOptions(%\$spec);\n"
,
);
$comp
= (
$args
{global} ?
$args
{helper_global_dir} :
$args
{helper_per_user_dir}) .
"/$prog"
;
$qcomp
= String::ShellQuote::shell_quote(
$comp
);
push
@helper_scripts
, {
path
=>
$comp
,
content
=>
$content
,
};
}
if
(
$shell
eq
'bash'
) {
if
(
defined
$args
) {
$script
=
q|
_|
.
$prog
.
q| ()
{
local words
words=("${COMP_WORDS[@]:0:1}")
# insert arguments into the second element
words+=(|
.
$qargs
.
q|)
words+=("${COMP_WORDS[@]:1:COMP_CWORD}")
local s1="${words[@]}"
local point=${#s1}
words+=("${COMP_WORDS[@]:COMP_CWORD+1}")
#echo "D:words = ${words[@]}"
#echo "D:point = $point"
#echo "D:cmd = COMP_LINE=\"${words[@]}\" COMP_POINT=$point |
.
$comp
.
q|"
COMPREPLY=( `COMP_LINE="${words[@]}" COMP_POINT=$point |
.
$comp
.
q|` )
#echo "D:reply = ${COMPREPLY[@]}"
}
complete -F _|
.
"$prog $qprog"
.
q|
|
;
}
else
{
$script
=
"complete -C $qcomp $qprog"
;
}
}
elsif
(
$shell
eq
'zsh'
) {
GEN_ZSH:
{
$header_at_bottom
++;
if
(
$args
{per_option}) {
if
(
$detres
->[3]{
'func.completer_type'
} =~ /^Perinci::CmdLine/) {
my
$res
= Complete::Zsh::Gen::FromPerinciCmdLine::gen_zsh_complete_from_perinci_cmdline_script(
filename
=>
$progpath
,
skip_detect
=> 1,
);
if
(
$res
->[0] == 200) {
log_debug(
"Using per-option completion script for '%s'"
,
$prog
);
$script
=
$res
->[2];
last
GEN_ZSH;
}
else
{
log_debug(
"Can't generate per-option completion script for '%s': %s, falling back"
,
$prog
,
$res
);
}
}
elsif
(
$detres
->[3]{
'func.completer_type'
} =~ /^Getopt::Long::Descriptive/) {
my
$res
= Complete::Zsh::Gen::FromGetoptLongDescriptive::gen_zsh_complete_from_getopt_long_descriptive_script(
filename
=>
$progpath
,
skip_detect
=> 1,
);
if
(
$res
->[0] == 200) {
log_debug(
"Using per-option completion script for '%s'"
,
$prog
);
$script
=
$res
->[2];
last
GEN_ZSH;
}
else
{
log_debug(
"Can't generate per-option completion script for '%s': %s, falling back"
,
$prog
,
$res
);
}
}
}
if
(
defined
$args
) {
$script
=
"# TODO: args not yet supported\n"
;
}
else
{
$script
=
q|#compdef |
.
$prog
.
q|
_|
.
$prog
.
q|() {
si=$IFS
compadd -- $(COMP_SHELL=zsh COMP_LINE=$BUFFER COMP_POINT=$CURSOR |
.
$qcomp
.
q|)
IFS=$si
}
_|
.
$prog
.
q| "$@"
|
;
}
}
}
elsif
(
$shell
eq
'tcsh'
) {
if
(
defined
$args
) {
$header_at_bottom
++;
$script
=
"complete $qprog 'p/*/`$qcomp $args`/'\n"
;
}
else
{
$header_at_bottom
++;
$script
=
"complete $qprog 'p/*/`$qcomp`/'\n"
;
}
}
elsif
(
$shell
eq
'fish'
) {
GEN_FISH:
{
if
(
$args
{per_option}) {
if
(
$detres
->[3]{
'func.completer_type'
} =~ /^Perinci::CmdLine/) {
my
$res
= Complete::Fish::Gen::FromPerinciCmdLine::gen_fish_complete_from_perinci_cmdline_script(
filename
=>
$progpath
,
skip_detect
=> 1,
);
if
(
$res
->[0] == 200) {
log_debug(
"Using per-option completion script for '%s'"
,
$prog
);
$script
=
$res
->[2];
last
GEN_FISH;
}
else
{
log_debug(
"Can't generate per-option completion script for '%s': %s, falling back"
,
$prog
,
$res
);
}
}
elsif
(
$detres
->[3]{
'func.completer_type'
} =~ /^Getopt::Long::Descriptive/) {
my
$res
= Complete::Fish::Gen::FromGetoptLongDescriptive::gen_fish_complete_from_getopt_long_descriptive_script(
filename
=>
$progpath
,
skip_detect
=> 1,
);
if
(
$res
->[0] == 200) {
log_debug(
"Using per-option completion script for '%s'"
,
$prog
);
$script
=
$res
->[2];
last
GEN_FISH;
}
else
{
log_debug(
"Can't generate per-option completion script for '%s': %s, falling back"
,
$prog
,
$res
);
}
}
}
if
(
defined
$args
) {
$script
=
"# TODO: args not yet supported\n"
;
}
else
{
$script
=
"complete -c $qprog -a '(begin; set -lx COMP_SHELL fish; set -lx COMP_LINE (commandline); set -lx COMP_POINT (commandline -C); $qcomp; end)'\n"
;
}
}
}
else
{
die
"Sorry, shell '$shell' is not supported yet"
;
}
L1:
if
(
$header_at_bottom
) {
$script
=
"$script\n"
.
"# FRAGMENT id=shcompgen-header note="
.
(
$detres
->[3]{
'func.note'
} //
''
).
"\n"
;
}
else
{
$script
=
"# FRAGMENT id=shcompgen-header note="
.
(
$detres
->[3]{
'func.note'
} //
''
).
"\n$script\n"
;
}
my
$i
= 0;
for
(
@helper_scripts
) {
$i
++;
$script
.=
"# FRAGMENT id=shcompgen-helper-$i path=$_->{path}\n"
;
}
(
$script
,
@helper_scripts
);
}
sub
_completion_scripts_dirs {
my
%args
=
@_
;
my
$shell
=
$args
{shell};
my
$global
=
$args
{global};
my
$dirs
;
if
(
$shell
eq
'bash'
) {
$dirs
=
$global
?
$args
{bash_global_dir} :
$args
{bash_per_user_dir};
}
elsif
(
$shell
eq
'fish'
) {
$dirs
=
$global
?
$args
{fish_global_dir} :
$args
{fish_per_user_dir};
}
elsif
(
$shell
eq
'tcsh'
) {
$dirs
=
$global
?
$args
{tcsh_global_dir} :
$args
{tcsh_per_user_dir};
}
elsif
(
$shell
eq
'zsh'
) {
$dirs
=
$global
?
$args
{zsh_global_dir} :
$args
{zsh_per_user_dir};
}
$dirs
;
}
sub
_completion_script_path {
my
%args
=
@_
;
my
$detres
=
$args
{detect_res};
my
$prog
=
$detres
->[3]{
'func.completee'
} //
$args
{prog};
my
$shell
=
$args
{shell};
my
$global
=
$args
{global};
my
$dir
=
$args
{dir} // _completion_scripts_dirs(
%args
)->[-1];
my
$path
;
if
(
$shell
eq
'bash'
) {
$path
=
"$dir/$prog"
;
}
elsif
(
$shell
eq
'fish'
) {
$path
=
"$dir/$prog.fish"
;
}
elsif
(
$shell
eq
'tcsh'
) {
$path
=
"$dir/$prog"
;
}
elsif
(
$shell
eq
'zsh'
) {
$path
=
"$dir/_$prog"
;
}
$path
;
}
sub
_detect_prog {
my
%args
=
@_
;
my
$shell
=
$args
{shell};
my
$prog
=
$args
{prog};
my
$progpath
=
$args
{progpath};
open
my
(
$fh
),
"<"
,
$progpath
or
return
[500,
"Can't open '$progpath': $!"
];
read
$fh
,
my
(
$buf
), 2;
my
$is_script
=
$buf
eq
'#!'
;
return
[200,
"OK"
, 0, {
"func.reason"
=>
"Not a script"
}]
if
!
$is_script
;
my
$is_perl_script
= <
$fh
> =~ /perl/;
seek
$fh
, 0, 0;
my
$content
=
do
{
local
$/;
scalar
<
$fh
> };
my
%extrametas
;
DETECT:
{
my
@lines
=
split
/^/,
$content
;
my
(
$has_hint_cmd
,
$cmd
,
$args
);
for
my
$line
(
@lines
) {
if
(
$line
=~
/^\s*
$has_hint_cmd
++;
$cmd
= $1;
$args
= $2;
last
;
}
}
my
$has_nohint
;
for
my
$line
(
@lines
) {
if
(
$line
=~ /^\s*
$has_nohint
++;
last
;
}
}
if
(
$has_hint_cmd
&& !
$has_nohint
) {
if
(
defined
(
$args
) &&
$args
=~ s/\A"//) {
$args
=~ s/"\z//;
$args
=~ s/\\(.)/$1/g;
}
return
[200,
"OK"
, 1, {
"func.completer_command"
=>
$cmd
,
"func.completer_command_args"
=>
$args
,
"func.note"
=>
"hint(command)"
,
%extrametas
,
}];
}
my
$has_hint_completer
;
my
$completee
;
for
my
$line
(
@lines
) {
if
(
$line
=~
/^\s*
$has_hint_completer
++;
$completee
= $1;
last
;
}
}
if
(
$has_hint_completer
&& !
$has_nohint
) {
return
[400,
"completee specified in '$progpath' is not a valid "
.
"program name: $completee"
]
unless
$completee
=~
$re_progname
;
return
[200,
"OK"
, 1, {
"func.completer_command"
=>
$prog
,
"func.completee"
=>
$completee
,
"func.note"
=>
"hint(completer)"
,
%extrametas
,
}];
}
if
(
$is_perl_script
) {
for
my
$line
(
@lines
) {
if
(
$line
=~ /^\s*\
return
[200,
"OK"
, 0, {
"func.reason"
=>
"Perinci::CmdLine::Inline script"
,
}];
}
}
for
my
$line
(
@lines
) {
if
(
$line
=~ /^\s*((?:
use
|
require
)\s+
(
Getopt::Std|
Getopt::Long(?:::Complete|::Less|::EvenLess|::Subcommand|::More|::Descriptive)?|
CLI::MetaUtil::Getopt::Long(?::Complete)?|
Perinci::CmdLine(?:::Any|::Lite|::Classic)
))\b/x) {
return
[200,
"OK"
, 1, {
"func.completer_command"
=>
$prog
,
"func.completer_type"
=> $2,
"func.note"
=>
"perl use/require statement: $1"
,
}];
}
}
}
}
[200,
"OK"
, 0];
}
sub
_generate_or_remove {
my
$which0
=
shift
;
my
%args
=
@_
;
my
$setdef_res
= _set_args_defaults(\
%args
);
return
$setdef_res
unless
$setdef_res
->[0] == 200;
my
%written_files
;
my
%removed_files
;
my
$envres
= envresmulti();
PROG:
for
my
$prog0
(@{
$args
{prog} }) {
my
(
$prog
,
$progpath
);
log_debug(
"Processing program %s ..."
,
$prog0
);
if
(
$prog0
=~ m!/!) {
(
$prog
=
$prog0
) =~ s!.+/!!;
$progpath
=
$prog0
;
unless
(-f
$progpath
) {
log_error(
"No such file %s, skipped"
,
$progpath
);
$envres
->add_result(404,
"No such file"
, {
item_id
=>
$prog0
});
next
PROG;
}
}
else
{
$prog
=
$prog0
;
$progpath
= File::Which::which(
$prog0
);
unless
(
$progpath
) {
log_error(
"'%s' not found in PATH, skipped"
,
$prog0
);
$envres
->add_result(404,
"Not in PATH"
, {
item_id
=>
$prog0
});
next
PROG;
}
}
my
$which
=
$which0
;
if
(
$which
eq
'generate'
) {
my
$detres
= _detect_prog(
prog
=>
$prog
,
progpath
=>
$progpath
,
shell
=>
$args
{shell});
if
(
$detres
->[0] != 200) {
log_error(
"Can't detect '%s': %s"
,
$prog
,
$detres
->[1]);
$envres
->add_result(
$detres
->[0],
$detres
->[1],
{
item_id
=>
$prog0
});
next
PROG;
}
log_debug(
"Detection result for '%s': %s"
,
$prog
,
$detres
);
if
(!
$detres
->[2]) {
if
(
$args
{remove}) {
$which
=
'remove'
;
goto
REMOVE;
}
else
{
next
PROG;
}
}
my
(
$script
,
@helper_scripts
) = _gen_completion_script(
%args
,
prog
=>
$prog
,
progpath
=>
$progpath
,
detect_res
=>
$detres
);
my
$comppath
= _completion_script_path(
%args
,
prog
=>
$prog
,
detect_res
=>
$detres
);
if
(
$args
{stdout}) {
print
$script
;
next
PROG;
}
if
(-f
$comppath
) {
if
(!
$args
{replace}) {
log_info(
"Not replacing completion script for $prog in '$comppath' (use --replace to replace)"
);
$envres
->add_result(304,
"Not replaced (already exists)"
, {
item_id
=>
$prog0
});
next
PROG;
}
}
log_info(
"Writing completion script to %s ..."
,
$comppath
);
$written_files
{
$comppath
}++;
eval
{ write_text(
$comppath
,
$script
) };
if
($@) {
$envres
->add_result(500,
"Can't write to '$comppath': $@"
,
{
item_id
=>
$prog0
});
next
PROG;
}
for
my
$hs
(
@helper_scripts
) {
log_info(
"Writing helper script %s ..."
,
$hs
->{path});
$written_files
{
$hs
->{path}}++;
eval
{
write_text(
$hs
->{path},
$hs
->{content});
chmod
0755,
$hs
->{path};
};
if
($@) {
$envres
->add_result(500,
"Can't write helper script to '$hs->{path}': $@"
,
{
item_id
=>
$prog0
});
next
PROG;
}
}
$envres
->add_result(200,
"OK"
, {
item_id
=>
$prog0
});
}
REMOVE:
if
(
$which
eq
'remove'
) {
my
$comppath
= _completion_script_path(
%args
,
prog
=>
$prog
);
unless
(-f
$comppath
) {
log_debug(
"Skipping %s (completion script does not exist)"
,
$prog0
);
$envres
->add_result(304,
"Completion does not exist"
, {
item_id
=>
$prog0
});
next
PROG;
}
my
$content
;
eval
{
$content
= read_text(
$comppath
) };
if
($@) {
$envres
->add_result(500,
"Can't open '$comppath': $@"
, {
item_id
=>
$prog0
});
next
;
};
unless
(
$content
=~ /^
log_debug(
"Skipping %s, not installed by us"
,
$prog0
);
$envres
->add_result(304,
"Not installed by us"
, {
item_id
=>
$prog0
});
next
PROG;
}
if
(
$written_files
{
$comppath
}) {
next
PROG;
}
log_info(
"Unlinking %s ..."
,
$comppath
);
unless
(
unlink
$comppath
) {
$envres
->add_result(500,
"Can't unlink '$comppath': $!"
,
{
item_id
=>
$prog0
});
next
PROG;
}
while
(
$content
=~ /^
my
$hspath
= $1;
log_info(
"Unlinking helper script %s ..."
, $1);
unless
(
unlink
$hspath
) {
$envres
->add_result(500,
"Can't unlink helper script '$hspath': $!"
,
{
item_id
=>
$prog0
});
next
PROG;
}
$removed_files
{
$hspath
}++;
}
$envres
->add_result(200,
"OK"
, {
item_id
=>
$prog0
});
$removed_files
{
$comppath
}++;
}
}
if
(
keys
(
%written_files
) ||
keys
(
%removed_files
)) {
if
(
$args
{shell} eq
'tcsh'
) {
my
$init_script_path
= _tcsh_init_script_path(
%args
);
my
$init_script
= _gen_tcsh_init_script(
%args
);
log_debug(
"Re-writing init script %s ..."
,
$init_script_path
);
write_text(
$init_script_path
,
$init_script
);
}
}
$envres
->as_struct;
}
$SPEC
{guess_shell} = {
v
=> 1.1,
summary
=>
'Guess running shell'
,
args
=> {
},
};
sub
guess_shell {
my
%args
=
@_
;
my
$setdef_res
= _set_args_defaults(\
%args
);
return
$setdef_res
unless
$setdef_res
->[0] == 200;
[200,
"OK"
,
$args
{shell}];
}
$SPEC
{detect_prog} = {
v
=> 1.1,
summary
=>
"Detect a program"
,
args
=> {
%shell_arg
,
prog
=> {
schema
=>
'str*'
,
completion
=>
$_complete_prog
,
req
=> 1,
pos
=> 0,
},
},
'cmdline.default_format'
=>
'json'
,
};
sub
detect_prog {
my
%args
=
@_
;
_set_args_defaults(\
%args
);
my
$progname
=
$args
{prog};
my
$progpath
= File::Which::which(
$progname
);
return
[404,
"No such program '$progname'"
]
unless
$progpath
;
$progname
=~ s!.+/!!;
_detect_prog(
prog
=>
$progname
,
progpath
=>
$progpath
,
shell
=>
$args
{shell},
);
}
$SPEC
{init} = {
v
=> 1.1,
summary
=>
'Initialize shcompgen'
,
description
=>
<<'_',
This subcommand creates the completion directories and initialization shell
script, as well as run `generate`.
_
args
=> {
%common_args
,
},
};
sub
init {
my
%args
=
@_
;
my
$setdef_res
= _set_args_defaults(\
%args
);
return
$setdef_res
unless
$setdef_res
->[0] == 200;
my
$shell
=
$args
{shell};
my
$global
=
$args
{global};
my
$instruction
=
''
;
my
$dirs
;
my
$init_location
;
my
$init_script
;
my
$init_script_path
;
$dirs
= _completion_scripts_dirs(
%args
);
if
(
$global
) {
push
@$dirs
,
$args
{helper_global_dir};
}
else
{
push
@$dirs
,
$args
{helper_per_user_dir};
}
if
(
$shell
eq
'bash'
) {
$init_location
=
$global
?
(-d
"/etc/profile.d"
?
"/etc/profile.d/shcompgen.sh"
:
"/etc/bash.bashrc"
) :
"~/.bashrc"
;
$init_script
=
<<_;
# generated by shcompgen version $App::shcompgen::VERSION
_
$init_script
.=
<<'_';
_shcompgen_loader()
{
# check if bash-completion is active by the existence of function
# '_completion_loader'.
local bc_active=0
if [[ "`type -t _completion_loader`" = "function" ]]; then bc_active=1; fi
# XXX should we use --bash-{global,per-user}-dir supplied by user here? probably.
local dirs
dirs=(~/.config/bash/completions /etc/bash/completions)
if [[ "$bc_active" = 1 ]]; then
# we only search in bash-completion dirs when bash-completion has been
# initialized because some of the completion scripts require that
# bash-completion system is initialized first (e.g. _init_completion)
dirs+=(/etc/bash_completion.d /usr/share/bash-completion/completions)
fi
local d
for d in ${dirs[*]}; do
if [[ -f "$d/$1" ]]; then . "$d/$1"; return 124; fi
done
if [[ $bc_active = 1 ]]; then _completion_loader "$1"; return 124; fi
# otherwise, do as default (XXX still need to fix this, we don't want to
# install a fixed completion for unknown commands; but using 'compopt -o
# default' also creates a 'complete' entry)
complete -o bashdefault -o default "$1" && return 124
}
complete -D -F _shcompgen_loader
_
if
(
$global
) {
$init_script_path
=
"/etc/shcompgen.bashrc"
;
}
else
{
$init_script_path
=
"$ENV{HOME}/.config/shcompgen.bashrc"
;
}
$instruction
.=
"Please put this into your $init_location:"
.
"\n\n"
.
" . $init_script_path\n\n"
;
}
elsif
(
$shell
eq
'zsh'
) {
$init_location
=
$global
?
"/etc/zsh/zshrc"
:
"~/.zshrc"
;
$init_script
=
<<_;
# generated by shcompgen version $App::shcompgen::VERSION
_
$init_script
.=
<<'_';
local added_dir
for d in ~/.config/zsh/completions; do
if [[ ${fpath[(i)$d]} == "" || ${fpath[(i)$d]} -gt ${#fpath} ]]; then
fpath=($d $fpath)
added_dir=1
fi
done
if [[ $added_dir == 1 ]]; then compinit; fi
_
if
(
$global
) {
$init_script_path
=
"/etc/shcompgen.zshrc"
;
}
else
{
$init_script_path
=
"$ENV{HOME}/.config/shcompgen.zshrc"
;
}
$instruction
.=
"Please put this into your $init_location:"
.
"\n\n"
.
" . $init_script_path\n\n"
;
}
elsif
(
$shell
eq
'fish'
) {
}
elsif
(
$shell
eq
'tcsh'
) {
$init_location
=
$global
?
"/etc/csh.cshrc"
:
"~/.tcshrc"
;
$init_script
= _gen_tcsh_init_script(
%args
);
$init_script_path
= _tcsh_init_script_path(
%args
);
$instruction
.=
"Please put this into your $init_location:"
.
"\n\n"
.
" source $init_script_path\n\n"
;
}
else
{
return
[412,
"Shell '$shell' not yet supported"
];
}
for
my
$dir
(
@$dirs
) {
unless
(-d
$dir
) {
log_trace(
"Creating directory %s ..."
,
$dir
);
File::Path::make_path(
$dir
)
or
return
[500,
"Can't create $dir: $!"
];
$instruction
.=
"Directory '$dir' created.\n\n"
;
}
}
if
(
$init_script
) {
write_text(
$init_script_path
,
$init_script
);
}
$instruction
=
"Congratulations, shcompgen initialization is successful."
.
"\n\n$instruction"
;
[200,
"OK"
,
$instruction
];
}
$SPEC
{generate} = {
v
=> 1.1,
summary
=>
'Generate shell completion scripts for detectable programs'
,
args
=> {
%common_args
,
prog
=> {
summary
=>
'Program(s) to generate completion for'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
pos
=> 0,
greedy
=> 1,
description
=>
<<'_',
Can contain path (e.g. `../foo`) or a plain word (`foo`) in which case will be
searched from PATH.
_
element_completion
=>
$_complete_prog
,
},
replace
=> {
summary
=>
'Replace existing script'
,
schema
=> [
'bool*'
,
is
=>1],
description
=>
<<'_',
The default behavior is to skip if an existing completion script exists.
_
},
remove
=> {
summary
=>
'Remove completion for script that (now) is '
.
'not detected to have completion'
,
schema
=> [
'bool*'
,
is
=>1],
description
=>
<<'_',
The default behavior is to simply ignore existing completion script if the
program is not detected to have completion. When the `remove` setting is
enabled, however, such existing completion script will be removed.
_
},
stdout
=> {
summary
=>
'Output completion script to STDOUT'
,
schema
=> [
'bool'
,
is
=>1],
},
},
};
sub
generate {
my
%args
=
@_
;
$args
{prog} //= _all_exec_in_PATH();
_generate_or_remove(
'generate'
,
%args
);
}
$SPEC
{list} = {
v
=> 1.1,
summary
=>
'List all shell completion scripts generated by this script'
,
args
=> {
%common_args
,
detail
=> {
schema
=>
'bool'
,
cmdline_aliases
=> {
l
=>{}},
},
},
};
sub
list {
my
%args
=
@_
;
my
$setdef_res
= _set_args_defaults(\
%args
);
return
$setdef_res
unless
$setdef_res
->[0] == 200;
my
$shell
=
$args
{shell};
my
@res
;
my
$resmeta
= {};
my
$dirs
= _completion_scripts_dirs(
%args
);
for
my
$dir
(
@$dirs
) {
log_debug(
"Opening dir %s ..."
,
$dir
);
opendir
my
(
$dh
),
$dir
or
return
[500,
"Can't read dir '$dir': $!"
];
for
my
$entry
(
readdir
$dh
) {
next
if
$entry
eq
'.'
||
$entry
eq
'..'
;
my
$prog
=
$entry
;
if
(
$shell
eq
'fish'
) {
$prog
=~ s/\.fish\z//;
}
elsif
(
$shell
eq
'zsh'
) {
$prog
=~ s/\A_//;
}
next
unless
$prog
=~
$re_progname
;
my
$comppath
= _completion_script_path(
%args
,
dir
=>
$dir
,
prog
=>
$prog
);
log_debug(
"Checking completion script '%s' ..."
,
$comppath
);
my
$content
;
eval
{
$content
= read_text(
$comppath
) };
if
($@) {
log_warn(
"Can't open file '%s': %s"
,
$comppath
, $@);
next
;
};
unless
(
$content
=~ /^
log_debug(
"Skipping prog %s, not generated by us"
,
$entry
);
next
;
}
my
$note
= $1;
if
(
$args
{detail}) {
push
@res
, {
prog
=>
$prog
,
note
=>
$note
,
path
=>
$comppath
,
};
}
else
{
push
@res
,
$prog
;
}
}
}
$resmeta
->{
'table.fields'
} = [
qw/prog path note/
]
if
$args
{detail};
[200,
"OK"
, \
@res
,
$resmeta
];
}
$SPEC
{remove} = {
v
=> 1.1,
summary
=>
'Remove shell completion scripts generated by this script'
,
args
=> {
%common_args
,
prog
=> {
summary
=>
'Program(s) to remove completion script of'
,
schema
=> [
'array*'
,
of
=>
'str*'
],
pos
=> 0,
greedy
=> 1,
description
=>
<<'_',
Can contain path (e.g. `../foo`) or a plain word (`foo`) in which case will be
searched from PATH.
_
element_completion
=>
sub
{
my
%args
=
@_
;
my
$word
=
$args
{word} //
''
;
my
$res
= list(
$args
{args});
return
unless
$res
->[0] == 200;
Complete::Util::complete_array_elem(
array
=>
$res
->[2],
word
=>
$word
);
},
},
},
};
sub
remove {
my
%args
=
@_
;
$args
{prog} //= _all_exec_in_PATH();
_generate_or_remove(
'remove'
,
%args
);
}
1;
Hide Show 546 lines of Pod