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
|
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;
=head1 NAME
App::CLI::Command::Help - output PODs of each command
=head1 SYNOPSIS
package MyApp::Help;
use base qw(App::CLI::Command::Help);
sub run {
my ($self, @args) = @_;
# preprocess
$self->SUPER(@_); # App::CLI::Command::Help would output PODs of each command
}
=head1 DESCRIPTION
Your command class should be capitalized.
To add help message , you just add pod in command class:
package YourApp::Command::Foo;
=head1 NAME
YourApp::Command::Foo - execute foo
=head1 DESCRIPTION
blah blah
=head1 USAGE
....
=cut
=cut
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;
|
