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