This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [ID 20020213.015] Pod::Html XHTML update for 5.7.2
[perl5.git] / lib / Pod / Html.pm
1 package Pod::Html;
2 use strict;
3 require Exporter;
4
5 use vars qw($VERSION @ISA @EXPORT);
6 $VERSION = 1.04;
7 @ISA = qw(Exporter);
8 @EXPORT = qw(pod2html htmlify);
9
10 use Carp;
11 use Config;
12 use Cwd;
13 use File::Spec;
14 use File::Spec::Unix;
15 use Getopt::Long;
16
17 use locale;     # make \w work right in non-ASCII lands
18
19 =head1 NAME
20
21 Pod::Html - module to convert pod files to HTML
22
23 =head1 SYNOPSIS
24
25     use Pod::Html;
26     pod2html([options]);
27
28 =head1 DESCRIPTION
29
30 Converts files from pod format (see L<perlpod>) to HTML format.  It
31 can automatically generate indexes and cross-references, and it keeps
32 a cache of things it knows how to cross-reference.
33
34 =head1 ARGUMENTS
35
36 Pod::Html takes the following arguments:
37
38 =over 4
39
40 =item backlink
41
42     --backlink="Back to Top"
43
44 Adds "Back to Top" links in front of every C<head1> heading (except for
45 the first).  By default, no backlinks are generated.
46
47 =item cachedir
48
49     --cachedir=name
50
51 Creates the item and directory caches in the given directory.
52
53 =item css
54
55     --css=stylesheet
56
57 Specify the URL of a cascading style sheet.  Also disables all HTML/CSS
58 C<style> attributes that are output by default (to avoid conflicts).
59
60 =item flush
61
62     --flush
63
64 Flushes the item and directory caches.
65
66 =item header
67
68     --header
69     --noheader
70
71 Creates header and footer blocks containing the text of the C<NAME>
72 section.  By default, no headers are generated.
73
74 =item help
75
76     --help
77
78 Displays the usage message.
79
80 =item htmldir
81
82     --htmldir=name
83
84 Sets the directory in which the resulting HTML file is placed.  This
85 is used to generate relative links to other files. Not passing this
86 causes all links to be absolute, since this is the value that tells
87 Pod::Html the root of the documentation tree.
88
89 =item htmlroot
90
91     --htmlroot=name
92
93 Sets the base URL for the HTML files.  When cross-references are made,
94 the HTML root is prepended to the URL.
95
96 =item index
97
98     --index
99     --noindex
100
101 Generate an index at the top of the HTML file.  This is the default
102 behaviour.
103
104 =item infile
105
106     --infile=name
107
108 Specify the pod file to convert.  Input is taken from STDIN if no
109 infile is specified.
110
111 =item libpods
112
113     --libpods=name:...:name
114
115 List of page names (eg, "perlfunc") which contain linkable C<=item>s.
116
117 =item netscape
118
119     --netscape
120     --nonetscape
121
122 B<Deprecated>, has no effect. For backwards compatibility only.
123
124 =item outfile
125
126     --outfile=name
127
128 Specify the HTML file to create.  Output goes to STDOUT if no outfile
129 is specified.
130
131 =item podpath
132
133     --podpath=name:...:name
134
135 Specify which subdirectories of the podroot contain pod files whose
136 HTML converted forms can be linked to in cross references.
137
138 =item podroot
139
140     --podroot=name
141
142 Specify the base directory for finding library pods.
143
144 =item quiet
145
146     --quiet
147     --noquiet
148
149 Don't display I<mostly harmless> warning messages.  These messages
150 will be displayed by default.  But this is not the same as C<verbose>
151 mode.
152
153 =item recurse
154
155     --recurse
156     --norecurse
157
158 Recurse into subdirectories specified in podpath (default behaviour).
159
160 =item title
161
162     --title=title
163
164 Specify the title of the resulting HTML file.
165
166 =item verbose
167
168     --verbose
169     --noverbose
170
171 Display progress messages.  By default, they won't be displayed.
172
173 =back
174
175 =head1 EXAMPLE
176
177     pod2html("pod2html",
178              "--podpath=lib:ext:pod:vms",
179              "--podroot=/usr/src/perl",
180              "--htmlroot=/perl/nmanual",
181              "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
182              "--recurse",
183              "--infile=foo.pod",
184              "--outfile=/perl/nmanual/foo.html");
185
186 =head1 ENVIRONMENT
187
188 Uses C<$Config{pod2html}> to setup default options.
189
190 =head1 AUTHOR
191
192 Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
193
194 =head1 SEE ALSO
195
196 L<perlpod>
197
198 =head1 COPYRIGHT
199
200 This program is distributed under the Artistic License.
201
202 =cut
203
204 my $cachedir = ".";             # The directory to which item and directory
205                                 # caches will be written.
206 my $cache_ext = $^O eq 'VMS' ? ".tmp" : ".x~~";
207 my $dircache = "pod2htmd$cache_ext";
208 my $itemcache = "pod2htmi$cache_ext";
209
210 my @begin_stack = ();           # begin/end stack
211
212 my @libpods = ();               # files to search for links from C<> directives
213 my $htmlroot = "/";             # http-server base directory from which all
214                                 #   relative paths in $podpath stem.
215 my $htmldir = "";               # The directory to which the html pages
216                                 # will (eventually) be written.
217 my $htmlfile = "";              # write to stdout by default
218 my $htmlfileurl = "" ;          # The url that other files would use to
219                                 # refer to this file.  This is only used
220                                 # to make relative urls that point to
221                                 # other files.
222 my $podfile = "";               # read from stdin by default
223 my @podpath = ();               # list of directories containing library pods.
224 my $podroot = File::Spec->curdir;               # filesystem base directory from which all
225                                 #   relative paths in $podpath stem.
226 my $css = '';                   # Cascading style sheet
227 my $recurse = 1;                # recurse on subdirectories in $podpath.
228 my $quiet = 0;                  # not quiet by default
229 my $verbose = 0;                # not verbose by default
230 my $doindex = 1;                # non-zero if we should generate an index
231 my $backlink = '';              # text for "back to top" links
232 my $listlevel = 0;              # current list depth
233 my @listend = ();               # the text to use to end the list.
234 my $after_lpar = 0;             # set to true after a par in an =item
235 my $ignore = 1;                 # whether or not to format text.  we don't
236                                 #   format text until we hit our first pod
237                                 #   directive.
238
239 my %items_named = ();           # for the multiples of the same item in perlfunc
240 my @items_seen = ();
241 my $title;                      # title to give the pod(s)
242 my $header = 0;                 # produce block header/footer
243 my $top = 1;                    # true if we are at the top of the doc.  used
244                                 #   to prevent the first <hr /> directive.
245 my $paragraph;                  # which paragraph we're processing (used
246                                 #   for error messages)
247 my $ptQuote = 0;                # status of double-quote conversion
248 my %pages = ();                 # associative array used to find the location
249                                 #   of pages referenced by L<> links.
250 my %sections = ();              # sections within this page
251 my %items = ();                 # associative array used to find the location
252                                 #   of =item directives referenced by C<> links
253 my %local_items = ();           # local items - avoid destruction of %items
254 my $Is83;                       # is dos with short filenames (8.3)
255
256 sub init_globals {
257 $dircache = "pod2htmd$cache_ext";
258 $itemcache = "pod2htmi$cache_ext";
259
260 @begin_stack = ();              # begin/end stack
261
262 @libpods = ();          # files to search for links from C<> directives
263 $htmlroot = "/";                # http-server base directory from which all
264                                 #   relative paths in $podpath stem.
265 $htmldir = "";          # The directory to which the html pages
266                                 # will (eventually) be written.
267 $htmlfile = "";         # write to stdout by default
268 $podfile = "";          # read from stdin by default
269 @podpath = ();          # list of directories containing library pods.
270 $podroot = File::Spec->curdir;          # filesystem base directory from which all
271                                 #   relative paths in $podpath stem.
272 $css = '';                   # Cascading style sheet
273 $recurse = 1;           # recurse on subdirectories in $podpath.
274 $quiet = 0;             # not quiet by default
275 $verbose = 0;           # not verbose by default
276 $doindex = 1;                   # non-zero if we should generate an index
277 $backlink = '';         # text for "back to top" links
278 $listlevel = 0;         # current list depth
279 @listend = ();          # the text to use to end the list.
280 $after_lpar = 0;        # set to true after a par in an =item
281 $ignore = 1;                    # whether or not to format text.  we don't
282                                 #   format text until we hit our first pod
283                                 #   directive.
284
285 @items_seen = ();
286 %items_named = ();
287 $header = 0;                    # produce block header/footer
288 $title = '';                    # title to give the pod(s)
289 $top = 1;                       # true if we are at the top of the doc.  used
290                                 #   to prevent the first <hr /> directive.
291 $paragraph = '';                        # which paragraph we're processing (used
292                                 #   for error messages)
293 %sections = ();         # sections within this page
294
295 # These are not reinitialised here but are kept as a cache.
296 # See get_cache and related cache management code.
297 #%pages = ();                   # associative array used to find the location
298                                 #   of pages referenced by L<> links.
299 #%items = ();                   # associative array used to find the location
300                                 #   of =item directives referenced by C<> links
301 %local_items = ();
302 $Is83=$^O eq 'dos';
303 }
304
305 #
306 # clean_data: global clean-up of pod data
307 #
308 sub clean_data($){
309     my( $dataref ) = @_;
310     for my $i ( 0..$#{$dataref} ) {
311         ${$dataref}[$i] =~ s/\s+\Z//;
312
313         # have a look for all-space lines
314       if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){
315             my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
316             splice( @$dataref, $i, 1, @chunks );
317         }
318     }
319 }
320
321
322 sub pod2html {
323     local(@ARGV) = @_;
324     local($/);
325     local $_;
326
327     init_globals();
328
329     $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
330
331     # cache of %pages and %items from last time we ran pod2html
332
333     #undef $opt_help if defined $opt_help;
334
335     # parse the command-line parameters
336     parse_command_line();
337
338     # escape the backlink argument (same goes for title but is done later...)
339     $backlink = html_escape($backlink) if defined $backlink;
340
341     # set some variables to their default values if necessary
342     local *POD;
343     unless (@ARGV && $ARGV[0]) {
344         $podfile  = "-" unless $podfile;        # stdin
345         open(POD, "<$podfile")
346                 || die "$0: cannot open $podfile file for input: $!\n";
347     } else {
348         $podfile = $ARGV[0];  # XXX: might be more filenames
349         *POD = *ARGV;
350     }
351     $htmlfile = "-" unless $htmlfile;   # stdout
352     $htmlroot = "" if $htmlroot eq "/"; # so we don't get a //
353     $htmldir =~ s#/\z## ;               # so we don't get a //
354     if (  $htmlroot eq ''
355        && defined( $htmldir )
356        && $htmldir ne ''
357        && substr( $htmlfile, 0, length( $htmldir ) ) eq $htmldir
358        )
359     {
360         # Set the 'base' url for this file, so that we can use it
361         # as the location from which to calculate relative links
362         # to other files. If this is '', then absolute links will
363         # be used throughout.
364         $htmlfileurl= "$htmldir/" . substr( $htmlfile, length( $htmldir ) + 1);
365     }
366
367     # read the pod a paragraph at a time
368     warn "Scanning for sections in input file(s)\n" if $verbose;
369     $/ = "";
370     my @poddata  = <POD>;
371     close(POD);
372     clean_data( \@poddata );
373
374     # scan the pod for =head[1-6] directives and build an index
375     my $index = scan_headings(\%sections, @poddata);
376
377     unless($index) {
378         warn "No headings in $podfile\n" if $verbose;
379     }
380
381     # open the output file
382     open(HTML, ">$htmlfile")
383             || die "$0: cannot open $htmlfile file for output: $!\n";
384
385     # put a title in the HTML file if one wasn't specified
386     if ($title eq '') {
387         TITLE_SEARCH: {
388             for (my $i = 0; $i < @poddata; $i++) {
389                 if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
390                     for my $para ( @poddata[$i, $i+1] ) {
391                         last TITLE_SEARCH
392                             if ($title) = $para =~ /(\S+\s+-+.*\S)/s;
393                     }
394                 }
395
396             }
397         }
398     }
399     if (!$title and $podfile =~ /\.pod\z/) {
400         # probably a split pod so take first =head[12] as title
401         for (my $i = 0; $i < @poddata; $i++) {
402             last if ($title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
403         }
404         warn "adopted '$title' as title for $podfile\n"
405             if $verbose and $title;
406     }
407     if ($title) {
408         $title =~ s/\s*\(.*\)//;
409     } else {
410         warn "$0: no title for $podfile" unless $quiet;
411         $podfile =~ /^(.*)(\.[^.\/]+)?\z/s;
412         $title = ($podfile eq "-" ? 'No Title' : $1);
413         warn "using $title" if $verbose;
414     }
415     $title = html_escape($title);
416
417     my $csslink = '';
418     my $bodystyle = ' style="background-color: white"';
419     my $tdstyle = ' style="background-color: #cccccc"';
420
421     if ($css) {
422       $csslink = qq(\n<link rel="stylesheet" href="$css" type="text/css" />);
423       $csslink =~ s,\\,/,g;
424       $csslink =~ s,(/.):,$1|,;
425       $bodystyle = '';
426       $tdstyle = '';
427     }
428
429       my $block = $header ? <<END_OF_BLOCK : '';
430 <table border="0" width="100%" cellspacing="0" cellpadding="3">
431 <tr><td class="block"$tdstyle valign="middle">
432 <big><strong><span class="block">&nbsp;$title</span></strong></big>
433 </td></tr>
434 </table>
435 END_OF_BLOCK
436
437     print HTML <<END_OF_HEAD;
438 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
439 <html xmlns="http://www.w3.org/1999/xhtml">
440 <head>
441 <title>$title</title>$csslink
442 <link rev="made" href="mailto:$Config{perladmin}" />
443 </head>
444
445 <body$bodystyle>
446 $block
447 END_OF_HEAD
448
449     # load/reload/validate/cache %pages and %items
450     get_cache($dircache, $itemcache, \@podpath, $podroot, $recurse);
451
452     # scan the pod for =item directives
453     scan_items( \%local_items, "", @poddata);
454
455     # put an index at the top of the file.  note, if $doindex is 0 we
456     # still generate an index, but surround it with an html comment.
457     # that way some other program can extract it if desired.
458     $index =~ s/--+/-/g;
459     print HTML "<p><a name=\"__index__\"></a></p>\n";
460     print HTML "<!-- INDEX BEGIN -->\n";
461     print HTML "<!--\n" unless $doindex;
462     print HTML $index;
463     print HTML "-->\n" unless $doindex;
464     print HTML "<!-- INDEX END -->\n\n";
465     print HTML "<hr />\n" if $doindex and $index;
466
467     # now convert this file
468     my $after_item;             # set to true after an =item
469     my $need_dd = 0;
470     warn "Converting input file $podfile\n" if $verbose;
471     foreach my $i (0..$#poddata){
472         $ptQuote = 0; # status of quote conversion
473
474         $_ = $poddata[$i];
475         $paragraph = $i+1;
476         if (/^(=.*)/s) {        # is it a pod directive?
477             $ignore = 0;
478             $after_item = 0;
479             $need_dd = 0;
480             $_ = $1;
481             if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
482                 process_begin($1, $2);
483             } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
484                 process_end($1, $2);
485             } elsif (/^=cut/) {                 # =cut
486                 process_cut();
487             } elsif (/^=pod/) {                 # =pod
488                 process_pod();
489             } else {
490                 next if @begin_stack && $begin_stack[-1] ne 'html';
491
492                 if (/^=(head[1-6])\s+(.*\S)/s) {        # =head[1-6] heading
493                     process_head( $1, $2, $doindex && $index );
494                 } elsif (/^=item\s*(.*\S)?/sm) {        # =item text
495                     warn "$0: $podfile: =item without bullet, number or text"
496                        . " in paragraph $paragraph.\n" if !defined($1) or $1 eq '';
497                     $need_dd = process_item( $1 );
498                     $after_item = 1;
499                 } elsif (/^=over\s*(.*)/) {             # =over N
500                     process_over();
501                 } elsif (/^=back/) {            # =back
502                     process_back();
503                 } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for
504                     process_for($1,$2);
505                 } else {
506                     /^=(\S*)\s*/;
507                     warn "$0: $podfile: unknown pod directive '$1' in "
508                        . "paragraph $paragraph.  ignoring.\n";
509                 }
510             }
511             $top = 0;
512         }
513         else {
514             next if $ignore;
515             next if @begin_stack && $begin_stack[-1] ne 'html';
516             print HTML and next if @begin_stack && $begin_stack[-1] eq 'html';
517             print HTML "<dd>\n" if $need_dd;
518             my $text = $_;
519             if( $text =~ /\A\s+/ ){
520                 process_pre( \$text );
521                 print HTML "<pre>\n$text</pre>\n";
522
523             } else {
524                 process_text( \$text );
525
526                 # experimental: check for a paragraph where all lines
527                 # have some ...\t...\t...\n pattern
528                 if( $text =~ /\t/ ){
529                     my @lines = split( "\n", $text );
530                     if( @lines > 1 ){
531                         my $all = 2;
532                         foreach my $line ( @lines ){
533                             if( $line =~ /\S/ && $line !~ /\t/ ){
534                                 $all--;
535                                 last if $all == 0;
536                             }
537                         }
538                         if( $all > 0 ){
539                             $text =~ s/\t+/<td>/g;
540                             $text =~ s/^/<tr><td>/gm;
541                             $text = '<table cellspacing="0" cellpadding="0">' .
542                                     $text . '</table>';
543                         }
544                     }
545                 }
546                 ## end of experimental
547
548                 if( $after_item ){
549                     print HTML "$text\n";
550                     $after_lpar = 1;
551                 } else {
552                     print HTML "<p>$text</p>\n";
553                 }
554             }
555             print HTML "</dd>\n" if $need_dd;
556             $after_item = 0;
557         }
558     }
559
560     # finish off any pending directives
561     finish_list();
562
563     # link to page index
564     print HTML "<p><a href=\"#__index__\"><small>$backlink</small></a></p>\n"
565         if $doindex and $index and $backlink;
566
567     print HTML <<END_OF_TAIL;
568 $block
569 </body>
570
571 </html>
572 END_OF_TAIL
573
574     # close the html file
575     close(HTML);
576
577     warn "Finished\n" if $verbose;
578 }
579
580 ##############################################################################
581
582 my $usage;                      # see below
583 sub usage {
584     my $podfile = shift;
585     warn "$0: $podfile: @_\n" if @_;
586     die $usage;
587 }
588
589 $usage =<<END_OF_USAGE;
590 Usage:  $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
591            --podpath=<name>:...:<name> --podroot=<name>
592            --libpods=<name>:...:<name> --recurse --verbose --index
593            --netscape --norecurse --noindex --cachedir=<name>
594
595   --backlink     - set text for "back to top" links (default: none).
596   --cachedir     - directory for the item and directory cache files.
597   --css          - stylesheet URL
598   --flush        - flushes the item and directory caches.
599   --[no]header   - produce block header/footer (default is no headers).
600   --help         - prints this message.
601   --htmldir      - directory for resulting HTML files.
602   --htmlroot     - http-server base directory from which all relative paths
603                    in podpath stem (default is /).
604   --[no]index    - generate an index at the top of the resulting html
605                    (default behaviour).
606   --infile       - filename for the pod to convert (input taken from stdin
607                    by default).
608   --libpods      - colon-separated list of pages to search for =item pod
609                    directives in as targets of C<> and implicit links (empty
610                    by default).  note, these are not filenames, but rather
611                    page names like those that appear in L<> links.
612   --outfile      - filename for the resulting html file (output sent to
613                    stdout by default).
614   --podpath      - colon-separated list of directories containing library
615                    pods (empty by default).
616   --podroot      - filesystem base directory from which all relative paths
617                    in podpath stem (default is .).
618   --[no]quiet    - supress some benign warning messages (default is off).
619   --[no]recurse  - recurse on those subdirectories listed in podpath
620                    (default behaviour).
621   --title        - title that will appear in resulting html file.
622   --[no]verbose  - self-explanatory (off by default).
623   --[no]netscape - deprecated, has no effect. for backwards compatibility only.
624
625 END_OF_USAGE
626
627 sub parse_command_line {
628     my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help,
629         $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,
630         $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,
631         $opt_recurse,$opt_title,$opt_verbose);
632
633     unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
634     my $result = GetOptions(
635                             'backlink=s' => \$opt_backlink,
636                             'cachedir=s' => \$opt_cachedir,
637                             'css=s'      => \$opt_css,
638                             'flush'      => \$opt_flush,
639                             'header!'    => \$opt_header,
640                             'help'       => \$opt_help,
641                             'htmldir=s'  => \$opt_htmldir,
642                             'htmlroot=s' => \$opt_htmlroot,
643                             'index!'     => \$opt_index,
644                             'infile=s'   => \$opt_infile,
645                             'libpods=s'  => \$opt_libpods,
646                             'netscape!'  => \$opt_netscape,
647                             'outfile=s'  => \$opt_outfile,
648                             'podpath=s'  => \$opt_podpath,
649                             'podroot=s'  => \$opt_podroot,
650                             'quiet!'     => \$opt_quiet,
651                             'recurse!'   => \$opt_recurse,
652                             'title=s'    => \$opt_title,
653                             'verbose!'   => \$opt_verbose,
654                            );
655     usage("-", "invalid parameters") if not $result;
656
657     usage("-") if defined $opt_help;    # see if the user asked for help
658     $opt_help = "";                     # just to make -w shut-up.
659
660     @podpath  = split(":", $opt_podpath) if defined $opt_podpath;
661     @libpods  = split(":", $opt_libpods) if defined $opt_libpods;
662
663     $backlink = $opt_backlink if defined $opt_backlink;
664     $cachedir = $opt_cachedir if defined $opt_cachedir;
665     $css      = $opt_css      if defined $opt_css;
666     $header   = $opt_header   if defined $opt_header;
667     $htmldir  = $opt_htmldir  if defined $opt_htmldir;
668     $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
669     $doindex  = $opt_index    if defined $opt_index;
670     $podfile  = $opt_infile   if defined $opt_infile;
671     $htmlfile = $opt_outfile  if defined $opt_outfile;
672     $podroot  = $opt_podroot  if defined $opt_podroot;
673     $quiet    = $opt_quiet    if defined $opt_quiet;
674     $recurse  = $opt_recurse  if defined $opt_recurse;
675     $title    = $opt_title    if defined $opt_title;
676     $verbose  = $opt_verbose  if defined $opt_verbose;
677
678     warn "Flushing item and directory caches\n"
679         if $opt_verbose && defined $opt_flush;
680     $dircache = "$cachedir/pod2htmd$cache_ext";
681     $itemcache = "$cachedir/pod2htmi$cache_ext";
682     unlink($dircache, $itemcache) if defined $opt_flush;
683 }
684
685
686 my $saved_cache_key;
687
688 sub get_cache {
689     my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
690     my @cache_key_args = @_;
691
692     # A first-level cache:
693     # Don't bother reading the cache files if they still apply
694     # and haven't changed since we last read them.
695
696     my $this_cache_key = cache_key(@cache_key_args);
697
698     return if $saved_cache_key and $this_cache_key eq $saved_cache_key;
699
700     # load the cache of %pages and %items if possible.  $tests will be
701     # non-zero if successful.
702     my $tests = 0;
703     if (-f $dircache && -f $itemcache) {
704         warn "scanning for item cache\n" if $verbose;
705         $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
706     }
707
708     # if we didn't succeed in loading the cache then we must (re)build
709     #  %pages and %items.
710     if (!$tests) {
711         warn "scanning directories in pod-path\n" if $verbose;
712         scan_podpath($podroot, $recurse, 0);
713     }
714     $saved_cache_key = cache_key(@cache_key_args);
715 }
716
717 sub cache_key {
718     my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
719     return join('!', $dircache, $itemcache, $recurse,
720         @$podpath, $podroot, stat($dircache), stat($itemcache));
721 }
722
723 #
724 # load_cache - tries to find if the caches stored in $dircache and $itemcache
725 #  are valid caches of %pages and %items.  if they are valid then it loads
726 #  them and returns a non-zero value.
727 #
728 sub load_cache {
729     my($dircache, $itemcache, $podpath, $podroot) = @_;
730     my($tests);
731     local $_;
732
733     $tests = 0;
734
735     open(CACHE, "<$itemcache") ||
736         die "$0: error opening $itemcache for reading: $!\n";
737     $/ = "\n";
738
739     # is it the same podpath?
740     $_ = <CACHE>;
741     chomp($_);
742     $tests++ if (join(":", @$podpath) eq $_);
743
744     # is it the same podroot?
745     $_ = <CACHE>;
746     chomp($_);
747     $tests++ if ($podroot eq $_);
748
749     # load the cache if its good
750     if ($tests != 2) {
751         close(CACHE);
752         return 0;
753     }
754
755     warn "loading item cache\n" if $verbose;
756     while (<CACHE>) {
757         /(.*?) (.*)$/;
758         $items{$1} = $2;
759     }
760     close(CACHE);
761
762     warn "scanning for directory cache\n" if $verbose;
763     open(CACHE, "<$dircache") ||
764         die "$0: error opening $dircache for reading: $!\n";
765     $/ = "\n";
766     $tests = 0;
767
768     # is it the same podpath?
769     $_ = <CACHE>;
770     chomp($_);
771     $tests++ if (join(":", @$podpath) eq $_);
772
773     # is it the same podroot?
774     $_ = <CACHE>;
775     chomp($_);
776     $tests++ if ($podroot eq $_);
777
778     # load the cache if its good
779     if ($tests != 2) {
780         close(CACHE);
781         return 0;
782     }
783
784     warn "loading directory cache\n" if $verbose;
785     while (<CACHE>) {
786         /(.*?) (.*)$/;
787         $pages{$1} = $2;
788     }
789
790     close(CACHE);
791
792     return 1;
793 }
794
795 #
796 # scan_podpath - scans the directories specified in @podpath for directories,
797 #  .pod files, and .pm files.  it also scans the pod files specified in
798 #  @libpods for =item directives.
799 #
800 sub scan_podpath {
801     my($podroot, $recurse, $append) = @_;
802     my($pwd, $dir);
803     my($libpod, $dirname, $pod, @files, @poddata);
804
805     unless($append) {
806         %items = ();
807         %pages = ();
808     }
809
810     # scan each directory listed in @podpath
811     $pwd = getcwd();
812     chdir($podroot)
813         || die "$0: error changing to directory $podroot: $!\n";
814     foreach $dir (@podpath) {
815         scan_dir($dir, $recurse);
816     }
817
818     # scan the pods listed in @libpods for =item directives
819     foreach $libpod (@libpods) {
820         # if the page isn't defined then we won't know where to find it
821         # on the system.
822         next unless defined $pages{$libpod} && $pages{$libpod};
823
824         # if there is a directory then use the .pod and .pm files within it.
825         # NOTE: Only finds the first so-named directory in the tree.
826 #       if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
827         if ($pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
828             #  find all the .pod and .pm files within the directory
829             $dirname = $1;
830             opendir(DIR, $dirname) ||
831                 die "$0: error opening directory $dirname: $!\n";
832             @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR));
833             closedir(DIR);
834
835             # scan each .pod and .pm file for =item directives
836             foreach $pod (@files) {
837                 open(POD, "<$dirname/$pod") ||
838                     die "$0: error opening $dirname/$pod for input: $!\n";
839                 @poddata = <POD>;
840                 close(POD);
841                 clean_data( \@poddata );
842
843                 scan_items( \%items, "$dirname/$pod", @poddata);
844             }
845
846             # use the names of files as =item directives too.
847 ### Don't think this should be done this way - confuses issues.(WL)
848 ###         foreach $pod (@files) {
849 ###             $pod =~ /^(.*)(\.pod|\.pm)$/;
850 ###             $items{$1} = "$dirname/$1.html" if $1;
851 ###         }
852         } elsif ($pages{$libpod} =~ /([^:]*\.pod):/ ||
853                  $pages{$libpod} =~ /([^:]*\.pm):/) {
854             # scan the .pod or .pm file for =item directives
855             $pod = $1;
856             open(POD, "<$pod") ||
857                 die "$0: error opening $pod for input: $!\n";
858             @poddata = <POD>;
859             close(POD);
860             clean_data( \@poddata );
861
862             scan_items( \%items, "$pod", @poddata);
863         } else {
864             warn "$0: shouldn't be here (line ".__LINE__."\n";
865         }
866     }
867     @poddata = ();      # clean-up a bit
868
869     chdir($pwd)
870         || die "$0: error changing to directory $pwd: $!\n";
871
872     # cache the item list for later use
873     warn "caching items for later use\n" if $verbose;
874     open(CACHE, ">$itemcache") ||
875         die "$0: error open $itemcache for writing: $!\n";
876
877     print CACHE join(":", @podpath) . "\n$podroot\n";
878     foreach my $key (keys %items) {
879         print CACHE "$key $items{$key}\n";
880     }
881
882     close(CACHE);
883
884     # cache the directory list for later use
885     warn "caching directories for later use\n" if $verbose;
886     open(CACHE, ">$dircache") ||
887         die "$0: error open $dircache for writing: $!\n";
888
889     print CACHE join(":", @podpath) . "\n$podroot\n";
890     foreach my $key (keys %pages) {
891         print CACHE "$key $pages{$key}\n";
892     }
893
894     close(CACHE);
895 }
896
897 #
898 # scan_dir - scans the directory specified in $dir for subdirectories, .pod
899 #  files, and .pm files.  notes those that it finds.  this information will
900 #  be used later in order to figure out where the pages specified in L<>
901 #  links are on the filesystem.
902 #
903 sub scan_dir {
904     my($dir, $recurse) = @_;
905     my($t, @subdirs, @pods, $pod, $dirname, @dirs);
906     local $_;
907
908     @subdirs = ();
909     @pods = ();
910
911     opendir(DIR, $dir) ||
912         die "$0: error opening directory $dir: $!\n";
913     while (defined($_ = readdir(DIR))) {
914         if (-d "$dir/$_" && $_ ne "." && $_ ne "..") {      # directory
915             $pages{$_}  = "" unless defined $pages{$_};
916             $pages{$_} .= "$dir/$_:";
917             push(@subdirs, $_);
918         } elsif (/\.pod\z/) {                               # .pod
919             s/\.pod\z//;
920             $pages{$_}  = "" unless defined $pages{$_};
921             $pages{$_} .= "$dir/$_.pod:";
922             push(@pods, "$dir/$_.pod");
923         } elsif (/\.html\z/) {                              # .html
924             s/\.html\z//;
925             $pages{$_}  = "" unless defined $pages{$_};
926             $pages{$_} .= "$dir/$_.pod:";
927         } elsif (/\.pm\z/) {                                # .pm
928             s/\.pm\z//;
929             $pages{$_}  = "" unless defined $pages{$_};
930             $pages{$_} .= "$dir/$_.pm:";
931             push(@pods, "$dir/$_.pm");
932         }
933     }
934     closedir(DIR);
935
936     # recurse on the subdirectories if necessary
937     if ($recurse) {
938         foreach my $subdir (@subdirs) {
939             scan_dir("$dir/$subdir", $recurse);
940         }
941     }
942 }
943
944 #
945 # scan_headings - scan a pod file for head[1-6] tags, note the tags, and
946 #  build an index.
947 #
948 sub scan_headings {
949     my($sections, @data) = @_;
950     my($tag, $which_head, $otitle, $listdepth, $index);
951
952     # here we need      local $ignore = 0;
953     #  unfortunately, we can't have it, because $ignore is lexical
954     $ignore = 0;
955
956     $listdepth = 0;
957     $index = "";
958
959     # scan for =head directives, note their name, and build an index
960     #  pointing to each of them.
961     foreach my $line (@data) {
962       if ($line =~ /^=(head)([1-6])\s+(.*)/) {
963         ($tag, $which_head, $otitle) = ($1,$2,$3);
964
965         my $title = depod( $otitle );
966         my $name = htmlify( $title );
967         $$sections{$name} = 1;
968         $name =~ s/\s/_/g; # htmlify keeps spaces but we don't want them here..
969         $title = process_text( \$otitle );
970
971             while ($which_head != $listdepth) {
972                 if ($which_head > $listdepth) {
973                     $index .= "\n" . ("\t" x $listdepth) . "<ul>\n";
974                     $listdepth++;
975                 } elsif ($which_head < $listdepth) {
976                     $listdepth--;
977                     $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
978                 }
979             }
980
981             $index .= "\n" . ("\t" x $listdepth) . "<li>" .
982                       "<a href=\"#" . $name . "\">" .
983                       $title . "</a></li>";
984         }
985     }
986
987     # finish off the lists
988     while ($listdepth--) {
989         $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
990     }
991
992     # get rid of bogus lists
993     $index =~ s,\t*<ul>\s*</ul>\n,,g;
994
995     $ignore = 1;        # restore old value;
996
997     return $index;
998 }
999
1000 #
1001 # scan_items - scans the pod specified by $pod for =item directives.  we
1002 #  will use this information later on in resolving C<> links.
1003 #
1004 sub scan_items {
1005     my( $itemref, $pod, @poddata ) = @_;
1006     my($i, $item);
1007     local $_;
1008
1009     $pod =~ s/\.pod\z//;
1010     $pod .= ".html" if $pod;
1011
1012     foreach $i (0..$#poddata) {
1013         my $txt = depod( $poddata[$i] );
1014
1015         # figure out what kind of item it is.
1016         # Build string for referencing this item.
1017         if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bullet
1018             next unless $1;
1019             $item = $1;
1020         } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list
1021             $item = $1;
1022         } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # plain item
1023             $item = $1;
1024         } else {
1025             next;
1026         }
1027         my $fid = fragment_id( $item );
1028         $$itemref{$fid} = "$pod" if $fid;
1029     }
1030 }
1031
1032 #
1033 # process_head - convert a pod head[1-6] tag and convert it to HTML format.
1034 #
1035 sub process_head {
1036     my($tag, $heading, $hasindex) = @_;
1037
1038     # figure out the level of the =head
1039     $tag =~ /head([1-6])/;
1040     my $level = $1;
1041
1042     if( $listlevel ){
1043         warn "$0: $podfile: unterminated list at =head in paragraph $paragraph.  ignoring.\n";
1044         while( $listlevel ){
1045             process_back();
1046         }
1047     }
1048
1049     print HTML "<p>\n";
1050     if( $level == 1 && ! $top ){
1051       print HTML "<a href=\"#__index__\"><small>$backlink</small></a>\n"
1052         if $hasindex and $backlink;
1053       print HTML "</p>\n<hr />\n"
1054     } else {
1055       print HTML "</p>\n";
1056     }
1057
1058     my $name = htmlify( depod( $heading ) );
1059     $name =~ s/\s/_/g; # htmlify keeps spaces but we don't want them here...
1060     my $convert = process_text( \$heading );
1061     print HTML "<h$level><a name=\"$name\">$convert</a></h$level>\n";
1062 }
1063
1064
1065 #
1066 # emit_item_tag - print an =item's text
1067 # Note: The global $EmittedItem is used for inhibiting self-references.
1068 #
1069 my $EmittedItem;
1070
1071 sub emit_item_tag($$$){
1072     my( $otext, $text, $compact ) = @_;
1073     my $item = fragment_id( $text );
1074
1075     $EmittedItem = $item;
1076     ### print STDERR "emit_item_tag=$item ($text)\n";
1077
1078     print HTML '<strong>';
1079     if ($items_named{$item}++) {
1080         print HTML process_text( \$otext );
1081     } else {
1082         my $name = 'item_' . $item;
1083         $name =~ s/\s/_/g; # we don't want spaces here...
1084         print HTML qq{<a name="$name">}, process_text( \$otext ), '</a>';
1085     }
1086     print HTML "</strong><br />\n";
1087     undef( $EmittedItem );
1088 }
1089
1090 sub emit_li {
1091     my( $tag ) = @_;
1092     if( $items_seen[$listlevel]++ == 0 ){
1093         push( @listend, "</$tag>" );
1094         print HTML "<$tag>\n";
1095     }
1096     my $emitted = $tag eq 'dl' ? 'dt' : 'li';
1097     print HTML "<$emitted>";
1098     return $emitted;
1099 }
1100
1101 #
1102 # process_item - convert a pod item tag and convert it to HTML format.
1103 #
1104 sub process_item {
1105     my( $otext ) = @_;
1106     my $need_dd = 0; # set to 1 if we need a <dd></dd> after an item
1107
1108     # lots of documents start a list without doing an =over.  this is
1109     # bad!  but, the proper thing to do seems to be to just assume
1110     # they did do an =over.  so warn them once and then continue.
1111     if( $listlevel == 0 ){
1112         warn "$0: $podfile: unexpected =item directive in paragraph $paragraph.  ignoring.\n";
1113         process_over();
1114     }
1115
1116     # formatting: insert a paragraph if preceding item has >1 paragraph
1117     if( $after_lpar ){
1118         print HTML "<p></p>\n";
1119         $after_lpar = 0;
1120     }
1121
1122     # remove formatting instructions from the text
1123     my $text = depod( $otext );
1124
1125     my $emitted; # the tag actually emitted, used for closing
1126
1127     # all the list variants:
1128     if( $text =~ /\A\*/ ){ # bullet
1129         $emitted = emit_li( 'ul' );
1130         if ($text =~ /\A\*\s+(.+)\Z/s ) { # with additional text
1131             my $tag = $1;
1132             $otext =~ s/\A\*\s+//;
1133             emit_item_tag( $otext, $tag, 1 );
1134         }
1135
1136     } elsif( $text =~ /\A\d+/ ){ # numbered list
1137         $emitted = emit_li( 'ol' );
1138         if ($text =~ /\A(?>\d+\.?)\s*(.+)\Z/s ) { # with additional text
1139             my $tag = $1;
1140             $otext =~ s/\A\d+\.?\s*//;
1141             emit_item_tag( $otext, $tag, 1 );
1142         }
1143
1144     } else {                    # definition list
1145         $emitted = emit_li( 'dl' );
1146         if ($text =~ /\A(.+)\Z/s ){ # should have text
1147             emit_item_tag( $otext, $text, 1 );
1148         }
1149         $need_dd = 1;
1150     }
1151     print HTML "</$emitted>" if $emitted;
1152     print HTML "\n";
1153     return $need_dd;
1154 }
1155
1156 #
1157 # process_over - process a pod over tag and start a corresponding HTML list.
1158 #
1159 sub process_over {
1160     # start a new list
1161     $listlevel++;
1162     push( @items_seen, 0 );
1163     $after_lpar = 0;
1164 }
1165
1166 #
1167 # process_back - process a pod back tag and convert it to HTML format.
1168 #
1169 sub process_back {
1170     if( $listlevel == 0 ){
1171         warn "$0: $podfile: unexpected =back directive in paragraph $paragraph.  ignoring.\n";
1172         return;
1173     }
1174
1175     # close off the list.  note, I check to see if $listend[$listlevel] is
1176     # defined because an =item directive may have never appeared and thus
1177     # $listend[$listlevel] may have never been initialized.
1178     $listlevel--;
1179     if( defined $listend[$listlevel] ){
1180         print HTML '<p></p>' if $after_lpar;
1181         print HTML $listend[$listlevel];
1182         print HTML "\n";
1183         pop( @listend );
1184     }
1185     $after_lpar = 0;
1186
1187     # clean up item count
1188     pop( @items_seen );
1189 }
1190
1191 #
1192 # process_cut - process a pod cut tag, thus start ignoring pod directives.
1193 #
1194 sub process_cut {
1195     $ignore = 1;
1196 }
1197
1198 #
1199 # process_pod - process a pod tag, thus stop ignoring pod directives
1200 # until we see a corresponding cut.
1201 #
1202 sub process_pod {
1203     # no need to set $ignore to 0 cause the main loop did it
1204 }
1205
1206 #
1207 # process_for - process a =for pod tag.  if it's for html, spit
1208 # it out verbatim, if illustration, center it, otherwise ignore it.
1209 #
1210 sub process_for {
1211     my($whom, $text) = @_;
1212     if ( $whom =~ /^(pod2)?html$/i) {
1213         print HTML $text;
1214     } elsif ($whom =~ /^illustration$/i) {
1215         1 while chomp $text;
1216         for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
1217           $text .= $ext, last if -r "$text$ext";
1218         }
1219         print HTML qq{<p align="center"><img src="$text" alt="$text illustration" /></p>};
1220     }
1221 }
1222
1223 #
1224 # process_begin - process a =begin pod tag.  this pushes
1225 # whom we're beginning on the begin stack.  if there's a
1226 # begin stack, we only print if it us.
1227 #
1228 sub process_begin {
1229     my($whom, $text) = @_;
1230     $whom = lc($whom);
1231     push (@begin_stack, $whom);
1232     if ( $whom =~ /^(pod2)?html$/) {
1233         print HTML $text if $text;
1234     }
1235 }
1236
1237 #
1238 # process_end - process a =end pod tag.  pop the
1239 # begin stack.  die if we're mismatched.
1240 #
1241 sub process_end {
1242     my($whom, $text) = @_;
1243     $whom = lc($whom);
1244     if ($begin_stack[-1] ne $whom ) {
1245         die "Unmatched begin/end at chunk $paragraph\n"
1246     }
1247     pop( @begin_stack );
1248 }
1249
1250 #
1251 # process_pre - indented paragraph, made into <pre></pre>
1252 #
1253 sub process_pre {
1254     my( $text ) = @_;
1255     my( $rest );
1256     return if $ignore;
1257
1258     $rest = $$text;
1259
1260     # insert spaces in place of tabs
1261     $rest =~ s#.*#
1262             my $line = $&;
1263             1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
1264             $line;
1265         #eg;
1266
1267     # convert some special chars to HTML escapes
1268     $rest = html_escape($rest);
1269
1270     # try and create links for all occurrences of perl.* within
1271     # the preformatted text.
1272     $rest =~ s{
1273                  (\s*)(perl\w+)
1274               }{
1275                  if ( defined $pages{$2} ){     # is a link
1276                      qq($1<a href="$htmlroot/$pages{$2}">$2</a>);
1277                  } elsif (defined $pages{dosify($2)}) { # is a link
1278                      qq($1<a href="$htmlroot/$pages{dosify($2)}">$2</a>);
1279                  } else {
1280                      "$1$2";
1281                  }
1282               }xeg;
1283      $rest =~ s{
1284                  (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
1285                }{
1286                   my $url ;
1287                   if ( $htmlfileurl ne '' ){
1288                      # Here, we take advantage of the knowledge
1289                      # that $htmlfileurl ne '' implies $htmlroot eq ''.
1290                      # Since $htmlroot eq '', we need to prepend $htmldir
1291                      # on the fron of the link to get the absolute path
1292                      # of the link's target. We check for a leading '/'
1293                      # to avoid corrupting links that are #, file:, etc.
1294                      my $old_url = $3 ;
1295                      $old_url = "$htmldir$old_url" if $old_url =~ m{^\/};
1296                      $url = relativize_url( "$old_url.html", $htmlfileurl );
1297                   } else {
1298                      $url = "$3.html" ;
1299                   }
1300                   "$1$url" ;
1301                }xeg;
1302
1303     # Look for embedded URLs and make them into links.  We don't
1304     # relativize them since they are best left as the author intended.
1305
1306     my $urls = '(' . join ('|', qw{
1307                 http
1308                 telnet
1309                 mailto
1310                 news
1311                 gopher
1312                 file
1313                 wais
1314                 ftp
1315             } )
1316         . ')';
1317
1318     my $ltrs = '\w';
1319     my $gunk = '/#~:.?+=&%@!\-';
1320     my $punc = '.:?\-';
1321     my $any  = "${ltrs}${gunk}${punc}";
1322
1323     $rest =~ s{
1324         \b                          # start at word boundary
1325         (                           # begin $1  {
1326           $urls     :               # need resource and a colon
1327           (?!:)                     # Ignore File::, among others.
1328           [$any] +?                 # followed by on or more
1329                                     #  of any valid character, but
1330                                     #  be conservative and take only
1331                                     #  what you need to....
1332         )                           # end   $1  }
1333         (?=                         # look-ahead non-consumptive assertion
1334                 [$punc]*            # either 0 or more puntuation
1335                 [^$any]             #   followed by a non-url char
1336             |                       # or else
1337                 $                   #   then end of the string
1338         )
1339       }{<a href="$1">$1</a>}igox;
1340
1341     # text should be as it is (verbatim)
1342     $$text = $rest;
1343 }
1344
1345
1346 #
1347 # pure text processing
1348 #
1349 # pure_text/inIS_text: differ with respect to automatic C<> recognition.
1350 # we don't want this to happen within IS
1351 #
1352 sub pure_text($){
1353     my $text = shift();
1354     process_puretext( $text, \$ptQuote, 1 );
1355 }
1356
1357 sub inIS_text($){
1358     my $text = shift();
1359     process_puretext( $text, \$ptQuote, 0 );
1360 }
1361
1362 #
1363 # process_puretext - process pure text (without pod-escapes) converting
1364 #  double-quotes and handling implicit C<> links.
1365 #
1366 sub process_puretext {
1367     my($text, $quote, $notinIS) = @_;
1368
1369     ## Guessing at func() or [$@%&]*var references in plain text is destined
1370     ## to produce some strange looking ref's. uncomment to disable:
1371     ## $notinIS = 0;
1372
1373     my(@words, $lead, $trail);
1374
1375     # convert double-quotes to single-quotes
1376     if( $$quote && $text =~ s/"/''/s ){
1377         $$quote = 0;
1378     }
1379     while ($text =~ s/"([^"]*)"/``$1''/sg) {};
1380     $$quote = 1 if $text =~ s/"/``/s;
1381
1382     # keep track of leading and trailing white-space
1383     $lead  = ($text =~ s/\A(\s+)//s ? $1 : "");
1384     $trail = ($text =~ s/(\s+)\Z//s ? $1 : "");
1385
1386     # split at space/non-space boundaries
1387     @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text );
1388
1389     # process each word individually
1390     foreach my $word (@words) {
1391         # skip space runs
1392         next if $word =~ /^\s*$/;
1393         # see if we can infer a link
1394         if( $notinIS && $word =~ /^(\w+)\((.*)\)$/ ) {
1395             # has parenthesis so should have been a C<> ref
1396             ## try for a pagename (perlXXX(1))?
1397             my( $func, $args ) = ( $1, $2 );
1398             if( $args =~ /^\d+$/ ){
1399                 my $url = page_sect( $word, '' );
1400                 if( defined $url ){
1401                     $word = "<a href=\"$url\">the $word manpage</a>";
1402                     next;
1403                 }
1404             }
1405             ## try function name for a link, append tt'ed argument list
1406             $word = emit_C( $func, '', "($args)");
1407
1408 #### disabled. either all (including $\W, $\w+{.*} etc.) or nothing.
1409 ##      } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) {
1410 ##          # perl variables, should be a C<> ref
1411 ##          $word = emit_C( $word );
1412
1413         } elsif ($word =~ m,^\w+://\w,) {
1414             # looks like a URL
1415             # Don't relativize it: leave it as the author intended
1416             $word = qq(<a href="$word">$word</a>);
1417         } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
1418             # looks like an e-mail address
1419             my ($w1, $w2, $w3) = ("", $word, "");
1420             ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
1421             ($w1, $w2, $w3) = ("&lt;", $1, "&gt;$2") if $word =~ /^<(.*?)>(,?)/;
1422             $word = qq($w1<a href="mailto:$w2">$w2</a>$w3);
1423         } else {
1424             $word = html_escape($word) if $word =~ /["&<>]/;
1425         }
1426     }
1427
1428     # put everything back together
1429     return $lead . join( '', @words ) . $trail;
1430 }
1431
1432
1433 #
1434 # process_text - handles plaintext that appears in the input pod file.
1435 # there may be pod commands embedded within the text so those must be
1436 # converted to html commands.
1437 #
1438
1439 sub process_text1($$;$$);
1440 sub pattern ($) { $_[0] ? '[^\S\n]+'.('>' x ($_[0] + 1)) : '>' }
1441 sub closing ($) { local($_) = shift; (defined && s/\s+$//) ? length : 0 }
1442
1443 sub process_text {
1444     return if $ignore;
1445     my( $tref ) = @_;
1446     my $res = process_text1( 0, $tref );
1447     $$tref = $res;
1448 }
1449
1450 sub process_text1($$;$$){
1451     my( $lev, $rstr, $func, $closing ) = @_;
1452     my $res = '';
1453
1454     unless (defined $func) {
1455         $func = '';
1456         $lev++;
1457     }
1458
1459     if( $func eq 'B' ){
1460         # B<text> - boldface
1461         $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>';
1462
1463     } elsif( $func eq 'C' ){
1464         # C<code> - can be a ref or <code></code>
1465         # need to extract text
1466         my $par = go_ahead( $rstr, 'C', $closing );
1467
1468         ## clean-up of the link target
1469         my $text = depod( $par );
1470
1471         ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ;
1472         ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n";
1473
1474         $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
1475
1476     } elsif( $func eq 'E' ){
1477         # E<x> - convert to character
1478         $$rstr =~ s/^([^>]*)>//;
1479         my $escape = $1;
1480         $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i;
1481         $res = "&$escape;";
1482
1483     } elsif( $func eq 'F' ){
1484         # F<filename> - italizice
1485         $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
1486
1487     } elsif( $func eq 'I' ){
1488         # I<text> - italizice
1489         $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
1490
1491     } elsif( $func eq 'L' ){
1492         # L<link> - link
1493         ## L<text|cross-ref> => produce text, use cross-ref for linking
1494         ## L<cross-ref> => make text from cross-ref
1495         ## need to extract text
1496         my $par = go_ahead( $rstr, 'L', $closing );
1497
1498         # some L<>'s that shouldn't be:
1499         # a) full-blown URL's are emitted as-is
1500         if( $par =~ m{^\w+://}s ){
1501             return make_URL_href( $par );
1502         }
1503         # b) C<...> is stripped and treated as C<>
1504         if( $par =~ /^C<(.*)>$/ ){
1505             my $text = depod( $1 );
1506             return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
1507         }
1508
1509         # analyze the contents
1510         $par =~ s/\n/ /g;   # undo word-wrapped tags
1511         my $opar = $par;
1512         my $linktext;
1513         if( $par =~ s{^([^|]+)\|}{} ){
1514             $linktext = $1;
1515         }
1516
1517         # make sure sections start with a /
1518         $par =~ s{^"}{/"};
1519
1520         my( $page, $section, $ident );
1521
1522         # check for link patterns
1523         if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){     # name/ident
1524             # we've got a name/ident (no quotes)
1525             ( $page, $ident ) = ( $1, $2 );
1526             ### print STDERR "--> L<$par> to page $page, ident $ident\n";
1527
1528         } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section"
1529             # even though this should be a "section", we go for ident first
1530             ( $page, $ident ) = ( $1, $2 );
1531             ### print STDERR "--> L<$par> to page $page, section $section\n";
1532
1533         } elsif( $par =~ /\s/ ){  # this must be a section with missing quotes
1534             ( $page, $section ) = ( '', $par );
1535             ### print STDERR "--> L<$par> to void page, section $section\n";
1536
1537         } else {
1538             ( $page, $section ) = ( $par, '' );
1539             ### print STDERR "--> L<$par> to page $par, void section\n";
1540         }
1541
1542         # now, either $section or $ident is defined. the convoluted logic
1543         # below tries to resolve L<> according to what the user specified.
1544         # failing this, we try to find the next best thing...
1545         my( $url, $ltext, $fid );
1546
1547         RESOLVE: {
1548             if( defined $ident ){
1549                 ## try to resolve $ident as an item
1550                 ( $url, $fid ) = coderef( $page, $ident );
1551                 if( $url ){
1552                     if( ! defined( $linktext ) ){
1553                         $linktext = $ident;
1554                         $linktext .= " in " if $ident && $page;
1555                         $linktext .= "the $page manpage" if $page;
1556                     }
1557                     ###  print STDERR "got coderef url=$url\n";
1558                     last RESOLVE;
1559                 }
1560                 ## no luck: go for a section (auto-quoting!)
1561                 $section = $ident;
1562             }
1563             ## now go for a section
1564             my $htmlsection = htmlify( $section );
1565             $url = page_sect( $page, $htmlsection );
1566             if( $url ){
1567                 if( ! defined( $linktext ) ){
1568                     $linktext = $section;
1569                     $linktext .= " in " if $section && $page;
1570                     $linktext .= "the $page manpage" if $page;
1571                 }
1572                 ### print STDERR "got page/section url=$url\n";
1573                 last RESOLVE;
1574             }
1575             ## no luck: go for an ident
1576             if( $section ){
1577                 $ident = $section;
1578             } else {
1579                 $ident = $page;
1580                 $page  = undef();
1581             }
1582             ( $url, $fid ) = coderef( $page, $ident );
1583             if( $url ){
1584                 if( ! defined( $linktext ) ){
1585                     $linktext = $ident;
1586                     $linktext .= " in " if $ident && $page;
1587                     $linktext .= "the $page manpage" if $page;
1588                 }
1589                 ### print STDERR "got section=>coderef url=$url\n";
1590                 last RESOLVE;
1591             }
1592
1593             # warning; show some text.
1594             $linktext = $opar unless defined $linktext;
1595             warn "$0: $podfile: cannot resolve L<$opar> in paragraph $paragraph.";
1596         }
1597
1598         # now we have a URL or just plain code
1599         $$rstr = $linktext . '>' . $$rstr;
1600         if( defined( $url ) ){
1601             $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>';
1602         } else {
1603             $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
1604         }
1605
1606     } elsif( $func eq 'S' ){
1607         # S<text> - non-breaking spaces
1608         $res = process_text1( $lev, $rstr );
1609         $res =~ s/ /&nbsp;/g;
1610
1611     } elsif( $func eq 'X' ){
1612         # X<> - ignore
1613         $$rstr =~ s/^[^>]*>//;
1614
1615     } elsif( $func eq 'Z' ){
1616         # Z<> - empty
1617         warn "$0: $podfile: invalid X<> in paragraph $paragraph."
1618             unless $$rstr =~ s/^>//;
1619
1620     } else {
1621         my $term = pattern $closing;
1622         while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
1623             # all others: either recurse into new function or
1624             # terminate at closing angle bracket(s)
1625             my $pt = $1;
1626             $pt .= $2 if !$3 &&  $lev == 1;
1627             $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt );
1628             return $res if !$3 && $lev > 1;
1629             if( $3 ){
1630                 $res .= process_text1( $lev, $rstr, $3, closing $4 );
1631             }
1632         }
1633         if( $lev == 1 ){
1634             $res .= pure_text( $$rstr );
1635         } else {
1636             warn "$0: $podfile: undelimited $func<> in paragraph $paragraph.";
1637         }
1638     }
1639     return $res;
1640 }
1641
1642 #
1643 # go_ahead: extract text of an IS (can be nested)
1644 #
1645 sub go_ahead($$$){
1646     my( $rstr, $func, $closing ) = @_;
1647     my $res = '';
1648     my @closing = ($closing);
1649     while( $$rstr =~
1650       s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|@{[pattern $closing[0]]})//s ){
1651         $res .= $1;
1652         unless( $3 ){
1653             shift @closing;
1654             return $res unless @closing;
1655         } else {
1656             unshift @closing, closing $4;
1657         }
1658         $res .= $2;
1659     }
1660     warn "$0: $podfile: undelimited $func<> in paragraph $paragraph.";
1661     return $res;
1662 }
1663
1664 #
1665 # emit_C - output result of C<text>
1666 #    $text is the depod-ed text
1667 #
1668 sub emit_C($;$$){
1669     my( $text, $nocode, $args ) = @_;
1670     $args = '' unless defined $args;
1671     my $res;
1672     my( $url, $fid ) = coderef( undef(), $text );
1673
1674     # need HTML-safe text
1675     my $linktext = html_escape( "$text$args" );
1676
1677     if( defined( $url ) &&
1678         (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){
1679         $res = "<a href=\"$url\"><code>$linktext</code></a>";
1680     } elsif( 0 && $nocode ){
1681         $res = $linktext;
1682     } else {
1683         $res = "<code>$linktext</code>";
1684     }
1685     return $res;
1686 }
1687
1688 #
1689 # html_escape: make text safe for HTML
1690 #
1691 sub html_escape {
1692     my $rest = $_[0];
1693     $rest   =~ s/&/&amp;/g;
1694     $rest   =~ s/</&lt;/g;
1695     $rest   =~ s/>/&gt;/g;
1696     $rest   =~ s/"/&quot;/g;
1697     $rest   =~ s/'/&apos;/g;
1698     return $rest;
1699 }
1700
1701
1702 #
1703 # dosify - convert filenames to 8.3
1704 #
1705 sub dosify {
1706     my($str) = @_;
1707     return lc($str) if $^O eq 'VMS';     # VMS just needs casing
1708     if ($Is83) {
1709         $str = lc $str;
1710         $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
1711         $str =~ s/(\w+)/substr ($1,0,8)/ge;
1712     }
1713     return $str;
1714 }
1715
1716 #
1717 # page_sect - make a URL from the text of a L<>
1718 #
1719 sub page_sect($$) {
1720     my( $page, $section ) = @_;
1721     my( $linktext, $page83, $link);     # work strings
1722
1723     # check if we know that this is a section in this page
1724     if (!defined $pages{$page} && defined $sections{$page}) {
1725         $section = $page;
1726         $page = "";
1727         ### print STDERR "reset page='', section=$section\n";
1728     }
1729
1730     $page83=dosify($page);
1731     $page=$page83 if (defined $pages{$page83});
1732     if ($page eq "") {
1733         $link = "#" . htmlify( $section );
1734     } elsif ( $page =~ /::/ ) {
1735         $page =~ s,::,/,g;
1736         # Search page cache for an entry keyed under the html page name,
1737         # then look to see what directory that page might be in.  NOTE:
1738         # this will only find one page. A better solution might be to produce
1739         # an intermediate page that is an index to all such pages.
1740         my $page_name = $page ;
1741         $page_name =~ s,^.*/,,s ;
1742         if ( defined( $pages{ $page_name } ) &&
1743              $pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
1744            ) {
1745             $page = $1 ;
1746         }
1747         else {
1748             # NOTE: This branch assumes that all A::B pages are located in
1749             # $htmlroot/A/B.html . This is often incorrect, since they are
1750             # often in $htmlroot/lib/A/B.html or such like. Perhaps we could
1751             # analyze the contents of %pages and figure out where any
1752             # cousins of A::B are, then assume that.  So, if A::B isn't found,
1753             # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
1754             # lib/A/B.pm. This is also limited, but it's an improvement.
1755             # Maybe a hints file so that the links point to the correct places
1756             # nonetheless?
1757
1758         }
1759         $link = "$htmlroot/$page.html";
1760         $link .= "#" . htmlify( $section ) if ($section);
1761     } elsif (!defined $pages{$page}) {
1762         $link = "";
1763     } else {
1764         $section = htmlify( $section ) if $section ne "";
1765         ### print STDERR "...section=$section\n";
1766
1767         # if there is a directory by the name of the page, then assume that an
1768         # appropriate section will exist in the subdirectory
1769 #       if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
1770         if ($section ne "" && $pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
1771             $link = "$htmlroot/$1/$section.html";
1772             ### print STDERR "...link=$link\n";
1773
1774         # since there is no directory by the name of the page, the section will
1775         # have to exist within a .html of the same name.  thus, make sure there
1776         # is a .pod or .pm that might become that .html
1777         } else {
1778             $section = "#$section" if $section;
1779             ### print STDERR "...section=$section\n";
1780
1781             # check if there is a .pod with the page name
1782             if ($pages{$page} =~ /([^:]*)\.pod:/) {
1783                 $link = "$htmlroot/$1.html$section";
1784             } elsif ($pages{$page} =~ /([^:]*)\.pm:/) {
1785                 $link = "$htmlroot/$1.html$section";
1786             } else {
1787                 $link = "";
1788             }
1789         }
1790     }
1791
1792     if ($link) {
1793         # Here, we take advantage of the knowledge that $htmlfileurl ne ''
1794         # implies $htmlroot eq ''. This means that the link in question
1795         # needs a prefix of $htmldir if it begins with '/'. The test for
1796         # the initial '/' is done to avoid '#'-only links, and to allow
1797         # for other kinds of links, like file:, ftp:, etc.
1798         my $url ;
1799         if (  $htmlfileurl ne '' ) {
1800             $link = "$htmldir$link" if $link =~ m{^/}s;
1801             $url = relativize_url( $link, $htmlfileurl );
1802 # print( "  b: [$link,$htmlfileurl,$url]\n" );
1803         }
1804         else {
1805             $url = $link ;
1806         }
1807         return $url;
1808
1809     } else {
1810         return undef();
1811     }
1812 }
1813
1814 #
1815 # relativize_url - convert an absolute URL to one relative to a base URL.
1816 # Assumes both end in a filename.
1817 #
1818 sub relativize_url {
1819     my ($dest,$source) = @_ ;
1820
1821     my ($dest_volume,$dest_directory,$dest_file) =
1822         File::Spec::Unix->splitpath( $dest ) ;
1823     $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
1824
1825     my ($source_volume,$source_directory,$source_file) =
1826         File::Spec::Unix->splitpath( $source ) ;
1827     $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
1828
1829     my $rel_path = '' ;
1830     if ( $dest ne '' ) {
1831        $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
1832     }
1833
1834     if ( $rel_path ne ''                &&
1835          substr( $rel_path, -1 ) ne '/' &&
1836          substr( $dest_file, 0, 1 ) ne '#'
1837         ) {
1838         $rel_path .= "/$dest_file" ;
1839     }
1840     else {
1841         $rel_path .= "$dest_file" ;
1842     }
1843
1844     return $rel_path ;
1845 }
1846
1847
1848 #
1849 # coderef - make URL from the text of a C<>
1850 #
1851 sub coderef($$){
1852     my( $page, $item ) = @_;
1853     my( $url );
1854
1855     my $fid = fragment_id( $item );
1856     if( defined( $page ) ){
1857         # we have been given a $page...
1858         $page =~ s{::}{/}g;
1859
1860         # Do we take it? Item could be a section!
1861         my $base = $items{$fid} || "";
1862         $base =~ s{[^/]*/}{};
1863         if( $base ne "$page.html" ){
1864             ###   print STDERR "coderef( $page, $item ): items{$fid} = $items{$fid} = $base => discard page!\n";
1865             $page = undef();
1866         }
1867
1868     } else {
1869         # no page - local items precede cached items
1870         if( defined( $fid ) ){
1871             if(  exists $local_items{$fid} ){
1872                 $page = $local_items{$fid};
1873             } else {
1874                 $page = $items{$fid};
1875             }
1876         }
1877     }
1878
1879     # if there was a pod file that we found earlier with an appropriate
1880     # =item directive, then create a link to that page.
1881     if( defined $page ){
1882         if( $page ){
1883             if( exists $pages{$page} and $pages{$page} =~ /([^:.]*)\.[^:]*:/){
1884                 $page = $1 . '.html';
1885             }
1886             my $link = "$htmlroot/$page#item_$fid";
1887
1888             # Here, we take advantage of the knowledge that $htmlfileurl
1889             # ne '' implies $htmlroot eq ''.
1890             if (  $htmlfileurl ne '' ) {
1891                 $link = "$htmldir$link" ;
1892                 $url = relativize_url( $link, $htmlfileurl ) ;
1893             } else {
1894                 $url = $link ;
1895             }
1896         } else {
1897             $url = "#item_" . $fid;
1898         }
1899
1900         confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/;
1901     }
1902     return( $url, $fid );
1903 }
1904
1905
1906
1907 #
1908 # Adapted from Nick Ing-Simmons' PodToHtml package.
1909 sub relative_url {
1910     my $source_file = shift ;
1911     my $destination_file = shift;
1912
1913     my $source = URI::file->new_abs($source_file);
1914     my $uo = URI::file->new($destination_file,$source)->abs;
1915     return $uo->rel->as_string;
1916 }
1917
1918
1919 #
1920 # finish_list - finish off any pending HTML lists.  this should be called
1921 # after the entire pod file has been read and converted.
1922 #
1923 sub finish_list {
1924     while ($listlevel > 0) {
1925         print HTML "</dl>\n";
1926         $listlevel--;
1927     }
1928 }
1929
1930 #
1931 # htmlify - converts a pod section specification to a suitable section
1932 # specification for HTML. Note that we keep spaces and special characters
1933 # except ", ? (Netscape problem) and the hyphen (writer's problem...).
1934 #
1935 sub htmlify {
1936     my( $heading) = @_;
1937     $heading =~ s/(\s+)/ /g;
1938     $heading =~ s/\s+\Z//;
1939     $heading =~ s/\A\s+//;
1940     # The hyphen is a disgrace to the English language.
1941     $heading =~ s/[-"?]//g;
1942     $heading = lc( $heading );
1943     return $heading;
1944 }
1945
1946 #
1947 # depod - convert text by eliminating all interior sequences
1948 # Note: can be called with copy or modify semantics
1949 #
1950 my %E2c;
1951 $E2c{lt}     = '<';
1952 $E2c{gt}     = '>';
1953 $E2c{sol}    = '/';
1954 $E2c{verbar} = '|';
1955 $E2c{amp}    = '&'; # in Tk's pods
1956
1957 sub depod1($;$$);
1958
1959 sub depod($){
1960     my $string;
1961     if( ref( $_[0] ) ){
1962         $string =  ${$_[0]};
1963         ${$_[0]} = depod1( \$string );
1964     } else {
1965         $string =  $_[0];
1966         depod1( \$string );
1967     }
1968 }
1969
1970 sub depod1($;$$){
1971   my( $rstr, $func, $closing ) = @_;
1972   my $res = '';
1973   return $res unless defined $$rstr;
1974   if( ! defined( $func ) ){
1975       # skip to next begin of an interior sequence
1976       while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?// ){
1977          # recurse into its text
1978           $res .= $1 . depod1( $rstr, $2, closing $3);
1979       }
1980       $res .= $$rstr;
1981   } elsif( $func eq 'E' ){
1982       # E<x> - convert to character
1983       $$rstr =~ s/^([^>]*)>//;
1984       $res .= $E2c{$1} || "";
1985   } elsif( $func eq 'X' ){
1986       # X<> - ignore
1987       $$rstr =~ s/^[^>]*>//;
1988   } elsif( $func eq 'Z' ){
1989       # Z<> - empty
1990       $$rstr =~ s/^>//;
1991   } else {
1992       # all others: either recurse into new function or
1993       # terminate at closing angle bracket
1994       my $term = pattern $closing;
1995       while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)// ){
1996           $res .= $1;
1997           last unless $3;
1998           $res .= depod1( $rstr, $3, closing $4 );
1999       }
2000       ## If we're here and $2 ne '>': undelimited interior sequence.
2001       ## Ignored, as this is called without proper indication of where we are.
2002       ## Rely on process_text to produce diagnostics.
2003   }
2004   return $res;
2005 }
2006
2007 #
2008 # fragment_id - construct a fragment identifier from:
2009 #   a) =item text
2010 #   b) contents of C<...>
2011 #
2012 my @hc;
2013 sub fragment_id {
2014     my $text = shift();
2015     $text =~ s/\s+\Z//s;
2016     if( $text ){
2017         # a method or function?
2018         return $1 if $text =~ /(\w+)\s*\(/;
2019         return $1 if $text =~ /->\s*(\w+)\s*\(?/;
2020
2021         # a variable name?
2022         return $1 if $text =~ /^([$@%*]\S+)/;
2023
2024         # some pattern matching operator?
2025         return $1 if $text =~ m|^(\w+/).*/\w*$|;
2026
2027         # fancy stuff... like "do { }"
2028         return $1 if $text =~ m|^(\w+)\s*{.*}$|;
2029
2030         # honour the perlfunc manpage: func [PAR[,[ ]PAR]...]
2031         # and some funnies with ... Module ...
2032         return $1 if $text =~ m{^([a-z\d]+)(\s+[A-Z\d,/& ]+)?$};
2033         return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$};
2034
2035         # text? normalize!
2036         $text =~ s/\s+/_/sg;
2037         $text =~ s{(\W)}{
2038          defined( $hc[ord($1)] ) ? $hc[ord($1)]
2039                  : ( $hc[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe;
2040         $text = substr( $text, 0, 50 );
2041     } else {
2042         return undef();
2043     }
2044 }
2045
2046 #
2047 # make_URL_href - generate HTML href from URL
2048 # Special treatment for CGI queries.
2049 #
2050 sub make_URL_href($){
2051     my( $url ) = @_;
2052     if( $url !~
2053         s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){
2054         $url = "<a href=\"$url\">$url</a>";
2055     }
2056     return $url;
2057 }
2058
2059 1;