t/lib/compress/tied.pl Compress::Zlib
t/lib/compress/truncate.pl Compress::Zlib
t/lib/compress/zlib-generic.pl Compress::Zlib
+t/lib/contains_bad_pod.xr Pod-Parser test file
t/lib/contains_pod.xr Pod-Parser test file
t/lib/cygwin.t Builtin cygwin function tests
t/lib/Devel/switchd.pm Module for t/run/switchd.t
t/pod/pod2usage2.t Test Pod::Usage
t/pod/pod2usage.t Test Pod::Usage
t/pod/pod2usage.xr Expected results for pod2usage.t
+t/pod/podchkenc.t Validate =encoding support
+t/pod/podchkenc.xr Expected results for the above
t/pod/poderrs.t Test POD errors
t/pod/poderrs.xr Expected results for poderrs.t
t/pod/podselect.t Test Pod::Select
t/pod/testpchk.pl Module to test Pod::Checker for a given file
t/pod/testpods/lib/Pod/Stuff.pm Sample data for find.t
t/pod/twice.t Test Pod::Parser
+t/pod/usage.pod Test POD for pod2usage tests
+t/pod/usage2.pod Test POD for pod2usage tests
t/README Instructions for regression tests
t/run/cloexec.t Test close-on-exec.
t/run/exit.t Test perl's exit status.
'Pod::Parser' => {
'MAINTAINER' => 'marekr',
- 'FILES' => q[lib/Pod/{InputObjects,Parser,ParseUtils,Select,PlainText,Usage,Checker,Find}.pm pod/pod{select,2usage,checker}.PL t/pod/testcmp.pl t/pod/testp2pt.pl t/pod/testpchk.pl t/pod/emptycmd.* t/pod/find.t t/pod/for.* t/pod/headings.* t/pod/include.* t/pod/included.* t/pod/lref.* t/pod/multiline_items.* t/pod/nested_items.* t/pod/nested_seqs.* t/pod/oneline_cmds.* t/pod/poderrs.* t/pod/pod2usage.* t/pod/podselect.* t/pod/special_seqs.*],
+ 'FILES' => q[lib/Pod/{Checker,Find,InputObjects,Parser,ParseUtils,PlainText,Select,Usage}.pm lib/Pod/t/contains_pod.t pod/pod{2usage,checker,select}.PL t/lib/contains_bad_pod.xr t/lib/contains_pod.xr t/pod/emptycmd.* t/pod/find.t t/pod/for.* t/pod/headings.* t/pod/include.* t/pod/included.* t/pod/lref.* t/pod/multiline_items.* t/pod/nested_items.* t/pod/nested_seqs.* t/pod/oneline_cmds.* t/pod/pod2usage.* t/pod/podchkenc.* t/pod/poderrs.* t/pod/podselect.* t/pod/special_seqs.* t/pod/testcmp.pl t/pod/testp2pt.pl t/pod/testpchk.pl t/pod/usage*.pod],
'CPAN' => 1,
'UPSTREAM' => undef,
},
#############################################################################
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
=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 *
=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>
=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
=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
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)
#############################################################################
-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,
'for' => 1,
'begin' => 1,
'end' => 1,
- 'encoding' => '1',
+ 'encoding' => 1,
);
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
## Function definitions begin here
##---------------------------------
-sub podchecker( $ ; $ % ) {
+sub podchecker {
my ($infile, $outfile, %options) = @_;
local $_;
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'));
sub name {
return (@_ > 1 && $_[1]) ?
- ($_[0]->{-name} = $_[1]) : $_[0]->{-name};
+ ($_[0]->{-name} = $_[1]) : $_[0]->{-name};
}
##################################
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' });
}
}
}
# 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
##### 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" });
#}
# 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);
}
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
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
}
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
# 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
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;
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)" });
}
}
$self->node($arg);
unless(length($arg)) {
$self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
+ -severity => 'ERROR',
-msg => "empty =$cmd"});
}
if($cmd eq 'head1') {
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";
# 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
}
$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"});
}
}
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;
my $count;
if($count = tr/<>/<>/) {
$self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
+ -severity => 'WARNING',
-msg => "$count unescaped <> in paragraph" });
}
}
# 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");
}
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
# 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];
}
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}) {
}
else {
$self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "Unknown entity " . $_->raw_text()});
+ -severity => 'WARNING',
+ -msg => 'Unknown entity ' . $_->raw_text()});
$text .= "E<$ent>";
}
}
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 });
}
}
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
}
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) = @_;
}
# process a block of regular text
-sub textblock {
+sub textblock {
my ($self, $paragraph, $line_num, $pod_para) = @_;
my ($file, $line) = $pod_para->file_line;
#############################################################################
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
=cut
-use strict;
#use diagnostics;
use Exporter;
use File::Spec;
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
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));
}, $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 {
# 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 )>
if ($^O eq 'MacOS') {
$str =~ s/^.*://s;
} else {
- $str =~ s:^.*/::s;
+ $str =~ s{^.*/}{}s;
}
_simplify($str);
- $str;
+ return $str;
}
# internal sub only
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);
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
# 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
# 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;
}
}
# No match;
- return undef;
+ return;
}
=head2 C<contains_pod( $file , $verbose )>
$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;
#############################################################################
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
#############################################################################
#############################################################################
-use strict;
-#use diagnostics;
-#use Carp;
-
-#############################################################################
-
package Pod::InputSource;
##---------------------------------------------------------------------------
sub text {
(@_ > 1) and $_[0]->{'-text'} = $_[1];
return $_[0]->{'-text'};
-}
+}
##---------------------------------------------------------------------------
sub raw_text {
return $_[0]->{'-text'} unless (defined $_[0]->{'-name'});
- return $_[0]->{'-prefix'} . $_[0]->{'-name'} .
+ return $_[0]->{'-prefix'} . $_[0]->{'-name'} .
$_[0]->{'-separator'} . $_[0]->{'-text'};
}
sub parse_tree {
(@_ > 1) and $_[0]->{'-ptree'} = $_[1];
return $_[0]->{'-ptree'};
-}
+}
## let ptree() be an alias for parse_tree()
*ptree = \&parse_tree;
$self->{'-ptree'}->prepend(@_);
_set_child2parent_links($self, @_);
return $self;
-}
+}
##---------------------------------------------------------------------------
$self->{'-ptree'}->append(@_);
_set_child2parent_links($self, @_);
return $self;
-}
+}
##---------------------------------------------------------------------------
sub parse_tree {
(@_ > 1) and $_[0]->{'-ptree'} = $_[1];
return $_[0]->{'-ptree'};
-}
+}
## let ptree() be an alias for parse_tree()
*ptree = \&parse_tree;
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 {
sub raw_text {
my $self = shift;
- my $text = "";
+ my $text = '';
for ( @$self ) {
$text .= (ref $_) ? $_->raw_text : $_;
}
#############################################################################
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
}
else {
# called with L<> contents
- return undef unless($self->parse($_[0]));
+ return unless($self->parse($_[0]));
}
}
return $self;
# 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
# 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 "")
# empty alternative text expands to node name
if(defined $alttext) {
if(!length($alttext)) {
- $alttext = $node | $page;
+ $alttext = $node || $page;
}
}
else {
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;
# The complete link's text
sub text {
- $_[0]->{_text};
+ return $_[0]->{_text};
}
=item $link-E<gt>warning()
$_[0]->{-page} = $_[1];
$_[0]->_construct_text();
}
- $_[0]->{-page};
+ return $_[0]->{-page};
}
=item $link-E<gt>node()
$_[0]->{-node} = $_[1];
$_[0]->_construct_text();
}
- $_[0]->{-node};
+ return $_[0]->{-node};
}
=item $link-E<gt>alttext()
$_[0]->{-alttext} = $_[1];
$_[0]->_construct_text();
}
- $_[0]->{-alttext};
+ return $_[0]->{-alttext};
}
=item $link-E<gt>type()
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 . '"';
}
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 {
#eval { die "$msg\n" };
#chomp $@;
$@ = $msg; # this seems to work, too!
- undef;
+ return;
}
#-----------------------------------------------------------------------------
return $_;
}
}
- undef;
+ return;
}
package Pod::Cache::Item;
return $_->[1]; # id
}
}
- undef;
+ return;
}
=item $cacheitem-E<gt>idx()
#############################################################################
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
#############################################################################
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()>.
#############################################################################
-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
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;
## 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(@_) };
## 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 )
{
" 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];
}
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();
}
##---------------------------------------------------------------------------
## 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') {
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
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.
{
## Not a filename, just a string implying STDIN
$infile ||= '-';
- $myData{_INFILE} = "<standard input>";
+ $myData{_INFILE} = '<standard input>';
$in_fh = \*STDIN;
}
else {
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 {
## 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";
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
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;
############################################################################
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
$$self{INDENTS} = []; # Stack of indentations.
$$self{MARGIN} = $$self{indent}; # Current left margin in spaces.
- $self->SUPER::initialize;
+ return $self->SUPER::initialize;
}
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
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
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;
# 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 {
my $self = shift;
local $_ = shift;
1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
- $_;
+ return $_;
}
sub cmd_head1 {
my $self = shift;
local $_ = shift;
- s/\s+$//;
+ s/\s+$//s;
$_ = $self->interpolate ($_, shift);
if ($$self{alt}) {
$self->output ("\n==== $_ ====\n\n");
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");
}
}
sub cmd_head3 {
my $self = shift;
local $_ = shift;
- s/\s+$//;
+ s/\s+$//s;
$_ = $self->interpolate ($_, shift);
if ($$self{alt}) {
$self->output ("\n= $_ =\n");
my $self = shift;
$$self{MARGIN} = pop @{ $$self{INDENTS} };
unless (defined $$self{MARGIN}) {
- carp "Unmatched =back";
+ carp 'Unmatched =back';
$$self{MARGIN} = $$self{indent};
}
}
my $self = shift;
if (defined $$self{ITEM}) { $self->item }
local $_ = shift;
- s/\s+$//;
+ s/\s+$//s;
$$self{ITEM} = $self->interpolate ($_);
}
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.
$section = '"' . $1 . '"';
} elsif (m/^[-:.\w]+(?:\(\S+\))?$/) {
($manpage, $section) = ($_, '');
- } elsif (m%/%) {
+ } elsif (m{/}) {
($manpage, $section) = split (/\s*\/\s*/, $_, 2);
}
} 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;
}
local $_ = shift;
my $tag = $$self{ITEM};
unless (defined $tag) {
- carp "item called without tag";
+ carp 'item called without tag';
return;
}
undef $$self{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 ($_);
}
}
}
$output .= $spaces . $_;
$output =~ s/\s+$/\n\n/;
- $output;
+ return $output;
}
# Reformat a paragraph of text for the current margin. Takes the text to
} else {
s/\s+/ /g;
}
- $self->wrap ($_);
+ return $self->wrap($_);
}
# Output text to the output device.
# 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 (@_);
#############################################################################
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
#############################################################################
#############################################################################
-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);
##
## =end _PRIVATE_
-use vars qw(%myData @section_headings);
-
sub _init_headings {
my $self = shift;
local *myData = $self;
=cut
-use vars qw(@selected_sections);
-
sub select {
- my $self = shift;
- my @sections = @_;
+ my ($self, @sections) = @_;
local *myData = $self;
local $_;
## 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;
}
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};
}
}
}
sub add_selection {
my $self = shift;
- $self->select("+", @_);
+ return $self->select('+', @_);
}
##---------------------------------------------------------------------------
sub clear_selections {
my $self = shift;
- $self->select();
+ return $self->select();
}
##---------------------------------------------------------------------------
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
## 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();
}
## 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);
my %defaults = ();
my $pod_parser = new Pod::Select(%defaults);
my $num_inputs = 0;
- my $output = ">&STDOUT";
+ my $output = '>&STDOUT';
my %opts;
local $_;
for (@argv) {
$key =~ s/^(?=\w)/-/;
$key =~ /^-se[cl]/ and $key = '-sections';
#! $key eq '-range' and $key .= 's';
- ($key => $val);
+ ($key => $val);
} (keys %opts);
## Process the options
++$num_inputs;
}
}
- $pod_parser->parse_from_file("-") unless ($num_inputs > 0);
+ $pod_parser->parse_from_file('-') unless ($num_inputs > 0);
}
#############################################################################
## 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) {
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)
#############################################################################
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
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
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
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
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 ) {
}
}
+require Pod::Select;
##---------------------------------------------------------------------------
%opts = ($_, @_);
}
elsif (!defined $_) {
- $_ = "";
+ $_ = '';
}
elsif (ref $_) {
## User passed a ref to a hash
}
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
## 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');
}
##---------------------------------------------------------------------------
}
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};
+ }
+ }
}
}
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
$$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();
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
}
-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");
+}
#############################################################################
use strict;
-use diagnostics;
+#use diagnostics;
=head1 NAME
=item I<file>
The pathname of a file containing pod documentation to be output in
-usage mesage format (defaults to standard input).
+usage message format (defaults to standard input).
=back
B<pod2usage> will read the given input file looking for pod
documentation and will print the corresponding usage message.
-If no input file is specified than standard input is read.
+If no input file is specified then standard input is read.
B<pod2usage> invokes the B<pod2usage()> function in the B<Pod::Usage>
module. Please see L<Pod::Usage/pod2usage()>.
## Define options
my %options = ();
my @opt_specs = (
- "help",
- "man",
- "exit=i",
- "output=s",
- "pathlist=s",
- "verbose=i",
+ 'help',
+ 'man',
+ 'exit=i',
+ 'output=s',
+ 'pathlist=s',
+ 'verbose=i',
);
## Parse options
## Dont default to STDIN if connected to a terminal
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
-@ARGV = ("-") unless (@ARGV > 0);
+@ARGV = ('-') unless (@ARGV);
if (@ARGV > 1) {
print STDERR "pod2usage: Too many filenames given\n\n";
pod2usage(2);
my %usage = ();
$usage{-input} = shift(@ARGV);
-$usage{-exitval} = $options{"exit"} if (defined $options{"exit"});
-$usage{-output} = $options{"output"} if (defined $options{"output"});
-$usage{-verbose} = $options{"verbose"} if (defined $options{"verbose"});
-$usage{-pathlist} = $options{"pathlist"} if (defined $options{"pathlist"});
+$usage{-exitval} = $options{'exit'} if (defined $options{'exit'});
+$usage{-output} = $options{'output'} if (defined $options{'output'});
+$usage{-verbose} = $options{'verbose'} if (defined $options{'verbose'});
+$usage{-pathlist} = $options{'pathlist'} if (defined $options{'pathlist'});
pod2usage(\%usage);
The status 2 indicates that at least one of the specified
files does not contain I<any> POD commands.
-Status 1 overrides status 2. If you want unambigouus
+Status 1 overrides status 2. If you want unambiguous
results, call B<podchecker> with one single argument only.
=head1 SEE ALSO
@ARGV = qw(-) unless(@ARGV);
for my $podfile (@ARGV) {
if($podfile eq '-') {
- $podfile = "<&STDIN";
+ $podfile = '<&STDIN';
}
elsif(-d $podfile) {
warn "podchecker: Warning: Ignoring directory '$podfile'\n";
next;
}
- my $errors = podchecker($podfile, undef, '-warnings' => $options{warnings});
+ my $errors =
+ podchecker($podfile, undef, '-warnings' => $options{warnings});
if($errors > 0) {
# errors occurred
- printf STDERR ("%s has %d pod syntax %s.\n",
- $podfile, $errors, ($errors == 1) ? "error" : "errors");
$status = 1;
+ printf STDERR ("%s has %d pod syntax %s.\n",
+ $podfile, $errors,
+ ($errors == 1) ? 'error' : 'errors');
}
elsif($errors < 0) {
- print STDERR "$podfile does not contain any pod commands.\n";
# no pod found
$status = 2 unless($status);
+ print STDERR "$podfile does not contain any pod commands.\n";
}
else {
print STDERR "$podfile pod syntax OK.\n";
#############################################################################
use strict;
-use diagnostics;
+#use diagnostics;
=head1 NAME
## Define options
my %options = (
- "help" => 0,
- "man" => 0,
- "sections" => [],
+ 'help' => 0,
+ 'man' => 0,
+ 'sections' => [],
);
## Parse options
-GetOptions(\%options, "help", "man", "sections|select=s@") || pod2usage(2);
+GetOptions(\%options, 'help', 'man', 'sections|select=s@') || pod2usage(2);
pod2usage(1) if ($options{help});
pod2usage(-verbose => 2) if ($options{man});
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
## Invoke podselect().
-if (@{ $options{"sections"} } > 0) {
- podselect({ -sections => $options{"sections"} }, @ARGV);
+if (@{ $options{'sections'} } > 0) {
+ podselect({ -sections => $options{'sections'} }, @ARGV);
}
else {
podselect(@ARGV);
--- /dev/null
+=head foo
+
+bar baz.
+
+=cut
my $lib_dir = $ENV{PERL_CORE} ?
File::Spec->catdir('pod', 'testpods', 'lib')
: File::Spec->catdir($THISDIR,'lib');
+
+my $vms_unix_rpt = 0;
+my $vms_efs = 0;
+my $unix_mode = 1;
+
if ($^O eq 'VMS') {
$lib_dir = $ENV{PERL_CORE} ?
VMS::Filespec::unixify(File::Spec->catdir('pod', 'testpods', 'lib'))
: VMS::Filespec::unixify(File::Spec->catdir($THISDIR,'-','lib','pod'));
$Qlib_dir = $lib_dir;
$Qlib_dir =~ s#\/#::#g;
+
+ $unix_mode = 0;
+ if (eval 'require VMS::Feature') {
+ $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
+ $vms_efs = VMS::Feature::current("efs_charset");
+ } else {
+ my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+ my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
+ $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
+ $vms_efs = $efs_charset =~ /^[ET1]/i;
+ }
+
+ # Traditional VMS mode only if VMS is not in UNIX compatible mode.
+ $unix_mode = ($vms_efs && $vms_unix_rpt);
}
print "### searching $lib_dir\n";
require Config;
if ($^O eq 'VMS') { # privlib is perl_root:[lib] OK but not under mms
- $compare = "lib.File]Find.pm";
+ if ($unix_mode) {
+ $compare = "../lib/File/Find.pm";
+ } else {
+ $compare = "lib.File]Find.pm";
+ }
$result =~ s/perl_root:\[\-?\.?//i;
$result =~ s/\[\-?\.?//i; # needed under `mms test`
ok($result,$compare);
else {
$compare = $ENV{PERL_CORE} ?
File::Spec->catfile(File::Spec->updir, 'lib','File','Find.pm')
- : File::Spec->catfile($Config::Config{privlib},"File","Find.pm");
+ : File::Spec->catfile($Config::Config{privlibexp},"File","Find.pm");
ok(_canon($result),_canon($compare));
}
appropriately.
This is a test.
+
on MSWin32 and DOS).
*file* The pathname of a file containing pod documentation to be output
- in usage mesage format (defaults to standard input).
+ in usage message format (defaults to standard input).
DESCRIPTION
pod2usage will read the given input file looking for pod documentation
and will print the corresponding usage message. If no input file is
- specified than standard input is read.
+ specified then standard input is read.
pod2usage invokes the pod2usage() function in the Pod::Usage module.
Please see the pod2usage() entry in the Pod::Usage manpage.
plan skip_all => "Not portable on Win32 or VMS\n";
}
else {
- plan tests => 15;
+ plan tests => 34;
}
use_ok ("Pod::Usage");
}
sub getoutput
{
my ($code) = @_;
- my $pid = open(IN, "-|");
+ my $pid = open(TEST_IN, "-|");
unless(defined $pid) {
die "Cannot fork: $!";
}
if($pid) {
# parent
- my @out = <IN>;
- close(IN);
+ my @out = <TEST_IN>;
+ close(TEST_IN);
my $exit = $?>>8;
s/^/#/ for @out;
local $" = "";
}
# child
open(STDERR, ">&STDOUT");
+ Test::More->builder->no_ending(1);
&$code;
print "--NORMAL-RETURN--\n";
exit 0;
$left eq $right;
}
+SKIP: {
+if('Pod::Usage'->isa('Pod::Text') && $Pod::Text::VERSION < 2.18) {
+ skip("Formatting with Pod::Text $Pod::Text::VERSION not reliable", 33);
+}
+
my ($exit, $text) = getoutput( sub { pod2usage() } );
is ($exit, 2, "Exit status pod2usage ()");
ok (compare ($text, <<'EOT'), "Output test pod2usage ()");
-message => 'You naughty person, what did you say?',
-verbose => 1 ) });
is ($exit, 1, "Exit status pod2usage (-message => '...', -verbose => 1)");
-ok (compare ($text, <<'EOT'), "Output test pod2usage (-message => '...', -verbose => 1)");
+ok (compare ($text, <<'EOT'), "Output test pod2usage (-message => '...', -verbose => 1)") or diag("Got:\n$text\n");
#You naughty person, what did you say?
# Usage:
# frobnicate [ -r | --recursive ] [ -f | --force ] file ...
#
EOT
+# does the __DATA__ work ok as input
+($exit, $text) = getoutput( sub { system($^X, '-Mblib', File::Spec->catfile(qw(t pod p2u_data.pl))); exit($? >> 8); } );
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+is ($exit, 17, "Exit status pod2usage (-verbose => 2, -input => \*DATA)");
+ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -input => \*DATA)") or diag "Got:\n$text\n";
+#NAME
+# Test
+#
+#SYNOPSIS
+# perl podusagetest.pl
+#
+#DESCRIPTION
+# This is a test.
+#
+EOT
+
+# test that SYNOPSIS and USAGE are printed
+($exit, $text) = getoutput( sub { pod2usage(-input => File::Spec->catfile(qw(t pod usage.pod)),
+ -exitval => 0, -verbose => 0); });
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+is ($exit, 0, "Exit status pod2usage with USAGE");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE") or diag "Got:\n$text\n";
+#Usage:
+# This is a test for CPAN#33020
+#
+#Usage:
+# And this will be also printed.
+#
+EOT
+# test that SYNOPSIS and USAGE are printed with options
+($exit, $text) = getoutput( sub { pod2usage(-input => File::Spec->catfile(qw(t pod usage.pod)),
+ -exitval => 0, -verbose => 1); });
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+is ($exit, 0, "Exit status pod2usage with USAGE and verbose=1");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=1") or diag "Got:\n$text\n";
+#Usage:
+# This is a test for CPAN#33020
+#
+#Usage:
+# And this will be also printed.
+#
+#Options:
+# And this with verbose == 1
+#
+EOT
+
+# test that only USAGE is printed when requested
+($exit, $text) = getoutput( sub { pod2usage(-input => File::Spec->catfile(qw(t pod usage.pod)),
+ -exitval => 0, -verbose => 99, -sections => 'USAGE'); });
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+is ($exit, 0, "Exit status pod2usage with USAGE and verbose=99");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=99") or diag "Got:\n$text\n";
+#Usage:
+# This is a test for CPAN#33020
+#
+EOT
+
+# test with pod_where
+use_ok('Pod::Find', qw(pod_where));
+($exit, $text) = getoutput( sub { pod2usage( -input => pod_where({-inc => 1}, 'Pod::Usage'),
+ -exitval => 0, -verbose => 0) } );
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+is ($exit, 0, "Exit status pod2usage with Pod::Find");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with Pod::Find") or diag "Got:\n$text\n";
+#Usage:
+# use Pod::Usage
+#
+# my $message_text = "This text precedes the usage message.";
+# my $exit_status = 2; ## The exit status to use
+# my $verbose_level = 0; ## The verbose level to use
+# my $filehandle = \*STDERR; ## The filehandle to write to
+#
+# pod2usage($message_text);
+#
+# pod2usage($exit_status);
+#
+# pod2usage( { -message => $message_text ,
+# -exitval => $exit_status ,
+# -verbose => $verbose_level,
+# -output => $filehandle } );
+#
+# pod2usage( -msg => $message_text ,
+# -exitval => $exit_status ,
+# -verbose => $verbose_level,
+# -output => $filehandle );
+#
+# pod2usage( -verbose => 2,
+# -noperldoc => 1 )
+#
+EOT
+
+# verify that sections are correctly found after nested headings
+($exit, $text) = getoutput( sub { pod2usage(-input => File::Spec->catfile(qw(t pod usage2.pod)),
+ -exitval => 0, -verbose => 99,
+ -sections => [qw(BugHeader BugHeader/.*')]) });
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+is ($exit, 0, "Exit status pod2usage with nested headings");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with nested headings") or diag "Got:\n$text\n";
+#BugHeader:
+# Some text
+#
+# BugHeader2:
+# More
+# Still More
+#
+EOT
+
+# Verify that =over =back work OK
+($exit, $text) = getoutput( sub {
+ pod2usage(-input => File::Spec->catfile(qw(t pod usage2.pod)),
+ -exitval => 0, -verbose => 99, -sections => 'BugHeader/BugHeader2') } );
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+is ($exit, 0, "Exit status pod2usage with over/back");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with over/back") or diag "Got:\n$text\n";
+# BugHeader2:
+# More
+# Still More
+#
+EOT
+
+# new array API for -sections
+($exit, $text) = getoutput( sub {
+ pod2usage(-input => File::Spec->catfile(qw(t pod usage2.pod)),
+ -exitval => 0, -verbose => 99, -sections => [qw(Heading-1/!.+ Heading-2/.+)]) } );
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+is ($exit, 0, "Exit status pod2usage with -sections => []");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with -sections => []") or diag "Got:\n$text\n";
+#Heading-1:
+# One
+# Two
+#
+# Heading-2.2:
+# More text.
+#
+EOT
+
+# allow subheadings in OPTIONS and ARGUMENTS
+($exit, $text) = getoutput( sub {
+ pod2usage(-input => File::Spec->catfile(qw(t pod usage2.pod)),
+ -exitval => 0, -verbose => 1) } );
+$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
+$text =~ s{[*](destination|files)[*]}{$1}g; # strip * chars
+is ($exit, 0, "Exit status pod2usage with subheadings in OPTIONS");
+ok (compare ($text, <<'EOT'), "Output test pod2usage with subheadings in OPTIONS") or diag "Got:\n$text\n";
+#Options and Arguments:
+# Arguments:
+# The required arguments (which typically follow any options on the
+# command line) are:
+#
+# destination
+# files
+#
+# Options:
+# Options may be abbreviated. Options which take values may be separated
+# from the values by whitespace or the "=" character.
+#
+EOT
+} # end SKIP
__END__
--- /dev/null
+#!/usr/bin/perl
+BEGIN {
+ use File::Basename;
+ my $THISDIR = dirname $0;
+ unshift @INC, $THISDIR;
+ require "testpchk.pl";
+ import TestPodChecker;
+}
+
+# this tests Pod::Checker accepts =encoding directive
+
+my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
+my $passed = testpodchecker \%options, $0;
+exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
+
+__END__
+
+=encoding utf8
+
+=encode utf8
+
+dummy error
+
+=head1 An example.
+
+'Twas brillig, and the slithy toves did gyre and gimble in the wabe.
+
+=cut
+
--- /dev/null
+*** ERROR: Unknown command 'encode' at line 20 in file t/pod/podchkenc.t
--- /dev/null
+=head1 NAME
+
+usage.pod - example for testing USAGE and SYNOPSIS
+
+=head1 USAGE
+
+This is a test for CPAN#33020
+
+=head1 SYNOPSIS
+
+And this will be also printed.
+
+=head1 OPTIONS
+
+And this with verbose == 1
+
+=cut
+
--- /dev/null
+=head1 Heading-1\r
+\r
+=over 100\r
+\r
+=item One\r
+\r
+=item Two\r
+\r
+=back\r
+\r
+=head2 Heading 2\r
+\r
+Some text\r
+\r
+=head1 BugHeader\r
+\r
+Some text\r
+\r
+=head2 BugHeader2\r
+\r
+=over 4\r
+\r
+=item More\r
+\r
+=item Still More\r
+\r
+=back\r
+\r
+=head1 Heading-2\r
+\r
+=head2 Heading-2.2\r
+\r
+More text.\r
+\r
+=head1 OPTIONS AND ARGUMENTS\r
+\r
+=head2 Arguments\r
+\r
+The required arguments (which typically follow any options on the\r
+command line) are:\r
+\r
+=over\r
+\r
+=item I<destination>\r
+\r
+=item I<files>\r
+\r
+=back\r
+\r
+=head2 Options\r
+\r
+Options may be abbreviated. Options which take values may be separated\r
+from the values by whitespace or the "=" character.\r
+\r
+=cut\r
+\r
projects / p5sagit/p5-mst-13.2.git / commitdiff