package Sub::Spec::CmdLine; BEGIN { $Sub::Spec::CmdLine::VERSION = '0.15'; } # 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; $log->tracef("-> parse_argv(), argv=%s", $argv); 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]}; } my $aliases = $schema->{attr_hashes}[0]{cmdline_aliases}; if ($aliases) { while (my ($alias, $alinfo) = each %$aliases) { if ($alinfo->{code}) { $go_spec{$alias} = sub { $alinfo->{code}->( args => $args, arg_ref => \$args->{$name[0]}, ); }; } else { $go_spec{$alias} = \$args->{$name[0]}; } } } } $log->tracef("GetOptions rule: %s", \%go_spec); Getopt::Long::Configure( $opts->{strict} ? "no_pass_through" : "pass_through", "no_ignore_case", "permute"); 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"); } } # 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)]; my $j = $i; # convert to yaml for (@{$args->{$name}}) { eval { $_ = YAML::Syck::Load($_) }; if ($@) { $log->info( "Argument #".($j+1)." doesn't contain ". "valid YAML, assuming it's literal string"); $j++; } } last ARGV; } else { $args->{$name} = splice(@$argv, $i, 1); # convert to yaml eval { $_ = YAML::Syck::Load($_) }; if ($@) { $log->info( "Argument #".($i+1)." doesn't contain ". "valid YAML, assuming it's literal string"); } } } } } $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->{$_}); } $log->tracef("<- parse_argv(), args=%s", $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" : ($opts->{options_name} ? "$opts->{options_name} 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 $aliases = $ah0->{cmdline_aliases}; if ($aliases) { $arg_desc .= "\n"; for (sort keys %$aliases) { my $alinfo = $aliases->{$_}; $arg_desc .= join( "", " ", (length == 1 ? "-$_" : "--$_"), " ", $alinfo->{summary} ? $alinfo->{summary} : " is alias for --$name", "\n" ); } } 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_list { my ($subcommands, $args) = @_; return unless $subcommands; if (ref($subcommands) eq 'CODE') { $subcommands = $subcommands->(args=>$args); die "Error: subcommands code didn't return a hashref\n" unless ref($subcommands) eq 'HASH'; } my %percat_subc; # (cat1 => {subcmd1=>..., ...}, ...) while (my ($scn, $sc) = each %$subcommands) { my $cat = $sc->{category} // ""; $percat_subc{$cat} //= {}; $percat_subc{$cat}{$scn} = $sc; } my $has_many_cats = scalar(keys %percat_subc) > 1; my $i = 0; for my $cat (sort keys %percat_subc) { print "\n" if $i++; if ($has_many_cats) { print "List of ", ucfirst($cat) || "main", " subcommands:\n"; } else { print "List of subcommands:\n"; } my $subc = $percat_subc{$cat}; for my $scn (sort keys %$subc) { my $sc = $subc->{$scn}; say " $scn", ($sc->{summary} ? " - $sc->{summary}" : ""); } } } sub _run_version { my ($module, $cmd, $summary) = @_; # get from module's $VERSION no strict 'refs'; my $version = ${$module."::VERSION"} // "?"; my $rev = ${$module."::REVISION"}; say "$cmd version ", $version, ($rev ? " rev $rev" : ""); } sub _run_completion { my %args = @_; my @general_opts; for my $o (keys %{$args{getopts}}) { $o =~ s/^--//; my @o = split /\|/, $o; for (@o) { push @general_opts, length > 1 ? "--$_" : "-$_" } } my $spec = $args{spec}; if ($spec) { $log->trace("Complete subcommand argument names & values"); return Sub::Spec::BashComplete::bash_complete_spec_arg( $spec, { words => $args{words}, cword => $args{cword}, arg_sub => $args{arg_sub}, args_sub => $args{args_sub}, custom_completer => ($args{subcommand} ? $args{subcommand}{custom_completer} : undef) // $args{parent_args}{custom_completer} }, ); } else { $log->trace("Complete general options & names of subcommands"); my $subcommands = $args{parent_args}{subcommands}; $log->tracef("subcommands=%s", $subcommands); if (ref($subcommands) eq 'CODE') { $subcommands = $subcommands->(parent_args=>$args{parent_args}); die "Error: subcommands code didn't return hashref (2)\n" unless ref($subcommands) eq 'HASH'; } #print "D: comp_word=$args{word}\n"; return Sub::Spec::BashComplete::_complete_array( $args{word}, [@general_opts, keys(%$subcommands)] ); } } # returns help text sub _run_help { my ($help, $spec, $cmd, $summary, $argv) = @_; my $out = ""; $out .= $cmd . ($summary ? " - $summary" : "") . "\n\n"; if ($help) { if (ref($help) eq 'CODE') { $out .= $help->( spec=>$spec, cmd=>$cmd, argv=>$argv, ); } else { $out .= $help; } } elsif ($spec) { $out .= gen_usage($spec, {cmd=>$cmd}); } else { $out .= <<_; Usage: To get general help: $cmd --help (or -h, or -?) To list subcommands: $cmd --list (or -l) To show version: $cmd --version (or -v) To get help on a subcommand: $cmd --help SUBCOMMAND To run a subcommand: $cmd SUBCOMMAND [ARGS ...] _ } $out; } sub run { require Getopt::Long; my %args = @_; my $exit = $args{exit} // 1; # detect (1) if we're being invoked for bash completion, get ARGV from # COMP_LINE instead since ARGV given by bash is messed up / different my ($comp_words, $comp_cword, $comp_word); if ($ENV{COMP_LINE}) { eval { require Sub::Spec::BashComplete }; my $eval_err = $@; if ($eval_err) { die "Can't load Sub::Spec::BashComplete: $eval_err\n"; } my $res = Sub::Spec::BashComplete::_parse_request(); $comp_words = $res->{words}; $comp_cword = $res->{cword}; $comp_word = $comp_words->[$comp_cword] // ""; @ARGV = @$comp_words; } my %opts = (format => undef, action => 'run'); Getopt::Long::Configure("pass_through", "no_ignore_case", "no_permute"); my %getopts = ( "--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' }, ); Getopt::Long::GetOptions(%getopts); my $cmd = $args{cmd}; if (!$cmd) { $cmd = $0; $cmd =~ s!.+/!!; } my $subcommands = $args{subcommands}; my $module; my $sub; # finding out which module/sub to use my $subc; my $subc_name; my $load; if ($subcommands && @ARGV) { $subc_name = shift @ARGV; $subc = ref($subcommands) eq 'CODE' ? $subcommands->(name=>$subc_name, args=>\%args) : $subcommands->{$subc_name}; # it's ok if user type incomplete subcommand name under completion unless ($ENV{COMP_LINE}) { $subc or die "Unknown subcommand `$subc_name`, please ". "use $cmd -l to list available subcommands\n"; } $module = $subc->{module} // $args{module}; $sub = $subc->{sub} // $subc_name; $load = $subc->{load} // $args{load} // 1; } else { $module = $args{module}; $sub = $args{sub}; $load = $args{load} // 1; } # require module and get spec my $spec; if ($subc && $subc->{spec}) { $spec = ref($subc->{spec}) eq 'CODE' ? $subc->{spec}->(module=>$module, sub=>$sub) : $subc->{spec}; } elsif ($args{spec}) { $spec = ref($args{spec}) eq 'CODE' ? $args{spec}->(module=>$module, sub=>$sub) : $args{spec}; } elsif ($module) { { my $modulep = $args{module}; $modulep =~ s!::!/!g; $modulep .= ".pm"; if ($load) { eval { require $modulep }; if ($@) { die $@ unless $ENV{COMP_LINE}; last; } } if ($sub) { no strict 'refs'; my $subs = \%{$module."::SUBS"}; $spec = $subs->{$sub}; die "Can't find spec for sub $module\::$sub\n" unless $spec || $ENV{COMP_LINE}; } } } # now that we have spec, detect (2) if we're being invoked for bash # completion and do completion, and exit. if ($ENV{COMP_LINE}) { my $complete_arg; my $complete_args; if ($subc) { shift @$comp_words; $comp_cword-- unless $comp_cword < 1; $complete_arg = $subc->{complete_arg}; $complete_args = $subc->{complete_arg }; } $complete_arg //= $args{complete_arg}; $complete_args //= $args{complete_args}; my @res = _run_completion( parent_args => \%args, spec => $spec, getopts => \%getopts, words => $comp_words, cword => $comp_cword, word => $comp_word , arg_sub => $complete_arg, args_sub => $complete_args, subcommand => $subc, subcommand_name => $subc_name, ); $log->tracef("completion result: %s", \@res); print map {"$_\n"} @res; if ($exit) { exit 0 } else { return 0 } } # handle --list if ($opts{action} eq 'list') { _run_list($subcommands, \%args); if ($exit) { exit 0 } else { return 0 } } # handle --version if ($opts{action} eq 'version') { _run_version($module, $cmd, $args{summary}); if ($exit) { exit 0 } else { return 0 } } # handle --help if ($opts{action} eq 'help') { if ($spec) { print _run_help( $subc->{help}, $spec, ($subc_name ? "$cmd $subc_name" : $cmd), ($subc ? $subc->{summary} : $args{summary}), \@ARGV); if ($exit) { exit 0 } else { return 0 } } else { print _run_help( $args{help}, undef, $cmd, $subc ? $subc->{summary} : $args{summary}, \@ARGV, undef); } if ($exit) { exit 0 } else { return 0 } } die "Please specify a subcommand, ". "use $cmd -l to list available subcommands\n" unless $spec; # parse argv my $popts = {}; $popts->{strict} = 0 if $subc->{allow_unknown_args} // $args{allow_unknown_args}; my $args = parse_argv(\@ARGV, $spec, $popts); # finally, run! my $res; if ($subc && $subc->{run}) { # use run routine instead if supplied $res = $subc->{run}->( module=>$module, sub=>$sub, spec=>$spec, args=>$args, ); } else { # call sub my $subref = \&{$module."::$sub"}; $res = $subref->(%$args); } # output $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.15 =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 subroutine(s) 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 Currently this must be supplied if you want --version, even if you use subcommands. --version gets $VERSION from the main module. =item * sub => STR =item * spec => HASH | CODEREF Instead of trying to look for the spec using B<module> and B<sub>, use the supplied spec. =item * help => STRING | CODEREF Instead of generating help using gen_usage() from the spec, use the supplied help message (or help code, which is expected to return help text). =item * subcommands => {NAME => {ARGUMENT=>...}, ...} | CODEREF 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 => { check => { }, backup => { }, # module defaults to main module argument, sync => { }, # sub defaults to the same name as subcommand name }, Available argument for each subcommand: module (defaults to main B<module> argument), sub (defaults to subcommand name), summary, help, category (for arrangement when listing commands), run, complete_arg, complete_args. Subcommand argument can be a code reference, in which case it will be called with C<%args> containing: name (subcommand name), args (arguments to run()). The code is expected to return structure for argument with specified name, or, when name is not specified, a hashref containing all subcommand arguments. =item * run => CODEREF Instead of running command by invoking subroutine specified by B<module> and B<sub>, run this code instead. Code is expected to return a response structure ([CODE, MESSAGE, DATA]). =item * exit => BOOL (optional, default 1) If set to 0, instead of exiting with exit(), return the exit code instead. =item * load => BOOL (optional, default 1) If set to 0, do not try to load (require()) the module. =item * allow_unknown_args => BOOL (optional, default 0) =item * complete_arg => {ARGNAME => CODEREF, ...} Under bash completion, when completing argument value, you can supply a code to provide its completion. Code will be called with %args containing word, words, arg, args. =item * complete_args => CODEREF Under bash completion, when completing argument value, you can supply a code to provide its completion. Code will be called with %args containing word, words, arg, args. =item * custom_completer => CODEREF To be passed to BashComplete's bash_complete_spec_arg(). This can be used e.g. to change bash completion code (e.g. calling bash_complete_spec_arg() recursively) based on context. =back run() can also perform completion for bash (if L<Sub::Spec::BashComplete> is available). To get bash completion for your B<perlprog>, just type this in bash: % complete -C /path/to/perlprog perlprog You can add that line in bash startup file (~/.bashrc, /etc/bash.bashrc, etc). =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__