File Coverage

lib/Class/Usul/Getopt/Usage.pm
Criterion Covered Total %
statement 39 45 86.6
branch 3 10 30.0
condition 3 9 33.3
subroutine 7 7 100.0
pod 2 2 100.0
total 54 73 73.9


line stmt bran cond sub pod time code
1             package Class::Usul::Getopt::Usage;
2              
3 19     19   169 use strict;
  19         58  
  19         670  
4 19     19   158 use warnings;
  19         55  
  19         725  
5 19     19   156 use parent 'Getopt::Long::Descriptive::Usage';
  19         55  
  19         160  
6              
7 19     19   1704 use List::Util qw( max );
  19         83  
  19         1691  
8 19     19   163 use Term::ANSIColor qw( color );
  19         56  
  19         26151  
9              
10             my $NUL = q(); my $SPC = q( ); my $USAGE_CONF = {};
11              
12             # Private functions
13             my $_tabstop = sub {
14             my $v = $USAGE_CONF->{tabstop} // 3; return $v; # Eight is too much
15             };
16              
17             my $_split_description = sub {
18             my ($length, $desc) = @_; my $width = $USAGE_CONF->{width} // 78;
19             # Length of a tab plus 2 for the space between option & desc;
20             my $max_length = $width - ( $_tabstop->() + $length + 2 );
21              
22             length $desc <= $max_length and return $desc; my @lines;
23              
24             while (length $desc > $max_length) {
25             my $idx = rindex( substr( $desc, 0, $max_length ), $SPC );
26              
27             $idx >= 0 or last;
28              
29             push @lines, substr $desc, 0, $idx; substr( $desc, 0, 1 + $idx ) = $NUL;
30             }
31              
32             push @lines, $desc;
33             return @lines;
34             };
35              
36             my $_types = sub {
37             my $k = shift; my $option_type = $USAGE_CONF->{option_type} // 'short';
38              
39             $option_type eq 'none' and return; # Old behaviour
40             $option_type eq 'verbose' and return uc $k; # New behaviour
41              
42             my $types = $USAGE_CONF->{type_map}
43             // { int => 'i', key => 'k', num => 'n', str => 's', };
44             my $type = $types->{ $k } // $NUL; # Prefered behaviour
45              
46             return $type;
47             };
48              
49             my $_parse_assignment = sub {
50             my $assign_spec = shift; $assign_spec or return $NUL;
51              
52             length $assign_spec < 2 and return $NUL; # Empty, ! or +
53              
54             my $argument = substr $assign_spec, 1, 2;
55             my $result = $_types->( 'str' );
56              
57             if ($argument eq 'i' or $argument eq 'o') { $result = $_types->( 'int' ) }
58             elsif ($argument eq 'f') { $result = $_types->( 'num' ) }
59              
60             if (length $assign_spec > 2) {
61             my $desttype = substr $assign_spec, 2, 1;
62              
63             # Imply it can be repeated
64             if ($desttype eq '@') { $result .= '...' }
65             elsif ($desttype eq '%') {
66             $result = $result ? $_types->( 'key' )."=${result}..." : $NUL;
67             }
68             }
69              
70             substr $assign_spec, 0, 1 eq ':' and return "[=${result}]";
71             # With leading space so it can just blindly be appended.
72             return $result ? " $result" : $NUL;
73             };
74              
75             my $_assemble_spec = sub {
76             my ($length, $spec) = @_;
77              
78             my $stripped = [ Getopt::Long::Descriptive->_strip_assignment( $spec ) ];
79             my $assign = $_parse_assignment->( $stripped->[ 1 ] );
80             my $plain = join $SPC, reverse
81             map { length > 1 ? "--${_}${assign}" : "-${_}${assign}" }
82             split m{ [|] }mx, $stripped->[ 0 ];
83             my $pad = $SPC x ($length - length $plain);
84             my $highlight = $USAGE_CONF->{highlight} // 'bold';
85              
86             $highlight eq 'none' and return $plain.$pad; # Old behaviour
87              
88             $assign = color( $highlight ).$assign.color( 'reset' );
89              
90             my $markedup = join $SPC, reverse
91             map { length > 1 ? "--${_}${assign}" : "-${_}${assign}" }
92             split m{ [|] }mx, $stripped->[ 0 ];
93              
94             return $markedup.$pad; # Prefered behaviour works well with short types
95             };
96              
97             my $_option_length = sub {
98             my $fullspec = shift;
99             my $number_opts = 1;
100             my $last_pos = 0;
101             my $number_shortopts = 0;
102             my ($spec, $assign)
103             = Getopt::Long::Descriptive->_strip_assignment( $fullspec );
104             my $length = length $spec;
105             my $arglen = length $_parse_assignment->( $assign );
106             # Spacing rules:
107             # For short options we want 1 space (for '-'), for long options 2
108             # spaces (for '--'). Then one space for separating the options,
109             # but we here abuse that $spec has a '|' char for that.
110              
111             # For options that take arguments, we want 2 spaces for mandatory
112             # options ('=X') and 4 for optional arguments ('[=X]'). Note we
113             # consider {N,M} cases as "single argument" atm.
114              
115             # Count the number of "variants" (e.g. "long|s" has two variants)
116             while ($spec =~ m{ [|] }gmx) {
117             $number_opts++;
118             (pos( $spec ) - $last_pos) == 2 and $number_shortopts++;
119             $last_pos = pos( $spec );
120             }
121              
122             # Was the last option a "short" one?
123             # Getopt::Long::Descriptive has a 2 here and thats wrong
124             ($length - $last_pos) == 1 and $number_shortopts++;
125             # We got $number_opts options, each with an argument length of
126             # $arglen. Plus each option (after the first) needs 3 a char
127             # spacing. $length gives us the total length of all options and 1
128             # char spacing per option (after the first). It does not account
129             # for argument length and we want (at least) one additional char
130             # for space before the description. So the result should be:
131             my $number_longopts = $number_opts - $number_shortopts;
132             my $total_arglen = $number_opts * $arglen;
133             my $total_optsep = 2 * $number_longopts + $number_shortopts;
134             my $total = $length + $total_optsep + $total_arglen;
135              
136             return $total;
137             };
138              
139             # Public methods
140             sub option_text {
141 2     2 1 40 my $self = shift;
142 2   50     61 my @options = @{ $self->{options} // [] };
  2         22  
143 2         8 my @specs = map { $_->{spec} } grep { $_->{desc} ne 'spacer' } @options;
  24         48  
  24         52  
144 2   50     7 my $length = max( map { $_option_length->( $_ ) } @specs ) || 0;
145 2         8 my $tab = $SPC x $_tabstop->(); # Originally an actual tab char
146 2         9 my $spec_fmt = "${tab}%-${length}s";
147 2         5 my $string = $NUL;
148              
149 2         10 while (defined (my $opt = shift @options)) {
150 24         48 my $spec = $opt->{spec}; my $desc = $opt->{desc};
  24         42  
151              
152 24 50       54 if ($desc eq 'spacer') { $string .= sprintf "${spec_fmt}\n", $spec; next }
  0         0  
  0         0  
153              
154 24 0 33     93 if (exists $opt->{constraint}->{default} and $self->{show_defaults}) {
155 0   0     0 my $default = $opt->{constraint}->{default} // '[undef]';
156              
157 0 0       0 length $default or $default = '[null]';
158             # Add the default to the description before splitting into lines
159 0         0 $desc .= " (default value: ${default})";
160             }
161              
162 24         59 my @desc = $_split_description->( $length, $desc );
163              
164 24         49 $spec = $_assemble_spec->( $length, $spec );
165 24         89 $string .= sprintf "${tab}${spec} %s\n", shift @desc;
166              
167 24         84 for my $line (@desc) {
168 0         0 $string .= $tab.($SPC x ( $length + 2 ))."${line}\n";
169             }
170             }
171              
172 2         27 return $string;
173             }
174              
175             sub usage_conf {
176 4 50   4 1 14 my ($self, $v) = @_; defined $v or return $USAGE_CONF;
  4         18  
177              
178 4 50       24 ref $v eq 'HASH' or die 'Usage configuration must be a hash reference';
179              
180 4         16 return $USAGE_CONF = $v;
181             }
182              
183             1;
184              
185             __END__
186              
187             =pod
188              
189             =encoding utf-8
190              
191             =head1 Name
192              
193             Class::Usul::Getopt::Usage - The usage description for Getopt::Long::Descriptive
194              
195             =head1 Synopsis
196              
197             use parent 'Getopt::Long::Descriptive';
198              
199             use Class::Usul::Getopt::Usage;
200             use Getopt::Long 2.38;
201              
202             sub usage_class {
203             return 'Class::Usul::Getopt::Usage';
204             }
205              
206             =head1 Description
207              
208             The usage description for L<Getopt::Long::Descriptive>. Inherits from
209             L<Getopt::Long::Descriptive::Usage>
210              
211             See L<Class::Usul::Options> for more usage information
212              
213             =head1 Configuration and Environment
214              
215             Defines no attributes
216              
217             =head1 Subroutines/Methods
218              
219             =head2 C<option_text>
220              
221             Returns the multiline string which is the usage text
222              
223             =head2 C<usage_conf>
224              
225             A class accessor / mutator for the configuration hash reference. Supported
226             attributes are;
227              
228             =over 3
229              
230             =item C<highlight>
231              
232             Defaults to C<bold> which causes the option argument types to be displayed
233             in a bold font. Set to C<none> to turn off highlighting
234              
235             =item C<option_type>
236              
237             One of; C<none>, C<short>, or C<verbose>. Determines the amount of option
238             type information displayed by the L<option_text|Class::Usul::Usage/option_text>
239             method. Defaults to C<short>
240              
241             =item C<tabstop>
242              
243             Defaults to 3. The number of spaces to expand the leading tab in the usage
244             string
245              
246             =item C<type_map>
247              
248             A hash reference keyed by option type. By default maps C<int> to C<i>, C<key>
249             to C<k>, C<num> to C<n>, and C<str> to C<s>
250              
251             =item C<width>
252              
253             The total line width available for displaying usage text, defaults to 78
254              
255             =back
256              
257             =head1 Diagnostics
258              
259             None
260              
261             =head1 Dependencies
262              
263             =over 3
264              
265             =item L<Getopt::Long::Descriptive::Usage>
266              
267             =item L<List::Util>
268              
269             =item L<Term::ANSIColor>
270              
271             =back
272              
273             =head1 Incompatibilities
274              
275             There are no known incompatibilities in this module
276              
277             =head1 Bugs and Limitations
278              
279             There are no known bugs in this module. Please report problems to
280             http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Usul.
281             Patches are welcome
282              
283             =head1 Acknowledgements
284              
285             Larry Wall - For the Perl programming language
286              
287             =head1 Author
288              
289             Peter Flanigan, C<< <pjfl@cpan.org> >>
290              
291             =head1 License and Copyright
292              
293             Copyright (c) 2017 Peter Flanigan. All rights reserved
294              
295             This program is free software; you can redistribute it and/or modify it
296             under the same terms as Perl itself. See L<perlartistic>
297              
298             This program is distributed in the hope that it will be useful,
299             but WITHOUT WARRANTY; without even the implied warranty of
300             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
301              
302             =cut
303              
304             # Local Variables:
305             # mode: perl
306             # tab-width: 3
307             # End:
308             # vim: expandtab shiftwidth=3: