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