Commit | Line | Data |
360aca43 |
1 | ############################################################################# |
2 | # Pod/Usage.pm -- print usage messages for the running script. |
3 | # |
66aff6dd |
4 | # Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. |
360aca43 |
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; |
1bc4b319 |
11 | use strict; |
360aca43 |
12 | |
1bc4b319 |
13 | use vars qw($VERSION @ISA @EXPORT); |
14 | $VERSION = '1.36'; ## Current version of this package |
828c4421 |
15 | require 5.005; ## requires this Perl version or later |
360aca43 |
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 | |
7b47f8ec |
44 | pod2usage( -verbose => 2, |
45 | -noperldoc => 1 ) |
46 | |
360aca43 |
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 | |
92e3d63a |
53 | =over 4 |
360aca43 |
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 | |
92e3d63a |
75 | =over 4 |
360aca43 |
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. |
39a52d2c |
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. |
360aca43 |
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 | |
bd4d8faa |
100 | The special verbosity level 99 requires to also specify the -sections |
7b47f8ec |
101 | parameter; then these sections are extracted (see L<Pod::Select>) |
102 | and printed. |
d5c61f7c |
103 | |
bd4d8faa |
104 | =item C<-sections> |
d5c61f7c |
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 | |
1bc4b319 |
109 | Alternatively, an array reference of section specifications can be used: |
110 | |
111 | pod2usage(-verbose => 99, |
112 | -sections => [ qw(fred fred/subsection) ] ); |
113 | |
360aca43 |
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 | |
1bc4b319 |
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 | |
360aca43 |
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 | |
7b47f8ec |
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 | |
360aca43 |
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 | |
92e3d63a |
167 | =over 4 |
360aca43 |
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 | |
92e3d63a |
197 | =over 4 |
360aca43 |
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 |
267d5541 |
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 |
360aca43 |
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 | |
92e3d63a |
249 | Some user's however may feel that the above "economy of expression" is |
360aca43 |
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> |
f48e6a7e |
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 |
360aca43 |
351 | things: |
352 | |
353 | use Getopt::Long; |
354 | use Pod::Usage; |
355 | |
f48e6a7e |
356 | my $man = 0; |
357 | my $help = 0; |
360aca43 |
358 | ## Parse options and print usage if there is a syntax error, |
359 | ## or if usage was explicitly requested. |
f48e6a7e |
360 | GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); |
361 | pod2usage(1) if $help; |
362 | pod2usage(-verbose => 2) if $man; |
360aca43 |
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)); |
f48e6a7e |
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 |
360aca43 |
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 | |
7b47f8ec |
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 | |
360aca43 |
419 | =head1 AUTHOR |
420 | |
aaa799f9 |
421 | Please report bugs using L<http://rt.cpan.org>. |
422 | |
1bc4b319 |
423 | Marek Rouchal E<lt>marekr@cpan.orgE<gt> |
424 | |
360aca43 |
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 | |
267d5541 |
430 | =head1 ACKNOWLEDGMENTS |
360aca43 |
431 | |
432 | Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience |
433 | with re-writing this manpage. |
434 | |
1bc4b319 |
435 | =head1 SEE ALSO |
436 | |
437 | L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find> |
438 | |
360aca43 |
439 | =cut |
440 | |
441 | ############################################################################# |
442 | |
360aca43 |
443 | #use diagnostics; |
444 | use Carp; |
39a52d2c |
445 | use Config; |
360aca43 |
446 | use Exporter; |
360aca43 |
447 | use File::Spec; |
448 | |
360aca43 |
449 | @EXPORT = qw(&pod2usage); |
664bb207 |
450 | BEGIN { |
451 | if ( $] >= 5.005_58 ) { |
452 | require Pod::Text; |
453 | @ISA = qw( Pod::Text ); |
454 | } |
455 | else { |
456 | require Pod::PlainText; |
457 | @ISA = qw( Pod::PlainText ); |
458 | } |
459 | } |
460 | |
1bc4b319 |
461 | require Pod::Select; |
360aca43 |
462 | |
463 | ##--------------------------------------------------------------------------- |
464 | |
465 | ##--------------------------------- |
466 | ## Function definitions begin here |
467 | ##--------------------------------- |
468 | |
469 | sub pod2usage { |
7b47f8ec |
470 | local($_) = shift; |
360aca43 |
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 | } |
7b47f8ec |
478 | elsif (!defined $_) { |
1bc4b319 |
479 | $_ = ''; |
7b47f8ec |
480 | } |
360aca43 |
481 | elsif (ref $_) { |
482 | ## User passed a ref to a hash |
483 | %opts = %{$_} if (ref($_) eq 'HASH'); |
484 | } |
e9fdc7d2 |
485 | elsif (/^[-+]?\d+$/) { |
360aca43 |
486 | ## User passed in the exit value to use |
1bc4b319 |
487 | $opts{'-exitval'} = $_; |
360aca43 |
488 | } |
489 | else { |
490 | ## User passed in a message to print before issuing usage. |
1bc4b319 |
491 | $_ and $opts{'-message'} = $_; |
360aca43 |
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 { |
1bc4b319 |
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; |
360aca43 |
504 | } (keys %opts); |
505 | |
506 | ## Now determine default -exitval and -verbose values to use |
1bc4b319 |
507 | if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) { |
508 | $opts{'-exitval'} = 2; |
509 | $opts{'-verbose'} = 0; |
360aca43 |
510 | } |
1bc4b319 |
511 | elsif (! defined $opts{'-exitval'}) { |
512 | $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2; |
360aca43 |
513 | } |
1bc4b319 |
514 | elsif (! defined $opts{'-verbose'}) { |
515 | $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' || |
516 | $opts{'-exitval'} < 2); |
360aca43 |
517 | } |
518 | |
519 | ## Default the output file |
1bc4b319 |
520 | $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' || |
521 | $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR |
522 | unless (defined $opts{'-output'}); |
360aca43 |
523 | ## Default the input file |
1bc4b319 |
524 | $opts{'-input'} = $0 unless (defined $opts{'-input'}); |
360aca43 |
525 | |
526 | ## Look up input file in path if it doesnt exist. |
1bc4b319 |
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}; |
360aca43 |
532 | |
533 | my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); |
1bc4b319 |
534 | for my $dirname (@paths) { |
360aca43 |
535 | $_ = File::Spec->catfile($dirname, $basename) if length; |
1bc4b319 |
536 | last if (-e $_) && ($opts{'-input'} = $_); |
360aca43 |
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); |
1bc4b319 |
542 | if ($opts{'-verbose'} == 0) { |
543 | $parser->select('(?:SYNOPSIS|USAGE)\s*'); |
360aca43 |
544 | } |
1bc4b319 |
545 | elsif ($opts{'-verbose'} == 1) { |
360aca43 |
546 | my $opt_re = '(?i)' . |
547 | '(?:OPTIONS|ARGUMENTS)' . |
548 | '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; |
1bc4b319 |
549 | $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" ); |
360aca43 |
550 | } |
1bc4b319 |
551 | elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { |
7eb7d786 |
552 | $parser->select('.*'); |
553 | } |
1bc4b319 |
554 | elsif ($opts{'-verbose'} == 99) { |
555 | my $sections = $opts{'-sections'}; |
556 | $parser->select( (ref $sections) ? @$sections : $sections ); |
557 | $opts{'-verbose'} = 1; |
d5c61f7c |
558 | } |
360aca43 |
559 | |
560 | ## Now translate the pod document and then exit with the desired status |
1bc4b319 |
561 | if ( !$opts{'-noperldoc'} |
562 | and $opts{'-verbose'} >= 2 |
563 | and !ref($opts{'-input'}) |
564 | and $opts{'-output'} == \*STDOUT ) |
39a52d2c |
565 | { |
566 | ## spit out the entire PODs. Might as well invoke perldoc |
1bc4b319 |
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"; |
267d5541 |
579 | } |
39a52d2c |
580 | } |
581 | else { |
1bc4b319 |
582 | $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); |
39a52d2c |
583 | } |
584 | |
1bc4b319 |
585 | exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); |
360aca43 |
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; |
d5c61f7c |
600 | if ($self->can('initialize')) { |
601 | $self->initialize(); |
602 | } else { |
603 | $self = $self->SUPER::new(); |
604 | %$self = (%$self, %params); |
605 | } |
360aca43 |
606 | return $self; |
607 | } |
608 | |
d5c61f7c |
609 | sub select { |
1bc4b319 |
610 | my ($self, @sections) = @_; |
d5c61f7c |
611 | if ($ISA[0]->can('select')) { |
1bc4b319 |
612 | $self->SUPER::select(@sections); |
d5c61f7c |
613 | } else { |
1bc4b319 |
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 | } |
d5c61f7c |
634 | } |
635 | } |
636 | |
7b47f8ec |
637 | # Override Pod::Text->seq_i to return just "arg", not "*arg*". |
638 | sub seq_i { return $_[1] } |
639 | |
d5c61f7c |
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) = @_; |
ce6e48f3 |
645 | if ($element eq 'head1') { |
1bc4b319 |
646 | $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ]; |
ce6e48f3 |
647 | if ($self->{USAGE_OPTIONS}->{-verbose} < 2) { |
648 | $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; |
649 | } |
1bc4b319 |
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]; |
d5c61f7c |
654 | } |
1bc4b319 |
655 | if ($element =~ /^head\d+$/) { |
d5c61f7c |
656 | $$self{USAGE_SKIPPING} = 1; |
210ccf0a |
657 | if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) { |
1bc4b319 |
658 | $$self{USAGE_SKIPPING} = 0; |
210ccf0a |
659 | } else { |
1bc4b319 |
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) { |
210ccf0a |
672 | $$self{USAGE_SKIPPING} = 0; |
673 | last; |
1bc4b319 |
674 | } |
675 | } # end sections |
d5c61f7c |
676 | } |
677 | |
678 | # Try to do some lowercasing instead of all-caps in headings, and use |
679 | # a colon to end all headings. |
7eb7d786 |
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 | } |
d5c61f7c |
687 | } |
1bc4b319 |
688 | if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) { |
d5c61f7c |
689 | pop @{ $$self{PENDING} }; |
690 | } else { |
691 | $self->SUPER::_handle_element_end($element); |
692 | } |
693 | } |
694 | |
1bc4b319 |
695 | # required for Pod::Simple API |
d5c61f7c |
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 | |
1bc4b319 |
704 | # required for old Pod::Parser API |
360aca43 |
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. |
e9fdc7d2 |
718 | if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { |
360aca43 |
719 | ## Change the title of the SYNOPSIS section to USAGE |
e9fdc7d2 |
720 | s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/; |
360aca43 |
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 |
e9fdc7d2 |
724 | s/\s*$/:/ unless (/:\s*$/); |
360aca43 |
725 | $_ .= "\n"; |
726 | } |
727 | return $self->SUPER::preprocess_paragraph($_); |
728 | } |
729 | |
8abb48c2 |
730 | 1; # keep require happy |