File Coverage

blib/lib/CLI/Osprey/Descriptive/Usage.pm
Criterion Covered Total %
statement 75 152 49.3
branch 19 52 36.5
condition 3 20 15.0
subroutine 9 17 52.9
pod 0 12 0.0
total 106 253 41.9


line stmt bran cond sub pod time code
1             package CLI::Osprey::Descriptive::Usage;
2              
3 5     5   54961 use strict;
  5         17  
  5         142  
4 5     5   24 use warnings;
  5         10  
  5         150  
5 5     5   453 use Moo;
  5         9293  
  5         36  
6              
7             use overload (
8 5         44 q{""} => "text",
9 5     5   3633 );
  5         805  
10              
11 5     5   773 use Getopt::Long::Descriptive::Usage ();
  5         1368  
  5         9161  
12              
13             *option_text = \&Getopt::Long::Descriptive::Usage::option_text;
14              
15             # ABSTRACT: Produce usage information for CLI::Osprey apps
16             our $VERSION = '0.06'; # VERSION
17             our $AUTHORITY = 'cpan:ARODLAND'; # AUTHORITY
18              
19             my %format_doc = (
20             s => { short => "string", long => "string" },
21             i => { short => "int" , long => "integer" },
22             o => { short => "int" , long => "integer (dec/hex/bin/oct)" },
23             f => { short => "num" , long => "number" },
24             );
25              
26             has 'options' => (
27             is => 'ro',
28             );
29              
30             has 'leader_text' => (
31             is => 'ro',
32             );
33              
34             has 'target' => (
35             is => 'ro',
36             predicate => 1,
37             );
38              
39             has 'prog_name' => (
40             is => 'ro',
41             predicate => 1,
42             );
43              
44             has 'width' => (
45             is => 'ro',
46             default => sub {
47             return $ENV{CLI_OSPREY_OVERRIDE_WIDTH} if exists $ENV{CLI_OSPREY_OVERRIDE_WIDTH};
48             return $ENV{COLUMNS} if exists $ENV{COLUMNS};
49             return 80;
50             },
51             );
52              
53             sub wrap {
54 0     0 0 0 my ($self, $in, $prefix) = @_;
55              
56 0         0 my $width = $self->width;
57 0 0       0 return $in if $width <= 0;
58              
59 0         0 my @out;
60 0         0 my $line = "";
61              
62 0         0 while ($in =~ /(\s*)(\S+)/g) {
63 0         0 my ($space, $nonspace) = ($1, $2);
64 0 0       0 if (length($line) + length($space) + length($nonspace) <= $width) {
65 0         0 $line .= $space . $nonspace;
66             } else {
67 0         0 while (length($nonspace)) {
68 0         0 push @out, $line;
69 0         0 $line = $prefix;
70 0         0 $line .= substr($nonspace, 0, $width - length($line), '');
71             }
72             }
73             }
74 0 0       0 push @out, $line if length($line);
75 0         0 return @out;
76             }
77              
78             sub maxlen {
79 0     0 0 0 my $max = 0;
80 0         0 for (@_) {
81 0 0       0 $max = length($_) if length($_) > $max;
82             }
83 0         0 return $max;
84             }
85              
86             sub sub_commands_text {
87 0     0 0 0 my ($self, $length) = @_;
88              
89 0 0 0     0 if ($self->has_target && (my %subcommands = $self->target->_osprey_subcommands)) {
90 0 0       0 if ($length eq 'long') {
91 0         0 my $maxlen = maxlen(keys %subcommands);
92              
93 0         0 my @out;
94 0         0 push @out, "";
95 0         0 push @out, "Subcommands available:";
96              
97 0         0 for my $name (sort keys %subcommands) {
98 0   0     0 my $desc = $subcommands{$name}->can('_osprey_subcommand_desc') && $subcommands{$name}->_osprey_subcommand_desc;
99 0 0       0 if (defined $desc) {
100             push @out, $self->wrap(
101 0         0 sprintf("%*s %s", -$maxlen, $name, $subcommands{$name}->_osprey_subcommand_desc),
102             " " x ($maxlen + 2)
103             );
104             } else {
105 0         0 push @out, $name;
106             }
107             }
108 0         0 push @out, "";
109              
110 0         0 return @out;
111             } else {
112 0         0 return "",
113             $self->wrap(
114             "Subcommands available: " . join(" | ", sort keys %subcommands),
115             " " x length("Subcommands available: ")
116             );
117             }
118             }
119 0         0 return;
120             }
121              
122             sub pod_escape {
123 3     3 0 6 my ($self, $text) = @_;
124 3         10 my %map = (
125             '<' => 'lt',
126             '>' => 'gt',
127             '|' => 'verbar',
128             '/' => 'sol',
129             );
130              
131 3         7 $text =~ s,([<>|/]),"E<$map{$1}>",eg;
  0         0  
132 3         19 return $text;
133             }
134              
135             sub describe_opt {
136 4     4 0 26 my ($self, $opt) = @_;
137              
138 4 100       9 if ($opt->{desc} eq 'spacer') {
139 1         4 return { spacer => 1 };
140             }
141              
142 3         6 my $name = my $attr_name = $opt->{name};
143              
144 3         4 my $option_attrs;
145              
146 3 50       9 if ($self->has_target) {
147 3         72 my %options = $self->target->_osprey_options;
148 3         28 $option_attrs = $options{$attr_name};
149 3 50       9 $name = $option_attrs->{option} if defined $option_attrs->{option};
150             }
151              
152 3         12 my ($short, $format) = $opt->{spec} =~ /(?:\|(\w))?(?:=(.*?))?$/;
153              
154 3         6 my $array;
155 3 50 33     7 if (defined $format && $format =~ s/[\@\+]$//) {
156 0         0 $array = 1;
157             }
158              
159 3         4 my $format_doc;
160 3 50       6 if (defined $format) {
161 0 0       0 if (defined $option_attrs->{format_doc}) {
162             $format_doc = {
163             short => $option_attrs->{format_doc},
164             long => $option_attrs->{format_doc},
165 0         0 };
166             } else {
167 0         0 $format_doc = $format_doc{$format};
168             }
169             }
170              
171 3         3 my $spec;
172              
173 3 50       6 if ($short) {
174 0         0 $spec = "-$short|";
175             }
176              
177 3 100       38 if (length($name) > 1) {
178 2         3 $spec .= "--$name";
179             } else {
180 1         5 $spec .= "-$name";
181             }
182              
183 3         6 my ($shortspec, $longspec) = ($spec, $spec);
184 3         8 my ($podshortspec, $podlongspec) = ("B<< $spec >>", "B<< $spec >>");
185              
186 3 50       6 if (defined $format_doc) {
187 0         0 $shortspec .= " $format_doc->{short}";
188 0         0 $podshortspec .= " I<< $format_doc->{short} >>";
189 0         0 $longspec .= " $format_doc->{long}";
190 0         0 $podlongspec .= " I<< $format_doc->{long} >>";
191             }
192              
193 3 50       13 if ($array) {
194 0         0 $shortspec .= "...";
195 0         0 $podshortspec .= "...";
196             }
197              
198 3 50 33     18 if (defined $option_attrs && !$option_attrs->{required}) {
199 3         12 $shortspec = "[$shortspec]";
200 3         6 $podshortspec = "[$podshortspec]";
201             }
202              
203             return {
204             short => $shortspec,
205             long => $longspec,
206             podshort => $podshortspec,
207             podlong => $podlongspec,
208             doc => $opt->{desc},
209 3 50       13 long_doc => defined($option_attrs->{long_doc}) ? $option_attrs->{long_doc} : $self->pod_escape($opt->{desc}),
210             };
211             }
212              
213             sub describe_options {
214 1     1 0 3 my ($self) = @_;
215              
216 1         2 return map $self->describe_opt($_), @{ $self->options };
  1         4  
217             }
218              
219             sub header {
220 0     0 0 0 my ($self) = @_;
221              
222 0         0 my @descs = $self->describe_options;
223              
224             my $option_text = join "\n", $self->wrap(
225 0         0 join(" ", map $_->{short}, grep !$_->{spacer}, @descs),
226             " ",
227             );
228              
229 0         0 my $text = $self->leader_text;
230 0         0 $text =~ s/\Q[long options...]/$option_text/;
231              
232 0         0 return $text;
233             }
234              
235             sub text {
236 0     0 0 0 my ($self) = @_;
237              
238 0         0 return join "\n", $self->header, $self->sub_commands_text('short');
239             }
240              
241             sub option_help {
242 0     0 0 0 my ($self) = @_;
243              
244 0         0 my @descs = $self->describe_options;
245              
246 0         0 my $maxlen = maxlen(map $_->{long}, grep !$_->{spacer}, @descs);
247              
248 0         0 my @out;
249 0         0 for my $desc (@descs) {
250 0 0       0 if ($desc->{spacer}) {
251 0         0 push @out, "";
252             } else {
253             push @out, $self->wrap(
254 0         0 sprintf("%*s %s", -$maxlen, $desc->{long}, $desc->{doc}),
255             " " x ($maxlen + 2),
256             );
257             }
258             }
259              
260 0         0 return join("\n", $self->header, $self->sub_commands_text('long'), @out);
261             }
262              
263             sub option_pod {
264 1     1 0 5 my ($self) = @_;
265              
266 1         28 my %osprey_config = $self->target->_osprey_config;
267              
268 1         16 my @descs = $self->describe_options;
269 1         2 my @pod;
270              
271 1         3 push @pod, "=encoding UTF-8";
272              
273 1         2 push @pod, "=head1 NAME";
274 1 50       5 push @pod, $self->{prog_name} . ($osprey_config{desc} ? " - " . $osprey_config{desc} : "" );
275              
276 1         2 push @pod, "=head1 SYNOPSIS";
277             push @pod, "B<< $self->{prog_name} >> "
278 1         9 . join(" ", map "S<<< $_->{podshort} >>>", grep !$_->{spacer}, @descs);
279              
280 1 50       4 if ($osprey_config{description_pod}) {
281 1         2 push @pod, "=head1 DESCRIPTION";
282 1         2 push @pod, $osprey_config{description_pod};
283             }
284              
285 1 50       12 if ($osprey_config{extra_pod}) {
286 1         12 push @pod, $osprey_config{extra_pod};
287             }
288              
289 1         4 push @pod, "=head1 OPTIONS";
290 1         1 push @pod, "=over";
291              
292 1         3 for my $desc (@descs) {
293 4 100       9 if ($desc->{spacer}) {
294 1         3 push @pod, "=back";
295 1         2 push @pod, "E<32>" x 40;
296 1         2 push @pod, "=over";
297             } else {
298 3         5 push @pod, "=item $desc->{podlong}";
299 3         5 push @pod, $desc->{long_doc};
300             }
301             }
302              
303 1         2 push @pod, "=back";
304              
305 1 50 33     27 if ($self->has_target && (my %subcommands = $self->target->_osprey_subcommands)) {
306 0         0 push @pod, "=head1 COMMANDS";
307 0         0 push @pod, "=over";
308              
309 0         0 for my $name (sort keys %subcommands) {
310 0   0     0 my $desc = $subcommands{$name}->can('_osprey_subcommand_desc') && $subcommands{$name}->_osprey_subcommand_desc;
311 0         0 push @pod, "=item B<< $name >>";
312 0 0       0 if ($desc) {
313 0         0 push @pod, $desc;
314             }
315             }
316              
317 0         0 push @pod, "=back";
318             }
319              
320 1         35 return join("\n\n", @pod);
321             }
322              
323             sub die {
324 0     0 0   my $self = shift;
325 0   0       my $arg = shift || {};
326              
327             die(
328 0           join q{}, grep { defined } $arg->{pre_text}, $self->text, $arg->{post_text}
329 0           );
330             }
331              
332 0     0 0   sub warn { warn shift->text }
333              
334             1;
335              
336             __END__