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