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