Filename | /usr/local/lib/perl5/5.24/Pod/Usage.pm |
Statements | Executed 21 statements in 6.09ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 8.39ms | 81.7ms | BEGIN@25 | Pod::Usage::
1 | 1 | 1 | 8.00ms | 9.04ms | BEGIN@19 | Pod::Usage::
1 | 1 | 1 | 5.47ms | 7.41ms | BEGIN@22 | Pod::Usage::
1 | 1 | 1 | 52µs | 60µs | BEGIN@12 | Pod::Usage::
1 | 1 | 1 | 43µs | 238µs | BEGIN@14 | Pod::Usage::
1 | 1 | 1 | 26µs | 70µs | BEGIN@20 | Pod::Usage::
1 | 1 | 1 | 26µs | 106µs | BEGIN@21 | Pod::Usage::
0 | 0 | 0 | 0s | 0s | _compile_section_spec | Pod::Usage::
0 | 0 | 0 | 0s | 0s | _handle_element_end | Pod::Usage::
0 | 0 | 0 | 0s | 0s | begin_pod | Pod::Usage::
0 | 0 | 0 | 0s | 0s | cmd_i | Pod::Usage::
0 | 0 | 0 | 0s | 0s | new | Pod::Usage::
0 | 0 | 0 | 0s | 0s | pod2usage | Pod::Usage::
0 | 0 | 0 | 0s | 0s | preprocess_paragraph | Pod::Usage::
0 | 0 | 0 | 0s | 0s | select | Pod::Usage::
0 | 0 | 0 | 0s | 0s | seq_i | Pod::Usage::
0 | 0 | 0 | 0s | 0s | start_document | Pod::Usage::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | ############################################################################# | ||||
2 | # Pod/Usage.pm -- print usage messages for the running script. | ||||
3 | # | ||||
4 | # Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. | ||||
5 | # Copyright (c) 2001-2016 by Marek Rouchal. | ||||
6 | # This file is part of "Pod-Usage". Pod-Usage is free software; | ||||
7 | # you can redistribute it and/or modify it under the same terms | ||||
8 | # as Perl itself. | ||||
9 | ############################################################################# | ||||
10 | |||||
11 | package Pod::Usage; | ||||
12 | 2 | 74µs | 2 | 67µs | # spent 60µs (52+8) within Pod::Usage::BEGIN@12 which was called:
# once (52µs+8µs) by main::BEGIN@25 at line 12 # spent 60µs making 1 call to Pod::Usage::BEGIN@12
# spent 8µs making 1 call to strict::import |
13 | |||||
14 | 2 | 91µs | 2 | 433µs | # spent 238µs (43+195) within Pod::Usage::BEGIN@14 which was called:
# once (43µs+195µs) by main::BEGIN@25 at line 14 # spent 238µs making 1 call to Pod::Usage::BEGIN@14
# spent 195µs making 1 call to vars::import |
15 | 1 | 3µs | $VERSION = '1.68'; ## Current version of this package | ||
16 | 1 | 31µs | require 5.006; ## requires this Perl version or later | ||
17 | |||||
18 | #use diagnostics; | ||||
19 | 2 | 300µs | 2 | 9.23ms | # spent 9.04ms (8.00+1.04) within Pod::Usage::BEGIN@19 which was called:
# once (8.00ms+1.04ms) by main::BEGIN@25 at line 19 # spent 9.04ms making 1 call to Pod::Usage::BEGIN@19
# spent 194µs making 1 call to Exporter::import |
20 | 2 | 62µs | 2 | 113µs | # spent 70µs (26+44) within Pod::Usage::BEGIN@20 which was called:
# once (26µs+44µs) by main::BEGIN@25 at line 20 # spent 70µs making 1 call to Pod::Usage::BEGIN@20
# spent 44µs making 1 call to Config::import |
21 | 2 | 58µs | 2 | 186µs | # spent 106µs (26+80) within Pod::Usage::BEGIN@21 which was called:
# once (26µs+80µs) by main::BEGIN@25 at line 21 # spent 106µs making 1 call to Pod::Usage::BEGIN@21
# spent 80µs making 1 call to Exporter::import |
22 | 2 | 446µs | 1 | 7.41ms | # spent 7.41ms (5.47+1.93) within Pod::Usage::BEGIN@22 which was called:
# once (5.47ms+1.93ms) by main::BEGIN@25 at line 22 # spent 7.41ms making 1 call to Pod::Usage::BEGIN@22 |
23 | |||||
24 | 1 | 5µs | @EXPORT = qw(&pod2usage); | ||
25 | # spent 81.7ms (8.39+73.3) within Pod::Usage::BEGIN@25 which was called:
# once (8.39ms+73.3ms) by main::BEGIN@25 at line 30 | ||||
26 | 1 | 2µs | $Pod::Usage::Formatter ||= 'Pod::Text'; | ||
27 | 1 | 49µs | eval "require $Pod::Usage::Formatter"; # spent 299µs executing statements in string eval | ||
28 | 1 | 2µs | die $@ if $@; | ||
29 | 1 | 28µs | @ISA = ( $Pod::Usage::Formatter ); | ||
30 | 1 | 4.92ms | 1 | 81.7ms | } # spent 81.7ms making 1 call to Pod::Usage::BEGIN@25 |
31 | |||||
32 | 1 | 2µs | our $MAX_HEADING_LEVEL = 3; | ||
33 | |||||
34 | ##--------------------------------------------------------------------------- | ||||
35 | |||||
36 | ##--------------------------------- | ||||
37 | ## Function definitions begin here | ||||
38 | ##--------------------------------- | ||||
39 | |||||
40 | sub pod2usage { | ||||
41 | local($_) = shift; | ||||
42 | my %opts; | ||||
43 | ## Collect arguments | ||||
44 | if (@_ > 0) { | ||||
45 | ## Too many arguments - assume that this is a hash and | ||||
46 | ## the user forgot to pass a reference to it. | ||||
47 | %opts = ($_, @_); | ||||
48 | } | ||||
49 | elsif (!defined $_) { | ||||
50 | $_ = ''; | ||||
51 | } | ||||
52 | elsif (ref $_) { | ||||
53 | ## User passed a ref to a hash | ||||
54 | %opts = %{$_} if (ref($_) eq 'HASH'); | ||||
55 | } | ||||
56 | elsif (/^[-+]?\d+$/) { | ||||
57 | ## User passed in the exit value to use | ||||
58 | $opts{'-exitval'} = $_; | ||||
59 | } | ||||
60 | else { | ||||
61 | ## User passed in a message to print before issuing usage. | ||||
62 | $_ and $opts{'-message'} = $_; | ||||
63 | } | ||||
64 | |||||
65 | ## Need this for backward compatibility since we formerly used | ||||
66 | ## options that were all uppercase words rather than ones that | ||||
67 | ## looked like Unix command-line options. | ||||
68 | ## to be uppercase keywords) | ||||
69 | %opts = map { | ||||
70 | my ($key, $val) = ($_, $opts{$_}); | ||||
71 | $key =~ s/^(?=\w)/-/; | ||||
72 | $key =~ /^-msg/i and $key = '-message'; | ||||
73 | $key =~ /^-exit/i and $key = '-exitval'; | ||||
74 | lc($key) => $val; | ||||
75 | } (keys %opts); | ||||
76 | |||||
77 | ## Now determine default -exitval and -verbose values to use | ||||
78 | if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) { | ||||
79 | $opts{'-exitval'} = 2; | ||||
80 | $opts{'-verbose'} = 0; | ||||
81 | } | ||||
82 | elsif (! defined $opts{'-exitval'}) { | ||||
83 | $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2; | ||||
84 | } | ||||
85 | elsif (! defined $opts{'-verbose'}) { | ||||
86 | $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' || | ||||
87 | $opts{'-exitval'} < 2); | ||||
88 | } | ||||
89 | |||||
90 | ## Default the output file | ||||
91 | $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' || | ||||
92 | $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR | ||||
93 | unless (defined $opts{'-output'}); | ||||
94 | ## Default the input file | ||||
95 | $opts{'-input'} = $0 unless (defined $opts{'-input'}); | ||||
96 | |||||
97 | ## Look up input file in path if it doesn't exist. | ||||
98 | unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) { | ||||
99 | my $basename = $opts{'-input'}; | ||||
100 | my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';' | ||||
101 | : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':'); | ||||
102 | my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB}; | ||||
103 | |||||
104 | my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); | ||||
105 | for my $dirname (@paths) { | ||||
106 | $_ = File::Spec->catfile($dirname, $basename) if length; | ||||
107 | last if (-e $_) && ($opts{'-input'} = $_); | ||||
108 | } | ||||
109 | } | ||||
110 | |||||
111 | ## Now create a pod reader and constrain it to the desired sections. | ||||
112 | my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); | ||||
113 | if ($opts{'-verbose'} == 0) { | ||||
114 | $parser->select('(?:SYNOPSIS|USAGE)\s*'); | ||||
115 | } | ||||
116 | elsif ($opts{'-verbose'} == 1) { | ||||
117 | my $opt_re = '(?i)' . | ||||
118 | '(?:OPTIONS|ARGUMENTS)' . | ||||
119 | '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; | ||||
120 | $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" ); | ||||
121 | } | ||||
122 | elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { | ||||
123 | $parser->select('.*'); | ||||
124 | } | ||||
125 | elsif ($opts{'-verbose'} == 99) { | ||||
126 | my $sections = $opts{'-sections'}; | ||||
127 | $parser->select( (ref $sections) ? @$sections : $sections ); | ||||
128 | $opts{'-verbose'} = 1; | ||||
129 | } | ||||
130 | |||||
131 | ## Check for perldoc | ||||
132 | my $progpath = $opts{'-perldoc'} ? $opts{'-perldoc'} : | ||||
133 | File::Spec->catfile($Config{scriptdirexp} | ||||
134 | || $Config{scriptdir}, 'perldoc'); | ||||
135 | |||||
136 | my $version = sprintf("%vd",$^V); | ||||
137 | if ($Config{versiononly} and $Config{startperl} =~ /\Q$version\E$/ ) { | ||||
138 | $progpath .= $version; | ||||
139 | } | ||||
140 | $opts{'-noperldoc'} = 1 unless -e $progpath; | ||||
141 | |||||
142 | ## Now translate the pod document and then exit with the desired status | ||||
143 | if ( !$opts{'-noperldoc'} | ||||
144 | and $opts{'-verbose'} >= 2 | ||||
145 | and !ref($opts{'-input'}) | ||||
146 | and $opts{'-output'} == \*STDOUT ) | ||||
147 | { | ||||
148 | ## spit out the entire PODs. Might as well invoke perldoc | ||||
149 | print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'}); | ||||
150 | if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) { | ||||
151 | # the perldocs back to 5.005 should all have -F | ||||
152 | # without -F there are warnings in -T scripts | ||||
153 | my $f = $1; | ||||
154 | my @perldoc_cmd = ($progpath); | ||||
155 | if ($opts{'-perldocopt'}) { | ||||
156 | $opts{'-perldocopt'} =~ s/^\s+|\s+$//g; | ||||
157 | push @perldoc_cmd, split(/\s+/, $opts{'-perldocopt'}); | ||||
158 | } | ||||
159 | push @perldoc_cmd, ('-F', $f); | ||||
160 | unshift @perldoc_cmd, $opts{'-perlcmd'} if $opts{'-perlcmd'}; | ||||
161 | system(@perldoc_cmd); | ||||
162 | if($?) { | ||||
163 | # RT16091: fall back to more if perldoc failed | ||||
164 | system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1); | ||||
165 | } | ||||
166 | } else { | ||||
167 | croak "Unspecified input file or insecure argument.\n"; | ||||
168 | } | ||||
169 | } | ||||
170 | else { | ||||
171 | $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); | ||||
172 | } | ||||
173 | |||||
174 | exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); | ||||
175 | } | ||||
176 | |||||
177 | ##--------------------------------------------------------------------------- | ||||
178 | |||||
179 | ##------------------------------- | ||||
180 | ## Method definitions begin here | ||||
181 | ##------------------------------- | ||||
182 | |||||
183 | sub new { | ||||
184 | my $this = shift; | ||||
185 | my $class = ref($this) || $this; | ||||
186 | my %params = @_; | ||||
187 | my $self = {%params}; | ||||
188 | bless $self, $class; | ||||
189 | if ($self->can('initialize')) { | ||||
190 | $self->initialize(); | ||||
191 | } else { | ||||
192 | # pass through options to Pod::Text | ||||
193 | my %opts; | ||||
194 | for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) { | ||||
195 | my $val = $params{USAGE_OPTIONS}{"-$_"}; | ||||
196 | $opts{$_} = $val if defined $val; | ||||
197 | } | ||||
198 | $self = $self->SUPER::new(%opts); | ||||
199 | %$self = (%$self, %params); | ||||
200 | } | ||||
201 | return $self; | ||||
202 | } | ||||
203 | |||||
204 | # This subroutine was copied in whole-cloth from Pod::Select 1.60 in order to | ||||
205 | # allow the ejection of Pod::Select from the core without breaking Pod::Usage. | ||||
206 | # -- rjbs, 2013-03-18 | ||||
207 | sub _compile_section_spec { | ||||
208 | my ($section_spec) = @_; | ||||
209 | my (@regexs, $negated); | ||||
210 | |||||
211 | ## Compile the spec into a list of regexs | ||||
212 | local $_ = $section_spec; | ||||
213 | s{\\\\}{\001}g; ## handle escaped backward slashes | ||||
214 | s{\\/}{\002}g; ## handle escaped forward slashes | ||||
215 | |||||
216 | ## Parse the regexs for the heading titles | ||||
217 | @regexs = split(/\//, $_, $MAX_HEADING_LEVEL); | ||||
218 | |||||
219 | ## Set default regex for ommitted levels | ||||
220 | for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { | ||||
221 | $regexs[$i] = '.*' unless ((defined $regexs[$i]) | ||||
222 | && (length $regexs[$i])); | ||||
223 | } | ||||
224 | ## Modify the regexs as needed and validate their syntax | ||||
225 | my $bad_regexs = 0; | ||||
226 | for (@regexs) { | ||||
227 | $_ .= '.+' if ($_ eq '!'); | ||||
228 | s{\001}{\\\\}g; ## restore escaped backward slashes | ||||
229 | s{\002}{\\/}g; ## restore escaped forward slashes | ||||
230 | $negated = s/^\!//; ## check for negation | ||||
231 | eval "m{$_}"; ## check regex syntax | ||||
232 | if ($@) { | ||||
233 | ++$bad_regexs; | ||||
234 | carp qq{Bad regular expression /$_/ in "$section_spec": $@\n}; | ||||
235 | } | ||||
236 | else { | ||||
237 | ## Add the forward and rear anchors (and put the negator back) | ||||
238 | $_ = '^' . $_ unless (/^\^/); | ||||
239 | $_ = $_ . '$' unless (/\$$/); | ||||
240 | $_ = '!' . $_ if ($negated); | ||||
241 | } | ||||
242 | } | ||||
243 | return (! $bad_regexs) ? [ @regexs ] : undef; | ||||
244 | } | ||||
245 | |||||
246 | sub select { | ||||
247 | my ($self, @sections) = @_; | ||||
248 | if ($ISA[0]->can('select')) { | ||||
249 | $self->SUPER::select(@sections); | ||||
250 | } else { | ||||
251 | # we're using Pod::Simple - need to mimic the behavior of Pod::Select | ||||
252 | my $add = ($sections[0] eq '+') ? shift(@sections) : ''; | ||||
253 | ## Reset the set of sections to use | ||||
254 | unless (@sections) { | ||||
255 | delete $self->{USAGE_SELECT} unless ($add); | ||||
256 | return; | ||||
257 | } | ||||
258 | $self->{USAGE_SELECT} = [] | ||||
259 | unless ($add && $self->{USAGE_SELECT}); | ||||
260 | my $sref = $self->{USAGE_SELECT}; | ||||
261 | ## Compile each spec | ||||
262 | for my $spec (@sections) { | ||||
263 | my $cs = _compile_section_spec($spec); | ||||
264 | if ( defined $cs ) { | ||||
265 | ## Store them in our sections array | ||||
266 | push(@$sref, $cs); | ||||
267 | } else { | ||||
268 | carp qq{Ignoring section spec "$spec"!\n}; | ||||
269 | } | ||||
270 | } | ||||
271 | } | ||||
272 | } | ||||
273 | |||||
274 | # Override Pod::Text->seq_i to return just "arg", not "*arg*". | ||||
275 | sub seq_i { return $_[1] } | ||||
276 | # Override Pod::Text->cmd_i to return just "arg", not "*arg*". | ||||
277 | # newer version based on Pod::Simple | ||||
278 | sub cmd_i { return $_[2] } | ||||
279 | |||||
280 | # This overrides the Pod::Text method to do something very akin to what | ||||
281 | # Pod::Select did as well as the work done below by preprocess_paragraph. | ||||
282 | # Note that the below is very, very specific to Pod::Text and Pod::Simple. | ||||
283 | sub _handle_element_end { | ||||
284 | my ($self, $element) = @_; | ||||
285 | if ($element eq 'head1') { | ||||
286 | $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ]; | ||||
287 | if ($self->{USAGE_OPTIONS}->{-verbose} < 2) { | ||||
288 | $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; | ||||
289 | } | ||||
290 | } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0 | ||||
291 | my $idx = $1 - 1; | ||||
292 | $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS}); | ||||
293 | $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1]; | ||||
294 | # we have to get rid of the lower headings | ||||
295 | splice(@{$self->{USAGE_HEADINGS}},$idx+1); | ||||
296 | } | ||||
297 | if ($element =~ /^head\d+$/) { | ||||
298 | $$self{USAGE_SKIPPING} = 1; | ||||
299 | if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) { | ||||
300 | $$self{USAGE_SKIPPING} = 0; | ||||
301 | } else { | ||||
302 | my @headings = @{$$self{USAGE_HEADINGS}}; | ||||
303 | for my $section_spec ( @{$$self{USAGE_SELECT}} ) { | ||||
304 | my $match = 1; | ||||
305 | for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { | ||||
306 | $headings[$i] = '' unless defined $headings[$i]; | ||||
307 | my $regex = $section_spec->[$i]; | ||||
308 | my $negated = ($regex =~ s/^\!//); | ||||
309 | $match &= ($negated ? ($headings[$i] !~ /${regex}/) | ||||
310 | : ($headings[$i] =~ /${regex}/)); | ||||
311 | last unless ($match); | ||||
312 | } # end heading levels | ||||
313 | if ($match) { | ||||
314 | $$self{USAGE_SKIPPING} = 0; | ||||
315 | last; | ||||
316 | } | ||||
317 | } # end sections | ||||
318 | } | ||||
319 | |||||
320 | # Try to do some lowercasing instead of all-caps in headings, and use | ||||
321 | # a colon to end all headings. | ||||
322 | if($self->{USAGE_OPTIONS}->{-verbose} < 2) { | ||||
323 | local $_ = $$self{PENDING}[-1][1]; | ||||
324 | s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; | ||||
325 | s/\s*$/:/ unless (/:\s*$/); | ||||
326 | $_ .= "\n"; | ||||
327 | $$self{PENDING}[-1][1] = $_; | ||||
328 | } | ||||
329 | } | ||||
330 | if ($$self{USAGE_SKIPPING} && $element !~ m/^over-|^[BCFILSZ]$/) { | ||||
331 | pop @{ $$self{PENDING} }; | ||||
332 | } else { | ||||
333 | $self->SUPER::_handle_element_end($element); | ||||
334 | } | ||||
335 | } | ||||
336 | |||||
337 | # required for Pod::Simple API | ||||
338 | sub start_document { | ||||
339 | my $self = shift; | ||||
340 | $self->SUPER::start_document(); | ||||
341 | my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; | ||||
342 | my $out_fh = $self->output_fh(); | ||||
343 | print $out_fh "$msg\n"; | ||||
344 | } | ||||
345 | |||||
346 | # required for old Pod::Parser API | ||||
347 | sub begin_pod { | ||||
348 | my $self = shift; | ||||
349 | $self->SUPER::begin_pod(); ## Have to call superclass | ||||
350 | my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; | ||||
351 | my $out_fh = $self->output_handle(); | ||||
352 | print $out_fh "$msg\n"; | ||||
353 | } | ||||
354 | |||||
355 | sub preprocess_paragraph { | ||||
356 | my $self = shift; | ||||
357 | local $_ = shift; | ||||
358 | my $line = shift; | ||||
359 | ## See if this is a heading and we aren't printing the entire manpage. | ||||
360 | if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { | ||||
361 | ## Change the title of the SYNOPSIS section to USAGE | ||||
362 | s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/; | ||||
363 | ## Try to do some lowercasing instead of all-caps in headings | ||||
364 | s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; | ||||
365 | ## Use a colon to end all headings | ||||
366 | s/\s*$/:/ unless (/:\s*$/); | ||||
367 | $_ .= "\n"; | ||||
368 | } | ||||
369 | return $self->SUPER::preprocess_paragraph($_); | ||||
370 | } | ||||
371 | |||||
372 | 1 | 14µs | 1; # keep require happy | ||
373 | |||||
374 | __END__ |