lib/Pod/Html.pm

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