[Bps-public-commit] r12190 - in App-CLI: . lib lib/App lib/App/CLI t t/lib t/lib/MyApp
clkao at bestpractical.com
clkao at bestpractical.com
Fri May 9 12:33:51 EDT 2008
Author: clkao
Date: Fri May 9 12:33:50 2008
New Revision: 12190
Added:
App-CLI/Changes
App-CLI/MANIFEST
App-CLI/Makefile.PL
App-CLI/SIGNATURE
App-CLI/lib/
App-CLI/lib/App/
App-CLI/lib/App/CLI/
App-CLI/lib/App/CLI.pm
App-CLI/lib/App/CLI/Command/
App-CLI/lib/App/CLI/Command.pm
App-CLI/lib/App/CLI/Command/Help.pm
App-CLI/t/
App-CLI/t/1basic.t
App-CLI/t/lib/
App-CLI/t/lib/CLITest.pm
App-CLI/t/lib/MyApp/
App-CLI/t/lib/MyApp.pm
App-CLI/t/lib/MyApp/Help.pm
App-CLI/t/lib/MyApp/Test.pm
Log:
import r409 of App::CLI from svn://svn.clkao.org/member/clkao/modules
Added: App-CLI/Changes
==============================================================================
--- (empty file)
+++ App-CLI/Changes Fri May 9 12:33:50 2008
@@ -0,0 +1,25 @@
+* 0.07 - 24 Nov 2006
+
+ * Don't use Carp without actually loading it.
+
+* 0.06 - 30 Jun 2006
+
+ * Really fix signatures.
+
+* 0.05 - 5 Jun 2006
+
+ * Fix signatures.
+
+* 0.04 - 11 Apr 2006
+
+ * Delay loading Pod::Simple::Text.
+
+* 0.03 - 27 Dec 2005
+
+ * Forgot to bundle Command::Help.
+
+* 0.02 - 25 Dec 2005
+
+ * Factored out Help system from SVK
+ * Factored out more command base stuff from SVK
+ (Thanks to Alex Vandiver)
Added: App-CLI/MANIFEST
==============================================================================
--- (empty file)
+++ App-CLI/MANIFEST Fri May 9 12:33:50 2008
@@ -0,0 +1,25 @@
+inc/ExtUtils/AutoInstall.pm
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/App/CLI.pm
+lib/App/CLI/Command.pm
+lib/App/CLI/Command/Help.pm
+Makefile.PL
+MANIFEST This list of files
+Changes
+META.yml
+SIGNATURE
+t/1basic.t
+t/lib/CLITest.pm
+t/lib/MyApp.pm
+t/lib/MyApp/Help.pm
+t/lib/MyApp/Test.pm
Added: App-CLI/Makefile.PL
==============================================================================
--- (empty file)
+++ App-CLI/Makefile.PL Fri May 9 12:33:50 2008
@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+
+use inc::Module::Install;
+
+name ('App-CLI');
+author ('Chia-liang Kao <clkao at clkao.org>');
+abstract_from ('lib/App/CLI.pm');
+license ('perl');
+version_from ('lib/App/CLI.pm');
+
+requires(
+ 'Locale::Maketext::Simple' => 0,
+ 'Getopt::Long' => '2.35',
+ 'Pod::Simple::Text' => 0,
+);
+
+include('ExtUtils::AutoInstall');
+auto_install();
+
+WriteAll( sign => 1 );
Added: App-CLI/SIGNATURE
==============================================================================
Added: App-CLI/lib/App/CLI.pm
==============================================================================
--- (empty file)
+++ App-CLI/lib/App/CLI.pm Fri May 9 12:33:50 2008
@@ -0,0 +1,158 @@
+package App::CLI;
+our $VERSION = 0.07;
+use strict;
+use warnings;
+
+=head1 NAME
+
+App::CLI - Dispatcher module for command line interface programs
+
+=head1 SYNOPSIS
+
+ package MyApp;
+ use base 'App::CLI';
+
+ package main;
+
+ MyApp->dispatch;
+
+ package MyApp::Help;
+ use base 'App::CLI::Command';
+
+ sub options {
+ ('verbose' => 'verbose');
+ }
+
+ sub run {
+ my ($self, $arg) = @_;
+ }
+
+=head1 DESCRIPTION
+
+C<App::CLI> dispatches CLI (command line interface) based commands
+into command classes. It also supports subcommand and per-command
+options.
+
+=cut
+
+use Getopt::Long ();
+
+use constant alias => ();
+use constant global_options => ();
+use constant options => ();
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ %$self = @_;
+ return $self;
+}
+
+sub prepare {
+ my $class = shift;
+ my $data = {};
+ $class->_getopt( [qw(no_ignore_case bundling pass_through)],
+ _opt_map($data, $class->global_options));
+ my $cmd = shift @ARGV;
+ $cmd = $class->get_cmd($cmd, @_, %$data);
+
+ $class->_getopt( [qw(no_ignore_case bundling)],
+ _opt_map($cmd, $cmd->command_options) );
+ return $cmd;
+}
+
+sub _getopt {
+ my $class = shift;
+ my $config = shift;
+ my $p = Getopt::Long::Parser->new;
+ $p->configure(@$config);
+ my $err = '';
+ local $SIG{__WARN__} = sub { my $msg = shift; $err .= "$msg" };
+ die $class->error_opt ($err)
+ unless $p->getoptions(@_);
+}
+
+sub dispatch {
+ my $class = shift;
+ my $cmd = $class->prepare(@_);
+ $cmd->subcommand;
+ $cmd->run_command(@ARGV);
+}
+
+sub _cmd_map {
+ my ($pkg, $cmd) = @_;
+ my %alias = $pkg->alias;
+ $cmd = $alias{$cmd} if exists $alias{$cmd};
+ return ucfirst($cmd);
+}
+
+sub error_cmd {
+ "Command not recognized, try $0 --help.\n";
+}
+
+sub error_opt { $_[1] }
+
+sub command_class { $_[0] }
+
+sub get_cmd {
+ my ($class, $cmd, @arg) = @_;
+ die $class->error_cmd
+ unless $cmd && $cmd =~ m/^[?a-z]+$/;
+ my $pkg = join('::', $class->command_class, $class->_cmd_map ($cmd));
+ my $file = "$pkg.pm";
+ $file =~ s!::!/!g;
+
+ unless (eval {require $file; 1} and $pkg->can('run')) {
+ warn $@ if $@ and exists $INC{$file};
+ die $class->error_cmd;
+ }
+ $cmd = $pkg->new (@arg);
+ $cmd->app ($class);
+ return $cmd;
+}
+
+sub _opt_map {
+ my ($self, %opt) = @_;
+ return map { $_ => ref($opt{$_}) ? $opt{$_} : \$self->{$opt{$_}}} keys %opt;
+}
+
+sub commands {
+ my $class = shift;
+ $class =~ s{::}{/}g;
+ my $dir = $INC{$class.'.pm'};
+ $dir =~ s/\.pm$//;
+ return sort map { ($_) = m{^\Q$dir\E/(.*)\.pm}; lc($_) } $class->files;
+}
+
+sub files {
+ my $class = shift;
+ $class =~ s{::}{/}g;
+ my $dir = $INC{$class.'.pm'};
+ $dir =~ s/\.pm$//;
+ return sort glob("$dir/*.pm");
+}
+
+=head1 TODO
+
+More documentation
+
+=head1 SEE ALSO
+
+L<App::CLI::Command>
+
+=head1 AUTHORS
+
+Chia-liang Kao E<lt>clkao at clkao.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2005-2006 by Chia-liang Kao E<lt>clkao at clkao.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
Added: App-CLI/lib/App/CLI/Command.pm
==============================================================================
--- (empty file)
+++ App-CLI/lib/App/CLI/Command.pm Fri May 9 12:33:50 2008
@@ -0,0 +1,193 @@
+package App::CLI::Command;
+use strict;
+use warnings;
+use Locale::Maketext::Simple;
+use Carp ();
+
+=head1 NAME
+
+App::CLI::Command - Base class for App::CLI commands
+
+=head1 SYNOPSIS
+
+ package MyApp;
+ use base 'App::CLI';
+
+ package main;
+
+ MyApp->dispatch;
+
+ package MyApp::Help;
+ use base 'App::CLI::Command';
+
+ sub options {
+ ('verbose' => 'verbose');
+ }
+
+ sub run {
+ my ($self, $arg) = @_;
+ }
+
+=head1 DESCRIPTION
+
+
+=cut
+
+use constant subcommands => ();
+use constant options => ();
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ %$self = @_;
+ return $self;
+}
+
+sub command_options {
+ ( (map { $_ => $_ } $_[0]->subcommands),
+ $_[0]->options );
+}
+
+sub run_command {
+ my $self = shift;
+ $self->run(@_);
+}
+
+sub subcommand {
+ my $self = shift;
+ my @cmd = $self->subcommands;
+ @cmd = values %{{$self->options}} if @cmd && $cmd[0] eq '*';
+ for (grep {$self->{$_}} @cmd) {
+ no strict 'refs';
+ if (exists ${ref($self).'::'}{$_.'::'}) {
+ bless ($self, (ref($self)."::$_"));
+ last;
+ }
+ }
+}
+
+sub app {
+ my $self = shift;
+ die Carp::longmess "not a ref" unless ref $self;
+ $self->{app} = shift if @_;
+ return ref ($self->{app}) || $self->{app};
+}
+
+=head3 brief_usage ($file)
+
+Display an one-line brief usage of the command object. Optionally, a file
+could be given to extract the usage from the POD.
+
+=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";
+ }
+ close $podfh;
+}
+
+=head3 usage ($want_detail)
+
+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);
+}
+
+=head3 loc_text $text
+
+Localizes the body of (formatted) text in $text, and returns the
+localized version.
+
+=cut
+
+sub loc_text {
+ my $self = shift;
+ my $buf = shift;
+
+ my $out = "";
+ foreach my $line (split(/\n\n+/, $buf, -1)) {
+ if (my @lines = $line =~ /^( {4}\s+.+\s*)$/mg) {
+ foreach my $chunk (@lines) {
+ $chunk =~ /^(\s*)(.+?)( *)(: .+?)?(\s*)$/ or next;
+ my $spaces = $3;
+ my $loc = $1 . loc($2 . ($4||'')) . $5;
+ $loc =~ s/: /$spaces: / if $spaces;
+ $out .= $loc . "\n";
+ }
+ $out .= "\n";
+ }
+ elsif ($line =~ /^(\s+)(\w+ - .*)$/) {
+ $out .= $1 . loc($2) . "\n\n";
+ }
+ elsif (length $line) {
+ $out .= loc($line) . "\n\n";
+ }
+ }
+ return $out;
+}
+
+=head3 filename
+
+Return the filename for the command module.
+
+=cut
+
+sub filename {
+ my $self = shift;
+ my $fname = ref($self);
+ $fname =~ s{::[a-z]+}{}; # subcommand
+ $fname =~ s{::}{/}g;
+ $INC{"$fname.pm"}
+}
+
+=head1 TODO
+
+More documentation
+
+=head1 SEE ALSO
+
+L<App::CLI>
+
+=head1 AUTHORS
+
+Chia-liang Kao E<lt>clkao at clkao.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2005-2006 by Chia-liang Kao E<lt>clkao at clkao.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
Added: App-CLI/lib/App/CLI/Command/Help.pm
==============================================================================
--- (empty file)
+++ App-CLI/lib/App/CLI/Command/Help.pm Fri May 9 12:33:50 2008
@@ -0,0 +1,75 @@
+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;
+
+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;
+}
+
+1;
Added: App-CLI/t/1basic.t
==============================================================================
--- (empty file)
+++ App-CLI/t/1basic.t Fri May 9 12:33:50 2008
@@ -0,0 +1,47 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More tests => 8;
+use lib qw(t/lib);
+use CLITest;
+
+use_ok ('MyApp');
+
+eval {
+ local *ARGV = ['--help'];
+ MyApp->dispatch;
+};
+ok ($@);
+
+is_deeply ([MyApp->commands],
+ ['help', 'test']);
+
+{
+ local *ARGV = ['test'];
+ MyApp->dispatch;
+ is_deeply (clicheck, [qw(MyApp::Test MyApp::Test::run), ''], 'simple dispatch');
+}
+
+{
+ local *ARGV = ['te', 'arg'];
+ MyApp->dispatch;
+ is_deeply (clicheck, [qw(MyApp::Test MyApp::Test::run), '', 'arg'], 'alias dispatch with arg');
+}
+
+{
+ local *ARGV = ['test', '--verbose'];
+ MyApp->dispatch;
+ is_deeply (clicheck, [qw(MyApp::Test MyApp::Test::run), 'v'], 'with option');
+}
+
+{
+ local *ARGV = ['test', 'arg', '--verbose'];
+ MyApp->dispatch;
+ is_deeply (clicheck, [qw(MyApp::Test MyApp::Test::run), 'v', 'arg'], 'with option and arg');
+}
+
+{
+ local *ARGV = ['test', '--hate', 'arg', '--verbose'];
+ MyApp->dispatch;
+ is_deeply (clicheck, [qw(MyApp::Test::hate MyApp::Test::hate::run), 'v', 'hate', 'arg'],
+ 'subcommand with option and arg');
+}
Added: App-CLI/t/lib/CLITest.pm
==============================================================================
--- (empty file)
+++ App-CLI/t/lib/CLITest.pm Fri May 9 12:33:50 2008
@@ -0,0 +1,15 @@
+package CLITest;
+use base 'Exporter';
+our @EXPORT = qw(cliack clicheck);
+
+our @STACK;
+
+sub cliack {
+ push @STACK, [(caller(0))[0],(caller(1))[3], @_];
+}
+
+sub clicheck {
+ pop @STACK;
+}
+
+1;
Added: App-CLI/t/lib/MyApp.pm
==============================================================================
--- (empty file)
+++ App-CLI/t/lib/MyApp.pm Fri May 9 12:33:50 2008
@@ -0,0 +1,11 @@
+package MyApp;
+use strict;
+use base qw(App::CLI App::CLI::Command);
+
+use constant alias => ( te => 'test' );
+
+use constant global_options => ( 'help' => 'help',
+ 'username=s' => 'username',
+ 'force' => 'force' );
+
+1;
Added: App-CLI/t/lib/MyApp/Help.pm
==============================================================================
--- (empty file)
+++ App-CLI/t/lib/MyApp/Help.pm Fri May 9 12:33:50 2008
@@ -0,0 +1,6 @@
+package MyApp::Help;
+use base 'App::CLI::Command';
+
+
+
+1;
Added: App-CLI/t/lib/MyApp/Test.pm
==============================================================================
--- (empty file)
+++ App-CLI/t/lib/MyApp/Test.pm Fri May 9 12:33:50 2008
@@ -0,0 +1,24 @@
+package MyApp::Test;
+use strict;
+use base 'MyApp';
+
+use constant subcommands => ('hate');
+use constant options => ( 'v|verbose' => 'verbose',
+ );
+use CLITest;
+
+sub run {
+ my $self = shift;
+ cliack($self->{verbose} ? 'v' : '', @_);
+}
+
+package MyApp::Test::hate;
+use base 'MyApp::Test';
+use CLITest;
+
+sub run {
+ my $self = shift;
+ cliack($self->{verbose} ? 'v' : '', 'hate', @_);
+}
+
+1;
More information about the Bps-public-commit
mailing list