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