← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:09 2023

Filename/home/hejohns/perl5/lib/perl5/Pod/Usage.pm
StatementsExecuted 19 statements in 1.64ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1112.56ms25.4msPod::Usage::::BEGIN@25Pod::Usage::BEGIN@25
1118µs10µsPod::Usage::::BEGIN@13Pod::Usage::BEGIN@13
1116µs7µsPod::Usage::::BEGIN@19Pod::Usage::BEGIN@19
1115µs11µsPod::Usage::::BEGIN@17Pod::Usage::BEGIN@17
1114µs24µsPod::Usage::::BEGIN@16Pod::Usage::BEGIN@16
1114µs9µsPod::Usage::::BEGIN@18Pod::Usage::BEGIN@18
111300ns300nsPod::Usage::::__ANON__Pod::Usage::__ANON__ (xsub)
0000s0sPod::Usage::::_compile_section_specPod::Usage::_compile_section_spec
0000s0sPod::Usage::::_handle_element_endPod::Usage::_handle_element_end
0000s0sPod::Usage::::begin_podPod::Usage::begin_pod
0000s0sPod::Usage::::cmd_iPod::Usage::cmd_i
0000s0sPod::Usage::::newPod::Usage::new
0000s0sPod::Usage::::pod2usagePod::Usage::pod2usage
0000s0sPod::Usage::::preprocess_paragraphPod::Usage::preprocess_paragraph
0000s0sPod::Usage::::selectPod::Usage::select
0000s0sPod::Usage::::seq_iPod::Usage::seq_i
0000s0sPod::Usage::::start_documentPod::Usage::start_document
Call graph for these subroutines as a Graphviz dot language file.
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
11package Pod::Usage;
12
13222µs212µs
# spent 10µs (8+2) within Pod::Usage::BEGIN@13 which was called: # once (8µs+2µs) by main::BEGIN@33 at line 13
use strict;
# spent 10µs making 1 call to Pod::Usage::BEGIN@13 # spent 2µs making 1 call to strict::import
1417µsrequire 5.006; ## requires this Perl version or later
15
16214µs245µs
# spent 24µs (4+20) within Pod::Usage::BEGIN@16 which was called: # once (4µs+20µs) by main::BEGIN@33 at line 16
use Carp;
# spent 24µs making 1 call to Pod::Usage::BEGIN@16 # spent 20µs making 1 call to Exporter::import
17213µs217µs
# spent 11µs (5+6) within Pod::Usage::BEGIN@17 which was called: # once (5µs+6µs) by main::BEGIN@33 at line 17
use Config;
# spent 11µs making 1 call to Pod::Usage::BEGIN@17 # spent 6µs making 1 call to Config::import
18212µs215µs
# spent 9µs (4+5) within Pod::Usage::BEGIN@18 which was called: # once (4µs+5µs) by main::BEGIN@33 at line 18
use Exporter;
# spent 9µs making 1 call to Pod::Usage::BEGIN@18 # spent 5µs making 1 call to Exporter::import
19258µs27µs
# spent 7µs (6+300ns) within Pod::Usage::BEGIN@19 which was called: # once (6µs+300ns) by main::BEGIN@33 at line 19
use File::Spec;
# spent 7µs making 1 call to Pod::Usage::BEGIN@19 # spent 300ns making 1 call to Pod::Usage::__ANON__
20
211400nsour $VERSION = '2.03';
22
231700nsour @EXPORT = qw(&pod2usage);
24our @ISA;
25
# spent 25.4ms (2.56+22.8) within Pod::Usage::BEGIN@25 which was called: # once (2.56ms+22.8ms) by main::BEGIN@33 at line 30
BEGIN {
261300ns $Pod::Usage::Formatter ||= 'Pod::Text';
27111µs eval "require $Pod::Usage::Formatter";
# spent 107µs executing statements in string eval
281200ns die $@ if $@;
2919µs @ISA = ( $Pod::Usage::Formatter );
3011.49ms125.4ms}
# spent 25.4ms making 1 call to Pod::Usage::BEGIN@25
31
321100nsour $MAX_HEADING_LEVEL = 3;
33
34##---------------------------------------------------------------------------
35
36##---------------------------------
37## Function definitions begin here
38##---------------------------------
39
40sub 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 $_ = length($dirname) ? File::Spec->catfile($dirname, $basename) : $basename;
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 = Pod::Usage->new(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} || $Config{scriptdir},
134 '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 # RT16091: fall back to more if perldoc failed
163 if($?) {
164 # RT131844: prefer PAGER env
165 my $pager = $ENV{PAGER} || $Config{pager};
166 if(defined($pager) && length($pager)) {
167 my $cmd = $pager . ' ' . ($^O =~ /win/i ? qq("$f") : quotemeta($f));
168 system($cmd);
169 } else {
170 # the most humble fallback; should work (at least) on *nix and Win
171 system('more', $f);
172 }
173 }
174 } else {
175 croak "Unspecified input file or insecure argument.\n";
176 }
177 }
178 else {
179 $parser->parse_from_file($opts{'-input'}, $opts{'-output'});
180 }
181
182 exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit');
183}
184
185##---------------------------------------------------------------------------
186
187##-------------------------------
188## Method definitions begin here
189##-------------------------------
190
191sub new {
192 my $this = shift;
193 my $class = ref($this) || $this;
194 my %params = @_;
195 my $self = {%params};
196 bless $self, $class;
197 if ($self->can('initialize')) {
198 $self->initialize();
199 } else {
200 # pass through options to Pod::Text
201 my %opts;
202 for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) {
203 my $val = $params{USAGE_OPTIONS}{"-$_"};
204 $opts{$_} = $val if defined $val;
205 }
206 $self = $self->SUPER::new(%opts);
207 %$self = (%$self, %params);
208 }
209 return $self;
210}
211
212# This subroutine was copied in whole-cloth from Pod::Select 1.60 in order to
213# allow the ejection of Pod::Select from the core without breaking Pod::Usage.
214# -- rjbs, 2013-03-18
215sub _compile_section_spec {
216 my ($section_spec) = @_;
217 my (@regexs, $negated);
218
219 ## Compile the spec into a list of regexs
220 local $_ = $section_spec;
221 s{\\\\}{\001}g; ## handle escaped backward slashes
222 s{\\/}{\002}g; ## handle escaped forward slashes
223
224 ## Parse the regexs for the heading titles
225 @regexs = split(/\//, $_, $MAX_HEADING_LEVEL);
226
227 ## Set default regex for ommitted levels
228 for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
229 $regexs[$i] = '.*' unless ((defined $regexs[$i])
230 && (length $regexs[$i]));
231 }
232 ## Modify the regexs as needed and validate their syntax
233 my $bad_regexs = 0;
234 for (@regexs) {
235 $_ .= '.+' if ($_ eq '!');
236 s{\001}{\\\\}g; ## restore escaped backward slashes
237 s{\002}{\\/}g; ## restore escaped forward slashes
238 $negated = s/^\!//; ## check for negation
239 eval "m{$_}"; ## check regex syntax
240 if ($@) {
241 ++$bad_regexs;
242 carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};
243 }
244 else {
245 ## Add the forward and rear anchors (and put the negator back)
246 $_ = '^' . $_ unless (/^\^/);
247 $_ = $_ . '$' unless (/\$$/);
248 $_ = '!' . $_ if ($negated);
249 }
250 }
251 return (! $bad_regexs) ? [ @regexs ] : undef;
252}
253
254sub select {
255 my ($self, @sections) = @_;
256 if ($ISA[0]->can('select')) {
257 $self->SUPER::select(@sections);
258 } else {
259 # we're using Pod::Simple - need to mimic the behavior of Pod::Select
260 my $add = ($sections[0] eq '+') ? shift(@sections) : '';
261 ## Reset the set of sections to use
262 unless (@sections) {
263 delete $self->{USAGE_SELECT} unless ($add);
264 return;
265 }
266 $self->{USAGE_SELECT} = []
267 unless ($add && $self->{USAGE_SELECT});
268 my $sref = $self->{USAGE_SELECT};
269 ## Compile each spec
270 for my $spec (@sections) {
271 my $cs = _compile_section_spec($spec);
272 if ( defined $cs ) {
273 ## Store them in our sections array
274 push(@$sref, $cs);
275 } else {
276 carp qq{Ignoring section spec "$spec"!\n};
277 }
278 }
279 }
280}
281
282# Override Pod::Text->seq_i to return just "arg", not "*arg*".
283sub seq_i { return $_[1] }
284# Override Pod::Text->cmd_i to return just "arg", not "*arg*".
285# newer version based on Pod::Simple
286sub cmd_i {
287 my $self = shift;
288 # RT121489: highlighting should be there with Termcap
289 return $self->SUPER::cmd_i(@_) if $self->isa('Pod::Text::Termcap');
290 return $_[1];
291}
292
293# This overrides the Pod::Text method to do something very akin to what
294# Pod::Select did as well as the work done below by preprocess_paragraph.
295# Note that the below is very, very specific to Pod::Text and Pod::Simple.
296sub _handle_element_end {
297 my ($self, $element) = @_;
298 if ($element eq 'head1') {
299 $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ];
300 if ($self->{USAGE_OPTIONS}->{-verbose} < 2) {
301 $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
302 }
303 } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
304 my $idx = $1 - 1;
305 $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
306 $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
307 # we have to get rid of the lower headings
308 splice(@{$self->{USAGE_HEADINGS}},$idx+1);
309 }
310 if ($element =~ /^head\d+$/) {
311 $$self{USAGE_SKIPPING} = 1;
312 if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) {
313 $$self{USAGE_SKIPPING} = 0;
314 } else {
315 my @headings = @{$$self{USAGE_HEADINGS}};
316 for my $section_spec ( @{$$self{USAGE_SELECT}} ) {
317 my $match = 1;
318 for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
319 $headings[$i] = '' unless defined $headings[$i];
320 my $regex = $section_spec->[$i];
321 my $negated = ($regex =~ s/^\!//);
322 $match &= ($negated ? ($headings[$i] !~ /${regex}/)
323 : ($headings[$i] =~ /${regex}/));
324 last unless ($match);
325 } # end heading levels
326 if ($match) {
327 $$self{USAGE_SKIPPING} = 0;
328 last;
329 }
330 } # end sections
331 }
332
333 # Try to do some lowercasing instead of all-caps in headings, and use
334 # a colon to end all headings.
335 if($self->{USAGE_OPTIONS}->{-verbose} < 2) {
336 local $_ = $$self{PENDING}[-1][1];
337 s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
338 s/\s*$/:/ unless (/:\s*$/);
339 $_ .= "\n";
340 $$self{PENDING}[-1][1] = $_;
341 }
342 }
343 if ($$self{USAGE_SKIPPING} && $element !~ m/^over-|^[BCFILSZ]$/) {
344 pop @{ $$self{PENDING} };
345 } else {
346 $self->SUPER::_handle_element_end($element);
347 }
348}
349
350# required for Pod::Simple API
351sub start_document {
352 my $self = shift;
353 $self->SUPER::start_document();
354 my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
355 my $out_fh = $self->output_fh();
356 print $out_fh "$msg\n";
357}
358
359# required for old Pod::Parser API
360sub begin_pod {
361 my $self = shift;
362 $self->SUPER::begin_pod(); ## Have to call superclass
363 my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
364 my $out_fh = $self->output_handle();
365 print $out_fh "$msg\n";
366}
367
368sub preprocess_paragraph {
369 my $self = shift;
370 local $_ = shift;
371 my $line = shift;
372 ## See if this is a heading and we aren't printing the entire manpage.
373 if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) {
374 ## Change the title of the SYNOPSIS section to USAGE
375 s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/;
376 ## Try to do some lowercasing instead of all-caps in headings
377 s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
378 ## Use a colon to end all headings
379 s/\s*$/:/ unless (/:\s*$/);
380 $_ .= "\n";
381 }
382 return $self->SUPER::preprocess_paragraph($_);
383}
384
38514µs1; # keep require happy
386
387__END__
 
# spent 300ns within Pod::Usage::__ANON__ which was called: # once (300ns+0s) by Pod::Usage::BEGIN@19 at line 19
sub Pod::Usage::__ANON__; # xsub
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.