Default commands

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    => {

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<ucfirst> of the package name, otherwise, return
-C<ucfirst> of C<$cmd> itself.
+The command is first searched for in C<alias>. 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<commands>,
+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<undef> 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;

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  = '<commands>' 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<DESCRIPTION>
+Display usage. If C<$want_detail> is true, the C<DESCRIPTION>
 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.

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;

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;

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<version> command modelled after
+that of L<App::Cmd>. You can modify the default message by subclassing
+this command and overriding its C<run> method, or by modifying it with
+eg. L<Class::Method::Modifiers>.
+
+=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;