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