This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
335ceee04377436a44a832c6cddb08bcc4b9d62a
[perl5.git] / cpan / Pod-Parser / lib / Pod / Checker.pm
1 #############################################################################
2 # Pod/Checker.pm -- check pod documents for syntax errors
3 #
4 # Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
5 # This file is part of "PodParser". PodParser is free software;
6 # you can redistribute it and/or modify it under the same terms
7 # as Perl itself.
8 #############################################################################
9
10 package Pod::Checker;
11 use strict;
12
13 use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES);
14 $VERSION = '1.50';  ## Current version of this package
15 require  5.005;    ## requires this Perl version or later
16
17 use Pod::ParseUtils; ## for hyperlinks and lists
18
19 =head1 NAME
20
21 Pod::Checker, podchecker() - check pod documents for syntax errors
22
23 =head1 SYNOPSIS
24
25   use Pod::Checker;
26
27   $syntax_okay = podchecker($filepath, $outputpath, %options);
28
29   my $checker = new Pod::Checker %options;
30   $checker->parse_from_file($filepath, \*STDERR);
31
32 =head1 OPTIONS/ARGUMENTS
33
34 C<$filepath> is the input POD to read and C<$outputpath> is
35 where to write POD syntax error messages. Either argument may be a scalar
36 indicating a file-path, or else a reference to an open filehandle.
37 If unspecified, the input-file it defaults to C<\*STDIN>, and
38 the output-file defaults to C<\*STDERR>.
39
40 =head2 podchecker()
41
42 This function can take a hash of options:
43
44 =over 4
45
46 =item B<-warnings> =E<gt> I<val>
47
48 Turn warnings on/off. I<val> is usually 1 for on, but higher values
49 trigger additional warnings. See L<"Warnings">.
50
51 =back
52
53 =head1 DESCRIPTION
54
55 B<podchecker> will perform syntax checking of Perl5 POD format documentation.
56
57 Curious/ambitious users are welcome to propose additional features they wish
58 to see in B<Pod::Checker> and B<podchecker> and verify that the checks are
59 consistent with L<perlpod>.
60
61 The following checks are currently performed:
62
63 =over 4
64
65 =item *
66
67 Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,
68 and unterminated interior sequences.
69
70 =item *
71
72 Check for proper balancing of C<=begin> and C<=end>. The contents of such
73 a block are generally ignored, i.e. no syntax checks are performed.
74
75 =item *
76
77 Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.
78
79 =item *
80
81 Check for same nested interior-sequences (e.g.
82 C<LE<lt>...LE<lt>...E<gt>...E<gt>>).
83
84 =item *
85
86 Check for malformed or non-existing entities C<EE<lt>...E<gt>>.
87
88 =item *
89
90 Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>
91 for details.
92
93 =item *
94
95 Check for unresolved document-internal links. This check may also reveal
96 misspelled links that seem to be internal links but should be links
97 to something else.
98
99 =back
100
101 =head1 DIAGNOSTICS
102
103 =head2 Errors
104
105 =over 4
106
107 =item * empty =headn
108
109 A heading (C<=head1> or C<=head2>) without any text? That ain't no
110 heading!
111
112 =item * =over on line I<N> without closing =back
113
114 The C<=over> command does not have a corresponding C<=back> before the
115 next heading (C<=head1> or C<=head2>) or the end of the file.
116
117 =item * =item without previous =over
118
119 =item * =back without previous =over
120
121 An C<=item> or C<=back> command has been found outside a
122 C<=over>/C<=back> block.
123
124 =item * No argument for =begin
125
126 A C<=begin> command was found that is not followed by the formatter
127 specification.
128
129 =item * =end without =begin
130
131 A standalone C<=end> command was found.
132
133 =item * Nested =begin's
134
135 There were at least two consecutive C<=begin> commands without
136 the corresponding C<=end>. Only one C<=begin> may be active at
137 a time.
138
139 =item * =for without formatter specification
140
141 There is no specification of the formatter after the C<=for> command.
142
143 =item * Apparent command =foo not preceded by blank line
144
145 A command which has ended up in the middle of a paragraph or other command,
146 such as
147
148   =item one
149   =item two <-- bad
150
151 =item * unresolved internal link I<NAME>
152
153 The given link to I<NAME> does not have a matching node in the current
154 POD. This also happened when a single word node name is not enclosed in
155 C<"">.
156
157 =item * hyperlink to URL with alt text deprecated in perlpodspec
158
159 Absolute hyperlinks with alternative text like
160 C<LE<lt>The Perl Home Page|http://www.perl.orgE<gt>> are discouraged in
161 L<perlpodspec>. There is a section in L<perlpod> though, which allows this
162 option. As L<perlpodspec> is the more modern document containing the essence
163 of many prior discussions, L<Pod::Checker> flags this as an error.
164
165 =item * Unknown command "I<CMD>"
166
167 An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
168 C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,
169 C<=for>, C<=pod>, C<=cut>
170
171 =item * Unknown interior-sequence "I<SEQ>"
172
173 An invalid markup command has been encountered. Valid are:
174 C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>,
175 C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>,
176 C<ZE<lt>E<gt>>
177
178 =item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
179
180 Two nested identical markup commands have been found. Generally this
181 does not make sense.
182
183 =item * garbled entity I<STRING>
184
185 The I<STRING> found cannot be interpreted as a character entity.
186
187 =item * Entity number out of range
188
189 An entity specified by number (dec, hex, oct) is out of range (1-255).
190
191 =item * malformed link LE<lt>E<gt>
192
193 The link found cannot be parsed because it does not conform to the
194 syntax described in L<perlpod>.
195
196 =item * nonempty ZE<lt>E<gt>
197
198 The C<ZE<lt>E<gt>> sequence is supposed to be empty.
199
200 =item * empty XE<lt>E<gt>
201
202 The index entry specified contains nothing but whitespace.
203
204 =item * Spurious text after =pod / =cut
205
206 The commands C<=pod> and C<=cut> do not take any arguments.
207
208 =item * Spurious =cut command
209
210 A C<=cut> command was found without a preceding POD paragraph.
211
212 =item * Spurious =pod command
213
214 A C<=pod> command was found after a preceding POD paragraph.
215
216 =item * Spurious character(s) after =back
217
218 The C<=back> command does not take any arguments.
219
220 =back
221
222 =head2 Warnings
223
224 These may not necessarily cause trouble, but indicate mediocre style.
225
226 =over 4
227
228 =item * multiple occurrence of link target I<name>
229
230 The POD file has some C<=item> and/or C<=head> commands that have
231 the same text. Potential hyperlinks to such a text cannot be unique then.
232 This warning is printed only with warning level greater than one.
233
234 =item * line containing nothing but whitespace in paragraph
235
236 There is some whitespace on a seemingly empty line. POD is very sensitive
237 to such things, so this is flagged. B<vi> users switch on the B<list>
238 option to avoid this problem.
239
240 =begin _disabled_
241
242 =item * file does not start with =head
243
244 The file starts with a different POD directive than head.
245 This is most probably something you do not want.
246
247 =end _disabled_
248
249 =item * previous =item has no contents
250
251 There is a list C<=item> right above the flagged line that has no
252 text contents. You probably want to delete empty items.
253
254 =item * preceding non-item paragraph(s)
255
256 A list introduced by C<=over> starts with a text or verbatim paragraph,
257 but continues with C<=item>s. Move the non-item paragraph out of the
258 C<=over>/C<=back> block.
259
260 =item * =item type mismatch (I<one> vs. I<two>)
261
262 A list started with e.g. a bullet-like C<=item> and continued with a
263 numbered one. This is obviously inconsistent. For most translators the
264 type of the I<first> C<=item> determines the type of the list.
265
266 =item * I<N> unescaped C<E<lt>E<gt>> in paragraph
267
268 Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>>
269 can potentially cause errors as they could be misinterpreted as
270 markup commands. This is only printed when the -warnings level is
271 greater than 1.
272
273 =item * Unknown entity
274
275 A character entity was found that does not belong to the standard
276 ISO set or the POD specials C<verbar> and C<sol>.
277
278 =item * No items in =over
279
280 The list opened with C<=over> does not contain any items.
281
282 =item * No argument for =item
283
284 C<=item> without any parameters is deprecated. It should either be followed
285 by C<*> to indicate an unordered list, by a number (optionally followed
286 by a dot) to indicate an ordered (numbered) list or simple text for a
287 definition list.
288
289 =item * empty section in previous paragraph
290
291 The previous section (introduced by a C<=head> command) does not contain
292 any text. This usually indicates that something is missing. Note: A
293 C<=head1> followed immediately by C<=head2> does not trigger this warning.
294
295 =item * Verbatim paragraph in NAME section
296
297 The NAME section (C<=head1 NAME>) should consist of a single paragraph
298 with the script/module name, followed by a dash `-' and a very short
299 description of what the thing is good for.
300
301 =item * =headI<n> without preceding higher level
302
303 For example if there is a C<=head2> in the POD file prior to a
304 C<=head1>.
305
306 =back
307
308 =head2 Hyperlinks
309
310 There are some warnings with respect to malformed hyperlinks:
311
312 =over 4
313
314 =item * ignoring leading/trailing whitespace in link
315
316 There is whitespace at the beginning or the end of the contents of
317 LE<lt>...E<gt>.
318
319 =item * (section) in '$page' deprecated
320
321 There is a section detected in the page name of LE<lt>...E<gt>, e.g.
322 C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only.
323 Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able
324 to expand this to appropriate code. For links to (builtin) functions,
325 please say C<LE<lt>perlfunc/mkdirE<gt>>, without ().
326
327 =item * alternative text/node '%s' contains non-escaped | or /
328
329 The characters C<|> and C</> are special in the LE<lt>...E<gt> context.
330 Although the hyperlink parser does its best to determine which "/" is
331 text and which is a delimiter in case of doubt, one ought to escape
332 these literal characters like this:
333
334   /     E<sol>
335   |     E<verbar>
336
337 =back
338
339 =head1 RETURN VALUE
340
341 B<podchecker> returns the number of POD syntax errors found or -1 if
342 there were no POD commands at all found in the file.
343
344 =head1 EXAMPLES
345
346 See L</SYNOPSIS>
347
348 =head1 INTERFACE
349
350 While checking, this module collects document properties, e.g. the nodes
351 for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).
352 POD translators can use this feature to syntax-check and get the nodes in
353 a first pass before actually starting to convert. This is expensive in terms
354 of execution time, but allows for very robust conversions.
355
356 Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror>
357 method to print errors and warnings. The summary output (e.g.
358 "Pod syntax OK") has been dropped from the module and has been included in
359 B<podchecker> (the script). This allows users of B<Pod::Checker> to
360 control completely the output behavior. Users of B<podchecker> (the script)
361 get the well-known behavior.
362
363 =cut
364
365 #############################################################################
366
367 #use diagnostics;
368 use Carp qw(croak);
369 use Exporter;
370 use Pod::Parser;
371
372 @ISA = qw(Pod::Parser);
373 @EXPORT = qw(&podchecker);
374
375 my %VALID_COMMANDS = (
376     'pod'    =>  1,
377     'cut'    =>  1,
378     'head1'  =>  1,
379     'head2'  =>  1,
380     'head3'  =>  1,
381     'head4'  =>  1,
382     'over'   =>  1,
383     'back'   =>  1,
384     'item'   =>  1,
385     'for'    =>  1,
386     'begin'  =>  1,
387     'end'    =>  1,
388     'encoding' =>  1,
389 );
390
391 my %VALID_SEQUENCES = (
392     'I'  =>  1,
393     'B'  =>  1,
394     'S'  =>  1,
395     'C'  =>  1,
396     'L'  =>  1,
397     'F'  =>  1,
398     'X'  =>  1,
399     'Z'  =>  1,
400     'E'  =>  1,
401 );
402
403 # stolen from HTML::Entities
404 my %ENTITIES = (
405  # Some normal chars that have special meaning in SGML context
406  amp    => '&',  # ampersand
407 'gt'    => '>',  # greater than
408 'lt'    => '<',  # less than
409  quot   => '"',  # double quote
410
411  # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML
412  AElig  => 'Æ',  # capital AE diphthong (ligature)
413  Aacute => 'Á',  # capital A, acute accent
414  Acirc  => 'Â',  # capital A, circumflex accent
415  Agrave => 'À',  # capital A, grave accent
416  Aring  => 'Å',  # capital A, ring
417  Atilde => 'Ã',  # capital A, tilde
418  Auml   => 'Ä',  # capital A, dieresis or umlaut mark
419  Ccedil => 'Ç',  # capital C, cedilla
420  ETH    => 'Ð',  # capital Eth, Icelandic
421  Eacute => 'É',  # capital E, acute accent
422  Ecirc  => 'Ê',  # capital E, circumflex accent
423  Egrave => 'È',  # capital E, grave accent
424  Euml   => 'Ë',  # capital E, dieresis or umlaut mark
425  Iacute => 'Í',  # capital I, acute accent
426  Icirc  => 'Î',  # capital I, circumflex accent
427  Igrave => 'Ì',  # capital I, grave accent
428  Iuml   => 'Ï',  # capital I, dieresis or umlaut mark
429  Ntilde => 'Ñ',  # capital N, tilde
430  Oacute => 'Ó',  # capital O, acute accent
431  Ocirc  => 'Ô',  # capital O, circumflex accent
432  Ograve => 'Ò',  # capital O, grave accent
433  Oslash => 'Ø',  # capital O, slash
434  Otilde => 'Õ',  # capital O, tilde
435  Ouml   => 'Ö',  # capital O, dieresis or umlaut mark
436  THORN  => 'Þ',  # capital THORN, Icelandic
437  Uacute => 'Ú',  # capital U, acute accent
438  Ucirc  => 'Û',  # capital U, circumflex accent
439  Ugrave => 'Ù',  # capital U, grave accent
440  Uuml   => 'Ü',  # capital U, dieresis or umlaut mark
441  Yacute => 'Ý',  # capital Y, acute accent
442  aacute => 'á',  # small a, acute accent
443  acirc  => 'â',  # small a, circumflex accent
444  aelig  => 'æ',  # small ae diphthong (ligature)
445  agrave => 'à',  # small a, grave accent
446  aring  => 'å',  # small a, ring
447  atilde => 'ã',  # small a, tilde
448  auml   => 'ä',  # small a, dieresis or umlaut mark
449  ccedil => 'ç',  # small c, cedilla
450  eacute => 'é',  # small e, acute accent
451  ecirc  => 'ê',  # small e, circumflex accent
452  egrave => 'è',  # small e, grave accent
453  eth    => 'ð',  # small eth, Icelandic
454  euml   => 'ë',  # small e, dieresis or umlaut mark
455  iacute => 'í',  # small i, acute accent
456  icirc  => 'î',  # small i, circumflex accent
457  igrave => 'ì',  # small i, grave accent
458  iuml   => 'ï',  # small i, dieresis or umlaut mark
459  ntilde => 'ñ',  # small n, tilde
460  oacute => 'ó',  # small o, acute accent
461  ocirc  => 'ô',  # small o, circumflex accent
462  ograve => 'ò',  # small o, grave accent
463  oslash => 'ø',  # small o, slash
464  otilde => 'õ',  # small o, tilde
465  ouml   => 'ö',  # small o, dieresis or umlaut mark
466  szlig  => 'ß',  # small sharp s, German (sz ligature)
467  thorn  => 'þ',  # small thorn, Icelandic
468  uacute => 'ú',  # small u, acute accent
469  ucirc  => 'û',  # small u, circumflex accent
470  ugrave => 'ù',  # small u, grave accent
471  uuml   => 'ü',  # small u, dieresis or umlaut mark
472  yacute => 'ý',  # small y, acute accent
473  yuml   => 'ÿ',  # small y, dieresis or umlaut mark
474
475  # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96)
476  copy   => '©',  # copyright sign
477  reg    => '®',  # registered sign
478  nbsp   => "\240", # non breaking space
479
480  # Additional ISO-8859/1 entities listed in rfc1866 (section 14)
481  iexcl  => '¡',
482  cent   => '¢',
483  pound  => '£',
484  curren => '¤',
485  yen    => '¥',
486  brvbar => '¦',
487  sect   => '§',
488  uml    => '¨',
489  ordf   => 'ª',
490  laquo  => '«',
491 'not'   => '¬',    # not is a keyword in perl
492  shy    => '­',
493  macr   => '¯',
494  deg    => '°',
495  plusmn => '±',
496  sup1   => '¹',
497  sup2   => '²',
498  sup3   => '³',
499  acute  => '´',
500  micro  => 'µ',
501  para   => '¶',
502  middot => '·',
503  cedil  => '¸',
504  ordm   => 'º',
505  raquo  => '»',
506  frac14 => '¼',
507  frac12 => '½',
508  frac34 => '¾',
509  iquest => '¿',
510 'times' => '×',    # times is a keyword in perl
511  divide => '÷',
512
513 # some POD special entities
514  verbar => '|',
515  sol => '/'
516 );
517
518 ##---------------------------------------------------------------------------
519
520 ##---------------------------------
521 ## Function definitions begin here
522 ##---------------------------------
523
524 sub podchecker {
525     my ($infile, $outfile, %options) = @_;
526     local $_;
527
528     ## Set defaults
529     $infile  ||= \*STDIN;
530     $outfile ||= \*STDERR;
531
532     ## Now create a pod checker
533     my $checker = new Pod::Checker(%options);
534
535     ## Now check the pod document for errors
536     $checker->parse_from_file($infile, $outfile);
537
538     ## Return the number of errors found
539     return $checker->num_errors();
540 }
541
542 ##---------------------------------------------------------------------------
543
544 ##-------------------------------
545 ## Method definitions begin here
546 ##-------------------------------
547
548 ##################################
549
550 =over 4
551
552 =item C<Pod::Checker-E<gt>new( %options )>
553
554 Return a reference to a new Pod::Checker object that inherits from
555 Pod::Parser and is used for calling the required methods later. The
556 following options are recognized:
557
558 C<-warnings =E<gt> num>
559   Print warnings if C<num> is true. The higher the value of C<num>,
560 the more warnings are printed. Currently there are only levels 1 and 2.
561
562 C<-quiet =E<gt> num>
563   If C<num> is true, do not print any errors/warnings. This is useful
564 when Pod::Checker is used to munge POD code into plain text from within
565 POD formatters.
566
567 =cut
568
569 ## sub new {
570 ##     my $this = shift;
571 ##     my $class = ref($this) || $this;
572 ##     my %params = @_;
573 ##     my $self = {%params};
574 ##     bless $self, $class;
575 ##     $self->initialize();
576 ##     return $self;
577 ## }
578
579 sub initialize {
580     my $self = shift;
581     ## Initialize number of errors, and setup an error function to
582     ## increment this number and then print to the designated output.
583     $self->{_NUM_ERRORS} = 0;
584     $self->{_NUM_WARNINGS} = 0;
585     $self->{-quiet} ||= 0;
586     # set the error handling subroutine
587     $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror');
588     $self->{_commands} = 0; # total number of POD commands encountered
589     $self->{_list_stack} = []; # stack for nested lists
590     $self->{_have_begin} = ''; # stores =begin
591     $self->{_links} = []; # stack for internal hyperlinks
592     $self->{_nodes} = []; # stack for =head/=item nodes
593     $self->{_index} = []; # text in X<>
594     # print warnings?
595     $self->{-warnings} = 1 unless(defined $self->{-warnings});
596     $self->{_current_head1} = ''; # the current =head1 block
597     $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings});
598 }
599
600 ##################################
601
602 =item C<$checker-E<gt>poderror( @args )>
603
604 =item C<$checker-E<gt>poderror( {%opts}, @args )>
605
606 Internal method for printing errors and warnings. If no options are
607 given, simply prints "@_". The following options are recognized and used
608 to form the output:
609
610   -msg
611
612 A message to print prior to C<@args>.
613
614   -line
615
616 The line number the error occurred in.
617
618   -file
619
620 The file (name) the error occurred in.
621
622   -severity
623
624 The error level, should be 'WARNING' or 'ERROR'.
625
626 =cut
627
628 # Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )
629 sub poderror {
630     my $self = shift;
631     my %opts = (ref $_[0]) ? %{shift()} : ();
632
633     ## Retrieve options
634     chomp( my $msg  = ($opts{-msg} || '')."@_" );
635     my $line = (exists $opts{-line}) ? " at line $opts{-line}" : '';
636     my $file = (exists $opts{-file}) ? " in file $opts{-file}" : '';
637     unless (exists $opts{-severity}) {
638        ## See if can find severity in message prefix
639        $opts{-severity} = $1  if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
640     }
641     my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : '';
642
643     ## Increment error count and print message "
644     ++($self->{_NUM_ERRORS})
645         if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR'));
646     ++($self->{_NUM_WARNINGS})
647         if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING'));
648     unless($self->{-quiet}) {
649       my $out_fh = $self->output_handle() || \*STDERR;
650       print $out_fh ($severity, $msg, $line, $file, "\n")
651         if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING');
652     }
653 }
654
655 ##################################
656
657 =item C<$checker-E<gt>num_errors()>
658
659 Set (if argument specified) and retrieve the number of errors found.
660
661 =cut
662
663 sub num_errors {
664    return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS};
665 }
666
667 ##################################
668
669 =item C<$checker-E<gt>num_warnings()>
670
671 Set (if argument specified) and retrieve the number of warnings found.
672
673 =cut
674
675 sub num_warnings {
676    return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS};
677 }
678
679 ##################################
680
681 =item C<$checker-E<gt>name()>
682
683 Set (if argument specified) and retrieve the canonical name of POD as
684 found in the C<=head1 NAME> section.
685
686 =cut
687
688 sub name {
689     return (@_ > 1 && $_[1]) ?
690         ($_[0]->{-name} = $_[1]) : $_[0]->{-name};
691 }
692
693 ##################################
694
695 =item C<$checker-E<gt>node()>
696
697 Add (if argument specified) and retrieve the nodes (as defined by C<=headX>
698 and C<=item>) of the current POD. The nodes are returned in the order of
699 their occurrence. They consist of plain text, each piece of whitespace is
700 collapsed to a single blank.
701
702 =cut
703
704 sub node {
705     my ($self,$text) = @_;
706     if(defined $text) {
707         $text =~ s/\s+$//s; # strip trailing whitespace
708         $text =~ s/\s+/ /gs; # collapse whitespace
709         # add node, order important!
710         push(@{$self->{_nodes}}, $text);
711         # keep also a uniqueness counter
712         $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
713         return $text;
714     }
715     @{$self->{_nodes}};
716 }
717
718 ##################################
719
720 =item C<$checker-E<gt>idx()>
721
722 Add (if argument specified) and retrieve the index entries (as defined by
723 C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece
724 of whitespace is collapsed to a single blank.
725
726 =cut
727
728 # set/return index entries of current POD
729 sub idx {
730     my ($self,$text) = @_;
731     if(defined $text) {
732         $text =~ s/\s+$//s; # strip trailing whitespace
733         $text =~ s/\s+/ /gs; # collapse whitespace
734         # add node, order important!
735         push(@{$self->{_index}}, $text);
736         # keep also a uniqueness counter
737         $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
738         return $text;
739     }
740     @{$self->{_index}};
741 }
742
743 ##################################
744
745 =item C<$checker-E<gt>hyperlink()>
746
747 Add (if argument specified) and retrieve the hyperlinks (as defined by
748 C<LE<lt>E<gt>>) of the current POD. They consist of a 2-item array: line
749 number and C<Pod::Hyperlink> object.
750
751 =back
752
753 =cut
754
755 # set/return hyperlinks of the current POD
756 sub hyperlink {
757     my $self = shift;
758     if($_[0]) {
759         push(@{$self->{_links}}, $_[0]);
760         return $_[0];
761     }
762     @{$self->{_links}};
763 }
764
765 ## overrides for Pod::Parser
766
767 sub end_pod {
768     ## Do some final checks and
769     ## print the number of errors found
770     my $self   = shift;
771     my $infile = $self->input_file();
772
773     if(@{$self->{_list_stack}}) {
774         my $list;
775         while(($list = $self->_close_list('EOF',$infile)) &&
776           $list->indent() ne 'auto') {
777             $self->poderror({ -line => 'EOF', -file => $infile,
778                 -severity => 'ERROR', -msg => '=over on line ' .
779                 $list->start() . ' without closing =back' });
780         }
781     }
782
783     # check validity of document internal hyperlinks
784     # first build the node names from the paragraph text
785     my %nodes;
786     foreach($self->node()) {
787         $nodes{$_} = 1;
788         if(/^(\S+)\s+\S/) {
789             # we have more than one word. Use the first as a node, too.
790             # This is used heavily in perlfunc.pod
791             $nodes{$1} ||= 2; # derived node
792         }
793     }
794     foreach($self->idx()) {
795         $nodes{$_} = 3; # index node
796     }
797     foreach($self->hyperlink()) {
798         my ($line,$link) = @$_;
799         # _TODO_ what if there is a link to the page itself by the name,
800         # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION">
801         if($link->node() && !$link->page() && $link->type() ne 'hyperlink') {
802             my $node = $self->_check_ptree($self->parse_text($link->node(),
803                 $line), $line, $infile, 'L');
804             if($node && !$nodes{$node}) {
805                 $self->poderror({ -line => $line || '', -file => $infile,
806                     -severity => 'ERROR',
807                     -msg => "unresolved internal link '$node'"});
808             }
809         }
810         if($link->type() eq 'hyperlink') {
811             my $alt = $link->alttext();
812             if(defined($alt) && length($alt)) {
813                 $self->poderror({ -line => $line || '', -file => $infile,
814                     -severity => 'ERROR',
815                     -msg => "hyperlink to URL with alt text deprecated in perlpodspec"});
816             }
817         }
818     }
819
820     # check the internal nodes for uniqueness. This pertains to
821     # =headX, =item and X<...>
822     if($self->{-warnings} && $self->{-warnings}>1) {
823       foreach(grep($self->{_unique_nodes}->{$_} > 1,
824         keys %{$self->{_unique_nodes}})) {
825           $self->poderror({ -line => '-', -file => $infile,
826             -severity => 'WARNING',
827             -msg => "multiple occurrence of link target '$_'"});
828       }
829     }
830
831     # no POD found here
832     $self->num_errors(-1) if($self->{_commands} == 0);
833 }
834
835 # check a POD command directive
836 sub command {
837     my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
838     my ($file, $line) = $pod_para->file_line;
839     ## Check the command syntax
840     my $arg; # this will hold the command argument
841     if (! $VALID_COMMANDS{$cmd}) {
842        $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR',
843                          -msg => "Unknown command '$cmd'" });
844     }
845     else { # found a valid command
846         $self->{_commands}++; # delete this line if below is enabled again
847
848         $self->_commands_in_paragraphs($paragraph, $pod_para);
849
850         ##### following check disabled due to strong request
851         #if(!$self->{_commands}++ && $cmd !~ /^head/) {
852         #    $self->poderror({ -line => $line, -file => $file,
853         #         -severity => 'WARNING',
854         #         -msg => "file does not start with =head" });
855         #}
856
857         # check syntax of particular command
858         if($cmd eq 'over') {
859             # check for argument
860             $arg = $self->interpolate_and_check($paragraph, $line,$file);
861             my $indent = 4; # default
862             if($arg && $arg =~ /^\s*(\d+)\s*$/) {
863                 $indent = $1;
864             }
865             # start a new list
866             $self->_open_list($indent,$line,$file);
867         }
868         elsif($cmd eq 'item') {
869             # are we in a list?
870             unless(@{$self->{_list_stack}}) {
871                 $self->poderror({ -line => $line, -file => $file,
872                      -severity => 'ERROR',
873                      -msg => '=item without previous =over' });
874                 # auto-open in case we encounter many more
875                 $self->_open_list('auto',$line,$file);
876             }
877             my $list = $self->{_list_stack}->[0];
878             # check whether the previous item had some contents
879             if(defined $self->{_list_item_contents} &&
880               $self->{_list_item_contents} == 0) {
881                 $self->poderror({ -line => $line, -file => $file,
882                      -severity => 'WARNING',
883                      -msg => 'previous =item has no contents' });
884             }
885             if($list->{_has_par}) {
886                 $self->poderror({ -line => $line, -file => $file,
887                      -severity => 'WARNING',
888                      -msg => 'preceding non-item paragraph(s)' });
889                 delete $list->{_has_par};
890             }
891             # check for argument
892             $arg = $self->interpolate_and_check($paragraph, $line, $file);
893             if($arg && $arg =~ /(\S+)/) {
894                 $arg =~ s/[\s\n]+$//;
895                 my $type;
896                 if($arg =~ /^[*]\s*(\S*.*)/) {
897                   $type = 'bullet';
898                   $self->{_list_item_contents} = $1 ? 1 : 0;
899                   $arg = $1;
900                 }
901                 elsif($arg =~ /^\d+\.?\s+(\S*)/) {
902                   $type = 'number';
903                   $self->{_list_item_contents} = $1 ? 1 : 0;
904                   $arg = $1;
905                 }
906                 else {
907                   $type = 'definition';
908                   $self->{_list_item_contents} = 1;
909                 }
910                 my $first = $list->type();
911                 if($first && $first ne $type) {
912                     $self->poderror({ -line => $line, -file => $file,
913                        -severity => 'WARNING',
914                        -msg => "=item type mismatch ('$first' vs. '$type')"});
915                 }
916                 else { # first item
917                     $list->type($type);
918                 }
919             }
920             else {
921                 $self->poderror({ -line => $line, -file => $file,
922                      -severity => 'WARNING',
923                      -msg => 'No argument for =item' });
924                 $arg = ' '; # empty
925                 $self->{_list_item_contents} = 0;
926             }
927             # add this item
928             $list->item($arg);
929             # remember this node
930             $self->node($arg);
931         }
932         elsif($cmd eq 'back') {
933             # check if we have an open list
934             unless(@{$self->{_list_stack}}) {
935                 $self->poderror({ -line => $line, -file => $file,
936                          -severity => 'ERROR',
937                          -msg => '=back without previous =over' });
938             }
939             else {
940                 # check for spurious characters
941                 $arg = $self->interpolate_and_check($paragraph, $line,$file);
942                 if($arg && $arg =~ /\S/) {
943                     $self->poderror({ -line => $line, -file => $file,
944                          -severity => 'ERROR',
945                          -msg => 'Spurious character(s) after =back' });
946                 }
947                 # close list
948                 my $list = $self->_close_list($line,$file);
949                 # check for empty lists
950                 if(!$list->item() && $self->{-warnings}) {
951                     $self->poderror({ -line => $line, -file => $file,
952                          -severity => 'WARNING',
953                          -msg => 'No items in =over (at line ' .
954                          $list->start() . ') / =back list'});
955                 }
956             }
957         }
958         elsif($cmd =~ /^head(\d+)/) {
959             my $hnum = $1;
960             $self->{"_have_head_$hnum"}++; # count head types
961             if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) {
962               $self->poderror({ -line => $line, -file => $file,
963                    -severity => 'WARNING',
964                    -msg => "=head$hnum without preceding higher level"});
965             }
966             # check whether the previous =head section had some contents
967             if(defined $self->{_commands_in_head} &&
968               $self->{_commands_in_head} == 0 &&
969               defined $self->{_last_head} &&
970               $self->{_last_head} >= $hnum) {
971                 $self->poderror({ -line => $line, -file => $file,
972                      -severity => 'WARNING',
973                      -msg => 'empty section in previous paragraph'});
974             }
975             $self->{_commands_in_head} = -1;
976             $self->{_last_head} = $hnum;
977             # check if there is an open list
978             if(@{$self->{_list_stack}}) {
979                 my $list;
980                 while(($list = $self->_close_list($line,$file)) &&
981                   $list->indent() ne 'auto') {
982                     $self->poderror({ -line => $line, -file => $file,
983                          -severity => 'ERROR',
984                          -msg => '=over on line '. $list->start() .
985                          " without closing =back (at $cmd)" });
986                 }
987             }
988             # remember this node
989             $arg = $self->interpolate_and_check($paragraph, $line,$file);
990             $arg =~ s/[\s\n]+$//s;
991             $self->node($arg);
992             unless(length($arg)) {
993                 $self->poderror({ -line => $line, -file => $file,
994                      -severity => 'ERROR',
995                      -msg => "empty =$cmd"});
996             }
997             if($cmd eq 'head1') {
998                 $self->{_current_head1} = $arg;
999             } else {
1000                 $self->{_current_head1} = '';
1001             }
1002         }
1003         elsif($cmd eq 'begin') {
1004             if($self->{_have_begin}) {
1005                 # already have a begin
1006                 $self->poderror({ -line => $line, -file => $file,
1007                      -severity => 'ERROR',
1008                      -msg => q{Nested =begin's (first at line } .
1009                      $self->{_have_begin} . ')'});
1010             }
1011             else {
1012                 # check for argument
1013                 $arg = $self->interpolate_and_check($paragraph, $line,$file);
1014                 unless($arg && $arg =~ /(\S+)/) {
1015                     $self->poderror({ -line => $line, -file => $file,
1016                          -severity => 'ERROR',
1017                          -msg => 'No argument for =begin'});
1018                 }
1019                 # remember the =begin
1020                 $self->{_have_begin} = "$line:$1";
1021             }
1022         }
1023         elsif($cmd eq 'end') {
1024             if($self->{_have_begin}) {
1025                 # close the existing =begin
1026                 $self->{_have_begin} = '';
1027                 # check for spurious characters
1028                 $arg = $self->interpolate_and_check($paragraph, $line,$file);
1029                 # the closing argument is optional
1030                 #if($arg && $arg =~ /\S/) {
1031                 #    $self->poderror({ -line => $line, -file => $file,
1032                 #         -severity => 'WARNING',
1033                 #         -msg => "Spurious character(s) after =end" });
1034                 #}
1035             }
1036             else {
1037                 # don't have a matching =begin
1038                 $self->poderror({ -line => $line, -file => $file,
1039                      -severity => 'ERROR',
1040                      -msg => '=end without =begin' });
1041             }
1042         }
1043         elsif($cmd eq 'for') {
1044             unless($paragraph =~ /\s*(\S+)\s*/) {
1045                 $self->poderror({ -line => $line, -file => $file,
1046                      -severity => 'ERROR',
1047                      -msg => '=for without formatter specification' });
1048             }
1049             $arg = ''; # do not expand paragraph below
1050         }
1051         elsif($cmd =~ /^(pod|cut)$/) {
1052             # check for argument
1053             $arg = $self->interpolate_and_check($paragraph, $line,$file);
1054             if($arg && $arg =~ /(\S+)/) {
1055                 $self->poderror({ -line => $line, -file => $file,
1056                       -severity => 'ERROR',
1057                       -msg => "Spurious text after =$cmd"});
1058             }
1059             if($cmd eq 'cut' && (!$self->{_PREVIOUS} || $self->{_PREVIOUS} eq 'cut')) {
1060                 $self->poderror({ -line => $line, -file => $file,
1061                       -severity => 'ERROR',
1062                       -msg => "Spurious =cut command"});
1063             }
1064             if($cmd eq 'pod' && $self->{_PREVIOUS} && $self->{_PREVIOUS} ne 'cut') {
1065                 $self->poderror({ -line => $line, -file => $file,
1066                       -severity => 'ERROR',
1067                       -msg => "Spurious =pod command"});
1068             }
1069         }
1070     $self->{_commands_in_head}++;
1071     ## Check the interior sequences in the command-text
1072     $self->interpolate_and_check($paragraph, $line,$file)
1073         unless(defined $arg);
1074     }
1075 }
1076
1077 sub _open_list
1078 {
1079     my ($self,$indent,$line,$file) = @_;
1080     my $list = Pod::List->new(
1081            -indent => $indent,
1082            -start => $line,
1083            -file => $file);
1084     unshift(@{$self->{_list_stack}}, $list);
1085     undef $self->{_list_item_contents};
1086     $list;
1087 }
1088
1089 sub _close_list
1090 {
1091     my ($self,$line,$file) = @_;
1092     my $list = shift(@{$self->{_list_stack}});
1093     if(defined $self->{_list_item_contents} &&
1094       $self->{_list_item_contents} == 0) {
1095         $self->poderror({ -line => $line, -file => $file,
1096             -severity => 'WARNING',
1097             -msg => 'previous =item has no contents' });
1098     }
1099     undef $self->{_list_item_contents};
1100     $list;
1101 }
1102
1103 # process a block of some text
1104 sub interpolate_and_check {
1105     my ($self, $paragraph, $line, $file) = @_;
1106     ## Check the interior sequences in the command-text
1107     # and return the text
1108     $self->_check_ptree(
1109         $self->parse_text($paragraph,$line), $line, $file, '');
1110 }
1111
1112 sub _check_ptree {
1113     my ($self,$ptree,$line,$file,$nestlist) = @_;
1114     local($_);
1115     my $text = '';
1116     # process each node in the parse tree
1117     foreach(@$ptree) {
1118         # regular text chunk
1119         unless(ref) {
1120             # count the unescaped angle brackets
1121             # complain only when warning level is greater than 1
1122             if($self->{-warnings} && $self->{-warnings}>1) {
1123               my $count;
1124               if($count = tr/<>/<>/) {
1125                 $self->poderror({ -line => $line, -file => $file,
1126                      -severity => 'WARNING',
1127                      -msg => "$count unescaped <> in paragraph" });
1128                 }
1129             }
1130             $text .= $_;
1131             next;
1132         }
1133         # have an interior sequence
1134         my $cmd = $_->cmd_name();
1135         my $contents = $_->parse_tree();
1136         ($file,$line) = $_->file_line();
1137         # check for valid tag
1138         if (! $VALID_SEQUENCES{$cmd}) {
1139             $self->poderror({ -line => $line, -file => $file,
1140                  -severity => 'ERROR',
1141                  -msg => qq(Unknown interior-sequence '$cmd')});
1142             # expand it anyway
1143             $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
1144             next;
1145         }
1146         if(index($nestlist, $cmd) != -1) {
1147             $self->poderror({ -line => $line, -file => $file,
1148                  -severity => 'WARNING',
1149                  -msg => "nested commands $cmd<...$cmd<...>...>"});
1150             # _TODO_ should we add the contents anyway?
1151             # expand it anyway, see below
1152         }
1153         if($cmd eq 'E') {
1154             # preserve entities
1155             if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) {
1156                 $self->poderror({ -line => $line, -file => $file,
1157                     -severity => 'ERROR',
1158                     -msg => 'garbled entity ' . $_->raw_text()});
1159                 next;
1160             }
1161             my $ent = $$contents[0];
1162             my $val;
1163             if($ent =~ /^0x[0-9a-f]+$/i) {
1164                 # hexadec entity
1165                 $val = hex($ent);
1166             }
1167             elsif($ent =~ /^0\d+$/) {
1168                 # octal
1169                 $val = oct($ent);
1170             }
1171             elsif($ent =~ /^\d+$/) {
1172                 # numeric entity
1173                 $val = $ent;
1174             }
1175             if(defined $val) {
1176                 if($val>0 && $val<256) {
1177                     $text .= chr($val);
1178                 }
1179                 else {
1180                     $self->poderror({ -line => $line, -file => $file,
1181                         -severity => 'ERROR',
1182                         -msg => 'Entity number out of range ' . $_->raw_text()});
1183                 }
1184             }
1185             elsif($ENTITIES{$ent}) {
1186                 # known ISO entity
1187                 $text .= $ENTITIES{$ent};
1188             }
1189             else {
1190                 $self->poderror({ -line => $line, -file => $file,
1191                     -severity => 'WARNING',
1192                     -msg => 'Unknown entity ' . $_->raw_text()});
1193                 $text .= "E<$ent>";
1194             }
1195         }
1196         elsif($cmd eq 'L') {
1197             # try to parse the hyperlink
1198             my $link = Pod::Hyperlink->new($contents->raw_text());
1199             unless(defined $link) {
1200                 $self->poderror({ -line => $line, -file => $file,
1201                     -severity => 'ERROR',
1202                     -msg => 'malformed link ' . $_->raw_text() ." : $@"});
1203                 next;
1204             }
1205             $link->line($line); # remember line
1206             if($self->{-warnings}) {
1207                 foreach my $w ($link->warning()) {
1208                     $self->poderror({ -line => $line, -file => $file,
1209                         -severity => 'WARNING',
1210                         -msg => $w });
1211                 }
1212             }
1213             # check the link text
1214             $text .= $self->_check_ptree($self->parse_text($link->text(),
1215                 $line), $line, $file, "$nestlist$cmd");
1216             # remember link
1217             $self->hyperlink([$line,$link]);
1218         }
1219         elsif($cmd =~ /[BCFIS]/) {
1220             # add the guts
1221             $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
1222         }
1223         elsif($cmd eq 'Z') {
1224             if(length($contents->raw_text())) {
1225                 $self->poderror({ -line => $line, -file => $file,
1226                     -severity => 'ERROR',
1227                     -msg => 'Nonempty Z<>'});
1228             }
1229         }
1230         elsif($cmd eq 'X') {
1231             my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
1232             if($idx =~ /^\s*$/s) {
1233                 $self->poderror({ -line => $line, -file => $file,
1234                     -severity => 'ERROR',
1235                     -msg => 'Empty X<>'});
1236             }
1237             else {
1238                 # remember this node
1239                 $self->idx($idx);
1240             }
1241         }
1242         else {
1243             # not reached
1244             croak 'internal error';
1245         }
1246     }
1247     $text;
1248 }
1249
1250 # process a block of verbatim text
1251 sub verbatim {
1252     ## Nothing particular to check
1253     my ($self, $paragraph, $line_num, $pod_para) = @_;
1254
1255     $self->_preproc_par($paragraph);
1256     $self->_commands_in_paragraphs($paragraph, $pod_para);
1257
1258     if($self->{_current_head1} eq 'NAME') {
1259         my ($file, $line) = $pod_para->file_line;
1260         $self->poderror({ -line => $line, -file => $file,
1261             -severity => 'WARNING',
1262             -msg => 'Verbatim paragraph in NAME section' });
1263     }
1264 }
1265
1266 # process a block of regular text
1267 sub textblock {
1268     my ($self, $paragraph, $line_num, $pod_para) = @_;
1269     my ($file, $line) = $pod_para->file_line;
1270
1271     $self->_preproc_par($paragraph);
1272     $self->_commands_in_paragraphs($paragraph, $pod_para);
1273
1274     # skip this paragraph if in a =begin block
1275     unless($self->{_have_begin}) {
1276         my $block = $self->interpolate_and_check($paragraph, $line,$file);
1277         if($self->{_current_head1} eq 'NAME') {
1278             if($block =~ /^\s*(\S+?)\s*[,-]/) {
1279                 # this is the canonical name
1280                 $self->{-name} = $1 unless(defined $self->{-name});
1281             }
1282         }
1283     }
1284 }
1285
1286 sub _preproc_par
1287 {
1288     my $self = shift;
1289     $_[0] =~ s/[\s\n]+$//;
1290     if($_[0]) {
1291         $self->{_commands_in_head}++;
1292         $self->{_list_item_contents}++ if(defined $self->{_list_item_contents});
1293         if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) {
1294             $self->{_list_stack}->[0]->{_has_par} = 1;
1295         }
1296     }
1297 }
1298
1299 # look for =foo commands at the start of a line within a paragraph, as for
1300 # instance the following which prints as "* one =item two".
1301 #
1302 #     =item one
1303 #     =item two
1304 #
1305 # Examples of =foo written in docs are expected to be indented in a verbatim
1306 # or marked up C<=foo> so won't be caught.  A double-angle C<< =foo >> could
1307 # have the =foo at the start of a line, but that should be unlikely and is
1308 # easily enough dealt with by not putting a newline after the C<<.
1309 #
1310 sub _commands_in_paragraphs {
1311   my ($self, $str, $pod_para) = @_;
1312   while ($str =~ /[^\n]\n=([a-z][a-z0-9]+)/sg) {
1313     my $cmd = $1;
1314     my $pos = pos($str);
1315     if ($VALID_COMMANDS{$cmd}) {
1316       my ($file, $line) = $pod_para->file_line;
1317       my $part = substr($str, 0, $pos);
1318       $line += ($part =~ tr/\n//);  # count of newlines
1319
1320       $self->poderror
1321         ({ -line => $line, -file => $file,
1322            -severity => 'ERROR',
1323            -msg => "Apparent command =$cmd not preceded by blank line"});
1324     }
1325   }
1326 }
1327
1328 1;
1329
1330 __END__
1331
1332 =head1 AUTHOR
1333
1334 Please report bugs using L<http://rt.cpan.org>.
1335
1336 Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version),
1337 Marek Rouchal E<lt>marekr@cpan.orgE<gt>
1338
1339 Based on code for B<Pod::Text::pod2text()> written by
1340 Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
1341
1342 B<Pod::Checker> is part of the L<Pod::Parser> distribution.
1343
1344 =cut
1345