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