Filename | /usr/lib64/perl5/vendor_perl/5.16.0/Pod/Usage.pm |
Statements | Executed 20 statements in 12.0ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 18.5ms | 240ms | BEGIN@450 | Pod::Usage::
1 | 1 | 1 | 83µs | 186µs | BEGIN@11 | Pod::Usage::
1 | 1 | 1 | 66µs | 367µs | BEGIN@13 | Pod::Usage::
1 | 1 | 1 | 63µs | 152µs | BEGIN@446 | Pod::Usage::
1 | 1 | 1 | 62µs | 323µs | BEGIN@444 | Pod::Usage::
1 | 1 | 1 | 53µs | 120µs | BEGIN@445 | Pod::Usage::
1 | 1 | 1 | 35µs | 35µs | BEGIN@447 | 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 | 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 | # This file is part of "PodParser". PodParser is free software; | ||||
6 | # you can redistribute it and/or modify it under the same terms | ||||
7 | # as Perl itself. | ||||
8 | ############################################################################# | ||||
9 | |||||
10 | package Pod::Usage; | ||||
11 | 2 | 194µs | 2 | 289µs | # spent 186µs (83+103) within Pod::Usage::BEGIN@11 which was called:
# once (83µs+103µs) by main::BEGIN@147 at line 11 # spent 186µs making 1 call to Pod::Usage::BEGIN@11
# spent 103µs making 1 call to strict::import |
12 | |||||
13 | 2 | 923µs | 2 | 669µs | # spent 367µs (66+301) within Pod::Usage::BEGIN@13 which was called:
# once (66µs+301µs) by main::BEGIN@147 at line 13 # spent 367µs making 1 call to Pod::Usage::BEGIN@13
# spent 301µs making 1 call to vars::import |
14 | 1 | 4µs | $VERSION = '1.36'; ## Current version of this package | ||
15 | 1 | 60µs | require 5.005; ## requires this Perl version or later | ||
16 | |||||
17 | =head1 NAME | ||||
18 | |||||
19 | Pod::Usage, pod2usage() - print a usage message from embedded pod documentation | ||||
20 | |||||
21 | =head1 SYNOPSIS | ||||
22 | |||||
23 | use Pod::Usage | ||||
24 | |||||
25 | my $message_text = "This text precedes the usage message."; | ||||
26 | my $exit_status = 2; ## The exit status to use | ||||
27 | my $verbose_level = 0; ## The verbose level to use | ||||
28 | my $filehandle = \*STDERR; ## The filehandle to write to | ||||
29 | |||||
30 | pod2usage($message_text); | ||||
31 | |||||
32 | pod2usage($exit_status); | ||||
33 | |||||
34 | pod2usage( { -message => $message_text , | ||||
35 | -exitval => $exit_status , | ||||
36 | -verbose => $verbose_level, | ||||
37 | -output => $filehandle } ); | ||||
38 | |||||
39 | pod2usage( -msg => $message_text , | ||||
40 | -exitval => $exit_status , | ||||
41 | -verbose => $verbose_level, | ||||
42 | -output => $filehandle ); | ||||
43 | |||||
44 | pod2usage( -verbose => 2, | ||||
45 | -noperldoc => 1 ) | ||||
46 | |||||
47 | =head1 ARGUMENTS | ||||
48 | |||||
49 | B<pod2usage> should be given either a single argument, or a list of | ||||
50 | arguments corresponding to an associative array (a "hash"). When a single | ||||
51 | argument is given, it should correspond to exactly one of the following: | ||||
52 | |||||
53 | =over 4 | ||||
54 | |||||
55 | =item * | ||||
56 | |||||
57 | A string containing the text of a message to print I<before> printing | ||||
58 | the usage message | ||||
59 | |||||
60 | =item * | ||||
61 | |||||
62 | A numeric value corresponding to the desired exit status | ||||
63 | |||||
64 | =item * | ||||
65 | |||||
66 | A reference to a hash | ||||
67 | |||||
68 | =back | ||||
69 | |||||
70 | If more than one argument is given then the entire argument list is | ||||
71 | assumed to be a hash. If a hash is supplied (either as a reference or | ||||
72 | as a list) it should contain one or more elements with the following | ||||
73 | keys: | ||||
74 | |||||
75 | =over 4 | ||||
76 | |||||
77 | =item C<-message> | ||||
78 | |||||
79 | =item C<-msg> | ||||
80 | |||||
81 | The text of a message to print immediately prior to printing the | ||||
82 | program's usage message. | ||||
83 | |||||
84 | =item C<-exitval> | ||||
85 | |||||
86 | The desired exit status to pass to the B<exit()> function. | ||||
87 | This should be an integer, or else the string "NOEXIT" to | ||||
88 | indicate that control should simply be returned without | ||||
89 | terminating the invoking process. | ||||
90 | |||||
91 | =item C<-verbose> | ||||
92 | |||||
93 | The desired level of "verboseness" to use when printing the usage | ||||
94 | message. If the corresponding value is 0, then only the "SYNOPSIS" | ||||
95 | section of the pod documentation is printed. If the corresponding value | ||||
96 | is 1, then the "SYNOPSIS" section, along with any section entitled | ||||
97 | "OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the | ||||
98 | corresponding value is 2 or more then the entire manpage is printed. | ||||
99 | |||||
100 | The special verbosity level 99 requires to also specify the -sections | ||||
101 | parameter; then these sections are extracted (see L<Pod::Select>) | ||||
102 | and printed. | ||||
103 | |||||
104 | =item C<-sections> | ||||
105 | |||||
106 | A string representing a selection list for sections to be printed | ||||
107 | when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">. | ||||
108 | |||||
109 | Alternatively, an array reference of section specifications can be used: | ||||
110 | |||||
111 | pod2usage(-verbose => 99, | ||||
112 | -sections => [ qw(fred fred/subsection) ] ); | ||||
113 | |||||
114 | =item C<-output> | ||||
115 | |||||
116 | A reference to a filehandle, or the pathname of a file to which the | ||||
117 | usage message should be written. The default is C<\*STDERR> unless the | ||||
118 | exit value is less than 2 (in which case the default is C<\*STDOUT>). | ||||
119 | |||||
120 | =item C<-input> | ||||
121 | |||||
122 | A reference to a filehandle, or the pathname of a file from which the | ||||
123 | invoking script's pod documentation should be read. It defaults to the | ||||
124 | file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>). | ||||
125 | |||||
126 | If you are calling B<pod2usage()> from a module and want to display | ||||
127 | that module's POD, you can use this: | ||||
128 | |||||
129 | use Pod::Find qw(pod_where); | ||||
130 | pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) ); | ||||
131 | |||||
132 | =item C<-pathlist> | ||||
133 | |||||
134 | A list of directory paths. If the input file does not exist, then it | ||||
135 | will be searched for in the given directory list (in the order the | ||||
136 | directories appear in the list). It defaults to the list of directories | ||||
137 | implied by C<$ENV{PATH}>. The list may be specified either by a reference | ||||
138 | to an array, or by a string of directory paths which use the same path | ||||
139 | separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for | ||||
140 | MSWin32 and DOS). | ||||
141 | |||||
142 | =item C<-noperldoc> | ||||
143 | |||||
144 | By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is | ||||
145 | specified. This does not work well e.g. if the script was packed | ||||
146 | with L<PAR>. The -noperldoc option suppresses the external call to | ||||
147 | L<perldoc> and uses the simple text formatter (L<Pod::Text>) to | ||||
148 | output the POD. | ||||
149 | |||||
150 | =back | ||||
151 | |||||
152 | =head1 DESCRIPTION | ||||
153 | |||||
154 | B<pod2usage> will print a usage message for the invoking script (using | ||||
155 | its embedded pod documentation) and then exit the script with the | ||||
156 | desired exit status. The usage message printed may have any one of three | ||||
157 | levels of "verboseness": If the verbose level is 0, then only a synopsis | ||||
158 | is printed. If the verbose level is 1, then the synopsis is printed | ||||
159 | along with a description (if present) of the command line options and | ||||
160 | arguments. If the verbose level is 2, then the entire manual page is | ||||
161 | printed. | ||||
162 | |||||
163 | Unless they are explicitly specified, the default values for the exit | ||||
164 | status, verbose level, and output stream to use are determined as | ||||
165 | follows: | ||||
166 | |||||
167 | =over 4 | ||||
168 | |||||
169 | =item * | ||||
170 | |||||
171 | If neither the exit status nor the verbose level is specified, then the | ||||
172 | default is to use an exit status of 2 with a verbose level of 0. | ||||
173 | |||||
174 | =item * | ||||
175 | |||||
176 | If an exit status I<is> specified but the verbose level is I<not>, then the | ||||
177 | verbose level will default to 1 if the exit status is less than 2 and | ||||
178 | will default to 0 otherwise. | ||||
179 | |||||
180 | =item * | ||||
181 | |||||
182 | If an exit status is I<not> specified but verbose level I<is> given, then | ||||
183 | the exit status will default to 2 if the verbose level is 0 and will | ||||
184 | default to 1 otherwise. | ||||
185 | |||||
186 | =item * | ||||
187 | |||||
188 | If the exit status used is less than 2, then output is printed on | ||||
189 | C<STDOUT>. Otherwise output is printed on C<STDERR>. | ||||
190 | |||||
191 | =back | ||||
192 | |||||
193 | Although the above may seem a bit confusing at first, it generally does | ||||
194 | "the right thing" in most situations. This determination of the default | ||||
195 | values to use is based upon the following typical Unix conventions: | ||||
196 | |||||
197 | =over 4 | ||||
198 | |||||
199 | =item * | ||||
200 | |||||
201 | An exit status of 0 implies "success". For example, B<diff(1)> exits | ||||
202 | with a status of 0 if the two files have the same contents. | ||||
203 | |||||
204 | =item * | ||||
205 | |||||
206 | An exit status of 1 implies possibly abnormal, but non-defective, program | ||||
207 | termination. For example, B<grep(1)> exits with a status of 1 if | ||||
208 | it did I<not> find a matching line for the given regular expression. | ||||
209 | |||||
210 | =item * | ||||
211 | |||||
212 | An exit status of 2 or more implies a fatal error. For example, B<ls(1)> | ||||
213 | exits with a status of 2 if you specify an illegal (unknown) option on | ||||
214 | the command line. | ||||
215 | |||||
216 | =item * | ||||
217 | |||||
218 | Usage messages issued as a result of bad command-line syntax should go | ||||
219 | to C<STDERR>. However, usage messages issued due to an explicit request | ||||
220 | to print usage (like specifying B<-help> on the command line) should go | ||||
221 | to C<STDOUT>, just in case the user wants to pipe the output to a pager | ||||
222 | (such as B<more(1)>). | ||||
223 | |||||
224 | =item * | ||||
225 | |||||
226 | If program usage has been explicitly requested by the user, it is often | ||||
227 | desirable to exit with a status of 1 (as opposed to 0) after issuing | ||||
228 | the user-requested usage message. It is also desirable to give a | ||||
229 | more verbose description of program usage in this case. | ||||
230 | |||||
231 | =back | ||||
232 | |||||
233 | B<pod2usage> doesn't force the above conventions upon you, but it will | ||||
234 | use them by default if you don't expressly tell it to do otherwise. The | ||||
235 | ability of B<pod2usage()> to accept a single number or a string makes it | ||||
236 | convenient to use as an innocent looking error message handling function: | ||||
237 | |||||
238 | use Pod::Usage; | ||||
239 | use Getopt::Long; | ||||
240 | |||||
241 | ## Parse options | ||||
242 | GetOptions("help", "man", "flag1") || pod2usage(2); | ||||
243 | pod2usage(1) if ($opt_help); | ||||
244 | pod2usage(-verbose => 2) if ($opt_man); | ||||
245 | |||||
246 | ## Check for too many filenames | ||||
247 | pod2usage("$0: Too many files given.\n") if (@ARGV > 1); | ||||
248 | |||||
249 | Some user's however may feel that the above "economy of expression" is | ||||
250 | not particularly readable nor consistent and may instead choose to do | ||||
251 | something more like the following: | ||||
252 | |||||
253 | use Pod::Usage; | ||||
254 | use Getopt::Long; | ||||
255 | |||||
256 | ## Parse options | ||||
257 | GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0); | ||||
258 | pod2usage(-verbose => 1) if ($opt_help); | ||||
259 | pod2usage(-verbose => 2) if ($opt_man); | ||||
260 | |||||
261 | ## Check for too many filenames | ||||
262 | pod2usage(-verbose => 2, -message => "$0: Too many files given.\n") | ||||
263 | if (@ARGV > 1); | ||||
264 | |||||
265 | As with all things in Perl, I<there's more than one way to do it>, and | ||||
266 | B<pod2usage()> adheres to this philosophy. If you are interested in | ||||
267 | seeing a number of different ways to invoke B<pod2usage> (although by no | ||||
268 | means exhaustive), please refer to L<"EXAMPLES">. | ||||
269 | |||||
270 | =head1 EXAMPLES | ||||
271 | |||||
272 | Each of the following invocations of C<pod2usage()> will print just the | ||||
273 | "SYNOPSIS" section to C<STDERR> and will exit with a status of 2: | ||||
274 | |||||
275 | pod2usage(); | ||||
276 | |||||
277 | pod2usage(2); | ||||
278 | |||||
279 | pod2usage(-verbose => 0); | ||||
280 | |||||
281 | pod2usage(-exitval => 2); | ||||
282 | |||||
283 | pod2usage({-exitval => 2, -output => \*STDERR}); | ||||
284 | |||||
285 | pod2usage({-verbose => 0, -output => \*STDERR}); | ||||
286 | |||||
287 | pod2usage(-exitval => 2, -verbose => 0); | ||||
288 | |||||
289 | pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR); | ||||
290 | |||||
291 | Each of the following invocations of C<pod2usage()> will print a message | ||||
292 | of "Syntax error." (followed by a newline) to C<STDERR>, immediately | ||||
293 | followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and | ||||
294 | will exit with a status of 2: | ||||
295 | |||||
296 | pod2usage("Syntax error."); | ||||
297 | |||||
298 | pod2usage(-message => "Syntax error.", -verbose => 0); | ||||
299 | |||||
300 | pod2usage(-msg => "Syntax error.", -exitval => 2); | ||||
301 | |||||
302 | pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR}); | ||||
303 | |||||
304 | pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR}); | ||||
305 | |||||
306 | pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0); | ||||
307 | |||||
308 | pod2usage(-message => "Syntax error.", | ||||
309 | -exitval => 2, | ||||
310 | -verbose => 0, | ||||
311 | -output => \*STDERR); | ||||
312 | |||||
313 | Each of the following invocations of C<pod2usage()> will print the | ||||
314 | "SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to | ||||
315 | C<STDOUT> and will exit with a status of 1: | ||||
316 | |||||
317 | pod2usage(1); | ||||
318 | |||||
319 | pod2usage(-verbose => 1); | ||||
320 | |||||
321 | pod2usage(-exitval => 1); | ||||
322 | |||||
323 | pod2usage({-exitval => 1, -output => \*STDOUT}); | ||||
324 | |||||
325 | pod2usage({-verbose => 1, -output => \*STDOUT}); | ||||
326 | |||||
327 | pod2usage(-exitval => 1, -verbose => 1); | ||||
328 | |||||
329 | pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT}); | ||||
330 | |||||
331 | Each of the following invocations of C<pod2usage()> will print the | ||||
332 | entire manual page to C<STDOUT> and will exit with a status of 1: | ||||
333 | |||||
334 | pod2usage(-verbose => 2); | ||||
335 | |||||
336 | pod2usage({-verbose => 2, -output => \*STDOUT}); | ||||
337 | |||||
338 | pod2usage(-exitval => 1, -verbose => 2); | ||||
339 | |||||
340 | pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT}); | ||||
341 | |||||
342 | =head2 Recommended Use | ||||
343 | |||||
344 | Most scripts should print some type of usage message to C<STDERR> when a | ||||
345 | command line syntax error is detected. They should also provide an | ||||
346 | option (usually C<-H> or C<-help>) to print a (possibly more verbose) | ||||
347 | usage message to C<STDOUT>. Some scripts may even wish to go so far as to | ||||
348 | provide a means of printing their complete documentation to C<STDOUT> | ||||
349 | (perhaps by allowing a C<-man> option). The following complete example | ||||
350 | uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these | ||||
351 | things: | ||||
352 | |||||
353 | use Getopt::Long; | ||||
354 | use Pod::Usage; | ||||
355 | |||||
356 | my $man = 0; | ||||
357 | my $help = 0; | ||||
358 | ## Parse options and print usage if there is a syntax error, | ||||
359 | ## or if usage was explicitly requested. | ||||
360 | GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); | ||||
361 | pod2usage(1) if $help; | ||||
362 | pod2usage(-verbose => 2) if $man; | ||||
363 | |||||
364 | ## If no arguments were given, then allow STDIN to be used only | ||||
365 | ## if it's not connected to a terminal (otherwise print usage) | ||||
366 | pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN)); | ||||
367 | __END__ | ||||
368 | |||||
369 | =head1 NAME | ||||
370 | |||||
371 | sample - Using GetOpt::Long and Pod::Usage | ||||
372 | |||||
373 | =head1 SYNOPSIS | ||||
374 | |||||
375 | sample [options] [file ...] | ||||
376 | |||||
377 | Options: | ||||
378 | -help brief help message | ||||
379 | -man full documentation | ||||
380 | |||||
381 | =head1 OPTIONS | ||||
382 | |||||
383 | =over 8 | ||||
384 | |||||
385 | =item B<-help> | ||||
386 | |||||
387 | Print a brief help message and exits. | ||||
388 | |||||
389 | =item B<-man> | ||||
390 | |||||
391 | Prints the manual page and exits. | ||||
392 | |||||
393 | =back | ||||
394 | |||||
395 | =head1 DESCRIPTION | ||||
396 | |||||
397 | B<This program> will read the given input file(s) and do something | ||||
398 | useful with the contents thereof. | ||||
399 | |||||
400 | =cut | ||||
401 | |||||
402 | =head1 CAVEATS | ||||
403 | |||||
404 | By default, B<pod2usage()> will use C<$0> as the path to the pod input | ||||
405 | file. Unfortunately, not all systems on which Perl runs will set C<$0> | ||||
406 | properly (although if C<$0> isn't found, B<pod2usage()> will search | ||||
407 | C<$ENV{PATH}> or else the list specified by the C<-pathlist> option). | ||||
408 | If this is the case for your system, you may need to explicitly specify | ||||
409 | the path to the pod docs for the invoking script using something | ||||
410 | similar to the following: | ||||
411 | |||||
412 | pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs"); | ||||
413 | |||||
414 | In the pathological case that a script is called via a relative path | ||||
415 | I<and> the script itself changes the current working directory | ||||
416 | (see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will | ||||
417 | fail even on robust platforms. Don't do that. | ||||
418 | |||||
419 | =head1 AUTHOR | ||||
420 | |||||
421 | Please report bugs using L<http://rt.cpan.org>. | ||||
422 | |||||
423 | Marek Rouchal E<lt>marekr@cpan.orgE<gt> | ||||
424 | |||||
425 | Brad Appleton E<lt>bradapp@enteract.comE<gt> | ||||
426 | |||||
427 | Based on code for B<Pod::Text::pod2text()> written by | ||||
428 | Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> | ||||
429 | |||||
430 | =head1 ACKNOWLEDGMENTS | ||||
431 | |||||
432 | Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience | ||||
433 | with re-writing this manpage. | ||||
434 | |||||
435 | =head1 SEE ALSO | ||||
436 | |||||
437 | L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find> | ||||
438 | |||||
439 | =cut | ||||
440 | |||||
441 | ############################################################################# | ||||
442 | |||||
443 | #use diagnostics; | ||||
444 | 2 | 155µs | 2 | 583µs | # spent 323µs (62+260) within Pod::Usage::BEGIN@444 which was called:
# once (62µs+260µs) by main::BEGIN@147 at line 444 # spent 323µs making 1 call to Pod::Usage::BEGIN@444
# spent 260µs making 1 call to Exporter::import |
445 | 2 | 160µs | 2 | 186µs | # spent 120µs (53+67) within Pod::Usage::BEGIN@445 which was called:
# once (53µs+67µs) by main::BEGIN@147 at line 445 # spent 120µs making 1 call to Pod::Usage::BEGIN@445
# spent 67µs making 1 call to Config::import |
446 | 2 | 143µs | 2 | 241µs | # spent 152µs (63+89) within Pod::Usage::BEGIN@446 which was called:
# once (63µs+89µs) by main::BEGIN@147 at line 446 # spent 152µs making 1 call to Pod::Usage::BEGIN@446
# spent 89µs making 1 call to Exporter::import |
447 | 2 | 579µs | 1 | 35µs | # spent 35µs within Pod::Usage::BEGIN@447 which was called:
# once (35µs+0s) by main::BEGIN@147 at line 447 # spent 35µs making 1 call to Pod::Usage::BEGIN@447 |
448 | |||||
449 | 1 | 7µs | @EXPORT = qw(&pod2usage); | ||
450 | # spent 240ms (18.5+222) within Pod::Usage::BEGIN@450 which was called:
# once (18.5ms+222ms) by main::BEGIN@147 at line 459 | ||||
451 | 1 | 43µs | if ( $] >= 5.005_58 ) { | ||
452 | 1 | 578µs | require Pod::Text; | ||
453 | 1 | 76µs | @ISA = qw( Pod::Text ); | ||
454 | } | ||||
455 | else { | ||||
456 | require Pod::PlainText; | ||||
457 | @ISA = qw( Pod::PlainText ); | ||||
458 | } | ||||
459 | 1 | 8.54ms | 1 | 240ms | } # spent 240ms making 1 call to Pod::Usage::BEGIN@450 |
460 | |||||
461 | 1 | 497µs | require Pod::Select; | ||
462 | |||||
463 | ##--------------------------------------------------------------------------- | ||||
464 | |||||
465 | ##--------------------------------- | ||||
466 | ## Function definitions begin here | ||||
467 | ##--------------------------------- | ||||
468 | |||||
469 | sub pod2usage { | ||||
470 | local($_) = shift; | ||||
471 | my %opts; | ||||
472 | ## Collect arguments | ||||
473 | if (@_ > 0) { | ||||
474 | ## Too many arguments - assume that this is a hash and | ||||
475 | ## the user forgot to pass a reference to it. | ||||
476 | %opts = ($_, @_); | ||||
477 | } | ||||
478 | elsif (!defined $_) { | ||||
479 | $_ = ''; | ||||
480 | } | ||||
481 | elsif (ref $_) { | ||||
482 | ## User passed a ref to a hash | ||||
483 | %opts = %{$_} if (ref($_) eq 'HASH'); | ||||
484 | } | ||||
485 | elsif (/^[-+]?\d+$/) { | ||||
486 | ## User passed in the exit value to use | ||||
487 | $opts{'-exitval'} = $_; | ||||
488 | } | ||||
489 | else { | ||||
490 | ## User passed in a message to print before issuing usage. | ||||
491 | $_ and $opts{'-message'} = $_; | ||||
492 | } | ||||
493 | |||||
494 | ## Need this for backward compatibility since we formerly used | ||||
495 | ## options that were all uppercase words rather than ones that | ||||
496 | ## looked like Unix command-line options. | ||||
497 | ## to be uppercase keywords) | ||||
498 | %opts = map { | ||||
499 | my ($key, $val) = ($_, $opts{$_}); | ||||
500 | $key =~ s/^(?=\w)/-/; | ||||
501 | $key =~ /^-msg/i and $key = '-message'; | ||||
502 | $key =~ /^-exit/i and $key = '-exitval'; | ||||
503 | lc($key) => $val; | ||||
504 | } (keys %opts); | ||||
505 | |||||
506 | ## Now determine default -exitval and -verbose values to use | ||||
507 | if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) { | ||||
508 | $opts{'-exitval'} = 2; | ||||
509 | $opts{'-verbose'} = 0; | ||||
510 | } | ||||
511 | elsif (! defined $opts{'-exitval'}) { | ||||
512 | $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2; | ||||
513 | } | ||||
514 | elsif (! defined $opts{'-verbose'}) { | ||||
515 | $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' || | ||||
516 | $opts{'-exitval'} < 2); | ||||
517 | } | ||||
518 | |||||
519 | ## Default the output file | ||||
520 | $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' || | ||||
521 | $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR | ||||
522 | unless (defined $opts{'-output'}); | ||||
523 | ## Default the input file | ||||
524 | $opts{'-input'} = $0 unless (defined $opts{'-input'}); | ||||
525 | |||||
526 | ## Look up input file in path if it doesnt exist. | ||||
527 | unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) { | ||||
528 | my $basename = $opts{'-input'}; | ||||
529 | my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';' | ||||
530 | : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':'); | ||||
531 | my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB}; | ||||
532 | |||||
533 | my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); | ||||
534 | for my $dirname (@paths) { | ||||
535 | $_ = File::Spec->catfile($dirname, $basename) if length; | ||||
536 | last if (-e $_) && ($opts{'-input'} = $_); | ||||
537 | } | ||||
538 | } | ||||
539 | |||||
540 | ## Now create a pod reader and constrain it to the desired sections. | ||||
541 | my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); | ||||
542 | if ($opts{'-verbose'} == 0) { | ||||
543 | $parser->select('(?:SYNOPSIS|USAGE)\s*'); | ||||
544 | } | ||||
545 | elsif ($opts{'-verbose'} == 1) { | ||||
546 | my $opt_re = '(?i)' . | ||||
547 | '(?:OPTIONS|ARGUMENTS)' . | ||||
548 | '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; | ||||
549 | $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" ); | ||||
550 | } | ||||
551 | elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { | ||||
552 | $parser->select('.*'); | ||||
553 | } | ||||
554 | elsif ($opts{'-verbose'} == 99) { | ||||
555 | my $sections = $opts{'-sections'}; | ||||
556 | $parser->select( (ref $sections) ? @$sections : $sections ); | ||||
557 | $opts{'-verbose'} = 1; | ||||
558 | } | ||||
559 | |||||
560 | ## Now translate the pod document and then exit with the desired status | ||||
561 | if ( !$opts{'-noperldoc'} | ||||
562 | and $opts{'-verbose'} >= 2 | ||||
563 | and !ref($opts{'-input'}) | ||||
564 | and $opts{'-output'} == \*STDOUT ) | ||||
565 | { | ||||
566 | ## spit out the entire PODs. Might as well invoke perldoc | ||||
567 | my $progpath = File::Spec->catfile($Config{scriptdir}, 'perldoc'); | ||||
568 | print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'}); | ||||
569 | if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) { | ||||
570 | # the perldocs back to 5.005 should all have -F | ||||
571 | # without -F there are warnings in -T scripts | ||||
572 | system($progpath, '-F', $1); | ||||
573 | if($?) { | ||||
574 | # RT16091: fall back to more if perldoc failed | ||||
575 | system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1); | ||||
576 | } | ||||
577 | } else { | ||||
578 | croak "Unspecified input file or insecure argument.\n"; | ||||
579 | } | ||||
580 | } | ||||
581 | else { | ||||
582 | $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); | ||||
583 | } | ||||
584 | |||||
585 | exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); | ||||
586 | } | ||||
587 | |||||
588 | ##--------------------------------------------------------------------------- | ||||
589 | |||||
590 | ##------------------------------- | ||||
591 | ## Method definitions begin here | ||||
592 | ##------------------------------- | ||||
593 | |||||
594 | sub new { | ||||
595 | my $this = shift; | ||||
596 | my $class = ref($this) || $this; | ||||
597 | my %params = @_; | ||||
598 | my $self = {%params}; | ||||
599 | bless $self, $class; | ||||
600 | if ($self->can('initialize')) { | ||||
601 | $self->initialize(); | ||||
602 | } else { | ||||
603 | $self = $self->SUPER::new(); | ||||
604 | %$self = (%$self, %params); | ||||
605 | } | ||||
606 | return $self; | ||||
607 | } | ||||
608 | |||||
609 | sub select { | ||||
610 | my ($self, @sections) = @_; | ||||
611 | if ($ISA[0]->can('select')) { | ||||
612 | $self->SUPER::select(@sections); | ||||
613 | } else { | ||||
614 | # we're using Pod::Simple - need to mimic the behavior of Pod::Select | ||||
615 | my $add = ($sections[0] eq '+') ? shift(@sections) : ''; | ||||
616 | ## Reset the set of sections to use | ||||
617 | unless (@sections) { | ||||
618 | delete $self->{USAGE_SELECT} unless ($add); | ||||
619 | return; | ||||
620 | } | ||||
621 | $self->{USAGE_SELECT} = [] | ||||
622 | unless ($add && $self->{USAGE_SELECT}); | ||||
623 | my $sref = $self->{USAGE_SELECT}; | ||||
624 | ## Compile each spec | ||||
625 | for my $spec (@sections) { | ||||
626 | my $cs = Pod::Select::_compile_section_spec($spec); | ||||
627 | if ( defined $cs ) { | ||||
628 | ## Store them in our sections array | ||||
629 | push(@$sref, $cs); | ||||
630 | } else { | ||||
631 | carp qq{Ignoring section spec "$spec"!\n}; | ||||
632 | } | ||||
633 | } | ||||
634 | } | ||||
635 | } | ||||
636 | |||||
637 | # Override Pod::Text->seq_i to return just "arg", not "*arg*". | ||||
638 | sub seq_i { return $_[1] } | ||||
639 | |||||
640 | # This overrides the Pod::Text method to do something very akin to what | ||||
641 | # Pod::Select did as well as the work done below by preprocess_paragraph. | ||||
642 | # Note that the below is very, very specific to Pod::Text. | ||||
643 | sub _handle_element_end { | ||||
644 | my ($self, $element) = @_; | ||||
645 | if ($element eq 'head1') { | ||||
646 | $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ]; | ||||
647 | if ($self->{USAGE_OPTIONS}->{-verbose} < 2) { | ||||
648 | $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; | ||||
649 | } | ||||
650 | } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0 | ||||
651 | my $idx = $1 - 1; | ||||
652 | $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS}); | ||||
653 | $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1]; | ||||
654 | } | ||||
655 | if ($element =~ /^head\d+$/) { | ||||
656 | $$self{USAGE_SKIPPING} = 1; | ||||
657 | if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) { | ||||
658 | $$self{USAGE_SKIPPING} = 0; | ||||
659 | } else { | ||||
660 | my @headings = @{$$self{USAGE_HEADINGS}}; | ||||
661 | for my $section_spec ( @{$$self{USAGE_SELECT}} ) { | ||||
662 | my $match = 1; | ||||
663 | for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) { | ||||
664 | $headings[$i] = '' unless defined $headings[$i]; | ||||
665 | my $regex = $section_spec->[$i]; | ||||
666 | my $negated = ($regex =~ s/^\!//); | ||||
667 | $match &= ($negated ? ($headings[$i] !~ /${regex}/) | ||||
668 | : ($headings[$i] =~ /${regex}/)); | ||||
669 | last unless ($match); | ||||
670 | } # end heading levels | ||||
671 | if ($match) { | ||||
672 | $$self{USAGE_SKIPPING} = 0; | ||||
673 | last; | ||||
674 | } | ||||
675 | } # end sections | ||||
676 | } | ||||
677 | |||||
678 | # Try to do some lowercasing instead of all-caps in headings, and use | ||||
679 | # a colon to end all headings. | ||||
680 | if($self->{USAGE_OPTIONS}->{-verbose} < 2) { | ||||
681 | local $_ = $$self{PENDING}[-1][1]; | ||||
682 | s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; | ||||
683 | s/\s*$/:/ unless (/:\s*$/); | ||||
684 | $_ .= "\n"; | ||||
685 | $$self{PENDING}[-1][1] = $_; | ||||
686 | } | ||||
687 | } | ||||
688 | if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) { | ||||
689 | pop @{ $$self{PENDING} }; | ||||
690 | } else { | ||||
691 | $self->SUPER::_handle_element_end($element); | ||||
692 | } | ||||
693 | } | ||||
694 | |||||
695 | # required for Pod::Simple API | ||||
696 | sub start_document { | ||||
697 | my $self = shift; | ||||
698 | $self->SUPER::start_document(); | ||||
699 | my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; | ||||
700 | my $out_fh = $self->output_fh(); | ||||
701 | print $out_fh "$msg\n"; | ||||
702 | } | ||||
703 | |||||
704 | # required for old Pod::Parser API | ||||
705 | sub begin_pod { | ||||
706 | my $self = shift; | ||||
707 | $self->SUPER::begin_pod(); ## Have to call superclass | ||||
708 | my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; | ||||
709 | my $out_fh = $self->output_handle(); | ||||
710 | print $out_fh "$msg\n"; | ||||
711 | } | ||||
712 | |||||
713 | sub preprocess_paragraph { | ||||
714 | my $self = shift; | ||||
715 | local $_ = shift; | ||||
716 | my $line = shift; | ||||
717 | ## See if this is a heading and we arent printing the entire manpage. | ||||
718 | if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { | ||||
719 | ## Change the title of the SYNOPSIS section to USAGE | ||||
720 | s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/; | ||||
721 | ## Try to do some lowercasing instead of all-caps in headings | ||||
722 | s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; | ||||
723 | ## Use a colon to end all headings | ||||
724 | s/\s*$/:/ unless (/:\s*$/); | ||||
725 | $_ .= "\n"; | ||||
726 | } | ||||
727 | return $self->SUPER::preprocess_paragraph($_); | ||||
728 | } | ||||
729 | |||||
730 | 1 | 20µs | 1; # keep require happy |