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