File Coverage

blib/lib/MooseX/App/Utils.pm
Criterion Covered Total %
statement 147 147 100.0
branch 36 44 81.8
condition 8 14 57.1
subroutine 16 16 100.0
pod 6 6 100.0
total 213 227 93.8


line stmt bran cond sub pod time code
1             package MooseX::App::Utils;
2              
3 16     16   128450 use 5.010;
  16         66  
4 16     16   728 use utf8;
  16         43  
  16         83  
5 16     16   456 use strict;
  16         31  
  16         332  
6 16     16   73 use warnings;
  16         33  
  16         572  
7              
8 16     16   102 use List::Util qw(max);
  16         31  
  16         1795  
9              
10             our $SCREEN_WIDTH = 78;
11             our $INDENT = 4;
12              
13 16     16   3796 use Moose::Util::TypeConstraints;
  16         1083392  
  16         167  
14              
15             subtype 'MooseX::App::Types::List'
16             => as 'ArrayRef';
17              
18             coerce 'MooseX::App::Types::List'
19             => from 'Str'
20             => via { [$_] };
21              
22             subtype 'MooseX::App::Types::CmdTypes'
23             => as enum([qw(proto option parameter)]);
24              
25             subtype 'MooseX::App::Types::MessageString'
26             => as 'Str';
27              
28             coerce 'MooseX::App::Types::MessageString'
29             => from 'ArrayRef'
30             => via { sprintf(@{$_}) };
31              
32             subtype 'MooseX::App::Types::Env'
33             => as 'Str'
34             => where { m/^[A-Z0-9_]+$/ };
35              
36             subtype 'MooseX::App::Types::Identifier'
37             => as 'Str'
38             => where {
39             $_ eq '?'
40             || (m/^[A-Za-z0-9][A-Za-z0-9_-]*$/ && m/[^-_]$/) };
41              
42             subtype 'MooseX::App::Types::IdentifierList'
43             => as 'ArrayRef[MooseX::App::Types::Identifier]';
44              
45             coerce 'MooseX::App::Types::IdentifierList'
46             => from 'MooseX::App::Types::Identifier'
47             => via { [$_] };
48              
49 16     16   41188 no Moose::Util::TypeConstraints;
  16         43  
  16         92  
50              
51 16     16   9435 no if $] >= 5.018000, warnings => qw/ experimental::smartmatch /;
  16         107  
  16         157  
