| 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>bradapp@enteract.comE<gt> |
| 412 | |
| 413 | Based on code for B<Pod::Text::pod2text()> written by |
| 414 | Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> |
| 415 | |
| 416 | =head1 ACKNOWLEDGEMENTS |
| 417 | |
| 418 | Steven McDougall E<lt>swmcd@world.std.comE<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 |