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