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