plugins/perl/lib/Pod/Html.pm

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