package Sub::Spec::CmdLine; BEGIN { $Sub::Spec::CmdLine::VERSION = '0.10'; } # ABSTRACT: Access Perl subs via command line use 5.010; use strict; use warnings; use Log::Any '$log'; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw(parse_argv gen_usage format_result run); # currently we cheat by only parsing a limited subset of schema. this is because # Data::Sah is not available yet. sub _parse_schema { my ($schema) = @_; $schema = [$schema, {}] if !ref($schema); die "BUG: Can't parse hash-form schema yet" if ref($schema) ne 'ARRAY'; my $type = $schema->[0]; $type =~ s/\*$// and $schema->[1]{required} = 1; die "BUG: Can't handle type `$type` yet" unless $type =~ /^(int|float|bool|str|array|hash|any)$/; {type=>$type, attr_hashes=>[$schema->[1]]}; } sub parse_argv { require Getopt::Long; require YAML::Syck; $YAML::Syck::ImplicitTyping = 1; my ($argv, $sub_spec, $opts) = @_; my $args_spec = $sub_spec->{args} // {}; $args_spec = { map { $_ => _parse_schema($args_spec->{$_}) } keys %$args_spec }; $opts //= {}; $opts->{strict} //= 1; my %go_spec; my $args = {}; while (my ($name, $schema) = each %$args_spec) { my $opt; my @name = ($name); push @name, $name if $name =~ s/_/-/g; # allow --foo_bar and --foo-bar for (@name) { if ($schema->{type} eq 'bool') { $opt = "$_!"; } else { $opt = "$_=s"; } #$go_spec{$opt} = sub { $args->{$name[0]} = $_[0] }; $go_spec{$opt} = \$args->{$name[0]}; } } $log->tracef("GetOptions rule: %s", \%go_spec); my $result = Getopt::Long::GetOptionsFromArray($argv, %go_spec); unless ($result) { die "Incorrect command-line options/arguments\n" if $opts->{strict}; } $log->tracef("tmp args result (after getoptions): %s, argv: %s", $args, $argv); # parse YAML in opt values for my $k (keys %$args) { next unless defined($args->{$k}); eval { $args->{$k} = YAML::Syck::Load($args->{$k}) }; if ($@) { $log->info("Option --$k doesn't contain valid YAML, ". "assuming it's literal string"); } } # parse YAML in remaining @argv for my $i (0..@$argv-1) { next unless defined($argv->[$i]); eval { $argv->[$i] = YAML::Syck::Load($argv->[$i]) }; if ($@) { $log->info("Argument #".($i+1)." doesn't contain valid YAML, ". "assuming it's literal string"); } } $log->tracef("tmp args result (after YAML conversion): %s", $args); # process arg_pos ARGV: for my $i (reverse 0..@$argv-1) { while (my ($name, $schema) = each %$args_spec) { my $ah0 = $schema->{attr_hashes}[0]; my $o = $ah0->{arg_pos}; if (defined($o) && $o == $i) { if (defined($args->{$name})) { die "You specified option --$name but also argument #". ($i+1)."\n" if $opts->{strict}; } if ($ah0->{arg_greedy}) { $args->{$name} = [splice(@$argv, $i)]; last ARGV; } else { $args->{$name} = splice(@$argv, $i, 1); } } } } $log->tracef("tmp args result (after arg_pos processing): %s, argv: %s", $args, $argv); if (@$argv) { die "Error: extra argument(s): ".join(", ", @$argv)."\n" if $opts->{strict}; } # check required args while (my ($name, $schema) = each %$args_spec) { if ($schema->{attr_hashes}[0]{required} && !defined($args->{$name})) { die "Missing required argument: $name\n" if $opts->{strict}; } } # cleanup undefined args for (keys %$args) { delete $args->{$_} unless defined($args->{$_}); } $args; } sub gen_usage($;$) { require Data::Dump::Partial; require List::MoreUtils; my ($sub_spec, $opts) = @_; $opts //= {}; my $usage = ""; my $cmd = $opts->{cmd}; if ($sub_spec->{name}) { $cmd = ($sub_spec->{_package} ? "$sub_spec->{_package}::" : "") . $sub_spec->{name}; } if ($sub_spec->{summary}) { $usage .= ($cmd ? "$cmd - " : "") . "$sub_spec->{summary}\n\n"; } my $desc = $sub_spec->{description}; if ($desc) { $desc =~ s/^\n+//; $desc =~ s/\n+$//; $usage .= "$desc\n\n"; } my $args = $sub_spec->{args} // {}; my $rargs = $sub_spec->{required_args}; $args = { map {$_ => _parse_schema($args->{$_})} keys %$args }; my $has_cat = grep { $_->{attr_hashes}[0]{arg_category} } values %$args; my $prev_cat; my $noted_star_req; 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) { $usage .= "\n" if defined($prev_cat); $usage .= ($cat ? ucfirst("$cat options") : ($has_cat ? "General options" : "Options")); $usage .= " (* denotes required options)" unless $noted_star_req++; $usage .= ":\n"; $prev_cat = $cat; } my $arg_desc = ""; if ($arg->{type} eq 'any') { my @schemas = map {_parse_schema($_)} @{$ah0->{of}}; my @types = map {$_->{type}} @schemas; @types = sort List::MoreUtils::uniq(@types); $arg_desc .= "[" . join("|", @types) . "]"; } else { $arg_desc .= "[" . $arg->{type} . "]"; } my $o = $ah0->{arg_pos}; my $g = $ah0->{arg_greedy}; $arg_desc .= " $ah0->{summary}" if $ah0->{summary}; $arg_desc .= " (one of: ". Data::Dump::Partial::dumpp($ah0->{in}).")" if defined($ah0->{in}); $arg_desc .= " (default: ". Data::Dump::Partial::dumpp($ah0->{default}).")" if defined($ah0->{default}); my $desc = $ah0->{description}; if ($desc) { $desc =~ s/^\n+//; $desc =~ s/\n+$//; # XXX format/rewrap $desc =~ s/^/ /mg; $arg_desc .= "\n$desc\n"; } $usage .= sprintf(" --%-25s %s\n", $name . ($ah0->{required} ? "*" : "") . (defined($o) ? " [or arg ".($o+1). ($g ? "-last":"")."]" : ""), $arg_desc); } if ($sub_spec->{cmdline_examples}) { $usage .= "\nExamples:\n\n"; my $cmd = $opts->{cmd} // $0; for my $ex (@{ $sub_spec->{cmdline_examples} }) { $usage .= " % $cmd $ex->{cmd}\n"; my $desc = $ex->{description}; if ($desc) { $desc =~ s/^\n+//; $desc =~ s/\n+$//; $usage .= "\n$desc\n\n"; } } } $usage; } sub format_result { require Data::Format::Pretty::Console; require JSON; require PHP::Serialization; require YAML::Syck; $YAML::Syck::ImplicitTyping = 1; state $json = JSON->new->allow_nonref; my ($res, $format, $opts) = @_; $format //= 'text'; $opts //= {}; if ($format eq 'yaml') { return YAML::Syck::Dump($res); } elsif ($format eq 'json') { return $json->encode($res); } elsif ($format eq 'php') { return PHP::Serialization::serialize($res); } elsif ($format =~ /^(text|pretty|nopretty)$/) { if (!defined($res->[2])) { return $res->[0] == 200 ? ($opts->{default_success_message} // "") : "ERROR $res->[0]: $res->[1]\n"; } my $r = $res->[0] == 200 ? $res->[2] : $res; if ($format eq 'text') { return Data::Format::Pretty::Console::format_pretty($r); } elsif ($format eq 'pretty') { return Data::Format::Pretty::Console::format_pretty( $r, {interactive=>1}); } elsif ($format eq 'nopretty') { return Data::Format::Pretty::Console::format_pretty( $r, {interactive=>0}); } } die "BUG: Unknown output format `$format`"; } sub run { require Getopt::Long; my %args = @_; my %opts = (format => undef, action => 'run'); Getopt::Long::Configure("pass_through", "no_permute"); Getopt::Long::GetOptions( "--list|l" => sub { $opts{action} = 'list' }, "--version|v" => sub { $opts{action} = 'version' }, "--help|h|?" => sub { $opts{action} = 'help' }, "--text" => sub { $opts{format} = 'text' }, "--yaml" => sub { $opts{format} = 'yaml' }, "--json" => sub { $opts{format} = 'json' }, "--pretty" => sub { $opts{format} = 'pretty' }, "--nopretty" => sub { $opts{format} = 'nopretty' }, ); my $exit = $args{exit} // 1; my $subcmds = $args{subcommands}; my $module; my $sub; # handle --list if ($opts{action} eq 'list') { if ($subcmds) { # XXX sort by category for my $c (sort keys %$subcmds) { my $sc = $subcmds->{$c}; say " $c", ($sc->{summary} ? " - $sc->{summary}" : ""); } } if ($exit) { exit 0 } else { return 0 } } # finding out which module/sub to use my $subcmdname; my $subcmd; if ($args{subcommands} && @ARGV) { $subcmdname = shift @ARGV; $subcmd = $args{subcommands}{$subcmdname}; $subcmd or die "Unknown subcommand `$subcmdname`, please ". "use $0 -l to list available subcommands\n"; $module = $subcmd->{module} // $args{module}; $sub = $subcmd->{sub} // $subcmdname; } else { $module = $args{module}; $sub = $args{sub}; } # handle --version if ($opts{action} eq 'version') { no strict 'refs'; my $version = ${$module."::VERSION"} // "?"; say "Version $version"; if ($exit) { exit 0 } else { return 0 } } die "Please specify a subcommand, ". "use $0 -l to list available subcommands\n" unless $module && $sub; my $cmd = $args{cmd} // $0; # require module and get spec my $modulep = $args{module}; $modulep =~ s!::!/!g; $modulep .= ".pm"; if ($args{require} // 1) { eval { require $modulep }; die $@ if $@; } no strict 'refs'; my $subs = \%{$module."::SUBS"}; my $spec = $subs->{$sub}; die "Can't find spec for sub $module\::$sub\n" unless $spec; # handle general --help if ($opts{action} eq 'help') { if ($args{subcommands}) { say $cmd, ($args{summary} ? " - $args{summary}" : ""); print <<_; Usage: $cmd SUBCOMMAND [ARGS ...] $cmd SUBCOMMAND --help (or -l, or -?) $cmd --list (or -?) $cmd --help Options: --list List subcommands --help Show this message _ } else { print gen_usage($spec, {cmd=>$cmd}); } if ($exit) { exit 0 } else { return 0 } } # handle per-command --help if ($subcmd && $ARGV[0] && $ARGV[0] =~ /^(--help|-h|-\?)$/) { print gen_usage($spec, {cmd=>"$cmd $subcmdname"}); if ($exit) { exit 0 } else { return 0 } } my $args = parse_argv(\@ARGV, $spec); my $subref = \&{$module."::$sub"}; my $res = $subref->(%$args); $log->tracef("opts=%s", \%opts); print format_result($res, $opts{format}) unless $spec->{cmdline_suppress_output}; my $exit_code = $res->[0] == 200 ? 0 : $res->[0] - 300; if ($exit) { exit $exit_code } else { return $exit_code } } 1; =pod =head1 NAME Sub::Spec::CmdLine - Access Perl subs via command line =head1 VERSION version 0.10 =head1 SYNOPSIS In your module: package YourModule; our %SUBS; $SUBS{foo} = { summary => 'Foo!', args => { arg => ..., arg2 => ... }, ... }; sub foo { ... } ... 1; In your script: #!/usr/bin/perl use Sub::Spec::CmdLine qw(run); run(module=>'YourModule', sub=>'foo'); In the command-line: % script.pl --help % script.pl --arg value --arg2 '[an, array, in, yaml, syntax]' ... For running multiple subs, in your script: use Sub::Spec::CmdLine qw(run); run(subcommands => { foo => { module=>'YourModule', sub=>'foo'}, bar => { module=>'YourModule', sub=>'bar'}, ... }); In the command-line: % script.pl --help % script.pl --list % script.pl foo --help % script.pl foo --arg value --arg2 ... % script.pl bar --blah ... =head1 DESCRIPTION This module utilize sub specs (as defined by L<Sub::Spec>) to let your subs be accessible from the command-line. This module uses L<Log::Any> logging framework. Use something like L<Log::Any::App>, etc to see more logging statements for debugging. NOTE: This module is not ready for public consumption yet. It will be after L<Data::Sah> and L<Sub::Spec> is released. =head1 FUNCTIONS None of the functions are exported by default, but they are exportable. =head2 parse_argv(\@argv, $sub_spec[, \%opts]) => \%args Parse command line argument @argv into hash %args, suitable for passing into subs. Uses Getopt::Long to parse the result. You can Getopt::Long::Configure beforehand to modify behaviour (e.g. if you want no_permute). Note: As with GetOptions, this function modifies its argument, @argv. Why would one use this function instead of using Getopt::Long directly? Among other reasons, we want YAML parsing (ability to pass data structures via command line) and parsing of arg_pos and arg_greedy. Options in %opts: =over 4 =item * strict => BOOL (default 1) If set to 0, will still return parsed argv even if there are errors. =back =head2 gen_usage($sub_spec) => TEXT Generate usage information for a sub (typically used for --help). =head2 format_result($sub_res[, \%opts]) => TEXT Format result from sub into various formats Options: =over 4 =item * format => FORMAT (optional, default 'text') Format can be 'text' (pretty text or nonpretty text), 'pretty' (pretty text, generated by L<Data::Format::Pretty::Console> under interactive=1), 'nopretty' (also generated by Data::Format::Pretty::Console under interactive=0), 'yaml', 'json', 'php' (generated by L<PHP::Serialization>'s serialize()). =item * default_success_message => STR (optional, default none) If output format is text ('text', 'pretty', 'nopretty') and result code is 200 and there is no data returned, this default_success_message is used. Example: 'Success'. =back =head2 run(%args) Run sub from the command line, which essentially comprises these steps: =over 4 =item * Parse command-line options in @ARGV (using parse_argv()) Also, display help using gen_usage() if given '--help' or '-h' or '-?'. =item * Call sub =item * Format the return value from sub (using format_result()) =item * Exit with appropriate exit code 0 if 200, or CODE-300. =back Arguments: =over 4 =item * summary => STR =item * module => STR =item * sub => STR =item * subcommands => {NAME => {module=>..., sub=>..., summary=>...}, ...} B<module> and B<sub> should be specified if you only have one sub to run. If you have several subs to run, assign each of them to a subcommand, e.g.: summary => 'Maintain a directory containing git repos', module => 'Git::Bunch', subcommands => { backup => { }, # module defaults to main module argument, status => { }, # sub defaults to the same name as subcommand name }, =item * exit => BOOL (optional, default 1) If set to 0, instead of exiting with exit(), return the exit code instead. =item * require => BOOL (optional, default 1) If set to 0, do not try to require the module. =back =head1 SEE ALSO L<Sub::Spec> L<Sub::Spec::Pod> L<MooseX::Getopt> =head1 AUTHOR Steven Haryanto <stevenharyanto@gmail.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011 by Steven Haryanto. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__