52              
53             # Default package name to command name translation function
54             sub class_to_command {
55 26     26 1 1248 my ($class) = @_;
56              
57             return
58 26 50       74 unless defined $class;
59              
60 26         42 my @commands;
61 26         98 foreach my $part (split /\s+/,$class) {
62 28         211 my @parts = split( /_+|\b|(?<![A-Z])(?=[A-Z])|(?<=[A-Z])(?=[A-Z][a-z])/, $part );
63 28         113 push (@commands,join('_',@parts));
64             }
65 26         110 return lc(join(" ",@commands));
66             }
67              
68             # Format output text for fixed screen width
69             sub format_text {
70 54     54 1 2866 my ($text) = @_;
71              
72 54         108 my @lines;
73 54         355 foreach my $line (split(/\n/,$text)) {
74 162         430 push(@lines,split_string($SCREEN_WIDTH-$INDENT,$line));
75             }
76              
77             return join(
78             "\n",
79 54         165 map { (' ' x $INDENT).$_ }
  175         881  
80             @lines
81             );
82             }
83              
84             # Format bullet list for fixed screen width
85             sub format_list {
86 79     79 1 2702 my (@list) = @_;
87              
88 79         185 my $max_length = max(map { length($_->[0]) } @list);
  258         677  
89 79         189 my $description_length = $SCREEN_WIDTH - $max_length - 7;
90 79         220 my $prefix_length = $max_length + $INDENT + 2;
91 79         145 my @return;
92              
93             # Loop all items
94 79         199 foreach my $command (@list) {
95 258   100     569 my $description = $command->[1] // '';
96 258         663 my @lines = split_string($description_length,$description);
97 258         1230 push (@return,(' 'x$INDENT).sprintf('%-*s %s',$max_length,$command->[0],shift(@lines)));
98 258         769 while (my $line = shift (@lines)) {
99 16         89 push(@return,' 'x $prefix_length.$line);
100             }
101             }
102 79         656 return join("\n",@return);
103             }
104              
105             # Simple splitting of long sentences on whitespaces or punctuation
106             sub split_string {
107 420     420 1 746 my ($maxlength, $string) = @_;
108              
109             return
110 420 50       813 unless defined $string;
111              
112 420 100       1166 return $string
113             if length $string <= $maxlength;
114              
115 28         57 my (@lines,$line);
116 28         80 $line = '';
117 16     16   11164 foreach my $word (split(m/(\p{IsPunct}|\p{IsSpace})/,$string)) {
  16         47  
  16         324  
  28         714  
118 864 100       1438 if (length($line.$word) <= $maxlength) {
119 835         1220 $line .= $word;
120             } else {
121 29 100       124 push(@lines,$line)
122             if ($line ne '');
123 29         68 $line = '';
124              
125 29 100       103 if (length($word) > $maxlength) {
126 7         112 my (@parts) = grep { $_ ne '' } split(/(.{$maxlength})/,$word);
  21         91  
127 7         23 my $lastline = pop(@parts);
128 7         19 push(@lines,@parts);
129 7 50 33     88 if (defined $lastline && $lastline ne '') {
130 7         28 $line = $lastline;
131             }
132             } else {
133 22         93 $line = $word;
134             }
135             }
136             }
137 28 50       158 push(@lines,$line)
138             if ($line ne '');
139              
140 28 50       90 @lines = map { m/^\s*(.+?)\s*$/ ? $1 : $_ } @lines;
  57         610  
141              
142 28         125 return @lines;
143             }
144              
145             # Try to get filename for a given package name
146             sub package_to_filename {
147 24     24 1 64 my ($package) = @_;
148              
149             # Package to filename
150 24         62 my $package_filename = $package;
151 24         130 $package_filename =~ s/::/\//g;
152 24         69 $package_filename .= '.pm';
153              
154              
155 24         55 my $package_filepath;
156 24 50       140 if (defined $INC{$package_filename}) {
157 24         70 $package_filepath = $INC{$package_filename};
158 24         79 $package_filepath =~ s/\/{2,}/\//g;
159             }
160              
161             # No filename available
162             return
163 24 100 66     868 unless defined $package_filepath
164             && -e $package_filepath;
165              
166 20         109 return $package_filepath;
167             }
168              
169             # Parse pod
170             sub parse_pod {
171 24     24 1 98 my ($package) = @_;
172              
173 24         95 my $package_filepath = package_to_filename($package);
174             return
175 24 100       135 unless $package_filepath;
176              
177             # Parse pod
178 20         254 my $document = Pod::Elemental->read_file($package_filepath);
179              
180 20         103312 Pod::Elemental::Transformer::Pod5->new->transform_node($document);
181              
182 20         64353 my $nester_head = Pod::Elemental::Transformer::Nester->new({
183             top_selector => Pod::Elemental::Selectors::s_command('head1'),
184             content_selectors => [
185             Pod::Elemental::Selectors::s_command([ qw(head2 head3 head4 over back item) ]),
186             Pod::Elemental::Selectors::s_flat()
187             ],
188             });
189 20         3123 $document = $nester_head->transform_node($document);
190              
191             # Process pod
192 20         34878 my %pod;
193 20         48 foreach my $element (@{$document->children}) {
  20         579  
194             # Distzilla ABSTRACT tag
195 35 100 66     946 if ($element->isa('Pod::Elemental::Element::Pod5::Nonpod')) {
    100          
196 20 100       616 if ($element->content =~ m/^\s*#+\s*ABSTRACT:\s*(.+)$/m) {
197 1   33     24 $pod{ABSTRACT} ||= $1;
198             }
199             # Pod head1 sections
200             } elsif ($element->isa('Pod::Elemental::Element::Nested')
201             && $element->command eq 'head1') {
202              
203 13 100       476 if ($element->content eq 'NAME') {
204 2         70 my $content = _pod_node_to_text($element->children);
205 2 50       9 next unless defined $content;
206 2         60 $content =~ s/^$package(\s-)?\s//;
207 2         8 chomp($content);
208 2         9 $pod{NAME} = $content;
209             } else {
210 11         351 my $content = _pod_node_to_text($element->children);
211 11 50       35 next unless defined $content;
212 11         40 chomp($content);
213 11         341 $pod{uc($element->content)} = $content;
214             }
215             }
216             }
217              
218 20         936 return %pod;
219             }
220              
221             # Transform POD to simple markup
222             sub _pod_node_to_text {
223 61     61   183 my ($node,$indent) = @_;
224              
225 61 100       131 unless (defined $indent) {
226 13         22 my $indent_init = 0;
227 13         28 $indent = \$indent_init;
228             }
229              
230 61         78 my (@lines);
231 61 100       146 if (ref $node eq 'ARRAY') {
232 13         31 foreach my $element (@$node) {
233 48         119 push (@lines,_pod_node_to_text($element,$indent));
234             }
235              
236             } else {
237 48         84 given (ref($node)) {
238 48         109 when ('Pod::Elemental::Element::Pod5::Ordinary') {
239 23         737 my $content = $node->content;
240             return
241 23 100       215 if $content =~ m/^=cut/;
242 21         58 $content =~ s/\n/ /g;
243 21         149 $content =~ s/\s+/ /g;
244 21         87 push (@lines,$content."\n");
245             }
246 25         42 when ('Pod::Elemental::Element::Pod5::Verbatim') {
247 2         71 push (@lines,$node->content."\n");
248             }
249 23         33 when ('Pod::Elemental::Element::Pod5::Command') {
250 20         613 given ($node->command) {
251 20         161 when ('over') {
252 4         9 ${$indent}++;
  4         10  
253             }
254 16         26 when ('item') {
255 8         236 push (@lines,(' ' x ($$indent-1)) . $node->content);
256             }
257 8         12 when ('back') {
258 4         12 push (@lines,"\n");
259 4         7 ${$indent}--;
  4         11  
260             }
261 4         51 when (qr/head\d/) {
262 4         133 push (@lines,"\n",$node->content,"\n");
263             }
264             }
265             }
266             }
267             }
268              
269             return
270 59 100       271 unless scalar @lines;
271              
272             # Convert text markup
273 52         95 my $return = join ("\n", grep { defined $_ } @lines);
  86         257  
274 52         140 $return =~ s/\n\n\n+/\n\n/g; # Max one empty line
275 52         103 $return =~ s/I<([^>]+)>/_$1_/g;
276 52         106 $return =~ s/B<([^>]+)>/*$1*/g;
277 52         97 $return =~ s/[LCBI]<([^>]+)>/$1/g;
278 52         90 $return =~ s/[LCBI]<([^>]+)>/$1/g;
279 52         140 return $return;
280             }
281              
282              
283             1;
284              
285             =pod
286              
287             =head1 NAME
288              
289             MooseX::App::Utils - Utility functions
290              
291             =head1 DESCRIPTION
292              
293             This package holds various utility functions used by MooseX-App internally.
294             Unless you develop plugins you will not need to interact with this class.
295              
296             =head1 FUNCTIONS
297              
298             =head2 class_to_command
299              
300             =head2 package_to_filename
301              
302             Tries to determine the filename containing the given package name.
303              
304             =head2 format_list
305              
306             =head2 format_text
307              
308             =head2 parse_pod
309              
310             =head2 split_string
311              
312              
313              
314             =head1 GLOBALS
315              
316             =head2 $MooseX::App::Utils::SCREEN_WIDTH
317              
318             Screen width for printing help and error messages
319              
320             =head2 $MooseX::App::Utils::INDENT
321              
322             Indent for printing help and error messages
323              
324             =cut