diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | lib/Pod/Checker.pm | 18 | ||||
| -rw-r--r-- | lib/Pod/InputObjects.pm | 2 | ||||
| -rw-r--r-- | lib/Pod/ParseUtils.pm | 6 | ||||
| -rw-r--r-- | lib/Pod/Parser.pm | 56 | ||||
| -rw-r--r-- | lib/Pod/Select.pm | 4 | ||||
| -rw-r--r-- | lib/Pod/Usage.pm | 38 | ||||
| -rw-r--r-- | t/pod/find.t | 31 | ||||
| -rw-r--r-- | t/pod/pod2usage2.t | 178 | ||||
| -rw-r--r-- | t/pod/poderrs.xr | 2 |
10 files changed, 264 insertions, 72 deletions
@@ -2976,6 +2976,7 @@ t/pod/oneline_cmds.t Test single paragraph ==cmds t/pod/oneline_cmds.xr Expected results for oneline_cmds.t t/pod/plainer.t Test Pod::Plainer t/pod/pod2usage.t Test Pod::Usage +t/pod/pod2usage2.t Test Pod::Usage t/pod/pod2usage.xr Expected results for pod2usage.t t/pod/poderrs.t Test POD errors t/pod/poderrs.xr Expected results for poderrs.t diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index f20fe84c4c..49162da4a2 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -10,7 +10,7 @@ package Pod::Checker; use vars qw($VERSION); -$VERSION = 1.42; ## Current version of this package +$VERSION = 1.43; ## Current version of this package require 5.005; ## requires this Perl version or later use Pod::ParseUtils; ## for hyperlinks and lists @@ -57,7 +57,7 @@ Curious/ambitious users are welcome to propose additional features they wish to see in B<Pod::Checker> and B<podchecker> and verify that the checks are consistent with L<perlpod>. -The following checks are currently preformed: +The following checks are currently performed: =over 4 @@ -142,7 +142,7 @@ There is no specification of the formatter after the C<=for> command. =item * unresolved internal link I<NAME> The given link to I<NAME> does not have a matching node in the current -POD. This also happens when a single word node name is not enclosed in +POD. This also happend when a single word node name is not enclosed in C<"">. =item * Unknown command "I<CMD>" @@ -234,7 +234,7 @@ C<=over>/C<=back> block. =item * =item type mismatch (I<one> vs. I<two>) -A list started with e.g. a bulleted C<=item> and continued with a +A list started with e.g. a bulletted C<=item> and continued with a numbered one. This is obviously inconsistent. For most translators the type of the I<first> C<=item> determines the type of the list. @@ -623,9 +623,11 @@ sub poderror { if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR')); ++($self->{_NUM_WARNINGS}) if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING')); - my $out_fh = $self->output_handle() || \*STDERR; - print $out_fh ($severity, $msg, $line, $file, "\n") - if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); + unless($self->{-quiet}) { + my $out_fh = $self->output_handle() || \*STDERR; + print $out_fh ($severity, $msg, $line, $file, "\n") + if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); + } } ################################## @@ -1101,7 +1103,7 @@ sub _check_ptree { } if($nestlist =~ /$cmd/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'ERROR', + -severity => 'WARNING', -msg => "nested commands $cmd<...$cmd<...>...>"}); # _TODO_ should we add the contents anyway? # expand it anyway, see below diff --git a/lib/Pod/InputObjects.pm b/lib/Pod/InputObjects.pm index 222061f55e..fa5f61f9a7 100644 --- a/lib/Pod/InputObjects.pm +++ b/lib/Pod/InputObjects.pm @@ -183,7 +183,7 @@ sub name { my $handle = $pod_input->handle(); Returns a reference to the handle object from which input is read (the -one used to construct this input source object). +one used to contructed this input source object). =end __PRIVATE__ diff --git a/lib/Pod/ParseUtils.pm b/lib/Pod/ParseUtils.pm index 64c92b6da6..878860121d 100644 --- a/lib/Pod/ParseUtils.pm +++ b/lib/Pod/ParseUtils.pm @@ -10,7 +10,7 @@ package Pod::ParseUtils; use vars qw($VERSION); -$VERSION = 1.30; ## Current version of this package +$VERSION = 1.33; ## Current version of this package require 5.005; ## requires this Perl version or later =head1 NAME @@ -357,7 +357,7 @@ sub parse { $type = 'item'; } # non-standard: Hyperlink - elsif(m!^((?:http|ftp|mailto|news):.+)$!i) { + elsif(m!^(\w+:[^:\s]\S*)$!i) { $node = $1; $type = 'hyperlink'; } @@ -371,7 +371,7 @@ sub parse { ($alttext, $node) = ($1,$2); } # nonstandard: alttext and hyperlink - elsif(m!^(.*?)\s*[|]\s*((?:http|ftp|mailto|news):.+)$!) { + elsif(m!^(.*?)\s*[|]\s*(\w+:[^:\s]\S*)$!) { ($alttext, $node) = ($1,$2); $type = 'hyperlink'; } diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm index 6c3f161815..a5fde84850 100644 --- a/lib/Pod/Parser.pm +++ b/lib/Pod/Parser.pm @@ -10,7 +10,7 @@ package Pod::Parser; use vars qw($VERSION); -$VERSION = 1.30; ## Current version of this package +$VERSION = 1.32; ## Current version of this package require 5.005; ## requires this Perl version or later ############################################################################# @@ -118,7 +118,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 preprocessing of input before it is parsed +If you need to perform any preprocesssing of input before it is parsed you may want to override one or more of B<preprocess_line()> and/or B<preprocess_paragraph()>. @@ -140,7 +140,7 @@ to avoid name collisions. For the most part, the B<Pod::Parser> base class should be able to do most of the input parsing for you and leave you free to worry about -how to interpret the commands and translate the result. +how to intepret the commands and translate the result. Note that all we have described here in this quick overview is the simplest most straightforward use of B<Pod::Parser> to do stream-based @@ -651,7 +651,7 @@ them in simple bottom-up order. The parameter C<$text> is a string or block of text to be parsed for interior sequences; and the parameter C<$line_num> is the -line number corresponding to the beginning of C<$text>. +line number curresponding to the beginning of C<$text>. B<parse_text()> will parse the given text into a parse-tree of "nodes." and interior-sequences. Each "node" in the parse tree is either a @@ -1066,7 +1066,6 @@ sub parse_from_filehandle { while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) { $textline = $self->preprocess_line($textline, ++$nlines); next unless ((defined $textline) && (length $textline)); - $_ = $paragraph; ## save previous contents if ((! length $paragraph) && ($textline =~ /^==/)) { ## '==' denotes a one-line command paragraph @@ -1157,20 +1156,13 @@ sub parse_from_file { my $self = shift; my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); my ($infile, $outfile) = @_; - my ($in_fh, $out_fh) = (gensym, gensym) if ($] < 5.6); + my ($in_fh, $out_fh) = (gensym(), gensym()) if ($] < 5.006); my ($close_input, $close_output) = (0, 0); local *myData = $self; local *_; ## Is $infile a filename or a (possibly implied) filehandle - $infile = '-' unless ((defined $infile) && (length $infile)); - if (($infile eq '-') || ($infile =~ /^<&(STDIN|0)$/i)) { - ## Not a filename, just a string implying STDIN - $infile ||= '-'; - $myData{_INFILE} = "<standard input>"; - $in_fh = \*STDIN; - } - elsif (ref $infile) { + if (defined $infile && ref $infile) { if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) { croak "Input from $1 reference not supported!\n"; } @@ -1179,6 +1171,14 @@ sub parse_from_file { $myData{_INFILE} = ${$infile}; $in_fh = $infile; } + elsif (!defined($infile) || !length($infile) || ($infile eq '-') + || ($infile =~ /^<&(?:STDIN|0)$/i)) + { + ## Not a filename, just a string implying STDIN + $infile ||= '-'; + $myData{_INFILE} = "<standard input>"; + $in_fh = \*STDIN; + } else { ## We have a filename, open it for reading $myData{_INFILE} = $infile; @@ -1194,20 +1194,7 @@ sub parse_from_file { ## already ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref? - if (!defined($outfile) || !length($outfile) || ($outfile eq '-') - || ($outfile =~ /^>&?(?:STDOUT|1)$/i)) - { - if (defined $myData{_TOP_STREAM}) { - $out_fh = $myData{_OUTPUT}; - } - else { - ## Not a filename, just a string implying STDOUT - $outfile ||= '-'; - $myData{_OUTFILE} = "<standard output>"; - $out_fh = \*STDOUT; - } - } - elsif (ref $outfile) { + if (ref $outfile) { ## we need to check for ref() first, as other checks involve reading if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) { croak "Output to $1 reference not supported!\n"; @@ -1227,6 +1214,19 @@ sub parse_from_file { $out_fh = $outfile; } } + elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-') + || ($outfile =~ /^>&?(?:STDOUT|1)$/i)) + { + if (defined $myData{_TOP_STREAM}) { + $out_fh = $myData{_OUTPUT}; + } + else { + ## Not a filename, just a string implying STDOUT + $outfile ||= '-'; + $myData{_OUTFILE} = "<standard output>"; + $out_fh = \*STDOUT; + } + } elsif ($outfile =~ /^>&(STDERR|2)$/i) { ## Not a filename, just a string implying STDERR $myData{_OUTFILE} = "<standard error>"; diff --git a/lib/Pod/Select.pm b/lib/Pod/Select.pm index d0cbec6901..1cc14dff4b 100644 --- a/lib/Pod/Select.pm +++ b/lib/Pod/Select.pm @@ -428,7 +428,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 explicitly selected/deselected sections). +there are no explictly 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 @@ -575,7 +575,7 @@ are used. All other arguments should correspond to the names of input files containing POD sections. A file name of "-" or "<&STDIN" will -be interpreted to mean standard input (which is the default if no +be interpeted to mean standard input (which is the default if no filenames are given). =cut diff --git a/lib/Pod/Usage.pm b/lib/Pod/Usage.pm index 0827dcc4d2..c298e941f2 100644 --- a/lib/Pod/Usage.pm +++ b/lib/Pod/Usage.pm @@ -10,7 +10,7 @@ package Pod::Usage; use vars qw($VERSION); -$VERSION = 1.30; ## Current version of this package +$VERSION = 1.33; ## Current version of this package require 5.005; ## requires this Perl version or later =head1 NAME @@ -40,6 +40,9 @@ Pod::Usage, pod2usage() - print a usage message from embedded pod documentation -verbose => $verbose_level, -output => $filehandle ); + pod2usage( -verbose => 2, + -noperldoc => 1 ) + =head1 ARGUMENTS B<pod2usage> should be given either a single argument, or a list of @@ -94,7 +97,8 @@ is 1, then the "SYNOPSIS" section, along with any section entitled corresponding value is 2 or more then the entire manpage is printed. The special verbosity level 99 requires to also specify the -section -parameter; then these sections are extracted and printed. +parameter; then these sections are extracted (see L<Pod::Select>) +and printed. =item C<-section> @@ -123,6 +127,14 @@ to an array, or by a string of directory paths which use the same path separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for MSWin32 and DOS). +=item C<-noperldoc> + +By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is +specified. This does not work well e.g. if the script was packed +with L<PAR>. The -noperldoc option suppresses the external call to +L<perldoc> and uses the simple text formatter (L<Pod::Text>) to +output the POD. + =back =head1 DESCRIPTION @@ -200,8 +212,8 @@ to C<STDOUT>, just in case the user wants to pipe the output to a pager =item * If program usage has been explicitly requested by the user, it is often -desirable to exit with a status of 1 (as opposed to 0) after issuing -the user-requested usage message. It is also desirable to give a +desireable to exit with a status of 1 (as opposed to 0) after issuing +the user-requested usage message. It is also desireable to give a more verbose description of program usage in this case. =back @@ -387,6 +399,11 @@ similar to the following: pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs"); +In the pathological case that a script is called via a relative path +I<and> the script itself changes the current working directory +(see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will +fail even on robust platforms. Don't do that. + =head1 AUTHOR Please report bugs using L<http://rt.cpan.org>. @@ -433,7 +450,7 @@ BEGIN { ##--------------------------------- sub pod2usage { - local($_) = shift || ""; + local($_) = shift; my %opts; ## Collect arguments if (@_ > 0) { @@ -441,6 +458,9 @@ sub pod2usage { ## the user forgot to pass a reference to it. %opts = ($_, @_); } + elsif (!defined $_) { + $_ = ""; + } elsif (ref $_) { ## User passed a ref to a hash %opts = %{$_} if (ref($_) eq 'HASH'); @@ -503,7 +523,7 @@ sub pod2usage { ## 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"); + $parser->select('SYNOPSIS\s*'); } elsif ($opts{"-verbose"} == 1) { my $opt_re = '(?i)' . @@ -517,7 +537,8 @@ sub pod2usage { } ## Now translate the pod document and then exit with the desired status - if ( $opts{"-verbose"} >= 2 + if ( !$opts{"-noperldoc"} + and $opts{"-verbose"} >= 2 and !ref($opts{"-input"}) and $opts{"-output"} == \*STDOUT ) { @@ -562,6 +583,9 @@ sub select { } } +# Override Pod::Text->seq_i to return just "arg", not "*arg*". +sub seq_i { return $_[1] } + # This overrides the Pod::Text method to do something very akin to what # Pod::Select did as well as the work done below by preprocess_paragraph. # Note that the below is very, very specific to Pod::Text. diff --git a/t/pod/find.t b/t/pod/find.t index 20586014f1..66b65c5c39 100644 --- a/t/pod/find.t +++ b/t/pod/find.t @@ -88,7 +88,6 @@ print "### found $result\n"; require Config; if ($^O eq 'VMS') { # privlib is perl_root:[lib] OK but not under mms - $result = VMS::Filespec::vmsify($result); #if you want VMS you need to force it. $compare = "lib.File]Find.pm"; $result =~ s/perl_root:\[\-?\.?//i; $result =~ s/\[\-?\.?//i; # needed under `mms test` @@ -102,31 +101,19 @@ else { } # Search for a documentation pod rather than a module -my $searchpod = $ENV{PERL_CORE} ? 'Stuff' : 'perlfunc'; +my $searchpod = 'Stuff'; print "### searching for $searchpod.pod\n"; -$result = pod_where($ENV{PERL_CORE} ? - { -dirs => [ File::Spec->catdir('pod', 'testpods', 'lib', 'Pod') ], - -verbose => $VERBOSE } - : { -inc => 1, -verbose => $VERBOSE }, $searchpod) +$result = pod_where( + { -dirs => [ File::Spec->catdir( + $ENV{PERL_CORE} ? () : qw(t), 'pod', 'testpods', 'lib', 'Pod') ], + -verbose => $VERBOSE }, $searchpod) || "undef - $searchpod.pod not found!"; print "### found $result\n"; -if($ENV{PERL_CORE}) { - $compare = File::Spec->catfile('pod', 'testpods', 'lib', 'Pod' ,'Stuff.pm'); - ok(_canon($result),_canon($compare)); -} -elsif ($^O eq 'VMS') { # privlib is perl_root:[lib] unfortunately - $compare = "/lib/pod/perlfunc.pod"; - $result = VMS::Filespec::unixify($result); - $result =~ s/perl_root\///i; - $result =~ s/^\.\.//; # needed under `mms test` - ok($result,$compare); -} -else { - $compare = File::Spec->catfile($Config::Config{privlib}, - ($^O =~ /macos|darwin|cygwin/i ? 'pods' : 'pod'),"perlfunc.pod"); - ok(_canon($result),_canon($compare)); -} +$compare = File::Spec->catfile( + $ENV{PERL_CORE} ? () : qw(t), + 'pod', 'testpods', 'lib', 'Pod' ,'Stuff.pm'); +ok(_canon($result),_canon($compare)); # make the path as generic as possible sub _canon diff --git a/t/pod/pod2usage2.t b/t/pod/pod2usage2.t new file mode 100644 index 0000000000..04890f207f --- /dev/null +++ b/t/pod/pod2usage2.t @@ -0,0 +1,178 @@ +#!/usr/bin/perl -w + +use Test; + +BEGIN { + plan tests => 8; +} + +eval "use Pod::Usage"; + +ok($@ eq ''); + +sub getoutput +{ + my ($code) = @_; + my $pid = open(IN, "-|"); + unless(defined $pid) { + die "Cannot fork: $!"; + } + if($pid) { + # parent + my @out = <IN>; + close(IN); + my $exit = $?>>8; + print "\nEXIT=$exit OUTPUT=+++\n@out+++\n"; + return($exit, join("",@out)); + } + # child + open(STDERR, ">&STDOUT"); + &$code; + print "--NORMAL-RETURN--\n"; + exit 0; +} + +sub compare +{ + my ($left,$right) = @_; + $left =~ s/[
\n]+/\n/sg; + $right =~ s/[
\n]+/\n/sg; + $left =~ s/\s+/ /gm; + $right =~ s/\s+/ /gm; + $left eq $right; +} + +# test 2 +my ($exit, $text) = getoutput( sub { pod2usage() } ); +ok($exit == 2 && compare($text, <<'EOT')); +Usage: + frobnicate [ -r | --recursive ] [ -f | --force ] [ -n number ] file ... + +EOT + +# test 3 +($exit, $text) = getoutput( sub { pod2usage( + -message => 'You naughty person, what did you say?', + -verbose => 1 ) } ); +ok($exit == 1 && compare($text,<<'EOT')); +You naughty person, what did you say? + Usage: + frobnicate [ -r | --recursive ] [ -f | --force ] [ -n number ] file ... + + Options: + -r | --recursive + Run recursively. + + -f | --force + Just do it! + + -n number + Specify number of frobs, default is 42. + +EOT + +# test 4 +($exit, $text) = getoutput( sub { pod2usage( + -verbose => 2, -exit => 42 ) } ); +ok($exit == 42 && compare($text,<<'EOT')); +NAME + frobnicate - do what I mean + + SYNOPSIS + frobnicate [ -r | --recursive ] [ -f | --force ] [ -n number ] file ... + + DESCRIPTION + frobnicate does foo and bar and what not. + + OPTIONS + -r | --recursive + Run recursively. + + -f | --force + Just do it! + + -n number + Specify number of frobs, default is 42. + +EOT + +# test 5 +($exit, $text) = getoutput( sub { pod2usage(0) } ); +ok($exit == 0 && compare($text, <<'EOT')); +Usage: + frobnicate [ -r | --recursive ] [ -f | --force ] [ -n number ] file ... + + Options: + -r | --recursive + Run recursively. + + -f | --force + Just do it! + + -n number + Specify number of frobs, default is 42. + +EOT + +# test 6 +($exit, $text) = getoutput( sub { pod2usage(42) } ); +ok($exit == 42 && compare($text, <<'EOT')); +Usage: + frobnicate [ -r | --recursive ] [ -f | --force ] [ -n number ] file ... + +EOT + +# test 7 +($exit, $text) = getoutput( sub { pod2usage(-verbose => 0, -exit => 'NOEXIT') } ); +ok($exit == 0 && compare($text, <<'EOT')); +Usage: + frobnicate [ -r | --recursive ] [ -f | --force ] [ -n number ] file ... + + --NORMAL-RETURN-- +EOT + +# test 8 +($exit, $text) = getoutput( sub { pod2usage(-verbose => 99, -sections => 'DESCRIPTION') } ); +ok($exit == 1 && compare($text, <<'EOT')); +Description: + frobnicate does foo and bar and what not. + +EOT + + + +__END__ + +=head1 NAME + +frobnicate - do what I mean + +=head1 SYNOPSIS + +B<frobnicate> S<[ B<-r> | B<--recursive> ]> S<[ B<-f> | B<--force> ]> + S<[ B<-n> I<number> ]> I<file> ... + +=head1 DESCRIPTION + +B<frobnicate> does foo and bar and what not. + +=head1 OPTIONS + +=over 4 + +=item B<-r> | B<--recursive> + +Run recursively. + +=item B<-f> | B<--force> + +Just do it! + +=item B<-n> I<number> + +Specify number of frobs, default is 42. + +=back + +=cut + diff --git a/t/pod/poderrs.xr b/t/pod/poderrs.xr index a8ef58bfb5..5b40d7a138 100644 --- a/t/pod/poderrs.xr +++ b/t/pod/poderrs.xr @@ -17,7 +17,7 @@ *** ERROR: =end without =begin at line 77 in file t/pod/poderrs.t *** ERROR: No argument for =begin at line 83 in file t/pod/poderrs.t *** ERROR: =for without formatter specification at line 89 in file t/pod/poderrs.t -*** ERROR: nested commands C<...C<...>...> at line 95 in file t/pod/poderrs.t +*** WARNING: nested commands C<...C<...>...> at line 95 in file t/pod/poderrs.t *** ERROR: garbled entity E<alea iacta est> at line 99 in file t/pod/poderrs.t *** ERROR: garbled entity E<C<auml>> at line 100 in file t/pod/poderrs.t *** ERROR: garbled entity E<abcI<bla>> at line 101 in file t/pod/poderrs.t |