BEGIN {
$Sub::Spec::Pod::VERSION
=
'0.10'
;
}
use
5.010;
our
@ISA
=
qw(Exporter)
;
our
@EXPORT_OK
=
qw(gen_pod)
;
sub
_parse_schema {
Sub::Spec::CmdLine::_parse_schema(
@_
);
}
sub
_gen_sub_pod($;$) {
my
(
$sub_spec
,
$opts
) =
@_
;
$opts
//= {};
my
$pod
=
""
;
die
"No name in spec"
unless
$sub_spec
->{name};
$log
->trace(
"Generating POD for $sub_spec->{name} ..."
);
$pod
.=
"=head2 $sub_spec->{name}(\%args) -> "
.
"[STATUSCODE, ERRMSG, RESULT]\n\n"
;
if
(
$sub_spec
->{summary}) {
$pod
.=
"$sub_spec->{summary}.\n\n"
;
}
my
$desc
=
$sub_spec
->{description};
if
(
$desc
) {
$desc
=~ s/^\n+//;
$desc
=~ s/\n+$//;
$pod
.=
"$desc\n\n"
;
}
$pod
.=
<<'_';
Returns a 3-element arrayref. STATUSCODE is 200 on success, or an error code
between 3xx-5xx (just like in HTTP). ERRMSG is a string containing error
message, RESULT is the actual result.
_
my
$args
=
$sub_spec
->{args} // {};
$args
= {
map
{
$_
=> _parse_schema(
$args
->{
$_
})}
keys
%$args
};
my
$has_cat
=
grep
{
$_
->{attr_hashes}[0]{arg_category} }
values
%$args
;
if
(
scalar
keys
%$args
) {
my
$noted_star_req
;
my
$prev_cat
;
for
my
$name
(
sort
{
((
$args
->{
$a
}{attr_hashes}[0]{arg_category} //
""
) cmp
(
$args
->{
$b
}{attr_hashes}[0]{arg_category} //
""
)) ||
((
$args
->{
$a
}{attr_hashes}[0]{arg_pos} // 9999) <=>
(
$args
->{
$b
}{attr_hashes}[0]{arg_pos} // 9999)) ||
(
$a
cmp
$b
) }
keys
%$args
) {
my
$arg
=
$args
->{
$name
};
my
$ah0
=
$arg
->{attr_hashes}[0];
my
$cat
=
$ah0
->{arg_category} //
""
;
if
(!
defined
(
$prev_cat
) ||
$prev_cat
ne
$cat
) {
$pod
.=
"=back\n\n"
if
defined
(
$prev_cat
);
$pod
.= (
$cat
?
ucfirst
(
"$cat arguments"
) :
(
$has_cat
?
"General arguments"
:
"Arguments"
));
$pod
.=
" (C<*> denotes required arguments)"
unless
$noted_star_req
++;
$pod
.=
":\n\n=over 4\n\n"
;
$prev_cat
=
$cat
;
}
$pod
.=
"=item * B<$name>"
.(
$ah0
->{required} ?
"*"
:
""
).
" => "
;
my
$type
;
if
(
$arg
->{type} eq
'any'
) {
my
@schemas
=
map
{_parse_schema(
$_
)} @{
$ah0
->{of}};
my
@types
=
map
{
$_
->{type}}
@schemas
;
@types
=
sort
List::MoreUtils::uniq(
@types
);
$type
=
join
(
"|"
,
@types
);
}
else
{
$type
=
$arg
->{type};
}
$pod
.=
"I<$type>"
;
$pod
.=
" (default "
.
(
defined
(
$ah0
->{
default
}) ?
"C<"
.Data::Dump::Partial::dumpp(
$ah0
->{
default
}).
">"
:
"none"
).
")"
if
defined
(
$ah0
->{
default
});
$pod
.=
"\n\n"
;
my
$aliases
=
$ah0
->{arg_aliases};
if
(
$aliases
&&
keys
%$aliases
) {
$pod
.=
"Aliases: "
;
my
$i
= 0;
for
my
$al
(
sort
keys
%$aliases
) {
$pod
.=
", "
if
$i
++;
my
$alinfo
=
$aliases
->{
$al
};
$pod
.=
"B<$al>"
.
(
$alinfo
->{summary} ?
" ($alinfo->{summary})"
:
""
);
}
$pod
.=
"\n\n"
;
}
$pod
.=
"Value must be one of:\n\n"
.
join
(
""
,
map
{
" $_\n"
}
split
/\n/,
Data::Dump::
dump
(
$ah0
->{in})).
"\n\n"
if
defined
(
$ah0
->{in});
$pod
.=
"$ah0->{summary}.\n\n"
if
$ah0
->{summary};
my
$desc
=
$ah0
->{description};
if
(
$desc
) {
$desc
=~ s/^\n+//;
$desc
=~ s/\n+$//;
$pod
.=
"$desc\n\n"
;
}
}
$pod
.=
"=back\n\n"
;
}
else
{
$pod
.=
"No known arguments at this time.\n\n"
;
}
$pod
;
}
sub
gen_pod {
my
%args
=
@_
;
my
$module
=
$args
{module};
my
$modulep
=
$args
{path};
if
(!
defined
(
$modulep
)) {
$modulep
=
$module
;
$modulep
=~ s!::!/!g;
$modulep
.=
".pm"
;
}
if
(
$args
{
require
} // 1) {
$log
->trace(
"Attempting to require $modulep ..."
);
eval
{
require
$modulep
};
die
$@
if
$@;
}
no
strict
'refs'
;
my
$specs
= \%{
$module
.
"::SUBS"
};
die
"Can't find \%SUBS in package $module\n"
unless
$specs
;
for
(
keys
%$specs
) {
$specs
->{
$_
}{_package} =
$module
;
$specs
->{
$_
}{name} =
$_
;
}
join
(
""
,
map
{ _gen_sub_pod(
$specs
->{
$_
}) }
sort
keys
%$specs
);
}
1;