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