lib/Pod/Html.pm

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