1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
package App::CLI;
our $VERSION = 0.08;
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;
eval {require $file; };
unless ($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@clkao.orgE<gt>
=head1 COPYRIGHT
Copyright 2005-2006 by Chia-liang Kao E<lt>clkao@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;
|
