diff options
author | Steve Hay <SteveHay@planit.com> | 2009-01-30 10:27:25 +0000 |
---|---|---|
committer | Steve Hay <SteveHay@planit.com> | 2009-01-30 10:27:25 +0000 |
commit | 1bc4b319ba6d50bfdf5332d4378c85af1205184b (patch) | |
tree | 7252397d3d1ef704642a76b9b935ddb12fc427dd /lib/Pod | |
parent | dc3c30404e1546ebc4bd89fa72dfcd44bcd246ee (diff) | |
download | perl-1bc4b319ba6d50bfdf5332d4378c85af1205184b.tar.gz |
Upgrade to Pod-Parser-1.36.
Three local changes remain in blead:
Blank lines "between" verbatim sections are now acceptible:
http://perl5.git.perl.org/perl.git/commitdiff/caa547d
Be less picky about what constitutes "numeric lists" in Pod:
http://perl5.git.perl.org/perl.git/commitdiff/4df4f5d
Changes made to contains_pod.t when upgrading to 1.34:
http://perl5.git.perl.org/perl.git/commitdiff/fb59f97
Diffstat (limited to 'lib/Pod')
-rw-r--r-- | lib/Pod/Checker.pm | 285 | ||||
-rw-r--r-- | lib/Pod/Find.pm | 72 | ||||
-rw-r--r-- | lib/Pod/InputObjects.pm | 25 | ||||
-rw-r--r-- | lib/Pod/ParseUtils.pm | 65 | ||||
-rw-r--r-- | lib/Pod/Parser.pm | 66 | ||||
-rw-r--r-- | lib/Pod/PlainText.pm | 69 | ||||
-rw-r--r-- | lib/Pod/Select.pm | 64 | ||||
-rw-r--r-- | lib/Pod/Usage.pm | 186 | ||||
-rw-r--r-- | lib/Pod/t/contains_pod.t | 6 |
9 files changed, 460 insertions, 378 deletions
diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index 5c301b6de6..deac5ded2b 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -8,9 +8,10 @@ ############################################################################# package Pod::Checker; +use strict; -use vars qw($VERSION); -$VERSION = "1.43_01"; ## Current version of this package +use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES); +$VERSION = '1.44_01'; ## Current version of this package require 5.005; ## requires this Perl version or later use Pod::ParseUtils; ## for hyperlinks and lists @@ -77,7 +78,7 @@ Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>. =item * -Check for same nested interior-sequences (e.g. +Check for same nested interior-sequences (e.g. C<LE<lt>...LE<lt>...E<gt>...E<gt>>). =item * @@ -154,8 +155,8 @@ C<=for>, C<=pod>, C<=cut> =item * Unknown interior-sequence "I<SEQ>" An invalid markup command has been encountered. Valid are: -C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>, -C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>, +C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>, +C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>, C<ZE<lt>E<gt>> =item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt> @@ -264,7 +265,7 @@ definition list. =item * empty section in previous paragraph The previous section (introduced by a C<=head> command) does not contain -any text. This usually indicates that something is missing. Note: A +any text. This usually indicates that something is missing. Note: A C<=head1> followed immediately by C<=head2> does not trigger this warning. =item * Verbatim paragraph in NAME section @@ -288,7 +289,7 @@ There are some warnings with respect to malformed hyperlinks: =item * ignoring leading/trailing whitespace in link -There is whitespace at the beginning or the end of the contents of +There is whitespace at the beginning or the end of the contents of LE<lt>...E<gt>. =item * (section) in '$page' deprecated @@ -329,7 +330,7 @@ a first pass before actually starting to convert. This is expensive in terms of execution time, but allows for very robust conversions. Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror> -method to print errors and warnings. The summary output (e.g. +method to print errors and warnings. The summary output (e.g. "Pod syntax OK") has been dropped from the module and has been included in B<podchecker> (the script). This allows users of B<Pod::Checker> to control completely the output behavior. Users of B<podchecker> (the script) @@ -339,18 +340,14 @@ get the well-known behavior. ############################################################################# -use strict; #use diagnostics; -use Carp; +use Carp qw(croak); use Exporter; use Pod::Parser; -use vars qw(@ISA @EXPORT); @ISA = qw(Pod::Parser); @EXPORT = qw(&podchecker); -use vars qw(%VALID_COMMANDS %VALID_SEQUENCES); - my %VALID_COMMANDS = ( 'pod' => 1, 'cut' => 1, @@ -364,7 +361,7 @@ my %VALID_COMMANDS = ( 'for' => 1, 'begin' => 1, 'end' => 1, - 'encoding' => '1', + 'encoding' => 1, ); my %VALID_SEQUENCES = ( @@ -382,74 +379,74 @@ my %VALID_SEQUENCES = ( # stolen from HTML::Entities my %ENTITIES = ( # Some normal chars that have special meaning in SGML context - amp => '&', # ampersand + amp => '&', # ampersand 'gt' => '>', # greater than 'lt' => '<', # less than quot => '"', # double quote # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML - AElig => 'Æ', # capital AE diphthong (ligature) - Aacute => 'Á', # capital A, acute accent - Acirc => 'Â', # capital A, circumflex accent - Agrave => 'À', # capital A, grave accent - Aring => 'Å', # capital A, ring - Atilde => 'Ã', # capital A, tilde - Auml => 'Ä', # capital A, dieresis or umlaut mark - Ccedil => 'Ç', # capital C, cedilla - ETH => 'Ð', # capital Eth, Icelandic - Eacute => 'É', # capital E, acute accent - Ecirc => 'Ê', # capital E, circumflex accent - Egrave => 'È', # capital E, grave accent - Euml => 'Ë', # capital E, dieresis or umlaut mark - Iacute => 'Í', # capital I, acute accent - Icirc => 'Î', # capital I, circumflex accent - Igrave => 'Ì', # capital I, grave accent - Iuml => 'Ï', # capital I, dieresis or umlaut mark - Ntilde => 'Ñ', # capital N, tilde - Oacute => 'Ó', # capital O, acute accent - Ocirc => 'Ô', # capital O, circumflex accent - Ograve => 'Ò', # capital O, grave accent - Oslash => 'Ø', # capital O, slash - Otilde => 'Õ', # capital O, tilde - Ouml => 'Ö', # capital O, dieresis or umlaut mark - THORN => 'Þ', # capital THORN, Icelandic - Uacute => 'Ú', # capital U, acute accent - Ucirc => 'Û', # capital U, circumflex accent - Ugrave => 'Ù', # capital U, grave accent - Uuml => 'Ü', # capital U, dieresis or umlaut mark - Yacute => 'Ý', # capital Y, acute accent - aacute => 'á', # small a, acute accent - acirc => 'â', # small a, circumflex accent - aelig => 'æ', # small ae diphthong (ligature) - agrave => 'à', # small a, grave accent - aring => 'å', # small a, ring - atilde => 'ã', # small a, tilde - auml => 'ä', # small a, dieresis or umlaut mark - ccedil => 'ç', # small c, cedilla - eacute => 'é', # small e, acute accent - ecirc => 'ê', # small e, circumflex accent - egrave => 'è', # small e, grave accent - eth => 'ð', # small eth, Icelandic - euml => 'ë', # small e, dieresis or umlaut mark - iacute => 'í', # small i, acute accent - icirc => 'î', # small i, circumflex accent - igrave => 'ì', # small i, grave accent - iuml => 'ï', # small i, dieresis or umlaut mark - ntilde => 'ñ', # small n, tilde - oacute => 'ó', # small o, acute accent - ocirc => 'ô', # small o, circumflex accent - ograve => 'ò', # small o, grave accent - oslash => 'ø', # small o, slash - otilde => 'õ', # small o, tilde - ouml => 'ö', # small o, dieresis or umlaut mark - szlig => 'ß', # small sharp s, German (sz ligature) - thorn => 'þ', # small thorn, Icelandic - uacute => 'ú', # small u, acute accent - ucirc => 'û', # small u, circumflex accent - ugrave => 'ù', # small u, grave accent - uuml => 'ü', # small u, dieresis or umlaut mark - yacute => 'ý', # small y, acute accent - yuml => 'ÿ', # small y, dieresis or umlaut mark + AElig => 'Æ', # capital AE diphthong (ligature) + Aacute => 'Á', # capital A, acute accent + Acirc => 'Â', # capital A, circumflex accent + Agrave => 'À', # capital A, grave accent + Aring => 'Å', # capital A, ring + Atilde => 'Ã', # capital A, tilde + Auml => 'Ä', # capital A, dieresis or umlaut mark + Ccedil => 'Ç', # capital C, cedilla + ETH => 'Ð', # capital Eth, Icelandic + Eacute => 'É', # capital E, acute accent + Ecirc => 'Ê', # capital E, circumflex accent + Egrave => 'È', # capital E, grave accent + Euml => 'Ë', # capital E, dieresis or umlaut mark + Iacute => 'Í', # capital I, acute accent + Icirc => 'Î', # capital I, circumflex accent + Igrave => 'Ì', # capital I, grave accent + Iuml => 'Ï', # capital I, dieresis or umlaut mark + Ntilde => 'Ñ', # capital N, tilde + Oacute => 'Ó', # capital O, acute accent + Ocirc => 'Ô', # capital O, circumflex accent + Ograve => 'Ò', # capital O, grave accent + Oslash => 'Ø', # capital O, slash + Otilde => 'Õ', # capital O, tilde + Ouml => 'Ö', # capital O, dieresis or umlaut mark + THORN => 'Þ', # capital THORN, Icelandic + Uacute => 'Ú', # capital U, acute accent + Ucirc => 'Û', # capital U, circumflex accent + Ugrave => 'Ù', # capital U, grave accent + Uuml => 'Ü', # capital U, dieresis or umlaut mark + Yacute => 'Ý', # capital Y, acute accent + aacute => 'á', # small a, acute accent + acirc => 'â', # small a, circumflex accent + aelig => 'æ', # small ae diphthong (ligature) + agrave => 'à', # small a, grave accent + aring => 'å', # small a, ring + atilde => 'ã', # small a, tilde + auml => 'ä', # small a, dieresis or umlaut mark + ccedil => 'ç', # small c, cedilla + eacute => 'é', # small e, acute accent + ecirc => 'ê', # small e, circumflex accent + egrave => 'è', # small e, grave accent + eth => 'ð', # small eth, Icelandic + euml => 'ë', # small e, dieresis or umlaut mark + iacute => 'í', # small i, acute accent + icirc => 'î', # small i, circumflex accent + igrave => 'ì', # small i, grave accent + iuml => 'ï', # small i, dieresis or umlaut mark + ntilde => 'ñ', # small n, tilde + oacute => 'ó', # small o, acute accent + ocirc => 'ô', # small o, circumflex accent + ograve => 'ò', # small o, grave accent + oslash => 'ø', # small o, slash + otilde => 'õ', # small o, tilde + ouml => 'ö', # small o, dieresis or umlaut mark + szlig => 'ß', # small sharp s, German (sz ligature) + thorn => 'þ', # small thorn, Icelandic + uacute => 'ú', # small u, acute accent + ucirc => 'û', # small u, circumflex accent + ugrave => 'ù', # small u, grave accent + uuml => 'ü', # small u, dieresis or umlaut mark + yacute => 'ý', # small y, acute accent + yuml => 'ÿ', # small y, dieresis or umlaut mark # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) copy => '©', # copyright sign @@ -500,7 +497,7 @@ my %ENTITIES = ( ## Function definitions begin here ##--------------------------------- -sub podchecker( $ ; $ % ) { +sub podchecker { my ($infile, $outfile, %options) = @_; local $_; @@ -610,17 +607,17 @@ sub poderror { my %opts = (ref $_[0]) ? %{shift()} : (); ## Retrieve options - chomp( my $msg = ($opts{-msg} || "")."@_" ); - my $line = (exists $opts{-line}) ? " at line $opts{-line}" : ""; - my $file = (exists $opts{-file}) ? " in file $opts{-file}" : ""; + chomp( my $msg = ($opts{-msg} || '')."@_" ); + my $line = (exists $opts{-line}) ? " at line $opts{-line}" : ''; + my $file = (exists $opts{-file}) ? " in file $opts{-file}" : ''; unless (exists $opts{-severity}) { ## See if can find severity in message prefix $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// ); } - my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : ""; + my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : ''; ## Increment error count and print message " - ++($self->{_NUM_ERRORS}) + ++($self->{_NUM_ERRORS}) if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR')); ++($self->{_NUM_WARNINGS}) if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING')); @@ -666,7 +663,7 @@ found in the C<=head1 NAME> section. sub name { return (@_ > 1 && $_[1]) ? - ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; + ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; } ################################## @@ -754,8 +751,8 @@ sub end_pod { while(($list = $self->_close_list('EOF',$infile)) && $list->indent() ne 'auto') { $self->poderror({ -line => 'EOF', -file => $infile, - -severity => 'ERROR', -msg => "=over on line " . - $list->start() . " without closing =back" }); #" + -severity => 'ERROR', -msg => '=over on line ' . + $list->start() . ' without closing =back' }); } } @@ -804,7 +801,7 @@ sub end_pod { } # check a POD command directive -sub command { +sub command { my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_; my ($file, $line) = $pod_para->file_line; ## Check the command syntax @@ -819,7 +816,7 @@ sub command { ##### following check disabled due to strong request #if(!$self->{_commands}++ && $cmd !~ /^head/) { # $self->poderror({ -line => $line, -file => $file, - # -severity => 'WARNING', + # -severity => 'WARNING', # -msg => "file does not start with =head" }); #} @@ -838,8 +835,8 @@ sub command { # are we in a list? unless(@{$self->{_list_stack}}) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "=item without previous =over" }); + -severity => 'ERROR', + -msg => '=item without previous =over' }); # auto-open in case we encounter many more $self->_open_list('auto',$line,$file); } @@ -848,13 +845,13 @@ sub command { if(defined $self->{_list_item_contents} && $self->{_list_item_contents} == 0) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "previous =item has no contents" }); + -severity => 'WARNING', + -msg => 'previous =item has no contents' }); } if($list->{_has_par}) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "preceding non-item paragraph(s)" }); + -severity => 'WARNING', + -msg => 'preceding non-item paragraph(s)' }); delete $list->{_has_par}; } # check for argument @@ -879,7 +876,7 @@ sub command { my $first = $list->type(); if($first && $first ne $type) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -severity => 'WARNING', -msg => "=item type mismatch ('$first' vs. '$type')"}); } else { # first item @@ -888,9 +885,9 @@ sub command { } else { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "No argument for =item" }); - $arg = ' '; # empty + -severity => 'WARNING', + -msg => 'No argument for =item' }); + $arg = ' '; # empty $self->{_list_item_contents} = 0; } # add this item @@ -902,34 +899,34 @@ sub command { # check if we have an open list unless(@{$self->{_list_stack}}) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "=back without previous =over" }); + -severity => 'ERROR', + -msg => '=back without previous =over' }); } else { # check for spurious characters $arg = $self->interpolate_and_check($paragraph, $line,$file); if($arg && $arg =~ /\S/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Spurious character(s) after =back" }); + -severity => 'ERROR', + -msg => 'Spurious character(s) after =back' }); } # close list my $list = $self->_close_list($line,$file); # check for empty lists if(!$list->item() && $self->{-warnings}) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "No items in =over (at line " . - $list->start() . ") / =back list"}); #" + -severity => 'WARNING', + -msg => 'No items in =over (at line ' . + $list->start() . ') / =back list'}); } } } elsif($cmd =~ /^head(\d+)/) { my $hnum = $1; $self->{"_have_head_$hnum"}++; # count head types - if($hnum > 1 && !$self->{"_have_head_".($hnum -1)}) { + if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -severity => 'WARNING', -msg => "=head$hnum without preceding higher level"}); } # check whether the previous =head section had some contents @@ -938,8 +935,8 @@ sub command { defined $self->{_last_head} && $self->{_last_head} >= $hnum) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "empty section in previous paragraph"}); + -severity => 'WARNING', + -msg => 'empty section in previous paragraph'}); } $self->{_commands_in_head} = -1; $self->{_last_head} = $hnum; @@ -949,8 +946,8 @@ sub command { while(($list = $self->_close_list($line,$file)) && $list->indent() ne 'auto') { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "=over on line ". $list->start() . + -severity => 'ERROR', + -msg => '=over on line '. $list->start() . " without closing =back (at $cmd)" }); } } @@ -960,7 +957,7 @@ sub command { $self->node($arg); unless(length($arg)) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', + -severity => 'ERROR', -msg => "empty =$cmd"}); } if($cmd eq 'head1') { @@ -973,17 +970,17 @@ sub command { if($self->{_have_begin}) { # already have a begin $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Nested =begin's (first at line " . - $self->{_have_begin} . ")"}); + -severity => 'ERROR', + -msg => q{Nested =begin's (first at line } . + $self->{_have_begin} . ')'}); } else { # check for argument $arg = $self->interpolate_and_check($paragraph, $line,$file); unless($arg && $arg =~ /(\S+)/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "No argument for =begin"}); + -severity => 'ERROR', + -msg => 'No argument for =begin'}); } # remember the =begin $self->{_have_begin} = "$line:$1"; @@ -998,22 +995,22 @@ sub command { # the closing argument is optional #if($arg && $arg =~ /\S/) { # $self->poderror({ -line => $line, -file => $file, - # -severity => 'WARNING', + # -severity => 'WARNING', # -msg => "Spurious character(s) after =end" }); #} } else { # don't have a matching =begin $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "=end without =begin" }); + -severity => 'ERROR', + -msg => '=end without =begin' }); } } elsif($cmd eq 'for') { unless($paragraph =~ /\s*(\S+)\s*/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "=for without formatter specification" }); + -severity => 'ERROR', + -msg => '=for without formatter specification' }); } $arg = ''; # do not expand paragraph below } @@ -1022,7 +1019,7 @@ sub command { $arg = $self->interpolate_and_check($paragraph, $line,$file); if($arg && $arg =~ /(\S+)/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', + -severity => 'ERROR', -msg => "Spurious text after =$cmd"}); } } @@ -1052,8 +1049,8 @@ sub _close_list if(defined $self->{_list_item_contents} && $self->{_list_item_contents} == 0) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "previous =item has no contents" }); + -severity => 'WARNING', + -msg => 'previous =item has no contents' }); } undef $self->{_list_item_contents}; $list; @@ -1082,7 +1079,7 @@ sub _check_ptree { my $count; if($count = tr/<>/<>/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -severity => 'WARNING', -msg => "$count unescaped <> in paragraph" }); } } @@ -1096,7 +1093,7 @@ sub _check_ptree { # check for valid tag if (! $VALID_SEQUENCES{$cmd}) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', + -severity => 'ERROR', -msg => qq(Unknown interior-sequence '$cmd')}); # expand it anyway $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); @@ -1104,7 +1101,7 @@ sub _check_ptree { } if($nestlist =~ /$cmd/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -severity => 'WARNING', -msg => "nested commands $cmd<...$cmd<...>...>"}); # _TODO_ should we add the contents anyway? # expand it anyway, see below @@ -1113,8 +1110,8 @@ sub _check_ptree { # preserve entities if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "garbled entity " . $_->raw_text()}); + -severity => 'ERROR', + -msg => 'garbled entity ' . $_->raw_text()}); next; } my $ent = $$contents[0]; @@ -1137,8 +1134,8 @@ sub _check_ptree { } else { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Entity number out of range " . $_->raw_text()}); + -severity => 'ERROR', + -msg => 'Entity number out of range ' . $_->raw_text()}); } } elsif($ENTITIES{$ent}) { @@ -1147,8 +1144,8 @@ sub _check_ptree { } else { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "Unknown entity " . $_->raw_text()}); + -severity => 'WARNING', + -msg => 'Unknown entity ' . $_->raw_text()}); $text .= "E<$ent>"; } } @@ -1157,15 +1154,15 @@ sub _check_ptree { my $link = Pod::Hyperlink->new($contents->raw_text()); unless(defined $link) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "malformed link " . $_->raw_text() ." : $@"}); + -severity => 'ERROR', + -msg => 'malformed link ' . $_->raw_text() ." : $@"}); next; } $link->line($line); # remember line if($self->{-warnings}) { foreach my $w ($link->warning()) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -severity => 'WARNING', -msg => $w }); } } @@ -1182,16 +1179,16 @@ sub _check_ptree { elsif($cmd eq 'Z') { if(length($contents->raw_text())) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Nonempty Z<>"}); + -severity => 'ERROR', + -msg => 'Nonempty Z<>'}); } } elsif($cmd eq 'X') { my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); if($idx =~ /^\s*$/s) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', - -msg => "Empty X<>"}); + -severity => 'ERROR', + -msg => 'Empty X<>'}); } else { # remember this node @@ -1200,14 +1197,14 @@ sub _check_ptree { } else { # not reached - die "internal error"; + croak 'internal error'; } } $text; } # process a block of verbatim text -sub verbatim { +sub verbatim { ## Nothing particular to check my ($self, $paragraph, $line_num, $pod_para) = @_; @@ -1222,7 +1219,7 @@ sub verbatim { } # process a block of regular text -sub textblock { +sub textblock { my ($self, $paragraph, $line_num, $pod_para) = @_; my ($file, $line) = $pod_para->file_line; diff --git a/lib/Pod/Find.pm b/lib/Pod/Find.pm index 0b085b8c9e..8d1103b6a1 100644 --- a/lib/Pod/Find.pm +++ b/lib/Pod/Find.pm @@ -11,12 +11,20 @@ ############################################################################# package Pod::Find; +use strict; use vars qw($VERSION); -$VERSION = 1.34; ## Current version of this package +$VERSION = '1.35'; ## Current version of this package require 5.005; ## requires this Perl version or later use Carp; +BEGIN { + if ($] < 5.006) { + require Symbol; + import Symbol; + } +} + ############################################################################# =head1 NAME @@ -48,7 +56,6 @@ files/directories like RCS, CVS, SCCS, .svn are ignored. =cut -use strict; #use diagnostics; use Exporter; use File::Spec; @@ -108,7 +115,7 @@ B<scriptdir>. This is taken from the local L<Config|Config> module. Search for PODs in the current Perl interpreter's I<@INC> paths. This automatically considers paths specified in the C<PERL5LIB> environment -as this is prepended to I<@INC> by the Perl interpreter itself. +as this is included in I<@INC> by the Perl interpreter itself. =back @@ -143,10 +150,10 @@ sub pod_find for (@new_INC) { if ( $_ eq '.' ) { $_ = ':'; - } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) { + } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { $_ = ':'. $_; } else { - $_ =~ s|^\./|:|; + $_ =~ s{^\./}{:}; } } push(@search, grep($_ ne File::Spec->curdir, @new_INC)); @@ -230,20 +237,20 @@ sub pod_find }, $try); # end of File::Find::find } chdir $pwd; - %pods; + return %pods; } sub _check_for_duplicates { my ($file, $name, $names_ref, $pods_ref) = @_; if($$names_ref{$name}) { warn "Duplicate POD found (shadowing?): $name ($file)\n"; - warn " Already seen in ", + warn ' Already seen in ', join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; } else { $$names_ref{$name} = 1; } - $$pods_ref{$file} = $name; + return $$pods_ref{$file} = $name; } sub _check_and_extract_name { @@ -252,33 +259,33 @@ sub _check_and_extract_name { # check extension or executable flag # this involves testing the .bat extension on Win32! unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) { - return undef; + return; } - return undef unless contains_pod($file,$verbose); + return unless contains_pod($file,$verbose); # strip non-significant path components # TODO what happens on e.g. Win32? my $name = $file; if(defined $root_rx) { - $name =~ s!$root_rx!!s; - $name =~ s!$SIMPLIFY_RX!!os if(defined $SIMPLIFY_RX); + $name =~ s/$root_rx//s; + $name =~ s/$SIMPLIFY_RX//s if(defined $SIMPLIFY_RX); } else { if ($^O eq 'MacOS') { $name =~ s/^.*://s; } else { - $name =~ s:^.*/::s; + $name =~ s{^.*/}{}s; } } _simplify($name); - $name =~ s!/+!::!g; #/ + $name =~ s{/+}{::}g; if ($^O eq 'MacOS') { - $name =~ s!:+!::!g; # : -> :: + $name =~ s{:+}{::}g; # : -> :: } else { - $name =~ s!/+!::!g; # / -> :: + $name =~ s{/+}{::}g; # / -> :: } - $name; + return $name; } =head2 C<simplify_name( $str )> @@ -297,10 +304,10 @@ sub simplify_name { if ($^O eq 'MacOS') { $str =~ s/^.*://s; } else { - $str =~ s:^.*/::s; + $str =~ s{^.*/}{}s; } _simplify($str); - $str; + return $str; } # internal sub only @@ -400,10 +407,10 @@ sub pod_where { for (@new_INC) { if ( $_ eq '.' ) { $_ = ':'; - } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) { + } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { $_ = ':'. $_; } else { - $_ =~ s|^\./|:|; + $_ =~ s{^\./}{:}; } } push (@search_dirs, @new_INC); @@ -423,7 +430,7 @@ sub pod_where { if -d $Config::Config{'scriptdir'}; } - warn "Search path is: ".join(' ', @search_dirs)."\n" + warn 'Search path is: '.join(' ', @search_dirs)."\n" if $options{'-verbose'}; # Loop over directories @@ -431,7 +438,7 @@ sub pod_where { # Don't bother if can't find the directory if (-d $dir) { - warn "Looking in directory $dir\n" + warn "Looking in directory $dir\n" if $options{'-verbose'}; # Now concatenate this directory with the pod we are searching for @@ -442,7 +449,7 @@ sub pod_where { # Loop over possible extensions foreach my $ext ('', '.pod', '.pm', '.pl') { my $fullext = $fullname . $ext; - if (-f $fullext && + if (-f $fullext && contains_pod($fullext, $options{'-verbose'}) ) { warn "FOUND: $fullext\n" if $options{'-verbose'}; return $fullext; @@ -470,7 +477,7 @@ sub pod_where { } } # No match; - return undef; + return; } =head2 C<contains_pod( $file , $verbose )> @@ -486,15 +493,20 @@ sub contains_pod { $verbose = shift if @_; # check for one line of POD - unless(open(POD,"<$file")) { + my $podfh; + if ($] < 5.006) { + $podfh = gensym(); + } + + unless(open($podfh,"<$file")) { warn "Error: $file is unreadable: $!\n"; - return undef; + return; } local $/ = undef; - my $pod = <POD>; - close(POD) || die "Error closing $file: $!\n"; - unless($pod =~ /^=(head\d|pod|over|item)\b/m) { + my $pod = <$podfh>; + close($podfh) || die "Error closing $file: $!\n"; + unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) { warn "No POD in $file, skipping.\n" if($verbose); return 0; diff --git a/lib/Pod/InputObjects.pm b/lib/Pod/InputObjects.pm index fa5f61f9a7..13a86188bc 100644 --- a/lib/Pod/InputObjects.pm +++ b/lib/Pod/InputObjects.pm @@ -9,9 +9,10 @@ ############################################################################# package Pod::InputObjects; +use strict; use vars qw($VERSION); -$VERSION = 1.30; ## Current version of this package +$VERSION = '1.31'; ## Current version of this package require 5.005; ## requires this Perl version or later ############################################################################# @@ -78,12 +79,6 @@ sections which follow. ############################################################################# -use strict; -#use diagnostics; -#use Carp; - -############################################################################# - package Pod::InputSource; ##--------------------------------------------------------------------------- @@ -314,7 +309,7 @@ This method will return the corresponding text of the paragraph. sub text { (@_ > 1) and $_[0]->{'-text'} = $_[1]; return $_[0]->{'-text'}; -} +} ##--------------------------------------------------------------------------- @@ -329,7 +324,7 @@ as it appeared in the input. sub raw_text { return $_[0]->{'-text'} unless (defined $_[0]->{'-name'}); - return $_[0]->{'-prefix'} . $_[0]->{'-name'} . + return $_[0]->{'-prefix'} . $_[0]->{'-name'} . $_[0]->{'-separator'} . $_[0]->{'-text'}; } @@ -380,7 +375,7 @@ This method will get/set the corresponding parse-tree of the paragraph's text. sub parse_tree { (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; return $_[0]->{'-ptree'}; -} +} ## let ptree() be an alias for parse_tree() *ptree = \&parse_tree; @@ -561,7 +556,7 @@ sub prepend { $self->{'-ptree'}->prepend(@_); _set_child2parent_links($self, @_); return $self; -} +} ##--------------------------------------------------------------------------- @@ -580,7 +575,7 @@ sub append { $self->{'-ptree'}->append(@_); _set_child2parent_links($self, @_); return $self; -} +} ##--------------------------------------------------------------------------- @@ -673,7 +668,7 @@ sequence's text. sub parse_tree { (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; return $_[0]->{'-ptree'}; -} +} ## let ptree() be an alias for parse_tree() *ptree = \&parse_tree; @@ -831,7 +826,7 @@ sub prepend { local *ptree = $self; for (@_) { next unless length; - if (@ptree and !(ref $ptree[0]) and !(ref $_)) { + if (@ptree && !(ref $ptree[0]) && !(ref $_)) { $ptree[0] = $_ . $ptree[0]; } else { @@ -883,7 +878,7 @@ exactly as it appeared in the input. sub raw_text { my $self = shift; - my $text = ""; + my $text = ''; for ( @$self ) { $text .= (ref $_) ? $_->raw_text : $_; } diff --git a/lib/Pod/ParseUtils.pm b/lib/Pod/ParseUtils.pm index 13d66ab8d2..f3c7ef4677 100644 --- a/lib/Pod/ParseUtils.pm +++ b/lib/Pod/ParseUtils.pm @@ -8,9 +8,10 @@ ############################################################################# package Pod::ParseUtils; +use strict; use vars qw($VERSION); -$VERSION = 1.35; ## Current version of this package +$VERSION = '1.36'; ## Current version of this package require 5.005; ## requires this Perl version or later =head1 NAME @@ -252,7 +253,7 @@ sub new { } else { # called with L<> contents - return undef unless($self->parse($_[0])); + return unless($self->parse($_[0])); } } return $self; @@ -293,14 +294,14 @@ sub parse { # strip leading/trailing whitespace if(s/^[\s\n]+//) { - $self->warning("ignoring leading whitespace in link"); + $self->warning('ignoring leading whitespace in link'); } if(s/[\s\n]+$//) { - $self->warning("ignoring trailing whitespace in link"); + $self->warning('ignoring trailing whitespace in link'); } unless(length($_)) { - _invalid_link("empty link"); - return undef; + _invalid_link('empty link'); + return; } ## Check for different possibilities. This is tedious and error-prone @@ -313,68 +314,68 @@ sub parse { # to point to an internal funtion... my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)'; # page name only - if(m!^($page_rx)$!o) { + if(/^($page_rx)$/o) { $page = $1; $type = 'page'; } # alttext, page and "section" - elsif(m!^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$!o) { + elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) { ($alttext, $page, $node) = ($1, $2, $3); $type = 'section'; $quoted = 1; #... therefore | and / are allowed } # alttext and page - elsif(m!^(.*?)\s*[|]\s*($page_rx)$!o) { + elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) { ($alttext, $page) = ($1, $2); $type = 'page'; } # alttext and "section" - elsif(m!^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$!) { + elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) { ($alttext, $node) = ($1,$2); $type = 'section'; $quoted = 1; } # page and "section" - elsif(m!^($page_rx)\s*/\s*"(.+)"$!o) { + elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) { ($page, $node) = ($1, $2); $type = 'section'; $quoted = 1; } # page and item - elsif(m!^($page_rx)\s*/\s*(.+)$!o) { + elsif(m{^($page_rx)\s*/\s*(.+)$}o) { ($page, $node) = ($1, $2); $type = 'item'; } # only "section" - elsif(m!^/?"(.+)"$!) { + elsif(m{^/?"(.+)"$}) { $node = $1; $type = 'section'; $quoted = 1; } # only item - elsif(m!^\s*/(.+)$!) { + elsif(m{^\s*/(.+)$}) { $node = $1; $type = 'item'; } # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should? - elsif(m!^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $!ix) { + elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) { ($alttext,$node) = ($1,$2); $type = 'hyperlink'; } # non-standard: Hyperlink - elsif(m!^(\w+:[^:\s]\S*)$!i) { + elsif(/^(\w+:[^:\s]\S*)$/i) { $node = $1; $type = 'hyperlink'; } # alttext, page and item - elsif(m!^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$!o) { + elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) { ($alttext, $page, $node) = ($1, $2, $3); $type = 'item'; } # alttext and item - elsif(m!^(.*?)\s*[|]\s*/(.+)$!) { + elsif(m{^(.*?)\s*[|]\s*/(.+)$}) { ($alttext, $node) = ($1,$2); } # must be an item or a "malformed" section (without "") @@ -388,7 +389,7 @@ sub parse { # empty alternative text expands to node name if(defined $alttext) { if(!length($alttext)) { - $alttext = $node | $page; + $alttext = $node || $page; } } else { @@ -398,10 +399,10 @@ sub parse { if($page =~ /[(]\w*[)]$/) { $self->warning("(section) in '$page' deprecated"); } - if(!$quoted && $node =~ m:[|/]: && $type ne 'hyperlink') { + if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') { $self->warning("node '$node' contains non-escaped | or /"); } - if($alttext =~ m:[|/]:) { + if($alttext =~ m{[|/]}) { $self->warning("alternative text '$node' contains non-escaped | or /"); } $self->{-page} = $page; @@ -479,7 +480,7 @@ that are marked up): # The complete link's text sub text { - $_[0]->{_text}; + return $_[0]->{_text}; } =item $link-E<gt>warning() @@ -530,7 +531,7 @@ sub page { $_[0]->{-page} = $_[1]; $_[0]->_construct_text(); } - $_[0]->{-page}; + return $_[0]->{-page}; } =item $link-E<gt>node() @@ -545,7 +546,7 @@ sub node { $_[0]->{-node} = $_[1]; $_[0]->_construct_text(); } - $_[0]->{-node}; + return $_[0]->{-node}; } =item $link-E<gt>alttext() @@ -560,7 +561,7 @@ sub alttext { $_[0]->{-alttext} = $_[1]; $_[0]->_construct_text(); } - $_[0]->{-alttext}; + return $_[0]->{-alttext}; } =item $link-E<gt>type() @@ -589,8 +590,8 @@ sub link { my $link = $self->page() || ''; if($self->node()) { my $node = $self->node(); - $text =~ s/\|/E<verbar>/g; - $text =~ s:/:E<sol>:g; + $node =~ s/\|/E<verbar>/g; + $node =~ s{/}{E<sol>}g; if($self->type() eq 'section') { $link .= ($link ? '/' : '') . '"' . $node . '"'; } @@ -604,10 +605,10 @@ sub link { if($self->alttext()) { my $text = $self->alttext(); $text =~ s/\|/E<verbar>/g; - $text =~ s:/:E<sol>:g; + $text =~ s{/}{E<sol>}g; $link = "$text|$link"; } - $link; + return $link; } sub _invalid_link { @@ -616,7 +617,7 @@ sub _invalid_link { #eval { die "$msg\n" }; #chomp $@; $@ = $msg; # this seems to work, too! - undef; + return; } #----------------------------------------------------------------------------- @@ -686,7 +687,7 @@ sub find_page { return $_; } } - undef; + return; } package Pod::Cache::Item; @@ -808,7 +809,7 @@ sub find_node { return $_->[1]; # id } } - undef; + return; } =item $cacheitem-E<gt>idx() diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm index 1f4a33d5b3..5e261a6b6a 100644 --- a/lib/Pod/Parser.pm +++ b/lib/Pod/Parser.pm @@ -8,9 +8,11 @@ ############################################################################# package Pod::Parser; +use strict; -use vars qw($VERSION); -$VERSION = 1.35; ## Current version of this package +## These "variables" are used as local "glob aliases" for performance +use vars qw($VERSION @ISA %myData %myOpts @input_stack); +$VERSION = '1.36_01'; ## Current version of this package require 5.005; ## requires this Perl version or later ############################################################################# @@ -118,7 +120,7 @@ You may also want to override the B<begin_input()> and B<end_input()> methods for your subclass (to perform any needed per-file and/or per-document initialization or cleanup). -If you need to perform any preprocesssing of input before it is parsed +If you need to perform any preprocessing of input before it is parsed you may want to override one or more of B<preprocess_line()> and/or B<preprocess_paragraph()>. @@ -199,23 +201,18 @@ for the setting and unsetting of parse-options. ############################################################################# -use vars qw(@ISA); -use strict; #use diagnostics; use Pod::InputObjects; use Carp; use Exporter; BEGIN { - if ($] < 5.6) { + if ($] < 5.006) { require Symbol; import Symbol; } } @ISA = qw(Exporter); -## These "variables" are used as local "glob aliases" for performance -use vars qw(%myData %myOpts @input_stack); - ############################################################################# =head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES @@ -445,11 +442,10 @@ subclasses returns a blessed reference to the initialized object (hash-table). sub new { ## Determine if we were called via an object-ref or a classname - my $this = shift; + my ($this,%params) = @_; my $class = ref($this) || $this; ## Any remaining arguments are treated as initial values for the ## hash that is used to represent this object. - my %params = @_; my $self = { %params }; ## Bless ourselves into the desired class and perform any initialization bless $self, $class; @@ -757,9 +753,9 @@ sub parse_text { ## more than just the sequence object, we also need to pass the ## sequence name and text. $xseq_sub = sub { - my ($self, $iseq) = @_; - my $args = join("", $iseq->parse_tree->children); - return $self->interior_sequence($iseq->name, $args, $iseq); + my ($sself, $iseq) = @_; + my $args = join('', $iseq->parse_tree->children); + return $sself->interior_sequence($iseq->name, $args, $iseq); }; } ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) }; @@ -803,7 +799,7 @@ sub parse_text { ## Look for sequence ending elsif ( @seq_stack > 1 ) { ## Make sure we match the right kind of closing delimiter - my ($seq_end, $post_seq) = ("", ""); + my ($seq_end, $post_seq) = ('', ''); if ( ($ldelim eq '<' and /\A(.*?)(>)/s) or /\A(.*?)(\s+$rdelim)/s ) { @@ -861,7 +857,7 @@ sub parse_text { " at line $line in file $file\n"; (ref $errorsub) and &{$errorsub}($errmsg) or (defined $errorsub) and $self->$errorsub($errmsg) - or warn($errmsg); + or carp($errmsg); $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); $seq = $seq_stack[-1]; } @@ -893,7 +889,7 @@ sub interpolate { my($self, $text, $line_num) = @_; my %parse_opts = ( -expand_seq => 'interior_sequence' ); my $ptree = $self->parse_text( \%parse_opts, $text, $line_num ); - return join "", $ptree->children(); + return join '', $ptree->children(); } ##--------------------------------------------------------------------------- @@ -966,7 +962,7 @@ sub parse_paragraph { ## and whatever sequence of characters was used to separate them $pfx = $1; $_ = substr($text, length $pfx); - ($cmd, $sep, $text) = split /(\s+)/, $_, 2; + ($cmd, $sep, $text) = split /(\s+)/, $_, 2; ## If this is a "cut" directive then we dont need to do anything ## except return to "cutting" mode. if ($cmd eq 'cut') { @@ -1145,7 +1141,10 @@ closes the input and output files. If the special input filename "-" or "<&STDIN" is given then the STDIN filehandle is used for input (and no open or close is performed). If no -input filename is specified then "-" is implied. +input filename is specified then "-" is implied. Filehandle references, +or objects that support the regular IO operations (like C<E<lt>$fhE<gt>> +or C<$fh-<Egt>getline>) are also accepted; the handles must already be +opened. If a second argument is given then it should be the name of the desired output file. If the special output filename "-" or ">&STDOUT" is given @@ -1154,8 +1153,9 @@ performed). If the special output filename ">&STDERR" is given then the STDERR filehandle is used for output (and no open or close is performed). If no output filehandle is currently in use and no output filename is specified, then "-" is implied. -Alternatively, an L<IO::String> object is also accepted as an output -file handle. +Alternatively, filehandle references or objects that support the regular +IO operations (like C<print>, e.g. L<IO::String>) are also accepted; +the object must already be opened. This method does I<not> usually need to be overridden by subclasses. @@ -1188,7 +1188,7 @@ sub parse_from_file { { ## Not a filename, just a string implying STDIN $infile ||= '-'; - $myData{_INFILE} = "<standard input>"; + $myData{_INFILE} = '<standard input>'; $in_fh = \*STDIN; } else { @@ -1235,13 +1235,13 @@ sub parse_from_file { else { ## Not a filename, just a string implying STDOUT $outfile ||= '-'; - $myData{_OUTFILE} = "<standard output>"; + $myData{_OUTFILE} = '<standard output>'; $out_fh = \*STDOUT; } } elsif ($outfile =~ /^>&(STDERR|2)$/i) { ## Not a filename, just a string implying STDERR - $myData{_OUTFILE} = "<standard error>"; + $myData{_OUTFILE} = '<standard error>'; $out_fh = \*STDERR; } else { @@ -1258,7 +1258,7 @@ sub parse_from_file { ## have to parse the input and close the handles when we're finished. $self->parse_from_filehandle(\%opts, $in_fh, $out_fh); - $close_input and + $close_input and close($in_fh) || croak "Can't close $infile after reading: $!\n"; $close_output and close($out_fh) || croak "Can't close $outfile after writing: $!\n"; @@ -1283,17 +1283,17 @@ instance data fields: Specifies the method or subroutine to use when printing error messages about POD syntax. The supplied method/subroutine I<must> return TRUE upon -successful printing of the message. If C<undef> is given, then the B<warn> +successful printing of the message. If C<undef> is given, then the B<carp> builtin is used to issue error messages (this is the default behavior). my $errorsub = $parser->errorsub() my $errmsg = "This is an error message!\n" (ref $errorsub) and &{$errorsub}($errmsg) or (defined $errorsub) and $parser->$errorsub($errmsg) - or warn($errmsg); + or carp($errmsg); Returns a method name, or else a reference to the user-supplied subroutine -used to print error messages. Returns C<undef> if the B<warn> builtin +used to print error messages. Returns C<undef> if the B<carp> builtin is used to issue error messages (this is the default behavior). =cut @@ -1813,6 +1813,16 @@ Brad Appleton E<lt>bradapp@enteract.comE<gt> Based on code for B<Pod::Text> written by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> +=head1 LICENSE + +Pod-Parser is free software; you can redistribute it and/or modify it +under the terms of the Artistic License distributed with Perl version +5.000 or (at your option) any later version. Please refer to the +Artistic License that came with your Perl distribution for more +details. If your version of Perl was not distributed under the +terms of the Artistic License, than you may distribute PodParser +under the same terms as Perl itself. + =cut 1; diff --git a/lib/Pod/PlainText.pm b/lib/Pod/PlainText.pm index ec56608ff2..05e58663f2 100644 --- a/lib/Pod/PlainText.pm +++ b/lib/Pod/PlainText.pm @@ -16,21 +16,27 @@ ############################################################################ package Pod::PlainText; +use strict; require 5.005; use Carp qw(carp croak); use Pod::Select (); -use strict; use vars qw(@ISA %ESCAPES $VERSION); # We inherit from Pod::Select instead of Pod::Parser so that we can be used # by Pod::Usage. @ISA = qw(Pod::Select); -$VERSION = '2.02'; +$VERSION = '2.03'; +BEGIN { + if ($] < 5.006) { + require Symbol; + import Symbol; + } +} ############################################################################ # Table of supported E<> escapes @@ -130,7 +136,7 @@ sub initialize { $$self{INDENTS} = []; # Stack of indentations. $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. - $self->SUPER::initialize; + return $self->SUPER::initialize; } @@ -147,9 +153,13 @@ sub command { my $command = shift; return if $command eq 'pod'; return if ($$self{EXCLUDE} && $command ne 'end'); - $self->item ("\n") if defined $$self{ITEM}; + if (defined $$self{ITEM}) { + $self->item ("\n"); + local $_ = "\n"; + $self->output($_) if($command eq 'back'); + } $command = 'cmd_' . $command; - $self->$command (@_); + return $self->$command (@_); } # Called for a verbatim paragraph. Gets the paragraph, the line number, and @@ -162,7 +172,7 @@ sub verbatim { local $_ = shift; return if /^\s*$/; s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme; - $self->output ($_); + return $self->output($_); } # Called for a regular text block. Gets the paragraph, the line number, and @@ -170,7 +180,10 @@ sub verbatim { sub textblock { my $self = shift; return if $$self{EXCLUDE}; - $self->output ($_[0]), return if $$self{VERBATIM}; + if($$self{VERBATIM}) { + $self->output($_[0]); + return; + } local $_ = shift; my $line = shift; @@ -215,7 +228,7 @@ sub textblock { # Now actually interpolate and output the paragraph. $_ = $self->interpolate ($_, $line); - s/\s+$/\n/; + s/\s*$/\n/s; if (defined $$self{ITEM}) { $self->item ($_ . "\n"); } else { @@ -266,7 +279,7 @@ sub preprocess_paragraph { my $self = shift; local $_ = shift; 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; - $_; + return $_; } @@ -280,7 +293,7 @@ sub preprocess_paragraph { sub cmd_head1 { my $self = shift; local $_ = shift; - s/\s+$//; + s/\s+$//s; $_ = $self->interpolate ($_, shift); if ($$self{alt}) { $self->output ("\n==== $_ ====\n\n"); @@ -294,12 +307,12 @@ sub cmd_head1 { sub cmd_head2 { my $self = shift; local $_ = shift; - s/\s+$//; + s/\s+$//s; $_ = $self->interpolate ($_, shift); if ($$self{alt}) { $self->output ("\n== $_ ==\n\n"); } else { - $self->output (' ' x ($$self{indent} / 2) . $_ . "\n\n"); + $self->output (' ' x ($$self{indent} / 2) . $_ . "\n"); } } @@ -307,7 +320,7 @@ sub cmd_head2 { sub cmd_head3 { my $self = shift; local $_ = shift; - s/\s+$//; + s/\s+$//s; $_ = $self->interpolate ($_, shift); if ($$self{alt}) { $self->output ("\n= $_ =\n"); @@ -334,7 +347,7 @@ sub cmd_back { my $self = shift; $$self{MARGIN} = pop @{ $$self{INDENTS} }; unless (defined $$self{MARGIN}) { - carp "Unmatched =back"; + carp 'Unmatched =back'; $$self{MARGIN} = $$self{indent}; } } @@ -344,7 +357,7 @@ sub cmd_item { my $self = shift; if (defined $$self{ITEM}) { $self->item } local $_ = shift; - s/\s+$//; + s/\s+$//s; $$self{ITEM} = $self->interpolate ($_); } @@ -367,7 +380,7 @@ sub cmd_end { my $self = shift; $$self{EXCLUDE} = 0; $$self{VERBATIM} = 0; -} +} # One paragraph for a particular translator. Ignore it unless it's intended # for text, in which case we treat it as a verbatim text block. @@ -420,7 +433,7 @@ sub seq_l { $section = '"' . $1 . '"'; } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) { ($manpage, $section) = ($_, ''); - } elsif (m%/%) { + } elsif (m{/}) { ($manpage, $section) = split (/\s*\/\s*/, $_, 2); } @@ -431,14 +444,14 @@ sub seq_l { } elsif ($section =~ /^[:\w]+(?:\(\))?/) { $text .= 'the ' . $section . ' entry'; $text .= (length $manpage) ? " in the $manpage manpage" - : " elsewhere in this document"; + : ' elsewhere in this document'; } else { $section =~ s/^\"\s*//; $section =~ s/\s*\"$//; $text .= 'the section on "' . $section . '"'; $text .= " in the $manpage manpage" if length $manpage; } - $text; + return $text; } @@ -458,7 +471,7 @@ sub item { local $_ = shift; my $tag = $$self{ITEM}; unless (defined $tag) { - carp "item called without tag"; + carp 'item called without tag'; return; } undef $$self{ITEM}; @@ -478,7 +491,7 @@ sub item { $_ = $self->reformat ($_); s/^ /:/ if ($$self{alt} && $indent > 0); my $tagspace = ' ' x length $tag; - s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item"; + s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item'; $self->output ($_); } } @@ -507,7 +520,7 @@ sub wrap { } $output .= $spaces . $_; $output =~ s/\s+$/\n\n/; - $output; + return $output; } # Reformat a paragraph of text for the current margin. Takes the text to @@ -526,7 +539,7 @@ sub reformat { } else { s/\s+/ /g; } - $self->wrap ($_); + return $self->wrap($_); } # Output text to the output device. @@ -563,12 +576,14 @@ sub pod2text { # means we need to turn the first argument into a file handle. Magic # open will handle the <&STDIN case automagically. if (defined $_[1]) { - local *IN; - unless (open (IN, $_[0])) { + my $infh; + if ($] < 5.006) { + $infh = gensym(); + } + unless (open ($infh, $_[0])) { croak ("Can't open $_[0] for reading: $!\n"); - return; } - $_[0] = \*IN; + $_[0] = $infh; return $parser->parse_from_filehandle (@_); } else { return $parser->parse_from_file (@_); diff --git a/lib/Pod/Select.pm b/lib/Pod/Select.pm index 321a68ab0d..4724cb79cf 100644 --- a/lib/Pod/Select.pm +++ b/lib/Pod/Select.pm @@ -8,9 +8,10 @@ ############################################################################# package Pod::Select; +use strict; -use vars qw($VERSION); -$VERSION = 1.35; ## Current version of this package +use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections); +$VERSION = '1.36'; ## Current version of this package require 5.005; ## requires this Perl version or later ############################################################################# @@ -236,11 +237,9 @@ C</=item mine/../=(item|back)/> ############################################################################# -use strict; #use diagnostics; use Carp; use Pod::Parser 1.04; -use vars qw(@ISA @EXPORT $MAX_HEADING_LEVEL); @ISA = qw(Pod::Parser); @EXPORT = qw(&podselect); @@ -269,8 +268,6 @@ reference to the object itself as an implicit first parameter. ## ## =end _PRIVATE_ -use vars qw(%myData @section_headings); - sub _init_headings { my $self = shift; local *myData = $self; @@ -334,11 +331,8 @@ This method should I<not> normally be overridden by subclasses. =cut -use vars qw(@selected_sections); - sub select { - my $self = shift; - my @sections = @_; + my ($self, @sections) = @_; local *myData = $self; local $_; @@ -355,10 +349,10 @@ sub select { ## it seems incredibly unlikely that "+" would ever correspond to ## a legitimate section heading ##--------------------------------------------------------------------- - my $add = ($sections[0] eq "+") ? shift(@sections) : ""; + my $add = ($sections[0] eq '+') ? shift(@sections) : ''; ## Reset the set of sections to use - unless (@sections > 0) { + unless (@sections) { delete $myData{_SELECTED_SECTIONS} unless ($add); return; } @@ -367,14 +361,13 @@ sub select { local *selected_sections = $myData{_SELECTED_SECTIONS}; ## Compile each spec - my $spec; - for $spec (@sections) { - if ( defined($_ = &_compile_section_spec($spec)) ) { + for my $spec (@sections) { + if ( defined($_ = _compile_section_spec($spec)) ) { ## Store them in our sections array push(@selected_sections, $_); } else { - carp "Ignoring section spec \"$spec\"!\n"; + carp qq{Ignoring section spec "$spec"!\n}; } } } @@ -400,7 +393,7 @@ This method should I<not> normally be overridden by subclasses. sub add_selection { my $self = shift; - $self->select("+", @_); + return $self->select('+', @_); } ##--------------------------------------------------------------------------- @@ -416,7 +409,7 @@ This method takes no arguments, it has the exact same effect as invoking sub clear_selections { my $self = shift; - $self->select(); + return $self->select(); } ##--------------------------------------------------------------------------- @@ -428,7 +421,7 @@ sub clear_selections { Returns a value of true if the given section and subsection heading titles match any of the currently selected section specifications in effect from prior calls to B<select()> and B<add_selection()> (or if -there are no explictly selected/deselected sections). +there are no explicitly selected/deselected sections). The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of the corresponding sections, subsections, etc. to try and match. If @@ -447,7 +440,7 @@ sub match_section { ## Return true if no restrictions were explicitly specified my $selections = (exists $myData{_SELECTED_SECTIONS}) ? $myData{_SELECTED_SECTIONS} : undef; - return 1 unless ((defined $selections) && (@{$selections} > 0)); + return 1 unless ((defined $selections) && @{$selections}); ## Default any unspecified sections to the current one my @current_headings = $self->curr_headings(); @@ -456,18 +449,17 @@ sub match_section { } ## Look for a match against the specified section expressions - my ($section_spec, $regex, $negated, $match); - for $section_spec ( @{$selections} ) { + for my $section_spec ( @{$selections} ) { ##------------------------------------------------------ ## Each portion of this spec must match in order for ## the spec to be matched. So we will start with a ## match-value of 'true' and logically 'and' it with ## the results of matching a given element of the spec. ##------------------------------------------------------ - $match = 1; + my $match = 1; for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - $regex = $section_spec->[$i]; - $negated = ($regex =~ s/^\!//); + my $regex = $section_spec->[$i]; + my $negated = ($regex =~ s/^\!//); $match &= ($negated ? ($headings[$i] !~ /${regex}/) : ($headings[$i] =~ /${regex}/)); last unless ($match); @@ -585,7 +577,7 @@ sub podselect { my %defaults = (); my $pod_parser = new Pod::Select(%defaults); my $num_inputs = 0; - my $output = ">&STDOUT"; + my $output = '>&STDOUT'; my %opts; local $_; for (@argv) { @@ -604,7 +596,7 @@ sub podselect { $key =~ s/^(?=\w)/-/; $key =~ /^-se[cl]/ and $key = '-sections'; #! $key eq '-range' and $key .= 's'; - ($key => $val); + ($key => $val); } (keys %opts); ## Process the options @@ -625,7 +617,7 @@ sub podselect { ++$num_inputs; } } - $pod_parser->parse_from_file("-") unless ($num_inputs > 0); + $pod_parser->parse_from_file('-') unless ($num_inputs > 0); } ############################################################################# @@ -671,11 +663,11 @@ sub _compile_section_spec { ## Compile the spec into a list of regexs local $_ = $section_spec; - s|\\\\|\001|g; ## handle escaped backward slashes - s|\\/|\002|g; ## handle escaped forward slashes + s{\\\\}{\001}g; ## handle escaped backward slashes + s{\\/}{\002}g; ## handle escaped forward slashes ## Parse the regexs for the heading titles - @regexs = split('/', $_, $MAX_HEADING_LEVEL); + @regexs = split(/\//, $_, $MAX_HEADING_LEVEL); ## Set default regex for ommitted levels for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { @@ -686,13 +678,13 @@ sub _compile_section_spec { my $bad_regexs = 0; for (@regexs) { $_ .= '.+' if ($_ eq '!'); - s|\001|\\\\|g; ## restore escaped backward slashes - s|\002|\\/|g; ## restore escaped forward slashes - $negated = s/^\!//; ## check for negation - eval "/$_/"; ## check regex syntax + s{\001}{\\\\}g; ## restore escaped backward slashes + s{\002}{\\/}g; ## restore escaped forward slashes + $negated = s/^\!//; ## check for negation + eval "m{$_}"; ## check regex syntax if ($@) { ++$bad_regexs; - carp "Bad regular expression /$_/ in \"$section_spec\": $@\n"; + carp qq{Bad regular expression /$_/ in "$section_spec": $@\n}; } else { ## Add the forward and rear anchors (and put the negator back) diff --git a/lib/Pod/Usage.pm b/lib/Pod/Usage.pm index cbb55c5fe2..f463fb9c46 100644 --- a/lib/Pod/Usage.pm +++ b/lib/Pod/Usage.pm @@ -8,9 +8,10 @@ ############################################################################# package Pod::Usage; +use strict; -use vars qw($VERSION); -$VERSION = "1.35"; ## Current version of this package +use vars qw($VERSION @ISA @EXPORT); +$VERSION = '1.36'; ## Current version of this package require 5.005; ## requires this Perl version or later =head1 NAME @@ -105,6 +106,11 @@ and printed. A string representing a selection list for sections to be printed when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">. +Alternatively, an array reference of section specifications can be used: + + pod2usage(-verbose => 99, + -sections => [ qw(fred fred/subsection) ] ); + =item C<-output> A reference to a filehandle, or the pathname of a file to which the @@ -117,6 +123,12 @@ A reference to a filehandle, or the pathname of a file from which the invoking script's pod documentation should be read. It defaults to the file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>). +If you are calling B<pod2usage()> from a module and want to display +that module's POD, you can use this: + + use Pod::Find qw(pod_where); + pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) ); + =item C<-pathlist> A list of directory paths. If the input file does not exist, then it @@ -408,6 +420,8 @@ fail even on robust platforms. Don't do that. Please report bugs using L<http://rt.cpan.org>. +Marek Rouchal E<lt>marekr@cpan.orgE<gt> + Brad Appleton E<lt>bradapp@enteract.comE<gt> Based on code for B<Pod::Text::pod2text()> written by @@ -418,18 +432,20 @@ Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience with re-writing this manpage. +=head1 SEE ALSO + +L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find> + =cut ############################################################################# -use strict; #use diagnostics; use Carp; use Config; use Exporter; use File::Spec; -use vars qw(@ISA @EXPORT); @EXPORT = qw(&pod2usage); BEGIN { if ( $] >= 5.005_58 ) { @@ -442,6 +458,7 @@ BEGIN { } } +require Pod::Select; ##--------------------------------------------------------------------------- @@ -459,7 +476,7 @@ sub pod2usage { %opts = ($_, @_); } elsif (!defined $_) { - $_ = ""; + $_ = ''; } elsif (ref $_) { ## User passed a ref to a hash @@ -467,11 +484,11 @@ sub pod2usage { } elsif (/^[-+]?\d+$/) { ## User passed in the exit value to use - $opts{"-exitval"} = $_; + $opts{'-exitval'} = $_; } else { ## User passed in a message to print before issuing usage. - $_ and $opts{"-message"} = $_; + $_ and $opts{'-message'} = $_; } ## Need this for backward compatibility since we formerly used @@ -479,85 +496,93 @@ sub pod2usage { ## looked like Unix command-line options. ## to be uppercase keywords) %opts = map { - my $val = $opts{$_}; - s/^(?=\w)/-/; - /^-msg/i and $_ = '-message'; - /^-exit/i and $_ = '-exitval'; - lc($_) => $val; + my ($key, $val) = ($_, $opts{$_}); + $key =~ s/^(?=\w)/-/; + $key =~ /^-msg/i and $key = '-message'; + $key =~ /^-exit/i and $key = '-exitval'; + lc($key) => $val; } (keys %opts); ## Now determine default -exitval and -verbose values to use - if ((! defined $opts{"-exitval"}) && (! defined $opts{"-verbose"})) { - $opts{"-exitval"} = 2; - $opts{"-verbose"} = 0; + if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) { + $opts{'-exitval'} = 2; + $opts{'-verbose'} = 0; } - elsif (! defined $opts{"-exitval"}) { - $opts{"-exitval"} = ($opts{"-verbose"} > 0) ? 1 : 2; + elsif (! defined $opts{'-exitval'}) { + $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2; } - elsif (! defined $opts{"-verbose"}) { - $opts{"-verbose"} = (lc($opts{"-exitval"}) eq "noexit" || - $opts{"-exitval"} < 2); + elsif (! defined $opts{'-verbose'}) { + $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' || + $opts{'-exitval'} < 2); } ## Default the output file - $opts{"-output"} = (lc($opts{"-exitval"}) eq "noexit" || - $opts{"-exitval"} < 2) ? \*STDOUT : \*STDERR - unless (defined $opts{"-output"}); + $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' || + $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR + unless (defined $opts{'-output'}); ## Default the input file - $opts{"-input"} = $0 unless (defined $opts{"-input"}); + $opts{'-input'} = $0 unless (defined $opts{'-input'}); ## Look up input file in path if it doesnt exist. - unless ((ref $opts{"-input"}) || (-e $opts{"-input"})) { - my ($dirname, $basename) = ('', $opts{"-input"}); - my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/) ? ";" - : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ":"); - my $pathspec = $opts{"-pathlist"} || $ENV{PATH} || $ENV{PERL5LIB}; + unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) { + my $basename = $opts{'-input'}; + my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';' + : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':'); + my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB}; my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); - for $dirname (@paths) { + for my $dirname (@paths) { $_ = File::Spec->catfile($dirname, $basename) if length; - last if (-e $_) && ($opts{"-input"} = $_); + last if (-e $_) && ($opts{'-input'} = $_); } } ## Now create a pod reader and constrain it to the desired sections. my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); - if ($opts{"-verbose"} == 0) { - $parser->select('SYNOPSIS\s*'); + if ($opts{'-verbose'} == 0) { + $parser->select('(?:SYNOPSIS|USAGE)\s*'); } - elsif ($opts{"-verbose"} == 1) { + elsif ($opts{'-verbose'} == 1) { my $opt_re = '(?i)' . '(?:OPTIONS|ARGUMENTS)' . '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; - $parser->select( 'SYNOPSIS', $opt_re, "DESCRIPTION/$opt_re" ); + $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" ); } - elsif ($opts{"-verbose"} >= 2 && $opts{"-verbose"} != 99) { + elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { $parser->select('.*'); } - elsif ($opts{"-verbose"} == 99) { - $parser->select( $opts{"-sections"} ); - $opts{"-verbose"} = 1; + elsif ($opts{'-verbose'} == 99) { + my $sections = $opts{'-sections'}; + $parser->select( (ref $sections) ? @$sections : $sections ); + $opts{'-verbose'} = 1; } ## Now translate the pod document and then exit with the desired status - if ( !$opts{"-noperldoc"} - and $opts{"-verbose"} >= 2 - and !ref($opts{"-input"}) - and $opts{"-output"} == \*STDOUT ) + if ( !$opts{'-noperldoc'} + and $opts{'-verbose'} >= 2 + and !ref($opts{'-input'}) + and $opts{'-output'} == \*STDOUT ) { ## spit out the entire PODs. Might as well invoke perldoc - my $progpath = File::Spec->catfile($Config{scriptdir}, "perldoc"); - system($progpath, $opts{"-input"}); - if($?) { - # RT16091: fall back to more if perldoc failed - system($ENV{PAGER} || 'more', $opts{"-input"}); + my $progpath = File::Spec->catfile($Config{scriptdir}, 'perldoc'); + print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'}); + if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) { + # the perldocs back to 5.005 should all have -F + # without -F there are warnings in -T scripts + system($progpath, '-F', $1); + if($?) { + # RT16091: fall back to more if perldoc failed + system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1); + } + } else { + croak "Unspecified input file or insecure argument.\n"; } } else { - $parser->parse_from_file($opts{"-input"}, $opts{"-output"}); + $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); } - exit($opts{"-exitval"}) unless (lc($opts{"-exitval"}) eq 'noexit'); + exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); } ##--------------------------------------------------------------------------- @@ -582,11 +607,30 @@ sub new { } sub select { - my ($self, @res) = @_; + my ($self, @sections) = @_; if ($ISA[0]->can('select')) { - $self->SUPER::select(@_); + $self->SUPER::select(@sections); } else { - $self->{USAGE_SELECT} = \@res; + # we're using Pod::Simple - need to mimic the behavior of Pod::Select + my $add = ($sections[0] eq '+') ? shift(@sections) : ''; + ## Reset the set of sections to use + unless (@sections) { + delete $self->{USAGE_SELECT} unless ($add); + return; + } + $self->{USAGE_SELECT} = [] + unless ($add && $self->{USAGE_SELECT}); + my $sref = $self->{USAGE_SELECT}; + ## Compile each spec + for my $spec (@sections) { + my $cs = Pod::Select::_compile_section_spec($spec); + if ( defined $cs ) { + ## Store them in our sections array + push(@$sref, $cs); + } else { + carp qq{Ignoring section spec "$spec"!\n}; + } + } } } @@ -599,26 +643,36 @@ sub seq_i { return $_[1] } sub _handle_element_end { my ($self, $element) = @_; if ($element eq 'head1') { - $$self{USAGE_HEAD1} = $$self{PENDING}[-1][1]; + $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ]; if ($self->{USAGE_OPTIONS}->{-verbose} < 2) { $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; } - } elsif ($element eq 'head2') { - $$self{USAGE_HEAD2} = $$self{PENDING}[-1][1]; + } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0 + my $idx = $1 - 1; + $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS}); + $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1]; } - if ($element eq 'head1' || $element eq 'head2') { + if ($element =~ /^head\d+$/) { $$self{USAGE_SKIPPING} = 1; - my $heading = $$self{USAGE_HEAD1}; - $heading .= '/' . $$self{USAGE_HEAD2} if defined $$self{USAGE_HEAD2}; if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) { - $$self{USAGE_SKIPPING} = 0; + $$self{USAGE_SKIPPING} = 0; } else { - for (@{ $$self{USAGE_SELECT} }) { - if ($heading =~ /^$_\s*$/) { + my @headings = @{$$self{USAGE_HEADINGS}}; + for my $section_spec ( @{$$self{USAGE_SELECT}} ) { + my $match = 1; + for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) { + $headings[$i] = '' unless defined $headings[$i]; + my $regex = $section_spec->[$i]; + my $negated = ($regex =~ s/^\!//); + $match &= ($negated ? ($headings[$i] !~ /${regex}/) + : ($headings[$i] =~ /${regex}/)); + last unless ($match); + } # end heading levels + if ($match) { $$self{USAGE_SKIPPING} = 0; last; - } - } + } + } # end sections } # Try to do some lowercasing instead of all-caps in headings, and use @@ -631,13 +685,14 @@ sub _handle_element_end { $$self{PENDING}[-1][1] = $_; } } - if ($$self{USAGE_SKIPPING}) { + if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) { pop @{ $$self{PENDING} }; } else { $self->SUPER::_handle_element_end($element); } } +# required for Pod::Simple API sub start_document { my $self = shift; $self->SUPER::start_document(); @@ -646,6 +701,7 @@ sub start_document { print $out_fh "$msg\n"; } +# required for old Pod::Parser API sub begin_pod { my $self = shift; $self->SUPER::begin_pod(); ## Have to call superclass diff --git a/lib/Pod/t/contains_pod.t b/lib/Pod/t/contains_pod.t index 9ebe665074..b7d08319e1 100644 --- a/lib/Pod/t/contains_pod.t +++ b/lib/Pod/t/contains_pod.t @@ -16,10 +16,14 @@ BEGIN { } -use Test::More tests => 1; +use Test::More tests => 2; use Pod::Find qw( contains_pod ); { ok(contains_pod('lib/contains_pod.xr'), "contains pod"); } + +{ + ok(contains_pod('lib/contains_bad_pod.xr'), "contains bad pod"); +} |