diff --git a/Makefile.PL b/Makefile.PL index f3cf87b..458577a 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -17,12 +17,11 @@ WriteMakefile( ], LICENSE => "perl_5", PREREQ_PM => { - 'Locale::Maketext::Simple' => 0, 'Getopt::Long' => '2.35', - 'Pod::Simple::Text' => 0, 'Carp' => 0, 'File::Find' => 0, 'Class::Load' => 0, + 'String::Format' => 0, }, MIN_PERL_VERSION => 5.006, TEST_REQUIRES => { diff --git a/lib/App/CLI.pm b/lib/App/CLI.pm index 7dd9f81..59e3e82 100644 --- a/lib/App/CLI.pm +++ b/lib/App/CLI.pm @@ -205,18 +205,41 @@ sub dispatch { =head3 cmd_map($cmd) -Find package name of subcommand in constant C<%alias>. +Find the name of the package implementing the requested command. -If it's found, return C of the package name, otherwise, return -C of C<$cmd> itself. +The command is first searched for in C. If the alias exists and points +to a package name starting with the C<+> sign, then that package name (minus +the C<+> sign) is returned. This makes it possible to map commands to arbitrary +packages. + +Otherwise, the package is searched for in the result of calling C, +and a package name is constructed by upper-casing the first character of the +command name, and appending it to the package name of the app itself. + +If both of these fail, and the command does not map to any package name, +C is returned instead. =cut sub cmd_map { - my ($pkg, $cmd) = @_; - my %alias = $pkg->alias; - $cmd = $alias{$cmd} if exists $alias{$cmd}; - return ucfirst($cmd); + my ($self, $cmd) = @_; + + my %alias = $self->alias; + + if (exists $alias{$cmd}) { + $cmd = $alias{$cmd}; + + # Alias points to package name, return immediately + return $cmd if $cmd =~ s/^\+//; + } + + ($cmd) = grep { $_ eq $cmd } $self->commands; + + # No such command + return unless $cmd; + + my $base = ref $self->app; + return join '::', $base, ucfirst $cmd; } sub error_cmd { @@ -246,12 +269,15 @@ sub get_cmd { die $self->error_cmd($cmd) unless $cmd && $cmd eq lc($cmd); my $base = ref $self; - my $pkg = join('::', $base, $self->cmd_map($cmd)); + my $pkg = $self->cmd_map($cmd); + + die $self->error_cmd($cmd) unless $pkg; + load_class $pkg; die $self->error_cmd($cmd) unless $pkg->can('run'); - my @arg = %$data; + my @arg = defined $data ? %$data : (); $cmd = $pkg->new(@arg); $cmd->app($self); return $cmd; diff --git a/lib/App/CLI/Command.pm b/lib/App/CLI/Command.pm index ab1d401..9d0e075 100644 --- a/lib/App/CLI/Command.pm +++ b/lib/App/CLI/Command.pm @@ -3,9 +3,13 @@ use strict; use warnings; use Locale::Maketext::Simple; use Carp (); + use App::CLI::Helper; +use App::CLI::Usage; + use Class::Load qw( load_class ); use Scalar::Util qw( weaken ); +use String::Format; =head1 NAME @@ -40,6 +44,7 @@ App::CLI::Command - Base class for App::CLI commands use constant subcommands => (); use constant options => (); +use constant usage_desc => '%c %C %o'; sub new { my $class = shift; @@ -142,49 +147,66 @@ sub app { =head3 brief_usage ($file) -Display a one-line brief usage of the command object. Optionally, a file -could be given to extract the usage from the POD. +Display a one-line brief usage of the command object. =cut sub brief_usage { - my ($self, $file) = @_; - open my ($podfh), '<', ($file || $self->filename) or return; - local $/=undef; - my $buf = <$podfh>; - my $base = $self->app; - if($buf =~ /^=head1\s+NAME\s*\Q$base\E::(\w+ - .+)$/m) { - print " ",loc(lc($1)),"\n"; - } else { - my $cmd = $file ||$self->filename; - $cmd =~ s/^(?:.*)\/(.*?).pm$/$1/; - print " ", lc($cmd), " - ",loc("undocumented")."\n"; + my ($self) = @_; + + my $option_string = q{}; + my $program_name = $self->prog_name; + my @components = split /::/, ref $self; + my $command_name = lc pop @components; + $command_name = '' if ref $self->app eq ref $self; + + my %options; + %options = $self->global_options if $self->can('global_options'); + %options = (%options, $self->options); + + if (%options) { + my (@short, @long); + + foreach my $opt (keys %options) { + foreach (split qr{\|}, $opt) { + (length == 1) + ? push @short, $_ + : push @long, $_; + } + } + + $option_string = '[' . join(q{}, sort @short) . ']' if @short; + $option_string .= ' [long options]' if @long; } - close $podfh; + + return stringf( $self->usage_desc . "\n\n" => + 'c' => $program_name, + 'C' => $command_name, + 'o' => $option_string, + ); } =head3 usage ($want_detail) -Display usage. If C<$want_detail> is true, the C +Display usage. If C<$want_detail> is true, the C section is displayed as well. =cut sub usage { my ($self, $want_detail) = @_; - my $fname = $self->filename; - my ($cmd) = $fname =~ m{\W(\w+)\.pm$}; - require Pod::Simple::Text; - my $parser = Pod::Simple::Text->new; - my $buf; - $parser->output_string(\$buf); - $parser->parse_file($fname); - - my $base = $self->app; - $buf =~ s/\Q$base\E::(\w+)/\l$1/g; - $buf =~ s/^AUTHORS.*//sm; - $buf =~ s/^DESCRIPTION.*//sm unless $want_detail; - print $self->loc_text($buf); + + my $select = '(?:NAME|SYNOPSIS' + . ($want_detail ? '|DESCRIPTION' : '') + . ')\s*'; + + my $usage = $self->brief_usage; + + my $parser = App::CLI::Usage->new( select => $select ); + $usage .= $parser->parse_file( $self->filename ); + + print $usage; + return $usage; } =head3 loc_text $text @@ -220,6 +242,22 @@ sub loc_text { return $out; } +=head3 abstract() + +Return the parsed abstract of the package implementing this command. + +=cut + +sub abstract { + my ($self) = @_; + + my $parser = App::CLI::Usage->new( select => '(?:NAME)\s*' ); + my $abstract = $parser->parse_file( $self->filename ); + $abstract =~ s/Name:[\n\s]*[\w:]+(\s+-\s+)?//m; + $abstract =~ s/[\n\s]*$//m; + return $abstract; +} + =head3 filename Return the filename for the command module. diff --git a/lib/App/CLI/Command/Commands.pm b/lib/App/CLI/Command/Commands.pm new file mode 100644 index 0000000..4a987f1 --- /dev/null +++ b/lib/App/CLI/Command/Commands.pm @@ -0,0 +1,45 @@ +package App::CLI::Command::Commands; + +use strict; +use warnings; + +use base qw/App::CLI::Command/; + +=head1 NAME + +App::CLI::Command::Commands - Print a list of commands for your app + +=head1 SYNOPSIS + + package MyApp; + use base qw(App::CLI App::CLI::Command); + + # Make your app get a list of commands + use constant alias => ( + commands => 'App::CLI::Command::Commands', + ); + + 1; + +=head1 DESCRIPTION + +Print a list of commands registered for your application; + +=cut + +sub run { + my ($self) = shift; + + my ($longest) = sort {length($b) cmp length($a)} $self->app->commands; + $longest = length $longest; + + foreach ($self->app->commands) { + my $cmd = $self->app->get_cmd($_); + my @components = split /::/, ref $cmd; + my $name = lc pop @components; + printf " %${longest}s: %s\n", $name, lc($cmd->abstract) || '[ undocumented ]'; + } + print "\n"; +} + +1; diff --git a/lib/App/CLI/Command/Help.pm b/lib/App/CLI/Command/Help.pm index 1fd7a5f..bdf8ecf 100644 --- a/lib/App/CLI/Command/Help.pm +++ b/lib/App/CLI/Command/Help.pm @@ -1,10 +1,14 @@ package App::CLI::Command::Help; + use strict; use warnings; + use base qw/App::CLI::Command/; + use File::Find qw(find); use Locale::Maketext::Simple; use Pod::Simple::Text; +use Class::Load qw( load_class ); =head1 NAME @@ -50,66 +54,8 @@ sub run { my $self = shift; my @topics = @_; - push @topics, 'commands' unless (@topics); - - foreach my $topic (@topics) { - if ($topic eq 'commands') { - $self->brief_usage ($_) for $self->app->files; - } - elsif (my $cmd = eval { $self->app->get_cmd ($topic) }) { - $cmd->usage(1); - } - elsif (my $file = $self->_find_topic($topic)) { - open my $fh, '<:utf8', $file or die $!; - require Pod::Simple::Text; - my $parser = Pod::Simple::Text->new; - my $buf; - $parser->output_string(\$buf); - $parser->parse_file($fh); - - $buf =~ s/^NAME\s+(.*?)::Help::\S+ - (.+)\s+DESCRIPTION/ $2:/; - print $self->loc_text($buf); - } - else { - die loc("Cannot find help topic '%1'.\n", $topic); - } - } - return; -} - -sub help_base { - my $self = shift; - return $self->app."::Help"; -} - -my ($inc, @prefix); -sub _find_topic { - my ($self, $topic) = @_; - - if (!$inc) { - my $pkg = __PACKAGE__; - $pkg =~ s{::}{/}; - $inc = substr( __FILE__, 0, -length("$pkg.pm") ); - - my $base = $self->help_base; - @prefix = (loc($base)); - $prefix[0] =~ s{::}{/}g; - $base =~ s{::}{/}g; - push @prefix, $base if $prefix[0] ne $base; - } - - foreach my $dir ($inc, @INC) { - foreach my $prefix (@prefix) { - foreach my $basename (ucfirst(lc($topic)), uc($topic)) { - foreach my $ext ('pod', 'pm') { - my $file = "$dir/$prefix/$basename.$ext"; - return $file if -f $file; - } - } - } - } - - return; + return $self->app->usage unless @topics; + return $self->app->get_cmd($_)->usage foreach @topics; } 1; diff --git a/lib/App/CLI/Command/Version.pm b/lib/App/CLI/Command/Version.pm new file mode 100644 index 0000000..09f0395 --- /dev/null +++ b/lib/App/CLI/Command/Version.pm @@ -0,0 +1,41 @@ +package App::CLI::Command::Version; + +use strict; +use warnings; + +use base qw/App::CLI::Command/; + +=head1 NAME + +App::CLI::Command::Version - Print a preformatted version string + +=head1 SYNOPSIS + + package MyApp; + use base qw(App::CLI App::CLI::Command); + + use constant alias => ( + '--version' => '+App::CLI::Command::Version', + 'version' => '+App::CLI::Command::Version', + # Other aliases + ); + + # Your app now supports a default version command and option + +=head1 DESCRIPTION + +This is package provides a default C command modelled after +that of L. You can modify the default message by subclassing +this command and overriding its C method, or by modifying it with +eg. L. + +=cut + +sub run { + my ($self) = shift; + no strict 'refs'; + print sprintf "%s (%s) version %s (%s)\n", + $self->app->prog_name, ref $self->app, $self->app->VERSION, $0; +} + +1; diff --git a/lib/App/CLI/Helper.pm b/lib/App/CLI/Helper.pm index aa8e747..92965f6 100644 --- a/lib/App/CLI/Helper.pm +++ b/lib/App/CLI/Helper.pm @@ -3,10 +3,12 @@ package App::CLI::Helper; use strict; use warnings; +use File::Basename qw( basename ); + sub import { no strict 'refs'; my $caller = caller; - for (qw(commands files)) { + for (qw(commands files prog_name)) { *{$caller."::$_"} = *$_; } } @@ -20,7 +22,7 @@ sub import { sub commands { - my $class = shift; + my ($class, $include_alias) = @_; my $dir = ref($class) || $class; $dir =~ s{::}{/}g; @@ -29,7 +31,7 @@ sub commands { my @cmds = map { ($_) = m{^\Q$dir\E/(.*)\.pm}; lc($_) } $class->files; - if (ref $class and $class->can('alias')) { + if ($include_alias and ref $class and $class->can('alias')) { my %aliases = $class->alias; push @cmds, $_ foreach keys %aliases; } @@ -37,6 +39,28 @@ sub commands { return sort @cmds; } +=head3 prog_name() + +The name of the program running your application. This will default to +C, but can be overiden from within your application. + +=cut + +{ + my $default; + sub prog_name { + my $self = shift; + + $default = basename $0 unless $default; + return $default unless ref $self; + + return $self->{prog_name} if defined $self->{prog_name}; + + $self->{prog_name} = basename $0; + return $self->{prog_name}; + } +} + =head3 files() return module files of subcommans of first level diff --git a/lib/App/CLI/Usage.pm b/lib/App/CLI/Usage.pm new file mode 100644 index 0000000..311d068 --- /dev/null +++ b/lib/App/CLI/Usage.pm @@ -0,0 +1,39 @@ +package App::CLI::Usage; + +use strict; +use warnings; + +use Pod::Usage; + +sub new { + my $class = shift; + my $args = @_ ? @_ > 1 ? { @_ } : shift : {}; + $args->{select} = '(?:NAME|SYNOPSIS|DESCRIPTION)\s*' unless $args->{select}; + $args->{parser} = Pod::Usage->new unless $args->{parser}; + + my $self = bless $args, $class; + $self->select($self->{select}); + + return $self; +} + +sub select { $_[0]->parser->select(@_) } + +sub parser { + my $self = shift; + $self->{parser} = shift if @_; + return $self->{parser}; +} + +sub parse_file { + my ($self, $filename) = @_; + + my $usage = q{}; + use autodie; + open my $fh, '>', \$usage; + $self->parser->parse_from_file($filename, $fh); + + return $usage; +} + +1; diff --git a/t/lib/Test/MyCmd.pm b/t/lib/Test/MyCmd.pm new file mode 100644 index 0000000..cd634c7 --- /dev/null +++ b/t/lib/Test/MyCmd.pm @@ -0,0 +1,41 @@ +package Test::MyCmd; + +use strict; +use warnings; + +use constant alias => ( + '--version' => '+App::CLI::Command::Version', + version => '+App::CLI::Command::Version', + '--help' => '+App::CLI::Command::Help', + help => '+App::CLI::Command::Help', + commands => '+App::CLI::Command::Commands', + frob => 'frobulate', +); + +use constant global_options => ( + 'v|verbose' => 'verbose', + 'F|force' => 'force', +); + +use parent qw(App::CLI App::CLI::Command); + +our $VERSION = '0.123'; + +1; + +__END__ + +=head1 NAME + +Test::MyCmd - A test command line application + +=head1 SYNOPSIS + + use Test::MyCmd; + Test::MyCmd->dispatch; + +=head1 DESCRIPTION + +Blib Bloob. + +=cut diff --git a/t/lib/Test/MyCmd/Exit.pm b/t/lib/Test/MyCmd/Exit.pm new file mode 100644 index 0000000..3a4f43a --- /dev/null +++ b/t/lib/Test/MyCmd/Exit.pm @@ -0,0 +1,13 @@ +package Test::MyCmd::Exit; + +use strict; +use warnings; + +use base qw(Test::MyCmd); + +sub run { + my ($self) = shift; + exit(defined $ARGV[0] ? $ARGV[0] : 0); +} + +1; diff --git a/t/lib/Test/MyCmd/Frobulate.pm b/t/lib/Test/MyCmd/Frobulate.pm new file mode 100644 index 0000000..d66e23e --- /dev/null +++ b/t/lib/Test/MyCmd/Frobulate.pm @@ -0,0 +1,19 @@ +package Test::MyCmd::Frobulate; + +use strict; +use warnings; + +use base qw(Test::MyCmd); + +use constant options => ( + 'foo-bar|F' => 'foo-bar', + 'widget=s' => 'widget', +); + +sub run { + my $self = shift; + $self->{widget} = '' unless defined $self->{widget}; + die "the widget name is $self->{widget} - @ARGV\n"; +} + +1; diff --git a/t/lib/Test/MyCmd/Hello.pm b/t/lib/Test/MyCmd/Hello.pm new file mode 100644 index 0000000..2cf0153 --- /dev/null +++ b/t/lib/Test/MyCmd/Hello.pm @@ -0,0 +1,24 @@ +package Test::MyCmd::Hello; + +use strict; +use warnings; + +use base qw(Test::MyCmd); + +use IPC::Cmd qw/can_run/; + +sub run { + my ($self, $opt, $arg) =@_; + + if ( $^O eq 'MSWin32' ) { + system('cmd', '/c', 'echo', "Hello World"); + } + else { + my $echo = can_run("echo"); + $self->usage_error("Program 'echo' not found") unless $echo; + system($echo, "Hello World"); + } + return; +} + +1; diff --git a/t/lib/Test/MyCmd/Justusage.pm b/t/lib/Test/MyCmd/Justusage.pm new file mode 100644 index 0000000..8797914 --- /dev/null +++ b/t/lib/Test/MyCmd/Justusage.pm @@ -0,0 +1,25 @@ +package Test::MyCmd::Justusage; + +use strict; +use warnings; + +use base qw(Test::MyCmd); + +use constant options => ( + 'd|detail' => 'detail', +); + +sub run { + my $self = shift; + die $self->usage($self->{detail}); +} + +1; + +__END__ + +=head1 NAME + +Test::MyCmd::Justusage - it just dies its own usage, no matter what + +=cut diff --git a/t/lib/Test/MyCmd/Stock.pm b/t/lib/Test/MyCmd/Stock.pm new file mode 100644 index 0000000..7fd1b2a --- /dev/null +++ b/t/lib/Test/MyCmd/Stock.pm @@ -0,0 +1,16 @@ +package Test::MyCmd::Stock; + +use strict; +use warnings; + +use base qw(Test::MyCmd); + +=head1 NAME + +Test::MyCmd::Stock - nothing here is overridden + +=cut + +# This package exists to test all the default command plugin behaviors. + +1;