lib/Pod/Html.pm

   1 package Pod::Html;
   2
   3 use Pod::Functions;
   4 use Getopt::Long;       # package for handling command-line parameters
   5 use File::Spec::Unix;
   6 require Exporter;
   7 use vars qw($VERSION);
   8 $VERSION = 1.02;
   9 @ISA = Exporter;
  10 @EXPORT = qw(pod2html htmlify);
  11 use Cwd;
  12
  13 use Carp;
  14
  15 use locale;     # make \w work right in non-ASCII lands
  16
  17 use strict;
  18
  19 use Config;
  20
  21 =head1 NAME
  22
  23 Pod::Html - module to convert pod files to HTML
  24
  25 =head1 SYNOPSIS
  26
  27     use Pod::Html;
  28     pod2html([options]);
  29
  30 =head1 DESCRIPTION
  31
  32 Converts files from pod format (see L<perlpod>) to HTML format.  It
  33 can automatically generate indexes and cross-references, and it keeps
  34 a cache of things it knows how to cross-reference.
  35
  36 =head1 ARGUMENTS
  37
  38 Pod::Html takes the following arguments:
  39
  40 =over 4
  41
  42 =item help
  43
  44     --help
  45
  46 Displays the usage message.
  47
  48 =item htmldir
  49
  50     --htmldir=name
  51
  52 Sets the directory in which the resulting HTML file is placed.  This
  53 is used to generate relative links to other files. Not passing this
  54 causes all links to be absolute, since this is the value that tells
  55 Pod::Html the root of the documentation tree.
  56
  57 =item htmlroot
  58
  59     --htmlroot=name
  60
  61 Sets the base URL for the HTML files.  When cross-references are made,
  62 the HTML root is prepended to the URL.
  63
  64 =item infile
  65
  66     --infile=name
  67
  68 Specify the pod file to convert.  Input is taken from STDIN if no
  69 infile is specified.
  70
  71 =item outfile
  72
  73     --outfile=name
  74
  75 Specify the HTML file to create.  Output goes to STDOUT if no outfile
  76 is specified.
  77
  78 =item podroot
  79
  80     --podroot=name
  81
  82 Specify the base directory for finding library pods.
  83
  84 =item podpath
  85
  86     --podpath=name:...:name
  87
  88 Specify which subdirectories of the podroot contain pod files whose
  89 HTML converted forms can be linked-to in cross-references.
  90
  91 =item libpods
  92
  93     --libpods=name:...:name
  94
  95 List of page names (eg, "perlfunc") which contain linkable C<=item>s.
  96
  97 =item netscape
  98
  99     --netscape
 100
 101 Use Netscape HTML directives when applicable.
 102
 103 =item nonetscape
 104
 105     --nonetscape
 106
 107 Do not use Netscape HTML directives (default).
 108
 109 =item index
 110
 111     --index
 112
 113 Generate an index at the top of the HTML file (default behaviour).
 114
 115 =item noindex
 116
 117     --noindex
 118
 119 Do not generate an index at the top of the HTML file.
 120
 121
 122 =item recurse
 123
 124     --recurse
 125
 126 Recurse into subdirectories specified in podpath (default behaviour).
 127
 128 =item norecurse
 129
 130     --norecurse
 131
 132 Do not recurse into subdirectories specified in podpath.
 133
 134 =item title
 135
 136     --title=title
 137
 138 Specify the title of the resulting HTML file.
 139
 140 =item css
 141
 142     --css=stylesheet
 143
 144 Specify the URL of a cascading style sheet.
 145
 146 =item verbose
 147
 148     --verbose
 149
 150 Display progress messages.
 151
 152 =item quiet
 153
 154     --quiet
 155
 156 Don't display I<mostly harmless> warning messages.
 157
 158 =back
 159
 160 =head1 EXAMPLE
 161
 162     pod2html("pod2html",
 163              "--podpath=lib:ext:pod:vms",
 164              "--podroot=/usr/src/perl",
 165              "--htmlroot=/perl/nmanual",
 166              "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
 167              "--recurse",
 168              "--infile=foo.pod",
 169              "--outfile=/perl/nmanual/foo.html");
 170
 171 =head1 ENVIRONMENT
 172
 173 Uses $Config{pod2html} to setup default options.
 174
 175 =head1 AUTHOR
 176
 177 Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
 178
 179 =head1 BUGS
 180
 181 Has trouble with C<> etc in = commands.
 182
 183 =head1 SEE ALSO
 184
 185 L<perlpod>
 186
 187 =head1 COPYRIGHT
 188
 189 This program is distributed under the Artistic License.
 190
 191 =cut
 192
 193 my $cache_ext = $^O eq 'VMS' ? ".tmp" : ".x~~";
 194 my $dircache = "pod2htmd$cache_ext";
 195 my $itemcache = "pod2htmi$cache_ext";
 196
 197 my @begin_stack = ();           # begin/end stack
 198
 199 my @libpods = ();               # files to search for links from C<> directives
 200 my $htmlroot = "/";             # http-server base directory from which all
 201                                 #   relative paths in $podpath stem.
 202 my $htmldir = "";               # The directory to which the html pages
 203                                 # will (eventually) be written.
 204 my $htmlfile = "";              # write to stdout by default
 205 my $htmlfileurl = "" ;          # The url that other files would use to
 206                                 # refer to this file.  This is only used
 207                                 # to make relative urls that point to
 208                                 # other files.
 209 my $podfile = "";               # read from stdin by default
 210 my @podpath = ();               # list of directories containing library pods.
 211 my $podroot = ".";              # filesystem base directory from which all
 212                                 #   relative paths in $podpath stem.
 213 my $css = '';                   # Cascading style sheet
 214 my $recurse = 1;                # recurse on subdirectories in $podpath.
 215 my $quiet = 0;                  # not quiet by default
 216 my $verbose = 0;                # not verbose by default
 217 my $doindex = 1;                # non-zero if we should generate an index
 218 my $listlevel = 0;              # current list depth
 219 my @listitem = ();              # stack of HTML commands to use when a =item is
 220                                 #   encountered.  the top of the stack is the
 221                                 #   current list.
 222 my @listdata = ();              # similar to @listitem, but for the text after
 223                                 #   an =item
 224 my @listend = ();               # similar to @listitem, but the text to use to
 225                                 #   end the list.
 226 my $ignore = 1;                 # whether or not to format text.  we don't
 227                                 #   format text until we hit our first pod
 228                                 #   directive.
 229
 230 my %items_named = ();           # for the multiples of the same item in perlfunc
 231 my @items_seen = ();
 232 my $netscape = 0;               # whether or not to use netscape directives.
 233 my $title;                      # title to give the pod(s)
 234 my $header = 0;                 # produce block header/footer
 235 my $top = 1;                    # true if we are at the top of the doc.  used
 236                                 #   to prevent the first <HR> directive.
 237 my $paragraph;                  # which paragraph we're processing (used
 238                                 #   for error messages)
 239 my %pages = ();                 # associative array used to find the location
 240                                 #   of pages referenced by L<> links.
 241 my %sections = ();              # sections within this page
 242 my %items = ();                 # associative array used to find the location
 243                                 #   of =item directives referenced by C<> links
 244 my $Is83;                       # is dos with short filenames (8.3)
 245
 246 sub init_globals {
 247 $dircache = "pod2html.d~~";
 248 $itemcache = "pod2html.i~~";
 249
 250 @begin_stack = ();              # begin/end stack
 251
 252 @libpods = ();          # files to search for links from C<> directives
 253 $htmlroot = "/";                # http-server base directory from which all
 254                                 #   relative paths in $podpath stem.
 255 $htmlfile = "";         # write to stdout by default
 256 $podfile = "";          # read from stdin by default
 257 @podpath = ();          # list of directories containing library pods.
 258 $podroot = ".";         # filesystem base directory from which all
 259                                 #   relative paths in $podpath stem.
 260 $css = '';                   # Cascading style sheet
 261 $recurse = 1;           # recurse on subdirectories in $podpath.
 262 $quiet = 0;             # not quiet by default
 263 $verbose = 0;           # not verbose by default
 264 $doindex = 1;                   # non-zero if we should generate an index
 265 $listlevel = 0;         # current list depth
 266 @listitem = ();         # stack of HTML commands to use when a =item is
 267                                 #   encountered.  the top of the stack is the
 268                                 #   current list.
 269 @listdata = ();         # similar to @listitem, but for the text after
 270                                 #   an =item
 271 @listend = ();          # similar to @listitem, but the text to use to
 272                                 #   end the list.
 273 $ignore = 1;                    # whether or not to format text.  we don't
 274                                 #   format text until we hit our first pod
 275                                 #   directive.
 276
 277 @items_seen = ();
 278 %items_named = ();
 279 $netscape = 0;          # whether or not to use netscape directives.
 280 $header = 0;                    # produce block header/footer
 281 $title = '';                    # title to give the pod(s)
 282 $top = 1;                       # true if we are at the top of the doc.  used
 283                                 #   to prevent the first <HR> directive.
 284 $paragraph = '';                        # which paragraph we're processing (used
 285                                 #   for error messages)
 286 %sections = ();         # sections within this page
 287
 288 # These are not reinitialised here but are kept as a cache.
 289 # See get_cache and related cache management code.
 290 #%pages = ();                   # associative array used to find the location
 291                                 #   of pages referenced by L<> links.
 292 #%items = ();                   # associative array used to find the location
 293                                 #   of =item directives referenced by C<> links
 294 $Is83=$^O eq 'dos';
 295 }
 296
 297 sub pod2html {
 298     local(@ARGV) = @_;
 299     local($/);
 300     local $_;
 301
 302     init_globals();
 303
 304     $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
 305
 306     # cache of %pages and %items from last time we ran pod2html
 307
 308     #undef $opt_help if defined $opt_help;
 309
 310     # parse the command-line parameters
 311     parse_command_line();
 312
 313     # set some variables to their default values if necessary
 314     local *POD;
 315     unless (@ARGV && $ARGV[0]) {
 316         $podfile  = "-" unless $podfile;        # stdin
 317         open(POD, "<$podfile")
 318                 || die "$0: cannot open $podfile file for input: $!\n";
 319     } else {
 320         $podfile = $ARGV[0];  # XXX: might be more filenames
 321         *POD = *ARGV;
 322     }
 323     $htmlfile = "-" unless $htmlfile;   # stdout
 324     $htmlroot = "" if $htmlroot eq "/"; # so we don't get a //
 325     $htmldir =~ s#/$## ;                # so we don't get a //
 326     if (  $htmlroot eq ''
 327        && defined( $htmldir )
 328        && $htmldir ne ''
 329        && substr( $htmlfile, 0, length( $htmldir ) ) eq $htmldir
 330        )
 331     {
 332         # Set the 'base' url for this file, so that we can use it
 333         # as the location from which to calculate relative links
 334         # to other files. If this is '', then absolute links will
 335         # be used throughout.
 336         $htmlfileurl= "$htmldir/" . substr( $htmlfile, length( $htmldir ) + 1);
 337     }
 338
 339     # read the pod a paragraph at a time
 340     warn "Scanning for sections in input file(s)\n" if $verbose;
 341     $/ = "";
 342     my @poddata  = <POD>;
 343     close(POD);
 344
 345     # scan the pod for =head[1-6] directives and build an index
 346     my $index = scan_headings(\%sections, @poddata);
 347
 348     unless($index) {
 349         warn "No pod in $podfile\n" if $verbose;
 350         return;
 351     }
 352
 353     # open the output file
 354     open(HTML, ">$htmlfile")
 355             || die "$0: cannot open $htmlfile file for output: $!\n";
 356
 357     # put a title in the HTML file if one wasn't specified
 358     if ($title eq '') {
 359         TITLE_SEARCH: {
 360             for (my $i = 0; $i < @poddata; $i++) {
 361                 if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
 362                     for my $para ( @poddata[$i, $i+1] ) {
 363                         last TITLE_SEARCH
 364                             if ($title) = $para =~ /(\S+\s+-+.*\S)/s;
 365                     }
 366                 }
 367
 368             }
 369         }
 370     }
 371     if (!$title and $podfile =~ /\.pod$/) {
 372         # probably a split pod so take first =head[12] as title
 373         for (my $i = 0; $i < @poddata; $i++) {
 374             last if ($title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
 375         }
 376         warn "adopted '$title' as title for $podfile\n"
 377             if $verbose and $title;
 378     }
 379     if ($title) {
 380         $title =~ s/\s*\(.*\)//;
 381     } else {
 382         warn "$0: no title for $podfile" unless $quiet;
 383         $podfile =~ /^(.*)(\.[^.\/]+)?$/;
 384         $title = ($podfile eq "-" ? 'No Title' : $1);
 385         warn "using $title" if $verbose;
 386     }
 387     my $csslink = $css ? qq(\n<LINK REL="stylesheet" HREF="$css" TYPE="text/css">) : '';
 388     $csslink =~ s,\\,/,g;
 389     $csslink =~ s,(/.):,$1|,;
 390
 391     my $block = $header ? <<END_OF_BLOCK : '';
 392 <TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0 WIDTH=100%>
 393 <TR><TD CLASS=block VALIGN=MIDDLE WIDTH=100% BGCOLOR="#cccccc">
 394 <FONT SIZE=+1><STRONG><P CLASS=block>&nbsp;$title</P></STRONG></FONT>
 395 </TD></TR>
 396 </TABLE>
 397 END_OF_BLOCK
 398
 399     print HTML <<END_OF_HEAD;
 400 <HTML>
 401 <HEAD>
 402 <TITLE>$title</TITLE>$csslink
 403 <LINK REV="made" HREF="mailto:$Config{perladmin}">
 404 </HEAD>
 405
 406 <BODY>
 407 $block
 408 END_OF_HEAD
 409
 410     # load/reload/validate/cache %pages and %items
 411     get_cache($dircache, $itemcache, \@podpath, $podroot, $recurse);
 412
 413     # scan the pod for =item directives
 414     scan_items("", \%items, @poddata);
 415
 416     # put an index at the top of the file.  note, if $doindex is 0 we
 417     # still generate an index, but surround it with an html comment.
 418     # that way some other program can extract it if desired.
 419     $index =~ s/--+/-/g;
 420     print HTML "<!-- INDEX BEGIN -->\n";
 421     print HTML "<!--\n" unless $doindex;
 422     print HTML $index;
 423     print HTML "-->\n" unless $doindex;
 424     print HTML "<!-- INDEX END -->\n\n";
 425     print HTML "<HR>\n" if $doindex;
 426
 427     # now convert this file
 428     warn "Converting input file\n" if $verbose;
 429     foreach my $i (0..$#poddata) {
 430         $_ = $poddata[$i];
 431         $paragraph = $i+1;
 432         if (/^(=.*)/s) {        # is it a pod directive?
 433             $ignore = 0;
 434             $_ = $1;
 435             if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
 436                 process_begin($1, $2);
 437             } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
 438                 process_end($1, $2);
 439             } elsif (/^=cut/) {                 # =cut
 440                 process_cut();
 441             } elsif (/^=pod/) {                 # =pod
 442                 process_pod();
 443             } else {
 444                 next if @begin_stack && $begin_stack[-1] ne 'html';
 445
 446                 if (/^=(head[1-6])\s+(.*\S)/s) {        # =head[1-6] heading
 447                     process_head($1, $2);
 448                 } elsif (/^=item\s*(.*\S)/sm) { # =item text
 449                     process_item($1);
 450                 } elsif (/^=over\s*(.*)/) {             # =over N
 451                     process_over();
 452                 } elsif (/^=back/) {            # =back
 453                     process_back();
 454                 } elsif (/^=for\s+(\S+)\s+(.*)/si) {# =for
 455                     process_for($1,$2);
 456                 } else {
 457                     /^=(\S*)\s*/;
 458                     warn "$0: $podfile: unknown pod directive '$1' in "
 459                        . "paragraph $paragraph.  ignoring.\n";
 460                 }
 461             }
 462             $top = 0;
 463         }
 464         else {
 465             next if $ignore;
 466             next if @begin_stack && $begin_stack[-1] ne 'html';
 467             my $text = $_;
 468             process_text(\$text, 1);
 469             print HTML "<P>\n$text</P>\n";
 470         }
 471     }
 472
 473     # finish off any pending directives
 474     finish_list();
 475     print HTML <<END_OF_TAIL;
 476 $block
 477 </BODY>
 478
 479 </HTML>
 480 END_OF_TAIL
 481
 482     # close the html file
 483     close(HTML);
 484
 485     warn "Finished\n" if $verbose;
 486 }
 487
 488 ##############################################################################
 489
 490 my $usage;                      # see below
 491 sub usage {
 492     my $podfile = shift;
 493     warn "$0: $podfile: @_\n" if @_;
 494     die $usage;
 495 }
 496
 497 $usage =<<END_OF_USAGE;
 498 Usage:  $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
 499            --podpath=<name>:...:<name> --podroot=<name>
 500            --libpods=<name>:...:<name> --recurse --verbose --index
 501            --netscape --norecurse --noindex
 502
 503   --flush      - flushes the item and directory caches.
 504   --help       - prints this message.
 505   --htmlroot   - http-server base directory from which all relative paths
 506                  in podpath stem (default is /).
 507   --index      - generate an index at the top of the resulting html
 508                  (default).
 509   --infile     - filename for the pod to convert (input taken from stdin
 510                  by default).
 511   --libpods    - colon-separated list of pages to search for =item pod
 512                  directives in as targets of C<> and implicit links (empty
 513                  by default).  note, these are not filenames, but rather
 514                  page names like those that appear in L<> links.
 515   --netscape   - will use netscape html directives when applicable.
 516   --nonetscape - will not use netscape directives (default).
 517   --outfile    - filename for the resulting html file (output sent to
 518                  stdout by default).
 519   --podpath    - colon-separated list of directories containing library
 520                  pods.  empty by default.
 521   --podroot    - filesystem base directory from which all relative paths
 522                  in podpath stem (default is .).
 523   --noindex    - don't generate an index at the top of the resulting html.
 524   --norecurse  - don't recurse on those subdirectories listed in podpath.
 525   --recurse    - recurse on those subdirectories listed in podpath
 526                  (default behavior).
 527   --title      - title that will appear in resulting html file.
 528   --header     - produce block header/footer
 529   --css        - stylesheet URL
 530   --verbose    - self-explanatory
 531   --quiet      - supress some benign warning messages
 532
 533 END_OF_USAGE
 534
 535 sub parse_command_line {
 536     my ($opt_flush,$opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose,$opt_css,$opt_header,$opt_quiet);
 537     unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
 538     my $result = GetOptions(
 539                             'flush'      => \$opt_flush,
 540                             'help'       => \$opt_help,
 541                             'htmldir=s'  => \$opt_htmldir,
 542                             'htmlroot=s' => \$opt_htmlroot,
 543                             'index!'     => \$opt_index,
 544                             'infile=s'   => \$opt_infile,
 545                             'libpods=s'  => \$opt_libpods,
 546                             'netscape!'  => \$opt_netscape,
 547                             'outfile=s'  => \$opt_outfile,
 548                             'podpath=s'  => \$opt_podpath,
 549                             'podroot=s'  => \$opt_podroot,
 550                             'norecurse'  => \$opt_norecurse,
 551                             'recurse!'   => \$opt_recurse,
 552                             'title=s'    => \$opt_title,
 553                             'header'     => \$opt_header,
 554                             'css=s'      => \$opt_css,
 555                             'verbose'    => \$opt_verbose,
 556                             'quiet'      => \$opt_quiet,
 557                            );
 558     usage("-", "invalid parameters") if not $result;
 559
 560     usage("-") if defined $opt_help;    # see if the user asked for help
 561     $opt_help = "";                     # just to make -w shut-up.
 562
 563     $podfile  = $opt_infile if defined $opt_infile;
 564     $htmlfile = $opt_outfile if defined $opt_outfile;
 565     $htmldir  = $opt_htmldir if defined $opt_outfile;
 566
 567     @podpath  = split(":", $opt_podpath) if defined $opt_podpath;
 568     @libpods  = split(":", $opt_libpods) if defined $opt_libpods;
 569
 570     warn "Flushing item and directory caches\n"
 571         if $opt_verbose && defined $opt_flush;
 572     unlink($dircache, $itemcache) if defined $opt_flush;
 573
 574     $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
 575     $podroot  = $opt_podroot if defined $opt_podroot;
 576
 577     $doindex  = $opt_index if defined $opt_index;
 578     $recurse  = $opt_recurse if defined $opt_recurse;
 579     $title    = $opt_title if defined $opt_title;
 580     $header   = defined $opt_header ? 1 : 0;
 581     $css      = $opt_css if defined $opt_css;
 582     $verbose  = defined $opt_verbose ? 1 : 0;
 583     $quiet    = defined $opt_quiet ? 1 : 0;
 584     $netscape = $opt_netscape if defined $opt_netscape;
 585 }
 586
 587
 588 my $saved_cache_key;
 589
 590 sub get_cache {
 591     my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
 592     my @cache_key_args = @_;
 593
 594     # A first-level cache:
 595     # Don't bother reading the cache files if they still apply
 596     # and haven't changed since we last read them.
 597
 598     my $this_cache_key = cache_key(@cache_key_args);
 599
 600     return if $saved_cache_key and $this_cache_key eq $saved_cache_key;
 601
 602     # load the cache of %pages and %items if possible.  $tests will be
 603     # non-zero if successful.
 604     my $tests = 0;
 605     if (-f $dircache && -f $itemcache) {
 606         warn "scanning for item cache\n" if $verbose;
 607         $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
 608     }
 609
 610     # if we didn't succeed in loading the cache then we must (re)build
 611     #  %pages and %items.
 612     if (!$tests) {
 613         warn "scanning directories in pod-path\n" if $verbose;
 614         scan_podpath($podroot, $recurse, 0);
 615     }
 616     $saved_cache_key = cache_key(@cache_key_args);
 617 }
 618
 619 sub cache_key {
 620     my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
 621     return join('!', $dircache, $itemcache, $recurse,
 622         @$podpath, $podroot, stat($dircache), stat($itemcache));
 623 }
 624
 625 #
 626 # load_cache - tries to find if the caches stored in $dircache and $itemcache
 627 #  are valid caches of %pages and %items.  if they are valid then it loads
 628 #  them and returns a non-zero value.
 629 #
 630
 631 sub load_cache {
 632     my($dircache, $itemcache, $podpath, $podroot) = @_;
 633     my($tests);
 634     local $_;
 635
 636     $tests = 0;
 637
 638     open(CACHE, "<$itemcache") ||
 639         die "$0: error opening $itemcache for reading: $!\n";
 640     $/ = "\n";
 641
 642     # is it the same podpath?
 643     $_ = <CACHE>;
 644     chomp($_);
 645     $tests++ if (join(":", @$podpath) eq $_);
 646
 647     # is it the same podroot?
 648     $_ = <CACHE>;
 649     chomp($_);
 650     $tests++ if ($podroot eq $_);
 651
 652     # load the cache if its good
 653     if ($tests != 2) {
 654         close(CACHE);
 655         return 0;
 656     }
 657
 658     warn "loading item cache\n" if $verbose;
 659     while (<CACHE>) {
 660         /(.*?) (.*)$/;
 661         $items{$1} = $2;
 662     }
 663     close(CACHE);
 664
 665     warn "scanning for directory cache\n" if $verbose;
 666     open(CACHE, "<$dircache") ||
 667         die "$0: error opening $dircache for reading: $!\n";
 668     $/ = "\n";
 669     $tests = 0;
 670
 671     # is it the same podpath?
 672     $_ = <CACHE>;
 673     chomp($_);
 674     $tests++ if (join(":", @$podpath) eq $_);
 675
 676     # is it the same podroot?
 677     $_ = <CACHE>;
 678     chomp($_);
 679     $tests++ if ($podroot eq $_);
 680
 681     # load the cache if its good
 682     if ($tests != 2) {
 683         close(CACHE);
 684         return 0;
 685     }
 686
 687     warn "loading directory cache\n" if $verbose;
 688     while (<CACHE>) {
 689         /(.*?) (.*)$/;
 690         $pages{$1} = $2;
 691     }
 692
 693     close(CACHE);
 694
 695     return 1;
 696 }
 697
 698 #
 699 # scan_podpath - scans the directories specified in @podpath for directories,
 700 #  .pod files, and .pm files.  it also scans the pod files specified in
 701 #  @libpods for =item directives.
 702 #
 703 sub scan_podpath {
 704     my($podroot, $recurse, $append) = @_;
 705     my($pwd, $dir);
 706     my($libpod, $dirname, $pod, @files, @poddata);
 707
 708     unless($append) {
 709         %items = ();
 710         %pages = ();
 711     }
 712
 713     # scan each directory listed in @podpath
 714     $pwd = getcwd();
 715     chdir($podroot)
 716         || die "$0: error changing to directory $podroot: $!\n";
 717     foreach $dir (@podpath) {
 718         scan_dir($dir, $recurse);
 719     }
 720
 721     # scan the pods listed in @libpods for =item directives
 722     foreach $libpod (@libpods) {
 723         # if the page isn't defined then we won't know where to find it
 724         # on the system.
 725         next unless defined $pages{$libpod} && $pages{$libpod};
 726
 727         # if there is a directory then use the .pod and .pm files within it.
 728         # NOTE: Only finds the first so-named directory in the tree.
 729 #       if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
 730         if ($pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
 731             #  find all the .pod and .pm files within the directory
 732             $dirname = $1;
 733             opendir(DIR, $dirname) ||
 734                 die "$0: error opening directory $dirname: $!\n";
 735             @files = grep(/(\.pod|\.pm)$/ && ! -d $_, readdir(DIR));
 736             closedir(DIR);
 737
 738             # scan each .pod and .pm file for =item directives
 739             foreach $pod (@files) {
 740                 open(POD, "<$dirname/$pod") ||
 741                     die "$0: error opening $dirname/$pod for input: $!\n";
 742                 @poddata = <POD>;
 743                 close(POD);
 744
 745                 scan_items("$dirname/$pod", @poddata);
 746             }
 747
 748             # use the names of files as =item directives too.
 749             foreach $pod (@files) {
 750                 $pod =~ /^(.*)(\.pod|\.pm)$/;
 751                 $items{$1} = "$dirname/$1.html" if $1;
 752             }
 753         } elsif ($pages{$libpod} =~ /([^:]*\.pod):/ ||
 754                  $pages{$libpod} =~ /([^:]*\.pm):/) {
 755             # scan the .pod or .pm file for =item directives
 756             $pod = $1;
 757             open(POD, "<$pod") ||
 758                 die "$0: error opening $pod for input: $!\n";
 759             @poddata = <POD>;
 760             close(POD);
 761
 762             scan_items("$pod", @poddata);
 763         } else {
 764             warn "$0: shouldn't be here (line ".__LINE__."\n";
 765         }
 766     }
 767     @poddata = ();      # clean-up a bit
 768
 769     chdir($pwd)
 770         || die "$0: error changing to directory $pwd: $!\n";
 771
 772     # cache the item list for later use
 773     warn "caching items for later use\n" if $verbose;
 774     open(CACHE, ">$itemcache") ||
 775         die "$0: error open $itemcache for writing: $!\n";
 776
 777     print CACHE join(":", @podpath) . "\n$podroot\n";
 778     foreach my $key (keys %items) {
 779         print CACHE "$key $items{$key}\n";
 780     }
 781
 782     close(CACHE);
 783
 784     # cache the directory list for later use
 785     warn "caching directories for later use\n" if $verbose;
 786     open(CACHE, ">$dircache") ||
 787         die "$0: error open $dircache for writing: $!\n";
 788
 789     print CACHE join(":", @podpath) . "\n$podroot\n";
 790     foreach my $key (keys %pages) {
 791         print CACHE "$key $pages{$key}\n";
 792     }
 793
 794     close(CACHE);
 795 }
 796
 797 #
 798 # scan_dir - scans the directory specified in $dir for subdirectories, .pod
 799 #  files, and .pm files.  notes those that it finds.  this information will
 800 #  be used later in order to figure out where the pages specified in L<>
 801 #  links are on the filesystem.
 802 #
 803 sub scan_dir {
 804     my($dir, $recurse) = @_;
 805     my($t, @subdirs, @pods, $pod, $dirname, @dirs);
 806     local $_;
 807
 808     @subdirs = ();
 809     @pods = ();
 810
 811     opendir(DIR, $dir) ||
 812         die "$0: error opening directory $dir: $!\n";
 813     while (defined($_ = readdir(DIR))) {
 814         if (-d "$dir/$_" && $_ ne "." && $_ ne "..") {      # directory
 815             $pages{$_}  = "" unless defined $pages{$_};
 816             $pages{$_} .= "$dir/$_:";
 817             push(@subdirs, $_);
 818         } elsif (/\.pod$/) {                                # .pod
 819             s/\.pod$//;
 820             $pages{$_}  = "" unless defined $pages{$_};
 821             $pages{$_} .= "$dir/$_.pod:";
 822             push(@pods, "$dir/$_.pod");
 823         } elsif (/\.pm$/) {                                 # .pm
 824             s/\.pm$//;
 825             $pages{$_}  = "" unless defined $pages{$_};
 826             $pages{$_} .= "$dir/$_.pm:";
 827             push(@pods, "$dir/$_.pm");
 828         }
 829     }
 830     closedir(DIR);
 831
 832     # recurse on the subdirectories if necessary
 833     if ($recurse) {
 834         foreach my $subdir (@subdirs) {
 835             scan_dir("$dir/$subdir", $recurse);
 836         }
 837     }
 838 }
 839
 840 #
 841 # scan_headings - scan a pod file for head[1-6] tags, note the tags, and
 842 #  build an index.
 843 #
 844 sub scan_headings {
 845     my($sections, @data) = @_;
 846     my($tag, $which_head, $title, $listdepth, $index);
 847
 848     # here we need      local $ignore = 0;
 849     #  unfortunately, we can't have it, because $ignore is lexical
 850     $ignore = 0;
 851
 852     $listdepth = 0;
 853     $index = "";
 854
 855     # scan for =head directives, note their name, and build an index
 856     #  pointing to each of them.
 857     foreach my $line (@data) {
 858         if ($line =~ /^=(head)([1-6])\s+(.*)/) {
 859             ($tag,$which_head, $title) = ($1,$2,$3);
 860             chomp($title);
 861             $$sections{htmlify(0,$title)} = 1;
 862
 863             while ($which_head != $listdepth) {
 864                 if ($which_head > $listdepth) {
 865                     $index .= "\n" . ("\t" x $listdepth) . "<UL>\n";
 866                     $listdepth++;
 867                 } elsif ($which_head < $listdepth) {
 868                     $listdepth--;
 869                     $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
 870                 }
 871             }
 872
 873             $index .= "\n" . ("\t" x $listdepth) . "<LI>" .
 874                       "<A HREF=\"#" . htmlify(0,$title) . "\">" .
 875                       html_escape(process_text(\$title, 0)) . "</A></LI>";
 876         }
 877     }
 878
 879     # finish off the lists
 880     while ($listdepth--) {
 881         $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
 882     }
 883
 884     # get rid of bogus lists
 885     $index =~ s,\t*<UL>\s*</UL>\n,,g;
 886
 887     $ignore = 1;        # restore old value;
 888
 889     return $index;
 890 }
 891
 892 #
 893 # scan_items - scans the pod specified by $pod for =item directives.  we
 894 #  will use this information later on in resolving C<> links.
 895 #
 896 sub scan_items {
 897     my($pod, @poddata) = @_;
 898     my($i, $item);
 899     local $_;
 900
 901     $pod =~ s/\.pod$//;
 902     $pod .= ".html" if $pod;
 903
 904     foreach $i (0..$#poddata) {
 905         $_ = $poddata[$i];
 906
 907         # remove any formatting instructions
 908         s,[A-Z]<([^<>]*)>,$1,g;
 909
 910         # figure out what kind of item it is and get the first word of
 911         #  it's name.
 912         if (/^=item\s+(\w*)\s*.*$/s) {
 913             if ($1 eq "*") {            # bullet list
 914                 /\A=item\s+\*\s*(.*?)\s*\Z/s;
 915                 $item = $1;
 916             } elsif ($1 =~ /^\d+/) {    # numbered list
 917                 /\A=item\s+\d+\.?(.*?)\s*\Z/s;
 918                 $item = $1;
 919             } else {
 920 #               /\A=item\s+(.*?)\s*\Z/s;
 921                 /\A=item\s+(\w*)/s;
 922                 $item = $1;
 923             }
 924
 925             $items{$item} = "$pod" if $item;
 926         }
 927     }
 928 }
 929
 930 #
 931 # process_head - convert a pod head[1-6] tag and convert it to HTML format.
 932 #
 933 sub process_head {
 934     my($tag, $heading) = @_;
 935     my $firstword;
 936
 937     # figure out the level of the =head
 938     $tag =~ /head([1-6])/;
 939     my $level = $1;
 940
 941     # can't have a heading full of spaces and speechmarks and so on
 942     $firstword = $heading; $firstword =~ s/\s*(\w+)\s.*/$1/;
 943
 944     print HTML "<P>\n" unless $listlevel;
 945     print HTML "<HR>\n" unless $listlevel || $top;
 946     print HTML "<H$level>"; # unless $listlevel;
 947     #print HTML "<H$level>" unless $listlevel;
 948     my $convert = $heading; process_text(\$convert, 0);
 949     $convert = html_escape($convert);
 950     print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>";
 951     print HTML "</H$level>"; # unless $listlevel;
 952     print HTML "\n";
 953 }
 954
 955 #
 956 # process_item - convert a pod item tag and convert it to HTML format.
 957 #
 958 sub process_item {
 959     my $text = $_[0];
 960     my($i, $quote, $name);
 961
 962     my $need_preamble = 0;
 963     my $this_entry;
 964
 965
 966     # lots of documents start a list without doing an =over.  this is
 967     # bad!  but, the proper thing to do seems to be to just assume
 968     # they did do an =over.  so warn them once and then continue.
 969     warn "$0: $podfile: unexpected =item directive in paragraph $paragraph.  ignoring.\n"
 970         unless $listlevel;
 971     process_over() unless $listlevel;
 972
 973     return unless $listlevel;
 974
 975     # remove formatting instructions from the text
 976     1 while $text =~ s/[A-Z]<([^<>]*)>/$1/g;
 977     pre_escape(\$text);
 978
 979     $need_preamble = $items_seen[$listlevel]++ == 0;
 980
 981     # check if this is the first =item after an =over
 982     $i = $listlevel - 1;
 983     my $need_new = $listlevel >= @listitem;
 984
 985     if ($text =~ /\A\*/) {              # bullet
 986
 987         if ($need_preamble) {
 988             push(@listend,  "</UL>");
 989             print HTML "<UL>\n";
 990         }
 991
 992         print HTML '<LI>';
 993         if ($text =~ /\A\*\s*(.+)\Z/s) {
 994             print HTML '<STRONG>';
 995             if ($items_named{$1}++) {
 996                 print HTML html_escape($1);
 997             } else {
 998                 my $name = 'item_' . htmlify(1,$1);
 999                 print HTML qq(<A NAME="$name">), html_escape($1), '</A>';
1000             }
1001             print HTML '</STRONG>';
1002         }
1003
1004     } elsif ($text =~ /\A[\d#]+/) {     # numbered list
1005
1006         if ($need_preamble) {
1007             push(@listend,  "</OL>");
1008             print HTML "<OL>\n";
1009         }
1010
1011         print HTML '<LI>';
1012         if ($text =~ /\A\d+\.?\s*(.+)\Z/s) {
1013             print HTML '<STRONG>';
1014             if ($items_named{$1}++) {
1015                 print HTML html_escape($1);
1016             } else {
1017                 my $name = 'item_' . htmlify(0,$1);
1018                 print HTML qq(<A NAME="$name">), html_escape($1), '</A>';
1019             }
1020             print HTML '</STRONG>';
1021         }
1022
1023     } else {                    # all others
1024
1025         if ($need_preamble) {
1026             push(@listend,  '</DL>');
1027             print HTML "<DL>\n";
1028         }
1029
1030         print HTML '<DT>';
1031         if ($text =~ /(\S+)/) {
1032             print HTML '<STRONG>';
1033             if ($items_named{$1}++) {
1034                 print HTML html_escape($text);
1035             } else {
1036                 my $name = 'item_' . htmlify(1,$text);
1037                 print HTML qq(<A NAME="$name">), html_escape($text), '</A>';
1038             }
1039             print HTML '</STRONG>';
1040         }
1041        print HTML '<DD>';
1042     }
1043
1044     print HTML "\n";
1045 }
1046
1047 #
1048 # process_over - process a pod over tag and start a corresponding HTML
1049 # list.
1050 #
1051 sub process_over {
1052     # start a new list
1053     $listlevel++;
1054 }
1055
1056 #
1057 # process_back - process a pod back tag and convert it to HTML format.
1058 #
1059 sub process_back {
1060     warn "$0: $podfile: unexpected =back directive in paragraph $paragraph.  ignoring.\n"
1061         unless $listlevel;
1062     return unless $listlevel;
1063
1064     # close off the list.  note, I check to see if $listend[$listlevel] is
1065     # defined because an =item directive may have never appeared and thus
1066     # $listend[$listlevel] may have never been initialized.
1067     $listlevel--;
1068     print HTML $listend[$listlevel] if defined $listend[$listlevel];
1069     print HTML "\n";
1070
1071     # don't need the corresponding perl code anymore
1072     pop(@listitem);
1073     pop(@listdata);
1074     pop(@listend);
1075
1076     pop(@items_seen);
1077 }
1078
1079 #
1080 # process_cut - process a pod cut tag, thus stop ignoring pod directives.
1081 #
1082 sub process_cut {
1083     $ignore = 1;
1084 }
1085
1086 #
1087 # process_pod - process a pod pod tag, thus ignore pod directives until we see a
1088 # corresponding cut.
1089 #
1090 sub process_pod {
1091     # no need to set $ignore to 0 cause the main loop did it
1092 }
1093
1094 #
1095 # process_for - process a =for pod tag.  if it's for html, split
1096 # it out verbatim, if illustration, center it, otherwise ignore it.
1097 #
1098 sub process_for {
1099     my($whom, $text) = @_;
1100     if ( $whom =~ /^(pod2)?html$/i) {
1101         print HTML $text;
1102     } elsif ($whom =~ /^illustration$/i) {
1103         1 while chomp $text;
1104         for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
1105           $text .= $ext, last if -r "$text$ext";
1106         }
1107         print HTML qq{<p align = "center"><img src = "$text" alt = "$text illustration"></p>};
1108     }
1109 }
1110
1111 #
1112 # process_begin - process a =begin pod tag.  this pushes
1113 # whom we're beginning on the begin stack.  if there's a
1114 # begin stack, we only print if it us.
1115 #
1116 sub process_begin {
1117     my($whom, $text) = @_;
1118     $whom = lc($whom);
1119     push (@begin_stack, $whom);
1120     if ( $whom =~ /^(pod2)?html$/) {
1121         print HTML $text if $text;
1122     }
1123 }
1124
1125 #
1126 # process_end - process a =end pod tag.  pop the
1127 # begin stack.  die if we're mismatched.
1128 #
1129 sub process_end {
1130     my($whom, $text) = @_;
1131     $whom = lc($whom);
1132     if ($begin_stack[-1] ne $whom ) {
1133         die "Unmatched begin/end at chunk $paragraph\n"
1134     }
1135     pop @begin_stack;
1136 }
1137
1138 #
1139 # process_text - handles plaintext that appears in the input pod file.
1140 # there may be pod commands embedded within the text so those must be
1141 # converted to html commands.
1142 #
1143 sub process_text {
1144     my($text, $escapeQuotes) = @_;
1145     my($result, $rest, $s1, $s2, $s3, $s4, $match, $bf);
1146     my($podcommand, $params, $tag, $quote);
1147
1148     return if $ignore;
1149
1150     $quote  = 0;                # status of double-quote conversion
1151     $result = "";
1152     $rest = $$text;
1153
1154     if ($rest =~ /^\s+/) {      # preformatted text, no pod directives
1155         $rest =~ s/\n+\Z//;
1156         $rest =~ s#.*#
1157             my $line = $&;
1158             1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
1159             $line;
1160         #eg;
1161
1162         $rest   =~ s/&/&amp;/g;
1163         $rest   =~ s/</&lt;/g;
1164         $rest   =~ s/>/&gt;/g;
1165         $rest   =~ s/"/&quot;/g;
1166
1167         # try and create links for all occurrences of perl.* within
1168         # the preformatted text.
1169         $rest =~ s{
1170                     (\s*)(perl\w+)
1171                   }{
1172                     if (defined $pages{$2}) {   # is a link
1173                         qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>);
1174                     } elsif (defined $pages{dosify($2)}) {      # is a link
1175                         qq($1<A HREF="$htmlroot/$pages{dosify($2)}">$2</A>);
1176                     } else {
1177                         "$1$2";
1178                     }
1179                   }xeg;
1180 #       $rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g;
1181         $rest =~ s{
1182                     (<A\ HREF="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
1183                   }{
1184                     my $url ;
1185                     if ( $htmlfileurl ne '' ) {
1186                         # Here, we take advantage of the knowledge
1187                         # that $htmlfileurl ne '' implies $htmlroot eq ''.
1188                         # Since $htmlroot eq '', we need to prepend $htmldir
1189                         # on the fron of the link to get the absolute path
1190                         # of the link's target. We check for a leading '/'
1191                         # to avoid corrupting links that are #, file:, etc.
1192                         my $old_url = $3 ;
1193                         $old_url = "$htmldir$old_url"
1194                             if ( $old_url =~ m{^\/} ) ;
1195                         $url = relativize_url( "$old_url.html", $htmlfileurl );
1196 # print( "  a: [$old_url.html,$htmlfileurl,$url]\n" ) ;
1197                     }
1198                     else {
1199                         $url = "$3.html" ;
1200                     }
1201                     "$1$url" ;
1202                   }xeg;
1203
1204   # Look for embedded URLs and make them in to links.  We don't
1205   # relativize them since they are best left as the author intended.
1206   my $urls = '(' . join ('|', qw{
1207                 http
1208                 telnet
1209                 mailto
1210                 news
1211                 gopher
1212                 file
1213                 wais
1214                 ftp
1215             } )
1216         . ')';
1217
1218   my $ltrs = '\w';
1219   my $gunk = '/#~:.?+=&%@!\-';
1220   my $punc = '.:?\-';
1221   my $any  = "${ltrs}${gunk}${punc}";
1222
1223   $rest =~ s{
1224         \b                          # start at word boundary
1225         (                           # begin $1  {
1226           $urls     :               # need resource and a colon
1227           (?!:)                     # Ignore File::, among others.
1228           [$any] +?                 # followed by on or more
1229                                     #  of any valid character, but
1230                                     #  be conservative and take only
1231                                     #  what you need to....
1232         )                           # end   $1  }
1233         (?=                         # look-ahead non-consumptive assertion
1234                 [$punc]*            # either 0 or more puntuation
1235                 [^$any]             #   followed by a non-url char
1236             |                       # or else
1237                 $                   #   then end of the string
1238         )
1239       }{<A HREF="$1">$1</A>}igox;
1240
1241         $result =   "<PRE>"     # text should be as it is (verbatim)
1242                   . "$rest\n"
1243                   . "</PRE>\n";
1244     } else {                    # formatted text
1245         # parse through the string, stopping each time we find a
1246         # pod-escape.  once the string has been throughly processed
1247         # we can output it.
1248         while (length $rest) {
1249             # check to see if there are any possible pod directives in
1250             # the remaining part of the text.
1251             if ($rest =~ m/[BCEIFLSZ]</) {
1252                 warn "\$rest\t= $rest\n" unless
1253                     $rest =~ /\A
1254                            ([^<]*?)
1255                            ([BCEIFLSZ]?)
1256                            <
1257                            (.*)\Z/xs;
1258
1259                 $s1 = $1;       # pure text
1260                 $s2 = $2;       # the type of pod-escape that follows
1261                 $s3 = '<';      # '<'
1262                 $s4 = $3;       # the rest of the string
1263             } else {
1264                 $s1 = $rest;
1265                 $s2 = "";
1266                 $s3 = "";
1267                 $s4 = "";
1268             }
1269
1270             if ($s3 eq '<' && $s2) {    # a pod-escape
1271                 $result    .= ($escapeQuotes ? process_puretext($s1, \$quote) : $s1);
1272                 $podcommand = "$s2<";
1273                 $rest       = $s4;
1274
1275                 # find the matching '>'
1276                 $match = 1;
1277                 $bf = 0;
1278                 while ($match && !$bf) {
1279                     $bf = 1;
1280                     if ($rest =~ /\A([^<>]*[BCEIFLSZ]<)(.*)\Z/s) {
1281                         $bf = 0;
1282                         $match++;
1283                         $podcommand .= $1;
1284                         $rest        = $2;
1285                     } elsif ($rest =~ /\A([^>]*>)(.*)\Z/s) {
1286                         $bf = 0;
1287                         $match--;
1288                         $podcommand .= $1;
1289                         $rest        = $2;
1290                     }
1291                 }
1292
1293                 if ($match != 0) {
1294                     warn <<WARN;
1295 $0: $podfile: cannot find matching > for $s2 in paragraph $paragraph.
1296 WARN
1297                     $result .= substr $podcommand, 0, 2;
1298                     $rest = substr($podcommand, 2) . $rest;
1299                     next;
1300                 }
1301
1302                 # pull out the parameters to the pod-escape
1303                 $podcommand =~ /^([BCFEILSZ]?)<(.*)>$/s;
1304                 $tag    = $1;
1305                 $params = $2;
1306
1307                 # process the text within the pod-escape so that any escapes
1308                 # which must occur do.
1309                 process_text(\$params, 0) unless $tag eq 'L';
1310
1311                 $s1 = $params;
1312                 if (!$tag || $tag eq " ") {     #  <> : no tag
1313                     $s1 = "&lt;$params&gt;";
1314                 } elsif ($tag eq "L") {         # L<> : link
1315                     $s1 = process_L($params);
1316                 } elsif ($tag eq "I" ||         # I<> : italicize text
1317                          $tag eq "B" ||         # B<> : bold text
1318                          $tag eq "F") {         # F<> : file specification
1319                     $s1 = process_BFI($tag, $params);
1320                 } elsif ($tag eq "C") {         # C<> : literal code
1321                     $s1 = process_C($params, 1);
1322                 } elsif ($tag eq "E") {         # E<> : escape
1323                     $s1 = process_E($params);
1324                 } elsif ($tag eq "Z") {         # Z<> : zero-width character
1325                     $s1 = process_Z($params);
1326                 } elsif ($tag eq "S") {         # S<> : non-breaking space
1327                     $s1 = process_S($params);
1328                 } elsif ($tag eq "X") {         # S<> : non-breaking space
1329                     $s1 = process_X($params);
1330                 } else {
1331                     warn "$0: $podfile: unhandled tag '$tag' in paragraph $paragraph\n";
1332                 }
1333
1334                 $result .= "$s1";
1335             } else {
1336                 # for pure text we must deal with implicit links and
1337                 # double-quotes among other things.
1338                 $result .= ($escapeQuotes ? process_puretext("$s1$s2$s3", \$quote) : "$s1$s2$s3");
1339                 $rest    = $s4;
1340             }
1341         }
1342     }
1343     $$text = $result;
1344 }
1345
1346 sub html_escape {
1347     my $rest = $_[0];
1348     $rest   =~ s/&(?!\w+;|#)/&amp;/g;   # XXX not bulletproof
1349     $rest   =~ s/</&lt;/g;
1350     $rest   =~ s/>/&gt;/g;
1351     $rest   =~ s/"/&quot;/g;
1352     return $rest;
1353 }
1354
1355 #
1356 # process_puretext - process pure text (without pod-escapes) converting
1357 #  double-quotes and handling implicit C<> links.
1358 #
1359 sub process_puretext {
1360     my($text, $quote) = @_;
1361     my(@words, $result, $rest, $lead, $trail);
1362
1363     # convert double-quotes to single-quotes
1364     $text =~ s/\A([^"]*)"/$1''/s if $$quote;
1365     while ($text =~ s/\A([^"]*)["]([^"]*)["]/$1``$2''/sg) {}
1366
1367     $$quote = ($text =~ m/"/ ? 1 : 0);
1368     $text =~ s/\A([^"]*)"/$1``/s if $$quote;
1369
1370     # keep track of leading and trailing white-space
1371     $lead  = ($text =~ /\A(\s*)/s ? $1 : "");
1372     $trail = ($text =~ /(\s*)\Z/s ? $1 : "");
1373
1374     # collapse all white space into a single space
1375     $text =~ s/\s+/ /g;
1376     @words = split(" ", $text);
1377
1378     # process each word individually
1379     foreach my $word (@words) {
1380         # see if we can infer a link
1381         if ($word =~ /^\w+\(/) {
1382             # has parenthesis so should have been a C<> ref
1383             $word = process_C($word);
1384 #           $word =~ /^[^()]*]\(/;
1385 #           if (defined $items{$1} && $items{$1}) {
1386 #               $word =   "\n<CODE><A HREF=\"$htmlroot/$items{$1}#item_"
1387 #                       . htmlify(0,$word)
1388 #                       . "\">$word</A></CODE>";
1389 #           } elsif (defined $items{$word} && $items{$word}) {
1390 #               $word =   "\n<CODE><A HREF=\"$htmlroot/$items{$word}#item_"
1391 #                       . htmlify(0,$word)
1392 #                       . "\">$word</A></CODE>";
1393 #           } else {
1394 #               $word =   "\n<CODE><A HREF=\"#item_"
1395 #                       . htmlify(0,$word)
1396 #                       . "\">$word</A></CODE>";
1397 #           }
1398         } elsif ($word =~ /^[\$\@%&*]+\w+$/) {
1399             # perl variables, should be a C<> ref
1400             $word = process_C($word, 1);
1401         } elsif ($word =~ m,^\w+://\w,) {
1402             # looks like a URL
1403             # Don't relativize it: leave it as the author intended
1404             $word = qq(<A HREF="$word">$word</A>);
1405         } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
1406             # looks like an e-mail address
1407             my ($w1, $w2, $w3) = ("", $word, "");
1408             ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
1409             ($w1, $w2, $w3) = ("&lt;", $1, "&gt;$2") if $word =~ /^<(.*?)>(,?)/;
1410             $word = qq($w1<A HREF="mailto:$w2">$w2</A>$w3);
1411         } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) {  # all uppercase?
1412             $word = html_escape($word) if $word =~ /["&<>]/;
1413             $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape;
1414         } else {
1415             $word = html_escape($word) if $word =~ /["&<>]/;
1416         }
1417     }
1418
1419     # build a new string based upon our conversion
1420     $result = "";
1421     $rest   = join(" ", @words);
1422     while (length($rest) > 75) {
1423         if ( $rest =~ m/^(.{0,75})\s(.*?)$/o ||
1424              $rest =~ m/^(\S*)\s(.*?)$/o) {
1425
1426             $result .= "$1\n";
1427             $rest    = $2;
1428         } else {
1429             $result .= "$rest\n";
1430             $rest    = "";
1431         }
1432     }
1433     $result .= $rest if $rest;
1434
1435     # restore the leading and trailing white-space
1436     $result = "$lead$result$trail";
1437
1438     return $result;
1439 }
1440
1441 #
1442 # pre_escape - convert & in text to $amp;
1443 #
1444 sub pre_escape {
1445     my($str) = @_;
1446     $$str =~ s/&(?!\w+;|#)/&amp;/g;     # XXX not bulletproof
1447 }
1448
1449 #
1450 # dosify - convert filenames to 8.3
1451 #
1452 sub dosify {
1453     my($str) = @_;
1454     return lc($str) if $^O eq 'VMS';     # VMS just needs casing
1455     if ($Is83) {
1456         $str = lc $str;
1457         $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
1458         $str =~ s/(\w+)/substr ($1,0,8)/ge;
1459     }
1460     return $str;
1461 }
1462
1463 #
1464 # process_L - convert a pod L<> directive to a corresponding HTML link.
1465 #  most of the links made are inferred rather than known about directly
1466 #  (i.e it's not known whether the =head\d section exists in the target file,
1467 #   or whether a .pod file exists in the case of split files).  however, the
1468 #  guessing usually works.
1469 #
1470 # Unlike the other directives, this should be called with an unprocessed
1471 # string, else tags in the link won't be matched.
1472 #
1473 sub process_L {
1474     my($str) = @_;
1475     my($s1, $s2, $linktext, $page, $page83, $section, $link);   # work strings
1476
1477     $str =~ s/\n/ /g;                   # undo word-wrapped tags
1478     $s1 = $str;
1479     for ($s1) {
1480         # LREF: a la HREF L<show this text|man/section>
1481         $linktext = $1 if s:^([^|]+)\|::;
1482
1483         # make sure sections start with a /
1484         s,^",/",g;
1485         s,^,/,g if (!m,/, && / /);
1486
1487         # check if there's a section specified
1488         if (m,^(.*?)/"?(.*?)"?$,) {     # yes
1489             ($page, $section) = ($1, $2);
1490         } else {                        # no
1491             ($page, $section) = ($str, "");
1492         }
1493
1494         # check if we know that this is a section in this page
1495         if (!defined $pages{$page} && defined $sections{$page}) {
1496             $section = $page;
1497             $page = "";
1498         }
1499
1500         # remove trailing punctuation, like ()
1501         $section =~ s/\W*$// ;
1502     }
1503
1504     $page83=dosify($page);
1505     $page=$page83 if (defined $pages{$page83});
1506     if ($page eq "") {
1507         $link = "#" . htmlify(0,$section);
1508         $linktext = $section unless defined($linktext);
1509     } elsif ( $page =~ /::/ ) {
1510         $linktext  = ($section ? "$section" : "$page");
1511         $page =~ s,::,/,g;
1512         # Search page cache for an entry keyed under the html page name,
1513         # then look to see what directory that page might be in.  NOTE:
1514         # this will only find one page. A better solution might be to produce
1515         # an intermediate page that is an index to all such pages.
1516         my $page_name = $page ;
1517         $page_name =~ s,^.*/,, ;
1518         if ( defined( $pages{ $page_name } ) &&
1519              $pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
1520            ) {
1521             $page = $1 ;
1522         }
1523         else {
1524             # NOTE: This branch assumes that all A::B pages are located in
1525             # $htmlroot/A/B.html . This is often incorrect, since they are
1526             # often in $htmlroot/lib/A/B.html or such like. Perhaps we could
1527             # analyze the contents of %pages and figure out where any
1528             # cousins of A::B are, then assume that.  So, if A::B isn't found,
1529             # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
1530             # lib/A/B.pm. This is also limited, but it's an improvement.
1531             # Maybe a hints file so that the links point to the correct places
1532             # non-theless?
1533             # Also, maybe put a warn "$0: cannot resolve..." here.
1534         }
1535         $link = "$htmlroot/$page.html";
1536         $link .= "#" . htmlify(0,$section) if ($section);
1537     } elsif (!defined $pages{$page}) {
1538         warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n" unless $quiet;
1539         $link = "";
1540         $linktext = $page unless defined($linktext);
1541     } else {
1542         $linktext  = ($section ? "$section" : "the $page manpage") unless defined($linktext);
1543         $section = htmlify(0,$section) if $section ne "";
1544
1545         # if there is a directory by the name of the page, then assume that an
1546         # appropriate section will exist in the subdirectory
1547 #       if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
1548         if ($section ne "" && $pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
1549             $link = "$htmlroot/$1/$section.html";
1550
1551         # since there is no directory by the name of the page, the section will
1552         # have to exist within a .html of the same name.  thus, make sure there
1553         # is a .pod or .pm that might become that .html
1554         } else {
1555             $section = "#$section";
1556             # check if there is a .pod with the page name
1557             if ($pages{$page} =~ /([^:]*)\.pod:/) {
1558                 $link = "$htmlroot/$1.html$section";
1559             } elsif ($pages{$page} =~ /([^:]*)\.pm:/) {
1560                 $link = "$htmlroot/$1.html$section";
1561             } else {
1562                 warn "$0: $podfile: cannot resolve L$str in paragraph $paragraph: ".
1563                              "no .pod or .pm found\n";
1564                 $link = "";
1565                 $linktext = $section unless defined($linktext);
1566             }
1567         }
1568     }
1569
1570     process_text(\$linktext, 0);
1571     if ($link) {
1572         # Here, we take advantage of the knowledge that $htmlfileurl ne ''
1573         # implies $htmlroot eq ''. This means that the link in question
1574         # needs a prefix of $htmldir if it begins with '/'. The test for
1575         # the initial '/' is done to avoid '#'-only links, and to allow
1576         # for other kinds of links, like file:, ftp:, etc.
1577         my $url ;
1578         if (  $htmlfileurl ne '' ) {
1579             $link = "$htmldir$link"
1580                 if ( $link =~ m{^/} ) ;
1581
1582             $url = relativize_url( $link, $htmlfileurl ) ;
1583 # print( "  b: [$link,$htmlfileurl,$url]\n" ) ;
1584         }
1585         else {
1586             $url = $link ;
1587         }
1588
1589         $s1 = "<A HREF=\"$url\">$linktext</A>";
1590     } else {
1591         $s1 = "<EM>$linktext</EM>";
1592     }
1593     return $s1;
1594 }
1595
1596 #
1597 # relativize_url - convert an absolute URL to one relative to a base URL.
1598 # Assumes both end in a filename.
1599 #
1600 sub relativize_url {
1601     my ($dest,$source) = @_ ;
1602
1603     my ($dest_volume,$dest_directory,$dest_file) =
1604         File::Spec::Unix->splitpath( $dest ) ;
1605     $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
1606
1607     my ($source_volume,$source_directory,$source_file) =
1608         File::Spec::Unix->splitpath( $source ) ;
1609     $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
1610
1611     my $rel_path = '' ;
1612     if ( $dest ne '' ) {
1613        $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
1614     }
1615
1616     if ( $rel_path ne ''                &&
1617          substr( $rel_path, -1 ) ne '/' &&
1618          substr( $dest_file, 0, 1 ) ne '#'
1619         ) {
1620         $rel_path .= "/$dest_file" ;
1621     }
1622     else {
1623         $rel_path .= "$dest_file" ;
1624     }
1625
1626     return $rel_path ;
1627 }
1628
1629 #
1630 # process_BFI - process any of the B<>, F<>, or I<> pod-escapes and
1631 # convert them to corresponding HTML directives.
1632 #
1633 sub process_BFI {
1634     my($tag, $str) = @_;
1635     my($s1);                    # work string
1636     my(%repltext) = (   'B' => 'STRONG',
1637                         'F' => 'EM',
1638                         'I' => 'EM');
1639
1640     # extract the modified text and convert to HTML
1641     $s1 = "<$repltext{$tag}>$str</$repltext{$tag}>";
1642     return $s1;
1643 }
1644
1645 #
1646 # process_C - process the C<> pod-escape.
1647 #
1648 sub process_C {
1649     my($str, $doref) = @_;
1650     my($s1, $s2);
1651
1652     $s1 = $str;
1653     $s1 =~ s/\([^()]*\)//g;     # delete parentheses
1654     $s2 = $s1;
1655     $s1 =~ s/\W//g;             # delete bogus characters
1656     $str = html_escape($str);
1657
1658     # if there was a pod file that we found earlier with an appropriate
1659     # =item directive, then create a link to that page.
1660     if ($doref && defined $items{$s1}) {
1661         if ( $items{$s1} ) {
1662             my $link = "$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) ;
1663             # Here, we take advantage of the knowledge that $htmlfileurl ne ''
1664             # implies $htmlroot eq ''.
1665             my $url ;
1666             if (  $htmlfileurl ne '' ) {
1667                 $link = "$htmldir$link" ;
1668                 $url = relativize_url( $link, $htmlfileurl ) ;
1669             }
1670             else {
1671                 $url = $link ;
1672             }
1673             $s1 = "<A HREF=\"$url\">$str</A>" ;
1674         }
1675         else {
1676             $s1 = "<A HREF=\"#item_" . htmlify(0,$s2) .  "\">$str</A>" ;
1677         }
1678         $s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,;
1679         confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/;
1680     } else {
1681         $s1 = "<CODE>$str</CODE>";
1682         # warn "$0: $podfile: cannot resolve C<$str> in paragraph $paragraph\n" if $verbose
1683     }
1684
1685
1686     return $s1;
1687 }
1688
1689 #
1690 # process_E - process the E<> pod directive which seems to escape a character.
1691 #
1692 sub process_E {
1693     my($str) = @_;
1694
1695     for ($str) {
1696         s,([^/].*),\&$1\;,g;
1697     }
1698
1699     return $str;
1700 }
1701
1702 #
1703 # process_Z - process the Z<> pod directive which really just amounts to
1704 # ignoring it.  this allows someone to start a paragraph with an =
1705 #
1706 sub process_Z {
1707     my($str) = @_;
1708
1709     # there is no equivalent in HTML for this so just ignore it.
1710     $str = "";
1711     return $str;
1712 }
1713
1714 #
1715 # process_S - process the S<> pod directive which means to convert all
1716 # spaces in the string to non-breaking spaces (in HTML-eze).
1717 #
1718 sub process_S {
1719     my($str) = @_;
1720
1721     # convert all spaces in the text to non-breaking spaces in HTML.
1722     $str =~ s/ /&nbsp;/g;
1723     return $str;
1724 }
1725
1726 #
1727 # process_X - this is supposed to make an index entry.  we'll just
1728 # ignore it.
1729 #
1730 sub process_X {
1731     return '';
1732 }
1733
1734
1735 #
1736 # Adapted from Nick Ing-Simmons' PodToHtml package.
1737 sub relative_url {
1738     my $source_file = shift ;
1739     my $destination_file = shift;
1740
1741     my $source = URI::file->new_abs($source_file);
1742     my $uo = URI::file->new($destination_file,$source)->abs;
1743     return $uo->rel->as_string;
1744 }
1745
1746
1747 #
1748 # finish_list - finish off any pending HTML lists.  this should be called
1749 # after the entire pod file has been read and converted.
1750 #
1751 sub finish_list {
1752     while ($listlevel > 0) {
1753         print HTML "</DL>\n";
1754         $listlevel--;
1755     }
1756 }
1757
1758 #
1759 # htmlify - converts a pod section specification to a suitable section
1760 # specification for HTML.  if first arg is 1, only takes 1st word.
1761 #
1762 sub htmlify {
1763     my($compact, $heading) = @_;
1764
1765     if ($compact) {
1766       $heading =~ /^(\w+)/;
1767       $heading = $1;
1768     }
1769
1770   # $heading = lc($heading);
1771   $heading =~ s/[^\w\s]/_/g;
1772   $heading =~ s/(\s+)/ /g;
1773   $heading =~ s/^\s*(.*?)\s*$/$1/s;
1774   $heading =~ s/ /_/g;
1775   $heading =~ s/\A(.{32}).*\Z/$1/s;
1776   $heading =~ s/\s+\Z//;
1777   $heading =~ s/_{2,}/_/g;
1778
1779   return $heading;
1780 }
1781
1782 BEGIN {
1783 }
1784
1785 1;