From: Gurusamy Sarathy Date: Wed, 2 Feb 2000 09:55:45 +0000 (+0000) Subject: PodParser-1.092 update via CPAN (from Brad Appleton) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e2c3adefd8c31a020997b83179ab5ab417e7e4ac;p=p5sagit%2Fp5-mst-13.2.git PodParser-1.092 update via CPAN (from Brad Appleton) p4raw-id: //depot/perl@4961 --- diff --git a/MANIFEST b/MANIFEST index a6506d8..938a0c0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -626,10 +626,12 @@ lib/Net/netent.pm By-name interface to Perl's builtin getnet* lib/Net/protoent.pm By-name interface to Perl's builtin getproto* lib/Net/servent.pm By-name interface to Perl's builtin getserv* lib/Pod/Checker.pm Pod-Parser - check POD documents for syntax errors +lib/Pod/Find.pm used by pod/splitpod lib/Pod/Functions.pm used by pod/splitpod lib/Pod/Html.pm Convert POD data to HTML lib/Pod/InputObjects.pm Pod-Parser - define objects for input streams lib/Pod/Man.pm Convert POD data to *roff +lib/Pod/ParseUtils.pm Pod-Parser - pod utility functions lib/Pod/Parser.pm Pod-Parser - define base class for parsing POD lib/Pod/Select.pm Pod-Parser - select portions of POD docs lib/Pod/Text.pm Pod-Parser - convert POD data to formatted ASCII text diff --git a/lib/Pod/Checker.pm b/lib/Pod/Checker.pm index aa5c549..c661c75 100644 --- a/lib/Pod/Checker.pm +++ b/lib/Pod/Checker.pm @@ -10,9 +10,11 @@ package Pod::Checker; use vars qw($VERSION); -$VERSION = 1.090; ## Current version of this package +$VERSION = 1.096; ## Current version of this package require 5.004; ## requires this Perl version or later +use Pod::ParseUtils; ## for hyperlinks and lists + =head1 NAME Pod::Checker, podchecker() - check pod documents for syntax errors @@ -23,15 +25,19 @@ Pod::Checker, podchecker() - check pod documents for syntax errors $syntax_okay = podchecker($filepath, $outputpath, %options); + my $checker = new Pod::Checker %options; + =head1 OPTIONS/ARGUMENTS C<$filepath> is the input POD to read and C<$outputpath> is where to write POD syntax error messages. Either argument may be a scalar -indcating a file-path, or else a reference to an open filehandle. +indicating a file-path, or else a reference to an open filehandle. If unspecified, the input-file it defaults to C<\*STDIN>, and the output-file defaults to C<\*STDERR>. -=head2 Options +=head2 podchecker() + +This function can take a hash of options: =over 4 @@ -45,20 +51,25 @@ Turn warnings on/off. See L<"Warnings">. B will perform syntax checking of Perl5 POD format documentation. -I -As of this writing, all it does is check for unknown '=xxxx' commands, -unknown 'X<...>' interior-sequences, and unterminated interior sequences. +I It is hoped that curious/ambitious user will help flesh out and add the -additional features they wish to see in B and B. +additional features they wish to see in B and B +and verify that the checks are consistent with L. -The following additional checks are preformed: +The following checks are preformed: =over 4 =item * -Check for proper balancing of C<=begin> and C<=end>. +Unknown '=xxxx' commands, unknown 'X<...>' interior-sequences, +and unterminated interior sequences. + +=item * + +Check for proper balancing of C<=begin> and C<=end>. The contents of such +a block are generally ignored, i.e. no syntax checks are performed. =item * @@ -66,55 +77,156 @@ Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>. =item * -Check for same nested interior-sequences (e.g. C...LE...E...E>). +Check for same nested interior-sequences (e.g. +C...LE...E...E>). =item * -Check for malformed entities. +Check for malformed or nonexisting entities C...E>. =item * -Check for correct syntax of hyperlinks CE>. See L for -details. +Check for correct syntax of hyperlinks C...E>. See L +for details. =item * -Check for unresolved document-internal links. +Check for unresolved document-internal links. This check may also reveal +misspelled links that seem to be internal links but should be links +to something else. =back -=head2 Warnings +=head2 Additional Features + +While checking, this module collects document properties, e.g. the nodes +for hyperlinks (C<=headX>, C<=item>). POD translators can use this feature +to syntax-check and get the nodes in a first pass before actually starting +to convert. This is expensive in terms of execution time, but allows for +very robust conversions. + +=head1 DIAGNOSTICS -The following warnings are printed. These may not necessarily cause trouble, -but indicate mediocre style. +=head2 Errors =over 4 -=item * +=item * =over on line I without closing =back -Spurious characters after C<=back> and C<=end>. +The C<=over> command does not have a corresponding C<=back> before the +next heading (C<=head1> or C<=head2>) or the end of the file. -=item * +=item * =item without previous =over -Unescaped C> and C> in the text. +=item * =back without previous =over -=item * +An C<=item> or C<=back> command has been found outside a +C<=over>/C<=back> block. -Missing arguments for C<=begin> and C<=over>. +=item * No argument for =begin -=item * +A C<=begin> command was found that is not followed by the formatter +specification. -Empty C<=over> / C<=back> list. +=item * =end without =begin -=item * +A standalone C<=end> command was found. + +=item * Nested =begin's + +There were at least two concecutive C<=begin> commands without +the corresponding C<=end>. Only one C<=begin> may be active at +a time. + +=item * =for without formatter specification -Hyperlinks: leading/trailing whitespace, brackets C<()> in the page name. +There is no specification of the formatter after the C<=for> command. + +=item * unresolved internal link I + +The given link to I does not have a matching node in the current +POD. This also happend when a single word node name is not enclosed in +C<"">. + +=item * Unknown command "I" + +An invalid POD command has been found. Valid are C<=head1>, C<=head2>, +C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, C<=for>, C<=pod>, +C<=cut> + +=item * Unknown interior-sequence "I" + +An invalid markup command has been encountered. Valid are: +CE>, CE>, CE>, CE>, +CE>, CE>, CE>, CE>, +CE> + +=item * nested commands IE...IE...E...E + +Two nested identical markup commands have been found. Generally this +does not make sense. + +=item * garbled entity I + +The I found cannot be interpreted as an character entity. + +=item * malformed link LEE + +The link found cannot be parsed because it does not conform to the +syntax described in L. =back -=head1 DIAGNOSTICS +=head2 Warnings -I<[T.B.D.]> +These may not necessarily cause trouble, but indicate mediocre style. + +=over 4 + +=item * No numeric argument for =over + +The C<=over> command is supposed to have a numeric argument (the +indentation). + +=item * Spurious character(s) after =back + +The C<=back> command does not take any arguments. + +=item * I unescaped CE> in paragraph + +Angle brackets not written as CltE> and CgtE> +can potentially cause errors as they could be misinterpreted as +markup commands. + +=item * Non-standard entity + +A character entity was found that does not belong to the standard +ISO set. + +=item * No items in =over + +The list does not contain any items. + +=item * No argument for =item + +C<=item> without any parameters is deprecated. It should either be followed +by C<*> to indicate an unordered list, by a number (optionally followed +by a dot) to indicate an ordered (numbered) list or simple text for a +definition list. + +=item * Verbatim paragraph in NAME section + +The NAME section (C<=head1 NAME>) should consist of a single paragraph +with the script/module name, followed by a dash `-' and a very short +description of what the thing is good for. + +=item * Hyperlinks + +There are some warnings wrt. hyperlinks: +Leading/trailing whitespace, newlines in hyperlinks, +brackets C<()>. + +=back =head1 RETURN VALUE @@ -174,6 +286,117 @@ my %VALID_SEQUENCES = ( 'E' => 1, ); +# stolen from HTML::Entities +my %ENTITIES = ( + # Some normal chars that have special meaning in SGML context + 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 + + # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) + copy => '©', # copyright sign + reg => '®', # registered sign + nbsp => "\240", # non breaking space + + # Additional ISO-8859/1 entities listed in rfc1866 (section 14) + iexcl => '¡', + cent => '¢', + pound => '£', + curren => '¤', + yen => '¥', + brvbar => '¦', + sect => '§', + uml => '¨', + ordf => 'ª', + laquo => '«', +'not' => '¬', # not is a keyword in perl + shy => '­', + macr => '¯', + deg => '°', + plusmn => '±', + sup1 => '¹', + sup2 => '²', + sup3 => '³', + acute => '´', + micro => 'µ', + para => '¶', + middot => '·', + cedil => '¸', + ordm => 'º', + raquo => '»', + frac14 => '¼', + frac12 => '½', + frac34 => '¾', + iquest => '¿', +'times' => '×', # times is a keyword in perl + divide => '÷', +); + ##--------------------------------------------------------------------------- ##--------------------------------- @@ -219,16 +442,18 @@ sub initialize { ## Initialize number of errors, and setup an error function to ## increment this number and then print to the designated output. $self->{_NUM_ERRORS} = 0; - $self->errorsub('poderror'); + $self->errorsub('poderror'); # set the error handling subroutine $self->{_commands} = 0; # total number of POD commands encountered $self->{_list_stack} = []; # stack for nested lists $self->{_have_begin} = ''; # stores =begin $self->{_links} = []; # stack for internal hyperlinks $self->{_nodes} = []; # stack for =head/=item nodes + # print warnings? $self->{-warnings} = 1 unless(defined $self->{-warnings}); + $self->{_current_head1} = ''; # the current =head1 block } -## Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) +# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) sub poderror { my $self = shift; my %opts = (ref $_[0]) ? %{shift()} : (); @@ -243,13 +468,43 @@ sub poderror { ++($self->{_NUM_ERRORS}) if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR')); my $out_fh = $self->output_handle(); - print $out_fh ($severity, $msg, $line, $file, "\n"); + print $out_fh ($severity, $msg, $line, $file, "\n") + if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); } +# set/retrieve the number of errors found sub num_errors { return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS}; } +# set and/or retrieve canonical name of POD +sub name { + return (@_ > 1 && $_[1]) ? + ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; +} + +# set/return nodes of the current POD +sub node { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/[\s\n]+$//; # strip trailing whitespace + # add node + push(@{$self->{_nodes}}, $text); + return $text; + } + @{$self->{_nodes}}; +} + +# set/return hyperlinks of the current POD +sub hyperlink { + my $self = shift; + if($_[0]) { + push(@{$self->{_links}}, $_[0]); + return $_[0]; + } + @{$self->{_links}}; +} + ## overrides for Pod::Parser sub end_pod { @@ -273,7 +528,6 @@ sub end_pod { # first build the node names from the paragraph text my %nodes; foreach($self->node()) { - #print "Have node: +$_+\n"; $nodes{$_} = 1; if(/^(\S+)\s+/) { # we have more than one word. Use the first as a node, too. @@ -282,7 +536,6 @@ sub end_pod { } } foreach($self->hyperlink()) { - #print "Seek node: +$_+\n"; my $line = ''; s/^(\d+):// && ($line = $1); if($_ && !$nodes{$_}) { @@ -307,6 +560,7 @@ sub end_pod { } } +# check a POD command directive sub command { my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_; my ($file, $line) = $pod_para->file_line; @@ -320,32 +574,47 @@ sub command { $self->{_commands}++; # found a valid command ## check syntax of particular command if($cmd eq 'over') { + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line,$file); + my $indent = 4; # default + if($arg && $arg =~ /^\s*(\d+)\s*$/) { + $indent = $1; + } else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "No numeric argument for =over"}); + } # start a new list - unshift(@{$self->{_list_stack}}, - Pod::List->new( - -indent => $paragraph, + unshift(@{$self->{_list_stack}}, Pod::List->new( + -indent => $indent, -start => $line, -file => $file)); } elsif($cmd eq 'item') { + # are we in a list? unless(@{$self->{_list_stack}}) { $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', -msg => "=item without previous =over" }); + # auto-open in case we encounter many more + unshift(@{$self->{_list_stack}}, + Pod::List->new( + -indent => 'auto', + -start => $line, + -file => $file)); } - else { - # check for argument - $arg = $self->_interpolate_and_check($paragraph, $line, $file); - unless($arg && $arg =~ /(\S+)/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "No argument for =item" }); - } - # add this item - $self->{_list_stack}[0]->item($arg || ''); - # remember this node - $self->node($arg) if($arg); + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line, $file); + unless($arg && $arg =~ /(\S+)/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "No argument for =item" }); + $arg = ' '; # empty } + # add this item + $self->{_list_stack}[0]->item($arg); + # remember this node + $self->node($arg); } elsif($cmd eq 'back') { # check if we have an open list @@ -356,7 +625,7 @@ sub command { } else { # check for spurious characters - $arg = $self->_interpolate_and_check($paragraph, $line,$file); + $arg = $self->interpolate_and_check($paragraph, $line,$file); if($arg && $arg =~ /\S/) { $self->poderror({ -line => $line, -file => $file, -severity => 'WARNING', @@ -380,13 +649,19 @@ sub command { while($list = shift(@{$self->{_list_stack}})) { $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', - -msg => "unclosed =over (line ". $list->start() . - ") at $cmd" }); + -msg => "=over on line ". $list->start() . + " without closing =back (at $cmd)" }); } } # remember this node - $arg = $self->_interpolate_and_check($paragraph, $line,$file); + $arg = $self->interpolate_and_check($paragraph, $line,$file); $self->node($arg) if($arg); + if($cmd eq 'head1') { + $arg =~ s/[\s\n]+$//; + $self->{_current_head1} = $arg; + } else { + $self->{_current_head1} = ''; + } } elsif($cmd eq 'begin') { if($self->{_have_begin}) { @@ -398,10 +673,10 @@ sub command { } else { # check for argument - $arg = $self->_interpolate_and_check($paragraph, $line,$file); + $arg = $self->interpolate_and_check($paragraph, $line,$file); unless($arg && $arg =~ /(\S+)/) { $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -severity => 'ERROR', -msg => "No argument for =begin"}); } # remember the =begin @@ -413,27 +688,37 @@ sub command { # close the existing =begin $self->{_have_begin} = ''; # check for spurious characters - $arg = $self->_interpolate_and_check($paragraph, $line,$file); - if($arg && $arg =~ /\S/) { - $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', - -msg => "Spurious character(s) after =end" }); - } + $arg = $self->interpolate_and_check($paragraph, $line,$file); + # the closing argument is optional + #if($arg && $arg =~ /\S/) { + # $self->poderror({ -line => $line, -file => $file, + # -severity => 'WARNING', + # -msg => "Spurious character(s) after =end" }); + #} } else { # don't have a matching =begin $self->poderror({ -line => $line, -file => $file, - -severity => 'WARNING', + -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" }); + } + $arg = ''; # do not expand paragraph below + } ## Check the interior sequences in the command-text - $self->_interpolate_and_check($paragraph, $line,$file) + $self->interpolate_and_check($paragraph, $line,$file) unless(defined $arg); + } } -sub _interpolate_and_check { +# process a block of some text +sub interpolate_and_check { my ($self, $paragraph, $line, $file) = @_; ## Check the interior sequences in the command-text # and return the text @@ -452,10 +737,11 @@ sub _check_ptree { my $count; # count the unescaped angle brackets my $i = $_; - if($count = $i =~ s/[<>]/$self->expand_unescaped_bracket($&)/ge) { + if($count = $i =~ tr/<>/<>/) { $self->poderror({ -line => $line, -file => $file, -severity => 'WARNING', - -msg => "$count unescaped <>" }); + -msg => "$count unescaped <> in paragraph" }) + if($self->{-warnings}); } $text .= $i; next; @@ -488,7 +774,21 @@ sub _check_ptree { -msg => "garbled entity " . $_->raw_text()}); next; } - $text .= $self->expand_entity($$contents[0]); + my $ent = $$contents[0]; + if($ent =~ /^\d+$/) { + # numeric entity + $text .= chr($ent); + } + elsif($ENTITIES{$ent}) { + # known ISO entity + $text .= $ENTITIES{$ent}; + } + else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "Non-standard entity " . $_->raw_text()}); + $text .= "E<$ent>"; + } } elsif($cmd eq 'L') { # try to parse the hyperlink @@ -496,7 +796,7 @@ sub _check_ptree { unless(defined $link) { $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', - -msg => "malformed link L<>: $@"}); + -msg => "malformed link " . $_->raw_text() ." : $@"}); next; } $link->line($line); # remember line @@ -511,13 +811,14 @@ sub _check_ptree { $text .= $self->_check_ptree($self->parse_text($link->text(), $line), $line, $file, "$nestlist$cmd"); my $node = ''; - $node = $self->_check_ptree($self->parse_text($link->node(), - $line), $line, $file, "$nestlist$cmd") - if($link->node()); - # store internal link + # remember internal link # _TODO_ what if there is a link to the page itself by the name, - # e.g. Tk::Pod : L - $self->hyperlink("$line:$node") if($node && !$link->page()); + # e.g. in Tk::Pod : L + if($link->node() && !$link->page() && $link->type() ne 'hyperlink') { + $node = $self->_check_ptree($self->parse_text($link->node(), + $line), $line, $file, "$nestlist$cmd"); + $self->hyperlink("$line:$node") if($node); + } } elsif($cmd =~ /[BCFIS]/) { # add the guts @@ -531,397 +832,35 @@ sub _check_ptree { $text; } -# default method - just return it -sub expand_unescaped_bracket { - my ($self,$bracket) = @_; - $bracket; -} - -# keep the entities -sub expand_entity { - my ($self,$entity) = @_; - "E<$entity>"; -} - -# _TODO_ overloadable methods for BC..Z<...> expansion +# _TODO_ overloadable methods for BC..Z<...> expansion? +# process a block of verbatim text sub verbatim { ## Nothing to check - ## my ($self, $paragraph, $line_num, $pod_para) = @_; + my ($self, $paragraph, $line_num, $pod_para) = @_; + if($self->{_current_head1} eq 'NAME') { + my ($file, $line) = $pod_para->file_line; + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'Verbatim paragraph in NAME section' }); + } } +# process a block of regular text sub textblock { my ($self, $paragraph, $line_num, $pod_para) = @_; my ($file, $line) = $pod_para->file_line; - $self->_interpolate_and_check($paragraph, $line,$file); -} - -# set/return nodes of the current POD -sub node { - my ($self,$text) = @_; - if(defined $text) { - $text =~ s/[\s\n]+$//; # strip trailing whitespace - # add node - push(@{$self->{_nodes}}, $text); - return $text; - } - @{$self->{_nodes}}; -} - -# set/return hyperlinks of the current POD -sub hyperlink { - my $self = shift; - if($_[0]) { - push(@{$self->{_links}}, $_[0]); - return $_[0]; - } - @{$self->{_links}}; -} - -#----------------------------------------------------------------------------- -# Pod::List -# -# class to hold POD list info (=over, =item, =back) -#----------------------------------------------------------------------------- - -package Pod::List; - -use Carp; - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->{-file} ||= 'unknown'; - $self->{-start} ||= 'unknown'; - $self->{-indent} ||= 4; # perlpod: "should be the default" - $self->{_items} = []; -} - -# The POD file name the list appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -# The line in the file the node appears -sub start { - return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; -} - -# indent level -sub indent { - return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; -} - -# The individual =items of this list -sub item { - my ($self,$item) = @_; - if(defined $item) { - push(@{$self->{_items}}, $item); - return $item; - } - else { - return @{$self->{_items}}; - } -} - -#----------------------------------------------------------------------------- -# Pod::Hyperlink -# -# class to hold hyperlinks (L<>) -#----------------------------------------------------------------------------- - -package Pod::Hyperlink; - -=head1 NAME - -Pod::Hyperlink - class for manipulation of POD hyperlinks - -=head1 SYNOPSIS - - my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); - -=head1 DESCRIPTION - -The B class is mainly designed to parse the contents of the -C...E> sequence, providing a simple interface for accessing the -different parts of a POD hyperlink. - -=head1 METHODS - -=over 4 - -=item new() - -The B method can either be passed a set of key/value pairs or a single -scalar value, namely the contents of a C...E> sequence. An object -of the class C is returned. The value C indicates a -failure, the error message is stored in C<$@>. - -=item parse() - -This method can be used to (re)parse a (new) hyperlink. The result is stored -in the current object. - -=item markup($on,$off,$pageon,$pageoff) - -The result of this method is a string the represents the textual value of the -link, but with included arbitrary markers that highlight the active portion -of the link. This will mainly be used by POD translators and saves the -effort of determining which words have to be highlighted. Examples: Depending -on the type of link, the following text will be returned, the C<*> represent -the places where the section/item specific on/off markers will be placed -(link to a specific node) and C<+> for the pageon/pageoff markers (link to the -top of the page). - - the +perl+ manpage - the *$|* entry in the +perlvar+ manpage - the section on *OPTIONS* in the +perldoc+ manpage - the section on *DESCRIPTION* elsewhere in this document - -This method is read-only. - -=item text() - -This method returns the textual representation of the hyperlink as above, -but without markers (read only). - -=item warning() - -After parsing, this method returns any warnings ecountered during the -parsing process. - -=item page() - -This method sets or returns the POD page this link points to. - -=item node() - -As above, but the destination node text of the link. - -=item type() - -The node type, either C
or C. - -=item alttext() - -Sets or returns an alternative text specified in the link. -=item line(), file() - -Just simple slots for storing information about the line and the file -the link was incountered in. Has to be filled in manually. - -=back - -=head1 AUTHOR - -Marek Rouchal Emarek@saftsack.fs.uni-bayreuth.deE, borrowing -a lot of things from L and L. - -=cut - -use Carp; - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = +{}; - bless $self, $class; - $self->initialize(); - if(defined $_[0]) { - if(ref($_[0])) { - # called with a list of parameters - %$self = %{$_[0]}; - } - else { - # called with L<> contents - return undef unless($self->parse($_[0])); - } - } - return $self; -} - -sub initialize { - my $self = shift; - $self->{-line} ||= 'undef'; - $self->{-file} ||= 'undef'; - $self->{-page} ||= ''; - $self->{-node} ||= ''; - $self->{-alttext} ||= ''; - $self->{-type} ||= 'undef'; - $self->{_warnings} = []; - $self->_construct_text(); -} - -sub parse { - my $self = shift; - local($_) = $_[0]; - # syntax check the link and extract destination - my ($alttext,$page,$section,$item) = ('','','',''); - - # strip leading/trailing whitespace - if(s/^[\s\n]+//) { - $self->warning("ignoring leading whitespace in link"); - } - if(s/[\s\n]+$//) { - $self->warning("ignoring trailing whitespace in link"); - } - - # collapse newlines with whitespace - s/\s*\n\s*/ /g; - - # extract alternative text - if(s!^([^|/"\n]*)[|]!!) { - $alttext = $1; - } - # extract page - if(s!^([^|/"\s]*)(?=/|$)!!) { - $page = $1; - } - # extract section - if(s!^/?"([^"\n]+)"$!!) { # e.g. L - $section = $1; - } - # extact item - if(s!^/(.*)$!!) { - $item = $1; - } - # last chance here - if(s!^([^|"\s\n/][^"\n/]*)$!!) { # e.g. L - $section = $1; - } - # now there should be nothing left - if(length) { - _invalid_link("garbled entry (spurious characters `$_')"); - return undef; - } - elsif(!(length($page) || length($section) || length($item))) { - _invalid_link("empty link"); - return undef; - } - elsif($alttext =~ /[<>]/) { - _invalid_link("alternative text contains < or >"); - return undef; - } - else { # no errors so far - if($page =~ /[(]\d\w*[)]$/) { - $self->warning("brackets in `$page'"); - $page = $`; # strip that extension - } - if($page =~ /^(\s*)(\S+)(\s*)/ && (length($1) || length($3))) { - $self->warning("whitespace in `$page'"); - $page = $2; # strip that extension + # skip this paragraph if in a =begin block + unless($self->{_have_begin}) { + my $block = $self->interpolate_and_check($paragraph, $line,$file); + if($self->{_current_head1} eq 'NAME') { + if($block =~ /^\s*(\S+?)\s*[,-]/) { + # this is the canonical name + $self->{-name} = $1 unless(defined $self->{-name}); + } } } - $self->page($page); - $self->node($section || $item); # _TODO_ do not distinguish for now - $self->alttext($alttext); - $self->type($item ? 'item' : 'section'); - 1; -} - -sub _construct_text { - my $self = shift; - my $alttext = $self->alttext(); - my $type = $self->type(); - my $section = $self->node(); - my $page = $self->page(); - $self->{_text} = - $alttext ? $alttext : ( - !$section ? '' : - $type eq 'item' ? 'the ' . $section . ' entry' : - 'the section on ' . $section ) . - ($page ? ($section ? ' in ':''). 'the ' . $page . ' manpage' : - 'elsewhere in this document'); - # for being marked up later - $self->{_markup} = - $alttext ? '' . $alttext . '' : ( - !$section ? '' : - $type eq 'item' ? 'the ' . $section . ' entry' : - 'the section on ' . $section . '' ) . - ($page ? ($section ? ' in ':'') . 'the ' . - $page . ' manpage' : - ' elsewhere in this document'); -} - -# include markup -sub markup { - my ($self,$on,$off,$pageon,$pageoff) = @_; - $on ||= ''; - $off ||= ''; - $pageon ||= ''; - $pageoff ||= ''; - $_[0]->_construct_text; - my $str = $self->{_markup}; - $str =~ s//$on/; - $str =~ s//$off/; - $str =~ s//$pageon/; - $str =~ s//$pageoff/; - return $str; -} - -# The complete link's text -sub text { - $_[0]->_construct_text(); - $_[0]->{_text}; -} - -# The POD page the link appears on -sub warning { - my $self = shift; - if(@_) { - push(@{$self->{_warnings}}, @_); - return @_; - } - return @{$self->{_warnings}}; -} - -# The POD file name the link appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -# The line in the file the link appears -sub line { - return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; -} - -# The POD page the link appears on -sub page { - return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; -} - -# The link destination -sub node { - return (@_ > 1) ? ($_[0]->{-node} = $_[1]) : $_[0]->{-node}; -} - -# Potential alternative text -sub alttext { - return (@_ > 1) ? ($_[0]->{-alttext} = $_[1]) : $_[0]->{-alttext}; -} - -# The type -sub type { - return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; -} - -sub _invalid_link { - my ($msg) = @_; - # this sets @_ - #eval { die "$msg\n" }; - #chomp $@; - $@ = $msg; # this seems to work, too! - undef; } 1; diff --git a/lib/Pod/Find.pm b/lib/Pod/Find.pm new file mode 100644 index 0000000..399bbba --- /dev/null +++ b/lib/Pod/Find.pm @@ -0,0 +1,259 @@ +############################################################################# +# Pod/Find.pm -- finds files containing POD documentation +# +# Author: Marek Rouchal +# +# borrowing code from Nick Ing-Simmon's PodToHtml +# This file is part of "PodParser". Pod::Find is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Find; + +use vars qw($VERSION); +$VERSION = 0.10; ## Current version of this package +require 5.005; ## requires this Perl version or later + +############################################################################# + +=head1 NAME + +Pod::Find - find POD documents in directory trees + +=head1 SYNOPSIS + + use Pod::Find qw(pod_find simplify_name); + my %pods = pod_find({ -verbose => 1, -inc => 1 }); + foreach(keys %pods) { + print "found library POD `$pods{$_}' in $_\n"; + } + + print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n"; + +=head1 DESCRIPTION + +B provides a function B that searches for POD +documents in a given set of files and directories. It returns a hash +with the file names as keys and the POD name as value. The POD name +is derived from the file name and its position in the directory tree. + +E.g. when searching in F<$HOME/perl5lib>, the file +F<$HOME/perl5lib/MyModule.pm> would get the POD name I, +whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be +I. The name information can be used for POD +translators. + +Only text files containing at least one valid POD command are found. + +A warning is printed if more than one POD file with the same POD name +is found, e.g. F in different directories. This usually +indicates duplicate occurences of modules in the I<@INC> search path. + +The function B is equivalent to B, but also +strips Perl-like extensions (.pm, .pl, .pod). + +Note that neither B nor B are exported by +default so be sure to specify them in the B statement if you need them: + + use Pod::Find qw(pod_find simplify_name); + +=head1 OPTIONS + +The first argument for B may be a hash reference with options. +The rest are either directories that are searched recursively or files. +The POD names of files are the plain basenames with any Perl-like extension +(.pm, .pl, .pod) stripped. + +=over 4 + +=item B<-verbose> + +Print progress information while scanning. + +=item B<-perl> + +Apply Perl-specific heuristics to find the correct PODs. This includes +stripping Perl-like extensions, omitting subdirectories that are numeric +but do I match the current Perl interpreter's version id, suppressing +F as a module hierarchy name etc. + +=item B<-script> + +Search for PODs in the current Perl interpreter's installation +B. This is taken from the local L module. + +=item B<-inc> + +Search for PODs in the current Perl interpreter's I<@INC> paths. + +=back + +=head1 AUTHOR + +Marek Rouchal Emarek@saftsack.fs.uni-bayreuth.deE, +heavily borrowing code from Nick Ing-Simmons' PodToHtml. + +=head1 SEE ALSO + +L, L + +=cut + +use strict; +#use diagnostics; +use Exporter; +use File::Find; +use Cwd; + +use vars qw(@ISA @EXPORT_OK $VERSION); +@ISA = qw(Exporter); +@EXPORT_OK = qw(&pod_find &simplify_name); + +# package global variables +my $SIMPLIFY_RX; + +# return a hash of the +sub pod_find +{ + my %opts; + if(ref $_[0]) { + %opts = %{shift()}; + } + + $opts{-verbose} ||= 0; + $opts{-perl} ||= 0; + + my (@search) = @_; + + if($opts{-script}) { + require Config; + push(@search, $Config::Config{scriptdir}); + $opts{-perl} = 1; + } + + if($opts{-inc}) { + push(@search, grep($_ ne '.',@INC)); + $opts{-perl} = 1; + } + + if($opts{-perl}) { + require Config; + # this code simplifies the POD name for Perl modules: + # * remove "site_perl" + # * remove e.g. "i586-linux" + # * remove e.g. 5.00503 + # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) + $SIMPLIFY_RX = + qr!^(?i:site_perl/|$Config::Config{archname}/|\d+\.\d+([_.]?\d+)?/|pod/(?=.*?\.pod$))*!o; + } + + my %dirs_visited; + my %pods; + my %names; + my $pwd = cwd(); + + foreach my $try (@search) { + unless($try =~ m:^/:) { + # make path absolute + $try = join('/',$pwd,$try); + } + $try =~ s:/\.?(?=/|$)::; # simplify path + my $name; + if(-f $try) { + if($name = _check_and_extract_name($try, $opts{-verbose})) { + _check_for_duplicates($try, $name, \%names, \%pods); + } + next; + } + my $root_rx = qr!^\Q$try\E/!; + File::Find::find( sub { + my $item = $File::Find::name; + if(-d) { + if($dirs_visited{$item}) { + warn "Directory '$item' already seen, skipping.\n" + if($opts{-verbose}); + $File::Find::prune = 1; + return; + } + else { + $dirs_visited{$item} = 1; + } + if($opts{-perl} && /^(\d+\.[\d_]+)$/ && eval "$1" != $]) { + $File::Find::prune = 1; + warn "Perl $] version mismatch on $_, skipping.\n" + if($opts{-verbose}); + } + return; + } + if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { + _check_for_duplicates($item, $name, \%names, \%pods); + } + }, $try); # end of File::Find::find + } + chdir $pwd; + %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 ", + join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; + } + else { + $$names_ref{$name} = 1; + } + $$pods_ref{$file} = $name; +} + +sub _check_and_extract_name { + my ($file, $verbose, $root_rx) = @_; + + # check extension or executable + unless($file =~ /\.(pod|pm|pl)$/i || (-f $file && -x _ && -T _)) { + return undef; + } + + # check for one line of POD + unless(open(POD,"<$file")) { + warn "Error: $file is unreadable: $!\n"; + return undef; + } + local $/ = undef; + my $pod = ; + close(POD); + unless($pod =~ /\n=(head\d|pod|over|item)\b/) { + warn "No POD in $file, skipping.\n" + if($verbose); + return; + } + undef $pod; + + # strip non-significant path components + # _TODO_ what happens on e.g. Win32? + my $name = $file; + if(defined $root_rx) { + $name =~ s!$root_rx!!; + $name =~ s!$SIMPLIFY_RX!!o if(defined $SIMPLIFY_RX); + } + else { + $name =~ s:^.*/::; + } + $name =~ s/\.(pod|pm|pl)$//i; + $name =~ s!/+!::!g; + $name; +} + +# basic simplification of the POD name: +# basename & strip extension +sub simplify_name { + my ($str) = @_; + $str =~ s:^.*/::; + $str =~ s:\.p([lm]|od)$::i; + $str; +} + +1; + diff --git a/lib/Pod/ParseUtils.pm b/lib/Pod/ParseUtils.pm new file mode 100644 index 0000000..a66e8f5 --- /dev/null +++ b/lib/Pod/ParseUtils.pm @@ -0,0 +1,792 @@ +############################################################################# +# Pod/ParseUtils.pm -- helpers for POD parsing and conversion +# +# Copyright (C) 1999 by Marek Rouchal. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::ParseUtils; + +use vars qw($VERSION); +$VERSION = 0.2; ## Current version of this package +require 5.004; ## requires this Perl version or later + +=head1 NAME + +Pod::ParseUtils - helpers for POD parsing and conversion + +=head1 SYNOPSIS + + use Pod::ParseUtils; + + my $list = new Pod::List; + my $link = Pod::Hyperlink->new('Pod::Parser'); + +=head1 DESCRIPTION + +B contains a few object-oriented helper packages for +POD parsing and processing (i.e. in POD formatters and translators). + +=cut + +#----------------------------------------------------------------------------- +# Pod::List +# +# class to hold POD list info (=over, =item, =back) +#----------------------------------------------------------------------------- + +package Pod::List; + +use Carp; + +=head2 Pod::List + +B can be used to hold information about POD lists +(written as =over ... =item ... =back) for further processing. +The following methods are available: + +=over 4 + +=item new() + +Create a new list object. Properties may be specified through a hash +reference like this: + + my $list = Pod::List->new({ -start => $., -indent => 4 }); + +See the individual methods/properties for details. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->{-file} ||= 'unknown'; + $self->{-start} ||= 'unknown'; + $self->{-indent} ||= 4; # perlpod: "should be the default" + $self->{_items} = []; + $self->{-type} ||= ''; +} + +=item file() + +Without argument, retrieves the file name the list is in. This must +have been set before by either specifying B<-file> in the B +method or by calling the B method with a scalar argument. + +=cut + +# The POD file name the list appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item start() + +Without argument, retrieves the line number where the list started. +This must have been set before by either specifying B<-start> in the +B method or by calling the B method with a scalar +argument. + +=cut + +# The line in the file the node appears +sub start { + return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; +} + +=item indent() + +Without argument, retrieves the indent level of the list as specified +in C<=over n>. This must have been set before by either specifying +B<-indent> in the B method or by calling the B method +with a scalar argument. + +=cut + +# indent level +sub indent { + return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; +} + +=item type() + +Without argument, retrieves the list type, which can be an arbitrary value, +e.g. C
    , C
      , ... when thinking the HTML way. +This must have been set before by either specifying +B<-type> in the B method or by calling the B method +with a scalar argument. + +=cut + +# The type of the list (UL, OL, ...) +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item rx() + +Without argument, retrieves a regular expression for simplifying the +individual item strings once the list type has been determined. Usage: +E.g. when converting to HTML, one might strip the leading number in +an ordered list as COLE> already prints numbers itself. +This must have been set before by either specifying +B<-rx> in the B method or by calling the B method +with a scalar argument. + +=cut + +# The regular expression to simplify the items +sub rx { + return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; +} + +=item item() + +Without argument, retrieves the array of the items in this list. +The items may be represented by any scalar. +If an argument has been given, it is pushed on the list of items. + +=cut + +# The individual =items of this list +sub item { + my ($self,$item) = @_; + if(defined $item) { + push(@{$self->{_items}}, $item); + return $item; + } + else { + return @{$self->{_items}}; + } +} + +=item parent() + +Without argument, retrieves information about the parent holding this +list, which is represented as an arbitrary scalar. +This must have been set before by either specifying +B<-parent> in the B method or by calling the B method +with a scalar argument. + +=cut + +# possibility for parsers/translators to store information about the +# lists's parent object +sub parent { + return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; +} + +=item tag() + +Without argument, retrieves information about the list tag, which can be +any scalar. +This must have been set before by either specifying +B<-tag> in the B method or by calling the B method +with a scalar argument. + +=back + +=cut + +# possibility for parsers/translators to store information about the +# list's object +sub tag { + return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag}; +} + +#----------------------------------------------------------------------------- +# Pod::Hyperlink +# +# class to manipulate POD hyperlinks (L<>) +#----------------------------------------------------------------------------- + +package Pod::Hyperlink; + +=head2 Pod::Hyperlink + +B is a class for manipulation of POD hyperlinks. Usage: + + my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); + +The B class is mainly designed to parse the contents of the +C...E> sequence, providing a simple interface for accessing the +different parts of a POD hyperlink for further processing. It can also be +used to construct hyperlinks. + +=over 4 + +=item new() + +The B method can either be passed a set of key/value pairs or a single +scalar value, namely the contents of a C...E> sequence. An object +of the class C is returned. The value C indicates a +failure, the error message is stored in C<$@>. + +=cut + +use Carp; + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = +{}; + bless $self, $class; + $self->initialize(); + if(defined $_[0]) { + if(ref($_[0])) { + # called with a list of parameters + %$self = %{$_[0]}; + $self->_construct_text(); + } + else { + # called with L<> contents + return undef unless($self->parse($_[0])); + } + } + return $self; +} + +sub initialize { + my $self = shift; + $self->{-line} ||= 'undef'; + $self->{-file} ||= 'undef'; + $self->{-page} ||= ''; + $self->{-node} ||= ''; + $self->{-alttext} ||= ''; + $self->{-type} ||= 'undef'; + $self->{_warnings} = []; +} + +=item parse($string) + +This method can be used to (re)parse a (new) hyperlink, i.e. the contents +of a C...E> sequence. The result is stored in the current object. + +=cut + +sub parse { + my $self = shift; + local($_) = $_[0]; + # syntax check the link and extract destination + my ($alttext,$page,$node,$type) = ('','','',''); + + $self->{_warnings} = []; + + # collapse newlines with whitespace + if(s/\s*\n+\s*/ /g) { + $self->warning("collapsing newlines to blanks"); + } + # strip leading/trailing whitespace + if(s/^[\s\n]+//) { + $self->warning("ignoring leading whitespace in link"); + } + if(s/[\s\n]+$//) { + $self->warning("ignoring trailing whitespace in link"); + } + unless(length($_)) { + _invalid_link("empty link"); + return undef; + } + + ## Check for different possibilities. This is tedious and error-prone + # we match all possibilities (alttext, page, section/item) + #warn "DEBUG: link=$_\n"; + + # only page + if(m!^(\w+(?:::\w+)*)\s*(\(\w*\)|)$!) { + $page = $1 . $2; + $type = 'page'; + } + # alttext, page and section + elsif(m!^(.+?)\s*[|]\s*(\w+(?:::\w+)*)\s*(\(\w*\)|)\s*/\s*"(.+)"$!) { + ($alttext, $page, $node) = ($1, $2 . $3, $4); + $type = 'section'; + } + # page and section + elsif(m!^(\w+(?:::\w+)*)\s*(\(\w*\)|)\s*/\s*"(.+)"$!) { + ($page, $node) = ($1 . $2, $3); + $type = 'section'; + } + # page and item + elsif(m!^(\w+(?:::\w+)*)\s*(\(\w*\)|)\s*/\s*(.+)$!) { + ($page, $node) = ($1 . $2, $3); + $type = 'item'; + } + # only section + elsif(m!^(?:/\s*|)"(.+)"$!) { + $node = $1; + $type = 'section'; + } + # only item + elsif(m!^/(.+)$!) { + $node = $1; + $type = 'item'; + } + # non-standard: Hyperlink + elsif(m!^((?:http|ftp|mailto|news):.+)$!i) { + $node = $1; + $type = 'hyperlink'; + } + # alttext, page and item + elsif(m!^(.+?)\s*[|]\s*(\w+(?:::\w+)*)\s*(\(\w*\)|)\s*/\s*(.+)$!) { + ($alttext, $page, $node) = ($1, $2 . $3, $4); + $type = 'item'; + } + # alttext and page + elsif(m!^(.+?)\s*[|]\s*(\w+(?:::\w+)*)\s*(\(\w*\)|)$!) { + ($alttext, $page) = ($1, $2 . $3); + $type = 'page'; + } + # alttext and section + elsif(m!^(.+?)\s*[|]\s*(?:/\s*|)"(.+)"$!) { + ($alttext, $node) = ($1,$2); + $type = 'section'; + } + # alttext and item + elsif(m!^(.+?)\s*[|]\s*/(.+)$!) { + ($alttext, $node) = ($1,$2); + } + # nonstandard: alttext and hyperlink + elsif(m!^(.+?)\s*[|]\s*((?:http|ftp|mailto|news):.+)$!) { + ($alttext, $node) = ($1,$2); + $type = 'hyperlink'; + } + # must be an item or a "malformed" section (without "") + else { + $node = $_; + $type = 'item'; + } + + if($page =~ /[(]\w*[)]$/) { + $self->warning("section in `$page' deprecated"); + } + $self->{-page} = $page; + $self->{-node} = $node; + $self->{-alttext} = $alttext; + #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n"; + $self->{-type} = $type; + $self->_construct_text(); + 1; +} + +sub _construct_text { + my $self = shift; + my $alttext = $self->alttext(); + my $type = $self->type(); + my $section = $self->node(); + my $page = $self->page(); + my $page_ext = ''; + $page =~ s/([(]\w*[)])$// && ($page_ext = $1); + if($alttext) { + $self->{_text} = $alttext; + } + elsif($type eq 'hyperlink') { + $self->{_text} = $section; + } + else { + $self->{_text} = (!$section ? '' : + $type eq 'item' ? "the $section entry" : + "the section on $section" ) . + ($page ? ($section ? ' in ':'') . "the $page$page_ext manpage" : + ' elsewhere in this document'); + } + # for being marked up later + # use the non-standard markers P<> and Q<>, so that the resulting + # text can be parsed by the translators. It's their job to put + # the correct hypertext around the linktext + if($alttext) { + $self->{_markup} = "Q<$alttext>"; + } + elsif($type eq 'hyperlink') { + $self->{_markup} = "Q<$section>"; + } + else { + $self->{_markup} = (!$section ? '' : + $type eq 'item' ? "the Q<$section> entry" : + "the section on Q<$section>" ) . + ($page ? ($section ? ' in ':'') . "the P<$page>$page_ext manpage" : + ' elsewhere in this document'); + } +} + +=item markup($string) + +Set/retrieve the textual value of the link. This string contains special +markers CE> and CE> that should be expanded by the +translator's interior sequence expansion engine to the +formatter-specific code to highlight/activate the hyperlink. The details +have to be implemented in the translator. + +=cut + +#' retrieve/set markuped text +sub markup { + return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; +} + +=item text() + +This method returns the textual representation of the hyperlink as above, +but without markers (read only). Depending on the link type this is one of +the following alternatives (the + and * denote the portions of the text +that are marked up): + + the +perl+ manpage + the *$|* entry in the +perlvar+ manpage + the section on *OPTIONS* in the +perldoc+ manpage + the section on *DESCRIPTION* elsewhere in this document + +=cut + +# The complete link's text +sub text { + $_[0]->{_text}; +} + +=item warning() + +After parsing, this method returns any warnings encountered during the +parsing process. + +=cut + +# Set/retrieve warnings +sub warning { + my $self = shift; + if(@_) { + push(@{$self->{_warnings}}, @_); + return @_; + } + return @{$self->{_warnings}}; +} + +=item line(), file() + +Just simple slots for storing information about the line and the file +the link was encountered in. Has to be filled in manually. + +=cut + +# The line in the file the link appears +sub line { + return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; +} + +# The POD file name the link appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item page() + +This method sets or returns the POD page this link points to. + +=cut + +# The POD page the link appears on +sub page { + if (@_ > 1) { + $_[0]->{-page} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-page}; +} + +=item node() + +As above, but the destination node text of the link. + +=cut + +# The link destination +sub node { + if (@_ > 1) { + $_[0]->{-node} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-node}; +} + +=item alttext() + +Sets or returns an alternative text specified in the link. + +=cut + +# Potential alternative text +sub alttext { + if (@_ > 1) { + $_[0]->{-alttext} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-alttext}; +} + +=item type() + +The node type, either C
      or C. As an unofficial type, +there is also C, derived from e.g. Chttp://perl.comE> + +=cut + +# The type: item or headn +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item link() + +Returns the link as contents of CE>. Reciprocal to B. + +=back + +=cut + +# The link itself +sub link { + my $self = shift; + my $link = $self->page() || ''; + if($self->node()) { + if($self->type() eq 'section') { + $link .= ($link ? '/' : '') . '"' . $self->node() . '"'; + } + elsif($self->type() eq 'hyperlink') { + $link = $self->node(); + } + else { # item + $link .= '/' . $self->node(); + } + } + if($self->alttext()) { + $link = $self->alttext() . '|' . $link; + } + $link; +} + +sub _invalid_link { + my ($msg) = @_; + # this sets @_ + #eval { die "$msg\n" }; + #chomp $@; + $@ = $msg; # this seems to work, too! + undef; +} + +#----------------------------------------------------------------------------- +# Pod::Cache +# +# class to hold POD page details +#----------------------------------------------------------------------------- + +package Pod::Cache; + +=head2 Pod::Cache + +B holds information about a set of POD documents, +especially the nodes for hyperlinks. +The following methods are available: + +=over 4 + +=item new() + +Create a new cache object. This object can hold an arbitrary number of +POD documents of class Pod::Cache::Item. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = []; + bless $self, $class; + return $self; +} + +=item item() + +Add a new item to the cache. Without arguments, this method returns a +list of all cache elements. + +=cut + +sub item { + my ($self,%param) = @_; + if(%param) { + my $item = Pod::Cache::Item->new(%param); + push(@$self, $item); + return $item; + } + else { + return @{$self}; + } +} + +=item find_page($name) + +Look for a POD document named C<$name> in the cache. Returns the +reference to the corresponding Pod::Cache::Item object or undef if +not found. + +=back + +=cut + +sub find_page { + my ($self,$page) = @_; + foreach(@$self) { + if($_->page() eq $page) { + return $_; + } + } + undef; +} + +package Pod::Cache::Item; + +=head2 Pod::Cache::Item + +B holds information about individual POD documents, +that can be grouped in a Pod::Cache object. +It is intended to hold information about the hyperlink nodes of POD +documents. +The following methods are available: + +=over 4 + +=item new() + +Create a new object. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->{-nodes} = [] unless(defined $self->{-nodes}); +} + +=item page() + +Set/retrieve the POD document name (e.g. "Pod::Parser"). + +=cut + +# The POD page +sub page { + return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; +} + +=item description() + +Set/retrieve the POD short description as found in the C<=head1 NAME> +section. + +=cut + +# The POD description, taken out of NAME if present +sub description { + return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; +} + +=item path() + +Set/retrieve the POD file storage path. + +=cut + +# The file path +sub path { + return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; +} + +=item file() + +Set/retrieve the POD file name. + +=cut + +# The POD file name +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item nodes() + +Add a node (or a list of nodes) to the document's node list. Note that +the order is kept, i.e. start with the first node and end with the last. +If no argument is given, the current list of nodes is returned in the +same order the nodes have been added. +A node can be any scalar, but usually is a pair of node string and +unique id for the C method to work correctly. + +=cut + +# The POD nodes +sub nodes { + my ($self,@nodes) = @_; + if(@nodes) { + push(@{$self->{-nodes}}, @nodes); + return @nodes; + } + else { + return @{$self->{-nodes}}; + } +} + +=item find_node($name) + +Look for a node named C<$name> in the object's node list. Returns the +unique id of the node (i.e. the second element of the array stored in +the node arry) or undef if not found. + +=back + +=cut + +sub find_node { + my ($self,$node) = @_; + foreach(@{$self->{-nodes}}) { + if($_->[0] eq $node) { + return $_->[1]; # id + } + } + undef; +} + + +=head1 AUTHOR + +Marek Rouchal Emarek@saftsack.fs.uni-bayreuth.deE, borrowing +a lot of things from L and L as well as other POD +processing tools by Tom Christiansen, Brad Appleton and Russ Allbery. + +=head1 SEE ALSO + +L, L, L, L, +L + +=cut + +1; diff --git a/t/pod/poderrs.t b/t/pod/poderrs.t index 9f7f6bd..e27130c 100755 --- a/t/pod/poderrs.t +++ b/t/pod/poderrs.t @@ -82,12 +82,12 @@ L L<"end with begin"> L -=head2 Garbled (almost) links +=head2 Some links with problems -L -L<".".":"> -L<"h"/"hh"> -L +L +L<> +L<"Warnings"> this one is ok =head2 Warnings diff --git a/t/pod/poderrs.xr b/t/pod/poderrs.xr index 70408cd..157d130 100644 --- a/t/pod/poderrs.xr +++ b/t/pod/poderrs.xr @@ -1,6 +1,4 @@ *** ERROR: Unknown command "unknown1" at line 21 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence "N" at line 21 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence "D" at line 22 in file pod/poderrs.t *** ERROR: Unknown interior-sequence "Q" at line 25 in file pod/poderrs.t *** ERROR: Unknown interior-sequence "A" at line 26 in file pod/poderrs.t *** ERROR: Unknown interior-sequence "Y" at line 27 in file pod/poderrs.t @@ -9,27 +7,26 @@ ** Unterminated I<...> at pod/poderrs.t line 30 ** Unterminated C<...> at pod/poderrs.t line 33 *** ERROR: =item without previous =over at line 43 in file pod/poderrs.t +*** ERROR: =over on line 43 without closing =back (at head2) at line 45 in file pod/poderrs.t *** ERROR: =back without previous =over at line 47 in file pod/poderrs.t -*** ERROR: unclosed =over (line 51) at head2 at line 55 in file pod/poderrs.t -*** WARNING: =end without =begin at line 57 in file pod/poderrs.t +*** ERROR: =over on line 51 without closing =back (at head2) at line 55 in file pod/poderrs.t +*** ERROR: =end without =begin at line 57 in file pod/poderrs.t *** ERROR: Nested =begin's (first at line 61:html) at line 63 in file pod/poderrs.t -*** WARNING: =end without =begin at line 67 in file pod/poderrs.t +*** ERROR: =end without =begin at line 67 in file pod/poderrs.t *** ERROR: nested commands C<...C<...>...> at line 71 in file pod/poderrs.t *** ERROR: garbled entity E at line 75 in file pod/poderrs.t *** ERROR: garbled entity E> at line 76 in file pod/poderrs.t *** ERROR: garbled entity E> at line 77 in file pod/poderrs.t -*** ERROR: malformed link L<>: garbled entry (spurious characters `s s / s s / ss') at line 87 in file pod/poderrs.t -*** ERROR: malformed link L<>: garbled entry (spurious characters `".".":"') at line 88 in file pod/poderrs.t -*** ERROR: malformed link L<>: garbled entry (spurious characters `"h"/"hh"') at line 89 in file pod/poderrs.t -*** WARNING: brackets in `passwd(5)' at line 94 in file pod/poderrs.t +*** WARNING: collapsing newlines to blanks at line 87 in file pod/poderrs.t +*** ERROR: malformed link L<> : empty link at line 89 in file pod/poderrs.t +*** WARNING: section in `passwd(5)' deprecated at line 94 in file pod/poderrs.t *** WARNING: ignoring leading whitespace in link at line 95 in file pod/poderrs.t *** WARNING: ignoring trailing whitespace in link at line 95 in file pod/poderrs.t *** WARNING: Spurious character(s) after =back at line 101 in file pod/poderrs.t -*** WARNING: Spurious character(s) after =end at line 107 in file pod/poderrs.t *** WARNING: No items in =over (at line 109) / =back list at line 111 in file pod/poderrs.t -*** WARNING: 2 unescaped <> at line 113 in file pod/poderrs.t +*** WARNING: 2 unescaped <> in paragraph at line 113 in file pod/poderrs.t *** ERROR: unresolved internal link `begin or begin' at line 81 in file pod/poderrs.t *** ERROR: unresolved internal link `end with begin' at line 82 in file pod/poderrs.t *** ERROR: unresolved internal link `OoPs' at line 83 in file pod/poderrs.t -*** ERROR: unresolved internal link `b|c' at line 90 in file pod/poderrs.t -pod/poderrs.t has 25 pod syntax errors. +*** ERROR: unresolved internal link `abc def' at line 87 in file pod/poderrs.t +pod/poderrs.t has 24 pod syntax errors.