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