line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package MooX::Commander::HasOptions; |
2
|
|
|
|
|
|
|
|
3
|
3
|
|
|
3
|
|
361582
|
use Moo::Role; |
|
3
|
|
|
|
|
13232
|
|
|
3
|
|
|
|
|
26
|
|
4
|
3
|
|
|
3
|
|
2644
|
use Getopt::Long; |
|
3
|
|
|
|
|
22831
|
|
|
3
|
|
|
|
|
19
|
|
5
|
3
|
|
|
3
|
|
1092
|
use String::CamelSnakeKebab qw/lower_snake_case/; |
|
3
|
|
|
|
|
8589
|
|
|
3
|
|
|
|
|
19
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
has argv => (is => 'lazy'); |
8
|
|
|
|
|
|
|
has options => (is => 'rw', builder => 1); |
9
|
|
|
|
|
|
|
|
10
|
0
|
|
|
0
|
|
|
sub _build_options { [] } |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
around '_build_options' => sub { |
13
|
|
|
|
|
|
|
my $orig = shift; |
14
|
|
|
|
|
|
|
my $self = shift; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
my $definitions = $self->$orig; |
17
|
|
|
|
|
|
|
my $options; |
18
|
|
|
|
|
|
|
my %params; |
19
|
|
|
|
|
|
|
$params{'help|h'} = \$options->{help}; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
for my $definition (@$definitions) { |
22
|
|
|
|
|
|
|
$definition =~ m/^([A-Za-z0-9_\-]+)/; |
23
|
|
|
|
|
|
|
die "barf that didn't work" unless $1; |
24
|
|
|
|
|
|
|
my $key = lower_snake_case $1; |
25
|
|
|
|
|
|
|
$params{$definition} = \$options->{$1}; |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
@ARGV = @{ $self->argv }; |
29
|
|
|
|
|
|
|
Getopt::Long::GetOptions(%params); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
$self->usage if $options->{help}; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
return $options; |
34
|
|
|
|
|
|
|
}; |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
around 'usage' => sub { |
37
|
|
|
|
|
|
|
my $orig = shift; |
38
|
|
|
|
|
|
|
my $self = shift; |
39
|
|
|
|
|
|
|
my $message = shift; |
40
|
|
|
|
|
|
|
print $message . "\n" if $message; |
41
|
|
|
|
|
|
|
print $self->$orig(@_); |
42
|
|
|
|
|
|
|
exit 1; |
43
|
|
|
|
|
|
|
}; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub die_with_usage { |
46
|
0
|
|
|
0
|
0
|
|
my ($self, $msg) = @_; |
47
|
0
|
|
|
|
|
|
print "error: " . $msg, "\n"; |
48
|
0
|
|
|
|
|
|
$self->usage; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
1; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
=encoding utf-8 |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
=head1 NAME |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
MooX::Commander::HasOptions - Moo role to add options to a subcommand |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
=head1 SYNOPSIS |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
package PieFactory::Cmd::Throw; |
62
|
|
|
|
|
|
|
use Moo; |
63
|
|
|
|
|
|
|
with 'MooX::Commander::HasOptions'; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# This array is used to configure Getopt::Long |
66
|
|
|
|
|
|
|
sub _build_options {( |
67
|
|
|
|
|
|
|
'angrily|a', |
68
|
|
|
|
|
|
|
'speed|s=i', |
69
|
|
|
|
|
|
|
)} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
# This string is printed and the program exits. |
72
|
|
|
|
|
|
|
sub usage { |
73
|
|
|
|
|
|
|
return <
|
74
|
|
|
|
|
|
|
usage: pie-factory throw [options] |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
Throw at . Valid values for are apple pie, rhubarb |
77
|
|
|
|
|
|
|
pie, or mud pie. |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
OPTIONS |
80
|
|
|
|
|
|
|
-a, --angrily Curse the target after throwing the pie |
81
|
|
|
|
|
|
|
-s, --speed Throw the pie this many mph |
82
|
|
|
|
|
|
|
-h, --help Show this message |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
EOF |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub go { |
88
|
|
|
|
|
|
|
my ($self, $pie, $target) = @_; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# print usage and then exit unsuccessfully |
91
|
|
|
|
|
|
|
$self->usage unless $pie && $target; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# print "Not a valid value for \n", usage() and exit unsuccessfully |
94
|
|
|
|
|
|
|
$self->usage("Not a valid value for ") unless $pie eq 'rhubarb'; |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
$self->curse_loudly if $self->options->{angrily}; |
97
|
|
|
|
|
|
|
$self->throw($pie => $target, $self->options->{speed}); |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=head1 DESCRIPTION |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
MooX::Commander::HasOptions is a simple Moo::Role thats adds option parsing to |
103
|
|
|
|
|
|
|
your module. Be sure to also read L. |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
It parses values in the $self->argv attribute with L. |
106
|
|
|
|
|
|
|
Getopt::Long is configured using the return value of _build_options(). |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
If a user asks for help with '--help' or '-h', the usage is shown and |
109
|
|
|
|
|
|
|
the program exits unsuccessfully. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
This module doesn't dynamically generate usage/help statements. I wasn't |
112
|
|
|
|
|
|
|
interested in solving that problem. I think its not possible or very difficult |
113
|
|
|
|
|
|
|
to do well and usually leads to a very complex and verbose user interface and a |
114
|
|
|
|
|
|
|
one size fits all usage/help output that is inflexible and poorly formatted. |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
I suspect people who really care about the usability of their command line |
117
|
|
|
|
|
|
|
applications will want to tweak help output based on the situation and their |
118
|
|
|
|
|
|
|
personal preferences. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=head1 LICENSE |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Copyright (C) Eric Johnson. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
125
|
|
|
|
|
|
|
it under the same terms as Perl itself. |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=head1 AUTHOR |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
Eric Johnson Eeric.git@iijo.orgE |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=cut |
132
|
|
|
|
|
|
|
|