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