lib/Pod/Html.pm

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