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