File Coverage

blib/lib/App/CLI.pm
Criterion Covered Total %
statement 72 77 93.5
branch 7 12 58.3
condition 3 9 33.3
subroutine 17 19 89.5
pod 0 9 0.0
total 99 126 78.6


line stmt bran cond sub pod time code
1             package App::CLI;
2             our $VERSION = 0.07;
3 1     1   17 use strict;
  1         18  
  1         17  
4 1     1   166 use warnings;
  1         10  
  1         17  
5              
6             =head1 NAME
7            
8             App::CLI - Dispatcher module for command line interface programs
9            
10             =head1 SYNOPSIS
11            
12             package MyApp;
13             use base 'App::CLI';
14            
15             package main;
16            
17             MyApp->dispatch;
18            
19             package MyApp::Help;
20             use base 'App::CLI::Command';
21            
22             sub options {
23             ('verbose' => 'verbose');
24             }
25            
26             sub run {
27             my ($self, $arg) = @_;
28             }
29            
30             =head1 DESCRIPTION
31            
32             C<App::CLI> dispatches CLI (command line interface) based commands
33             into command classes. It also supports subcommand and per-command
34             options.
35            
36             =cut
37              
38 1     1   30 use Getopt::Long ();
  1         9  
  1         75  
39              
40 1     1   26 use constant alias => ();
  1         9  
  1         17  
41 1     1   15 use constant global_options => ();
  1         9  
  1         14  
42 1     1   14 use constant options => ();
  1         9  
  1         13  
43              
44             sub new {
45 5     5 0 47     my $class = shift;
46 5         109     my $self = bless {}, $class;
47 5         66     %$self = @_;
48 5         56     return $self;
49             }
50              
51             sub prepare {
52 6     6 0 54     my $class = shift;
53 6         56     my $data = {};
54 6         95     $class->_getopt( [qw(no_ignore_case bundling pass_through)],
55             _opt_map($data, $class->global_options));
56 6         95     my $cmd = shift @ARGV;
57 6         111     $cmd = $class->get_cmd($cmd, @_, %$data);
58              
59 5         81     $class->_getopt( [qw(no_ignore_case bundling)],
60             _opt_map($cmd, $cmd->command_options) );
61 5         80     return $cmd;
62             }
63              
64             sub _getopt {
65 11     11   98     my $class = shift;
66 11         90     my $config = shift;
67 11         145     my $p = Getopt::Long::Parser->new;
68 11         124     $p->configure(@$config);
69 11         96     my $err = '';
70 11     0   221     local $SIG{__WARN__} = sub { my $msg = shift; $err .= "$msg" };
  0         0  
  0         0  
71 11 50       127     die $class->error_opt ($err)
72             unless $p->getoptions(@_);
73             }
74              
75             sub dispatch {
76 6     6 0 90     my $class = shift;
77 6         150     my $cmd = $class->prepare(@_);
78 5         80     $cmd->subcommand;
79 5         76     $cmd->run_command(@ARGV);
80             }
81              
82             sub _cmd_map {
83 5     5   51     my ($pkg, $cmd) = @_;
84 5         64     my %alias = $pkg->alias;
85 5 100       101     $cmd = $alias{$cmd} if exists $alias{$cmd};
86 5         69     return ucfirst($cmd);
87             }
88              
89             sub error_cmd {
90 1     1 0 13     "Command not recognized, try $0 --help.\n";
91             }
92              
93 0     0 0 0 sub error_opt { $_[1] }
94              
95 5     5 0 72 sub command_class { $_[0] }
96              
97             sub get_cmd {
98 6     6 0 74     my ($class, $cmd, @arg) = @_;
99 6 100 66     141     die $class->error_cmd
100             unless $cmd && $cmd =~ m/^[?a-z]+$/;
101 5         67     my $pkg = join('::', $class->command_class, $class->_cmd_map ($cmd));
102 5         51     my $file = "$pkg.pm";
103 5         63     $file =~ s!::!/!g;
104              
105 5 50 33     47     unless (eval {require $file; 1} and $pkg->can('run')) {
  5         105  
  5         124  
106 0 0 0     0 warn $@ if $@ and exists $INC{$file};
107 0         0 die $class->error_cmd;
108                 }
109 5         65     $cmd = $pkg->new (@arg);
110 5         79     $cmd->app ($class);
111 5         54     return $cmd;
112             }
113              
114             sub _opt_map {
115 11     11   294     my ($self, %opt) = @_;
116 11 50       121     return map { $_ => ref($opt{$_}) ? $opt{$_} : \$self->{$opt{$_}}} keys %opt;
  28         389  
117             }
118              
119             sub commands {
120 1     1 0 11     my $class = shift;
121 1         11     $class =~ s{::}{/}g;
122 1         12     my $dir = $INC{$class.'.pm'};
123 1         271     $dir =~ s/\.pm$//;
124 1         76     return sort map { ($_) = m{^\Q$dir\E/(.*)\.pm}; lc($_) } $class->files;
  2         436  
  2         34  
125             }
126              
127             sub files {
128 1     1 0 12     my $class = shift;
129 1         10     $class =~ s{::}{/}g;
130 1         43     my $dir = $INC{$class.'.pm'};
131 1         12     $dir =~ s/\.pm$//;
132 1         16     return sort glob("$dir/*.pm");
133             }
134              
135             =head1 TODO
136            
137             More documentation
138            
139             =head1 SEE ALSO
140            
141             L<App::CLI::Command>
142            
143             =head1 AUTHORS
144            
145             Chia-liang Kao E<lt>clkao@clkao.orgE<gt>
146            
147             =head1 COPYRIGHT
148            
149             Copyright 2005-2006 by Chia-liang Kao E<lt>clkao@clkao.orgE<gt>.
150            
151             This program is free software; you can redistribute it and/or modify it
152             under the same terms as Perl itself.
153            
154             See L<http://www.perl.com/perl/misc/Artistic.html>
155            
156             =cut
157              
158             1;
159