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