use
5.010001;
our
$AUTHORITY
=
'cpan:PERLANCAR'
;
our
$DATE
=
'2022-10-09'
;
our
$DIST
=
'Perinci-Sub-To-CLIDocData'
;
our
$VERSION
=
'0.301'
;
our
%SPEC
;
our
@ISA
=
qw(Exporter)
;
our
@EXPORT_OK
=
qw(gen_cli_doc_data_from_meta)
;
sub
_has_cats {
for
my
$spec
(@{
$_
[0] }) {
for
(@{
$spec
->{tags} // [] }) {
my
$tag_name
=
ref
(
$_
) ?
$_
->{name} :
$_
;
if
(
$tag_name
=~ /^category:/) {
return
1;
}
}
}
0;
}
sub
_add_category_from_spec {
my
(
$cats_spec
,
$thing
,
$spec
,
$noun
,
$has_cats
) =
@_
;
my
@cats
;
for
(@{
$spec
->{tags} // [] }) {
my
$tag_name
=
ref
(
$_
) ?
$_
->{name} :
$_
;
if
(
$tag_name
=~ /^category(\d+)?:(.+)/) {
my
$cat
=
ucfirst
($2);
my
$ordering
= $1 // 50;
$cat
=~ s/-/ /g;
$cat
.=
" "
.
$noun
;
push
@cats
, [
$cat
,
$ordering
];
}
}
if
(!
@cats
) {
@cats
= [
$has_cats
?
"Other $noun"
:
ucfirst
(
$noun
), 99];
}
$thing
->{category} =
$cats
[0][0];
$thing
->{categories} = [
map
{
$_
->[0]}
@cats
];
$cats_spec
->{
$_
->[0]}{order} //=
$_
->[1]
for
@cats
;
}
sub
_add_default_from_arg_spec {
my
(
$opt
,
$arg_spec
) =
@_
;
if
(
exists
$arg_spec
->{
default
}) {
$opt
->{
default
} =
$arg_spec
->{
default
};
}
elsif
(
$arg_spec
->{schema} &&
exists
(
$arg_spec
->{schema}[1]{
default
})) {
$opt
->{
default
} =
$arg_spec
->{schema}[1]{
default
};
}
}
sub
_dash_prefix {
length
(
$_
[0]) > 1 ?
"--$_[0]"
:
"-$_[0]"
;
}
sub
_fmt_opt {
my
$spec
=
shift
;
my
@ospecs
=
@_
;
my
@res
;
my
$i
= 0;
for
my
$ospec
(
@ospecs
) {
my
$j
= 0;
my
$parsed
=
$ospec
->{parsed};
for
(@{
$parsed
->{opts} }) {
my
$opt
= _dash_prefix(
$_
);
if
(
$i
==0 &&
$j
==0) {
if
(
$parsed
->{type}) {
if
(
$spec
->{
'x.schema.entity'
}) {
$opt
.=
"="
.
$spec
->{
'x.schema.entity'
};
}
elsif
(
$spec
->{
'x.schema.element_entity'
}) {
$opt
.=
"="
.
$spec
->{
'x.schema.element_entity'
};
}
else
{
$opt
.=
"=$parsed->{type}"
;
}
}
$opt
.=
"*"
if
$spec
->{req} && !
$ospec
->{is_base64} &&
!
$ospec
->{is_json} && !
$ospec
->{is_yaml};
}
push
@res
,
$opt
;
$j
++;
}
$i
++;
}
join
", "
,
@res
;
}
$SPEC
{gen_cli_doc_data_from_meta} = {
v
=> 1.1,
summary
=>
'From Rinci function metadata, generate structure convenient '
.
'for producing CLI documentation (help/usage/POD)'
,
description
=>
<<'_',
This function calls <pm:Perinci::Sub::GetArgs::Argv>'s
`gen_getopt_long_spec_from_meta()` (or receive its result as an argument, if
passed, to avoid calling the function twice) and post-processes it: produce
command usage line, format the options, include information from metadata, group
the options by category. It also selects examples in the `examples` property
which are applicable to CLI environment and format them.
The resulting data structure is convenient to use when one wants to produce a
documentation for CLI program (including help/usage message and POD).
_
args
=> {
meta
=> {
schema
=>
'hash*'
,
req
=> 1,
pos
=> 0,
},
meta_is_normalized
=> {
schema
=>
'bool*'
,
},
common_opts
=> {
summary
=>
'Will be passed to gen_getopt_long_spec_from_meta()'
,
schema
=>
'hash*'
,
},
ggls_res
=> {
summary
=>
'Full result from gen_getopt_long_spec_from_meta()'
,
schema
=>
'array*'
,
description
=>
<<'_',
If you already call <pm:Perinci::Sub::GetArgs::Argv>'s
`gen_getopt_long_spec_from_meta()`, you can pass the _full_ enveloped result
here, to avoid calculating twice. What will be useful for the function is the
extra result in result metadata (`func.*` keys in `$res->[3]` hash).
_
},
per_arg_json
=> {
schema
=>
'bool'
,
summary
=>
'Pass per_arg_json=1 to Perinci::Sub::GetArgs::Argv'
,
},
per_arg_yaml
=> {
schema
=>
'bool'
,
summary
=>
'Pass per_arg_json=1 to Perinci::Sub::GetArgs::Argv'
,
},
lang
=> {
schema
=>
'str*'
,
},
},
result
=> {
schema
=>
'hash*'
,
},
};
sub
gen_cli_doc_data_from_meta {
my
%args
=
@_
;
my
$lang
=
$args
{lang};
my
$meta
=
$args
{meta} or
return
[400,
'Please specify meta'
];
my
$common_opts
=
$args
{common_opts};
unless
(
$args
{meta_is_normalized}) {
$meta
= Perinci::Sub::Normalize::normalize_function_metadata(
$meta
);
}
my
$ggls_res
=
$args
{ggls_res} //
do
{
Perinci::Sub::GetArgs::Argv::gen_getopt_long_spec_from_meta(
meta
=>
$meta
,
meta_is_normalized
=>1,
common_opts
=>
$common_opts
,
per_arg_json
=>
$args
{per_arg_json},
per_arg_yaml
=>
$args
{per_arg_yaml},
);
};
$ggls_res
->[0] == 200 or
return
$ggls_res
;
my
$args_prop
=
$meta
->{args} // {};
my
$clidocdata
= {
option_categories
=> {},
example_categories
=> {},
};
my
%opts
;
GEN_LIST_OF_OPTIONS: {
my
$ospecs
=
$ggls_res
->[3]{
'func.specmeta'
};
my
(
@k
,
@k_aliases
);
OSPEC1:
for
(
sort
keys
%$ospecs
) {
my
$ospec
=
$ospecs
->{
$_
};
{
last
unless
$ospec
->{is_alias};
next
if
$ospec
->{is_code};
my
$arg_spec
=
$args_prop
->{
$ospec
->{arg}};
my
$alias_spec
=
$arg_spec
->{cmdline_aliases}{
$ospec
->{alias}};
next
if
$alias_spec
->{summary};
push
@k_aliases
,
$_
;
next
OSPEC1;
}
push
@k
,
$_
;
}
my
%negs
;
OSPEC2:
while
(
@k
) {
my
$k
=
shift
@k
;
my
$ospec
=
$ospecs
->{
$k
};
my
$opt
;
my
$optkey
;
if
(
$ospec
->{is_alias} ||
defined
(
$ospec
->{arg})) {
my
$arg_spec
;
my
$alias_spec
;
if
(
$ospec
->{is_alias}) {
my
$real_opt_ospec
=
$ospecs
->{
$ospec
->{alias_for} };
$arg_spec
=
$args_prop
->{
$ospec
->{arg} };
$alias_spec
=
$arg_spec
->{cmdline_aliases}{
$ospec
->{alias}};
my
$rimeta
= rimeta(
$alias_spec
);
$optkey
= _fmt_opt(
$arg_spec
,
$ospec
);
$opt
= {
opt_parsed
=>
$ospec
->{parsed},
orig_opt
=>
$k
,
is_alias
=> 1,
alias_for
=>
$ospec
->{alias_for},
summary
=>
$rimeta
->langprop({
lang
=>
$lang
},
'summary'
) //
"Alias for "
._dash_prefix(
$real_opt_ospec
->{parsed}{opts}[0]),
description
=>
$rimeta
->langprop({
lang
=>
$lang
},
'description'
),
};
}
else
{
$arg_spec
=
$args_prop
->{
$ospec
->{arg}};
my
$rimeta
= rimeta(
$arg_spec
);
$opt
= {
opt_parsed
=>
$ospec
->{parsed},
orig_opt
=>
$k
,
};
if
(
defined
(
$ospec
->{is_neg})) {
my
$default
=
$arg_spec
->{
default
} //
$arg_spec
->{schema}[1]{
default
};
next
OSPEC2
if
$default
&& !
$ospec
->{is_neg};
next
OSPEC2
if
!
$default
&&
$ospec
->{is_neg};
if
(
$ospec
->{is_neg}) {
next
OSPEC2
if
$negs
{
$ospec
->{arg}}++;
}
}
if
(
$ospec
->{is_neg}) {
$opt
->{summary} =
$rimeta
->langprop({
lang
=>
$lang
},
'summary.alt.bool.not'
);
}
elsif
(
defined
$ospec
->{is_neg}) {
$opt
->{summary} =
$rimeta
->langprop({
lang
=>
$lang
},
'summary.alt.bool.yes'
) //
$rimeta
->langprop({
lang
=>
$lang
},
'summary'
);
}
elsif
((
$ospec
->{parsed}{type}//
''
) eq
's@'
) {
$opt
->{summary} =
$rimeta
->langprop({
lang
=>
$lang
},
'summary.alt.plurality.singular'
) //
$rimeta
->langprop({
lang
=>
$lang
},
'summary'
);
}
else
{
$opt
->{summary} =
$rimeta
->langprop({
lang
=>
$lang
},
'summary'
);
}
$opt
->{description} =
$rimeta
->langprop({
lang
=>
$lang
},
'description'
);
my
@aliases
;
my
$j
=
$#k_aliases
;
while
(
$j
>= 0) {
my
$aospec
=
$ospecs
->{
$k_aliases
[
$j
] };
{
last
unless
$aospec
->{arg} eq
$ospec
->{arg};
push
@aliases
,
$aospec
;
splice
@k_aliases
,
$j
, 1;
}
$j
--;
}
$optkey
= _fmt_opt(
$arg_spec
,
$ospec
,
@aliases
);
}
$opt
->{arg_spec} =
$arg_spec
;
$opt
->{alias_spec} =
$alias_spec
if
$alias_spec
;
for
(
qw/arg fqarg is_base64 is_json is_yaml/
) {
$opt
->{
$_
} =
$ospec
->{
$_
}
if
defined
$ospec
->{
$_
};
}
for
(
qw/req pos slurpy greedy is_password links tags/
) {
$opt
->{
$_
} =
$arg_spec
->{
$_
}
if
defined
$arg_spec
->{
$_
};
}
{
local
$arg_spec
->{tags} = [
'category0:main'
]
if
!
$arg_spec
->{tags} || !@{
$arg_spec
->{tags}};
_add_category_from_spec(
$clidocdata
->{option_categories},
$opt
,
$arg_spec
,
"options"
, 1);
}
_add_default_from_arg_spec(
$opt
,
$arg_spec
);
}
else
{
my
$spec
=
$common_opts
->{
$ospec
->{common_opt}};
my
$show_neg
=
$ospec
->{parsed}{is_neg} &&
$spec
->{
default
};
local
$ospec
->{parsed}{opts} =
do
{
my
@opts
= Getopt::Long::Negate::EN::negations_for_option(
$ospec
->{parsed}{opts}[0]);
[
$opts
[0] ];
}
if
$show_neg
;
$optkey
= _fmt_opt(
$spec
,
$ospec
);
my
$rimeta
= rimeta(
$spec
);
$opt
= {
opt_parsed
=>
$ospec
->{parsed},
orig_opt
=>
$k
,
common_opt
=>
$ospec
->{common_opt},
common_opt_spec
=>
$spec
,
summary
=>
$show_neg
?
$rimeta
->langprop({
lang
=>
$lang
},
'summary.alt.bool.not'
) :
$rimeta
->langprop({
lang
=>
$lang
},
'summary'
),
(
schema
=>
$spec
->{schema}) x !!
$spec
->{schema},
(
'x.schema.entity'
=>
$spec
->{
'x.schema.entity'
}) x !!
$spec
->{
'x.schema.entity'
},
(
'x.schema.element_entity'
=>
$spec
->{
'x.schema.element_entity'
}) x !!
$spec
->{
'x.schema.element_entity'
},
description
=>
$rimeta
->langprop({
lang
=>
$lang
},
'description'
),
(
default
=>
$spec
->{
default
}) x !!(
exists
(
$spec
->{
default
}) && !
$show_neg
),
};
_add_category_from_spec(
$clidocdata
->{option_categories},
$opt
,
$spec
,
"options"
, 1);
}
$opts
{
$optkey
} =
$opt
;
}
OPT1:
for
my
$k
(
keys
%opts
) {
my
$opt
=
$opts
{
$k
};
next
unless
$opt
->{is_alias} ||
$opt
->{is_base64} ||
$opt
->{is_json} ||
$opt
->{is_yaml};
for
my
$k2
(
keys
%opts
) {
my
$arg_opt
=
$opts
{
$k2
};
next
if
$arg_opt
->{is_alias} ||
$arg_opt
->{is_base64} ||
$arg_opt
->{is_json} ||
$arg_opt
->{is_yaml};
next
unless
defined
(
$arg_opt
->{arg}) &&
$arg_opt
->{arg} eq
$opt
->{arg};
$opt
->{main_opt} =
$k2
;
next
OPT1;
}
}
}
$clidocdata
->{opts} = \
%opts
;
GEN_USAGE_LINE: {
my
@plain_args
;
my
@pod_args
;
my
%args_prop
=
%$args_prop
;
my
$max_pos
= -1;
for
(
values
%args_prop
) {
$max_pos
=
$_
->{
pos
}
if
defined
(
$_
->{
pos
}) &&
$_
->{
pos
} >
$max_pos
;
}
my
$pos
= 0;
while
(
$pos
<=
$max_pos
) {
my
(
$arg
,
$arg_spec
);
for
(
keys
%args_prop
) {
$arg_spec
=
$args_prop
{
$_
};
if
(
defined
(
$arg_spec
->{
pos
}) &&
$arg_spec
->{
pos
}==
$pos
) {
$arg
=
$_
;
last
;
}
}
$pos
++;
next
unless
defined
(
$arg
);
if
(
$arg_spec
->{slurpy} //
$arg_spec
->{greedy}) {
$arg
=
$arg_spec
->{
'x.name.singular'
}
if
$arg_spec
->{
'x.name.is_plural'
} &&
defined
$arg_spec
->{
'x.name.singular'
};
}
if
(
$arg_spec
->{req}) {
push
@plain_args
,
"<$arg>"
;
push
@pod_args
,
"E<lt>I<$arg>E<gt>"
;
}
else
{
push
@plain_args
,
"[$arg]"
;
push
@pod_args
,
"[I<$arg>]"
;
}
$plain_args
[-1] .=
" ..."
if
(
$arg_spec
->{slurpy} //
$arg_spec
->{greedy});
$pod_args
[-1] .=
" ..."
if
(
$arg_spec
->{slurpy} //
$arg_spec
->{greedy});
delete
$args_prop
{
$arg
};
}
my
@plain_opts
;
my
@pod_opts
;
my
%opt_locations
;
for
my
$ospec
(
sort
{
(
$ggls_res
->[3]{
'func.specmeta'
}{
$a
}{is_neg} ? 1:0) <=> (
$ggls_res
->[3]{
'func.specmeta'
}{
$b
}{is_neg} ? 1:0) ||
(
$ggls_res
->[3]{
'func.specmeta'
}{
$a
}{is_alias} ? 1:0) <=> (
$ggls_res
->[3]{
'func.specmeta'
}{
$b
}{is_alias} ? 1:0) ||
(
$ggls_res
->[3]{
'func.specmeta'
}{
$a
}{is_json} ? 1:0) <=> (
$ggls_res
->[3]{
'func.specmeta'
}{
$b
}{is_json} ? 1:0) ||
(
$ggls_res
->[3]{
'func.specmeta'
}{
$a
}{is_yaml} ? 1:0) <=> (
$ggls_res
->[3]{
'func.specmeta'
}{
$b
}{is_yaml} ? 1:0) ||
$a
cmp
$b
}
keys
%{
$ggls_res
->[3]{
'func.specmeta'
} }) {
my
$ospecmeta
=
$ggls_res
->[3]{
'func.specmeta'
}{
$ospec
};
my
$argprop
=
defined
$ospecmeta
->{arg} ?
$args_prop
{
$ospecmeta
->{arg} } :
undef
;
next
if
defined
$ospecmeta
->{arg} && !
$argprop
;
my
$copt
=
defined
$ospecmeta
->{common_opt} ?
$common_opts
->{
$ospecmeta
->{common_opt} } :
undef
;
next
if
defined
$ospecmeta
->{common_opt} &&
$copt
->{usage};
my
(
$caption_from_schema
,
$type
,
$cset
);
if
(
$argprop
&&
$argprop
->{schema} &&
ref
$argprop
->{schema} eq
'ARRAY'
) {
$type
=
$argprop
->{schema}[0];
$cset
=
$argprop
->{schema}[1];
if
(
$type
eq
'array'
) {
if
(
$cset
->{of} &&
ref
$cset
->{of} eq
'ARRAY'
) {
$caption_from_schema
=
$cset
->{of}[0];
}
}
elsif
(
$type
eq
'hash'
) {
if
(
$cset
->{of} &&
ref
$cset
->{of} eq
'ARRAY'
) {
$caption_from_schema
=
$cset
->{of}[0];
}
}
else
{
$caption_from_schema
=
$type
;
}
}
my
$hres
= Getopt::Long::Util::humanize_getopt_long_opt_spec({
extended
=>1,
separator
=>
"|"
,
value_label
=>(
$ospecmeta
->{is_json} ?
'json'
:
$ospecmeta
->{is_yaml} ?
'yaml'
:
$argprop
?
(
$argprop
->{
'x.cli.opt_value_label'
} //
$argprop
->{caption} //
$caption_from_schema
) :
$copt
->{value_label}
),
value_label_link
=>(
$ospecmeta
->{is_json} ?
undef
:
$ospecmeta
->{is_yaml} ?
undef
:
defined
(
$type
) && Module::Installed::Tiny::module_installed(
"Sah::Schema::$type"
) ?
"Sah::Schema::$type"
:
undef
),
},
$ospec
);
my
$plain_opt
=
$hres
->{plaintext};
my
$pod_opt
=
$hres
->{pod};
my
$key
;
if
(
$copt
&&
defined
$copt
->{key}) {
$key
=
"00common:"
.
$copt
->{key};
}
elsif
(
defined
$ospecmeta
->{arg}) {
$key
=
$ospecmeta
->{arg};
}
else
{
$key
=
$ospec
;
$key
=~ s/[=:].+\z//;
}
$key
=~ s/_/-/g;
$opt_locations
{
$key
} //=
scalar
@plain_opts
;
push
@{
$plain_opts
[
$opt_locations
{
$key
} ] },
$plain_opt
;
push
@{
$pod_opts
[
$opt_locations
{
$key
} ] },
$pod_opt
;
}
$clidocdata
->{compact_usage_line} =
"[[prog]]"
.
(
keys
(
%args_prop
) ||
keys
(
%$common_opts
) ?
" [options]"
:
""
).
(
@plain_args
?
" "
.
join
(
" "
,
@plain_args
) :
""
);
$clidocdata
->{usage_line} =
"[[prog]]"
.
(
@plain_opts
+
@plain_args
?
" "
.
join
(
" "
,
(
map
{
"["
.
join
(
"|"
,
@$_
) .
"]"
}
@plain_opts
),
(
@plain_opts
&&
@plain_args
? (
"--"
) : ()),
@plain_args
,
) :
""
);
$clidocdata
->{
'usage_line.alt.fmt.pod'
} =
"B<[[prog]]>"
.
(
@pod_opts
+
@pod_args
?
" "
.
join
(
" "
,
(
map
{
"["
.
join
(
"|"
,
@$_
) .
"]"
}
@pod_opts
),
(
@pod_opts
&&
@pod_args
? (
"--"
) : ()),
@pod_args
,
) :
""
);
}
my
@examples
;
{
my
$examples
=
$meta
->{examples} // [];
my
$has_cats
= _has_cats(
$examples
);
for
my
$eg
(
@$examples
) {
my
$rimeta
= rimeta(
$eg
);
my
$argv
;
my
$cmdline
;
if
(
defined
(
$eg
->{src})) {
if
(
$eg
->{src_plang} =~ /^(sh|bash)$/) {
$cmdline
=
$eg
->{src};
}
else
{
next
;
}
}
else
{
if
(
$eg
->{argv}) {
$argv
=
$eg
->{argv};
}
else
{
my
$res
= Perinci::Sub::ConvertArgs::Argv::convert_args_to_argv(
args
=>
$eg
->{args},
meta
=>
$meta
,
use_pos
=> 1);
return
err(
$res
, 500,
"Can't convert args to argv"
)
unless
$res
->[0] == 200;
$argv
=
$res
->[2];
}
$cmdline
=
"[[prog]]"
;
for
my
$arg
(
@$argv
) {
my
$qarg
= String::ShellQuote::shell_quote(
$arg
);
$cmdline
.=
" $qarg"
;
}
}
my
$egdata
= {
cmdline
=>
$cmdline
,
summary
=>
$rimeta
->langprop({
lang
=>
$lang
},
'summary'
),
description
=>
$rimeta
->langprop({
lang
=>
$lang
},
'description'
),
example_spec
=>
$eg
,
};
_add_category_from_spec(
$clidocdata
->{example_categories},
$egdata
,
$eg
,
"examples"
,
$has_cats
);
push
@examples
,
$egdata
;
}
}
$clidocdata
->{examples} = \
@examples
;
[200,
"OK"
,
$clidocdata
];
}
1;
Hide Show 281 lines of Pod