ext/Pod-Html/lib/Pod/Html.pm

   1 package Pod::Html;
   2 use strict;
   3 require Exporter;
   4
   5 our $VERSION = 1.24;
   6 our @ISA = qw(Exporter);
   7 our @EXPORT = qw(pod2html htmlify);
   8 our @EXPORT_OK = qw(anchorify relativize_url);
   9
  10 use Carp;
  11 use Config;
  12 use Cwd;
  13 use File::Basename;
  14 use File::Spec;
  15 use File::Spec::Unix;
  16 use Getopt::Long;
  17 use Pod::Simple::Search;
  18 use Pod::Simple::SimpleTree ();
  19 use locale; # make \w work right in non-ASCII lands
  20
  21 =head1 NAME
  22
  23 Pod::Html - module to convert pod files to HTML
  24
  25 =head1 SYNOPSIS
  26
  27     use Pod::Html;
  28     pod2html([options]);
  29
  30 =head1 DESCRIPTION
  31
  32 Converts files from pod format (see L<perlpod>) to HTML format.  It
  33 can automatically generate indexes and cross-references, and it keeps
  34 a cache of things it knows how to cross-reference.
  35
  36 =head1 FUNCTIONS
  37
  38 =head2 pod2html
  39
  40     pod2html("pod2html",
  41              "--podpath=lib:ext:pod:vms",
  42              "--podroot=/usr/src/perl",
  43              "--htmlroot=/perl/nmanual",
  44              "--recurse",
  45              "--infile=foo.pod",
  46              "--outfile=/perl/nmanual/foo.html");
  47
  48 pod2html takes the following arguments:
  49
  50 =over 4
  51
  52 =item backlink
  53
  54     --backlink
  55
  56 Turns every C<head1> heading into a link back to the top of the page.
  57 By default, no backlinks are generated.
  58
  59 =item cachedir
  60
  61     --cachedir=name
  62
  63 Creates the directory cache in the given directory.
  64
  65 =item css
  66
  67     --css=stylesheet
  68
  69 Specify the URL of a cascading style sheet.  Also disables all HTML/CSS
  70 C<style> attributes that are output by default (to avoid conflicts).
  71
  72 =item flush
  73
  74     --flush
  75
  76 Flushes the directory cache.
  77
  78 =item header
  79
  80     --header
  81     --noheader
  82
  83 Creates header and footer blocks containing the text of the C<NAME>
  84 section.  By default, no headers are generated.
  85
  86 =item help
  87
  88     --help
  89
  90 Displays the usage message.
  91
  92 =item htmldir
  93
  94     --htmldir=name
  95
  96 Sets the directory to which all cross references in the resulting
  97 html file will be relative. Not passing this causes all links to be
  98 absolute since this is the value that tells Pod::Html the root of the
  99 documentation tree.
 100
 101 Do not use this and --htmlroot in the same call to pod2html; they are
 102 mutually exclusive.
 103
 104 =item htmlroot
 105
 106     --htmlroot=name
 107
 108 Sets the base URL for the HTML files.  When cross-references are made,
 109 the HTML root is prepended to the URL.
 110
 111 Do not use this if relative links are desired: use --htmldir instead.
 112
 113 Do not pass both this and --htmldir to pod2html; they are mutually
 114 exclusive.
 115
 116 =item index
 117
 118     --index
 119     --noindex
 120
 121 Generate an index at the top of the HTML file.  This is the default
 122 behaviour.
 123
 124 =item infile
 125
 126     --infile=name
 127
 128 Specify the pod file to convert.  Input is taken from STDIN if no
 129 infile is specified.
 130
 131 =item outfile
 132
 133     --outfile=name
 134
 135 Specify the HTML file to create.  Output goes to STDOUT if no outfile
 136 is specified.
 137
 138 =item poderrors
 139
 140     --poderrors
 141     --nopoderrors
 142
 143 Include a "POD ERRORS" section in the outfile if there were any POD
 144 errors in the infile. This section is included by default.
 145
 146 =item podpath
 147
 148     --podpath=name:...:name
 149
 150 Specify which subdirectories of the podroot contain pod files whose
 151 HTML converted forms can be linked to in cross references.
 152
 153 =item podroot
 154
 155     --podroot=name
 156
 157 Specify the base directory for finding library pods. Default is the
 158 current working directory.
 159
 160 =item quiet
 161
 162     --quiet
 163     --noquiet
 164
 165 Don't display I<mostly harmless> warning messages.  These messages
 166 will be displayed by default.  But this is not the same as C<verbose>
 167 mode.
 168
 169 =item recurse
 170
 171     --recurse
 172     --norecurse
 173
 174 Recurse into subdirectories specified in podpath (default behaviour).
 175
 176 =item title
 177
 178     --title=title
 179
 180 Specify the title of the resulting HTML file.
 181
 182 =item verbose
 183
 184     --verbose
 185     --noverbose
 186
 187 Display progress messages.  By default, they won't be displayed.
 188
 189 =back
 190
 191 =head2 htmlify
 192
 193     htmlify($heading);
 194
 195 Converts a pod section specification to a suitable section specification
 196 for HTML. Note that we keep spaces and special characters except
 197 C<", ?> (Netscape problem) and the hyphen (writer's problem...).
 198
 199 =head2 anchorify
 200
 201     anchorify(@heading);
 202
 203 Similar to C<htmlify()>, but turns non-alphanumerics into underscores.  Note
 204 that C<anchorify()> is not exported by default.
 205
 206 =head1 ENVIRONMENT
 207
 208 Uses C<$Config{pod2html}> to setup default options.
 209
 210 =head1 AUTHOR
 211
 212 Marc Green, E<lt>marcgreen@cpan.orgE<gt>.
 213
 214 Original version by Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
 215
 216 =head1 SEE ALSO
 217
 218 L<perlpod>
 219
 220 =head1 COPYRIGHT
 221
 222 This program is distributed under the Artistic License.
 223
 224 =cut
 225
 226 # This sub duplicates the guts of Pod::Simple::FromTree.  We could have
 227 # used that module, except that it would have been a non-core dependency.
 228 sub feed_tree_to_parser {
 229     my($parser, $tree) = @_;
 230     if(ref($tree) eq "") {
 231         $parser->_handle_text($tree);
 232     } elsif(!($tree->[0] eq "X" && $parser->nix_X_codes)) {
 233         $parser->_handle_element_start($tree->[0], $tree->[1]);
 234         feed_tree_to_parser($parser, $_) foreach @{$tree}[2..$#$tree];
 235         $parser->_handle_element_end($tree->[0]);
 236     }
 237 }
 238
 239 my $Cachedir;
 240 my $Dircache;
 241 my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl);
 242 my($Podfile, @Podpath, $Podroot);
 243 my $Poderrors;
 244 my $Css;
 245
 246 my $Recurse;
 247 my $Quiet;
 248 my $Verbose;
 249 my $Doindex;
 250
 251 my $Backlink;
 252
 253 my($Title, $Header);
 254
 255 my %Pages = ();                 # associative array used to find the location
 256                                 #   of pages referenced by L<> links.
 257
 258 my $Curdir = File::Spec->curdir;
 259
 260 init_globals();
 261
 262 sub init_globals {
 263     $Cachedir = ".";            # The directory to which directory caches
 264                                 #   will be written.
 265
 266     $Dircache = "pod2htmd.tmp";
 267
 268     $Htmlroot = "/";            # http-server base directory from which all
 269                                 #   relative paths in $podpath stem.
 270     $Htmldir = "";              # The directory to which the html pages
 271                                 #   will (eventually) be written.
 272     $Htmlfile = "";             # write to stdout by default
 273     $Htmlfileurl = "";          # The url that other files would use to
 274                                 # refer to this file.  This is only used
 275                                 # to make relative urls that point to
 276                                 # other files.
 277
 278     $Poderrors = 1;
 279     $Podfile = "";              # read from stdin by default
 280     @Podpath = ();              # list of directories containing library pods.
 281     $Podroot = $Curdir;         # filesystem base directory from which all
 282                                 #   relative paths in $podpath stem.
 283     $Css = '';                  # Cascading style sheet
 284     $Recurse = 1;               # recurse on subdirectories in $podpath.
 285     $Quiet = 0;                 # not quiet by default
 286     $Verbose = 0;               # not verbose by default
 287     $Doindex = 1;               # non-zero if we should generate an index
 288     $Backlink = 0;              # no backlinks added by default
 289     $Header = 0;                # produce block header/footer
 290     $Title = undef;             # title to give the pod(s)
 291 }
 292
 293 sub pod2html {
 294     local(@ARGV) = @_;
 295     local $_;
 296
 297     init_globals();
 298     parse_command_line();
 299
 300     # prevent '//' in urls
 301     $Htmlroot = "" if $Htmlroot eq "/";
 302     $Htmldir =~ s#/\z##;
 303
 304     if (  $Htmlroot eq ''
 305        && defined( $Htmldir )
 306        && $Htmldir ne ''
 307        && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir
 308        ) {
 309         # Set the 'base' url for this file, so that we can use it
 310         # as the location from which to calculate relative links
 311         # to other files. If this is '', then absolute links will
 312         # be used throughout.
 313         #$Htmlfileurl = "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
 314         # Is the above not just "$Htmlfileurl = $Htmlfile"?
 315         $Htmlfileurl = Pod::Html::_unixify($Htmlfile);
 316
 317     }
 318
 319     # load or generate/cache %Pages
 320     unless (get_cache($Dircache, \@Podpath, $Podroot, $Recurse)) {
 321         # generate %Pages
 322         my $pwd = getcwd();
 323         chdir($Podroot) ||
 324             die "$0: error changing to directory $Podroot: $!\n";
 325
 326         # find all pod modules/pages in podpath, store in %Pages
 327         # - callback used to remove Podroot and extension from each file
 328         # - laborious to allow '.' in dirnames (e.g., /usr/share/perl/5.14.1)
 329         Pod::Simple::Search->new->inc(0)->verbose($Verbose)->laborious(1)
 330             ->callback(\&_save_page)->recurse($Recurse)->survey(@Podpath);
 331
 332         chdir($pwd) || die "$0: error changing to directory $pwd: $!\n";
 333
 334         # cache the directory list for later use
 335         warn "caching directories for later use\n" if $Verbose;
 336         open my $cache, '>', $Dircache
 337             or die "$0: error open $Dircache for writing: $!\n";
 338
 339         print $cache join(":", @Podpath) . "\n$Podroot\n";
 340         my $_updirs_only = ($Podroot =~ /\.\./) && !($Podroot =~ /[^\.\\\/]/);
 341         foreach my $key (keys %Pages) {
 342             if($_updirs_only) {
 343               my $_dirlevel = $Podroot;
 344               while($_dirlevel =~ /\.\./) {
 345                 $_dirlevel =~ s/\.\.//;
 346                 # Assume $Pages{$key} has '/' separators (html dir separators).
 347                 $Pages{$key} =~ s/^[\w\s\-\.]+\///;
 348               }
 349             }
 350             print $cache "$key $Pages{$key}\n";
 351         }
 352
 353         close $cache or die "error closing $Dircache: $!";
 354     }
 355
 356     my $input;
 357     unless (@ARGV && $ARGV[0]) {
 358         if ($Podfile and $Podfile ne '-') {
 359             $input = $Podfile;
 360         } else {
 361             $input = '-'; # XXX: make a test case for this
 362         }
 363     } else {
 364         $Podfile = $ARGV[0];
 365         $input = *ARGV;
 366     }
 367
 368     # set options for input parser
 369     my $parser = Pod::Simple::SimpleTree->new;
 370     $parser->codes_in_verbatim(0);
 371     $parser->accept_targets(qw(html HTML));
 372     $parser->no_errata_section(!$Poderrors); # note the inverse
 373
 374     warn "Converting input file $Podfile\n" if $Verbose;
 375     my $podtree = $parser->parse_file($input)->root;
 376
 377     unless(defined $Title) {
 378         if($podtree->[0] eq "Document" && ref($podtree->[2]) eq "ARRAY" &&
 379                 $podtree->[2]->[0] eq "head1" && @{$podtree->[2]} == 3 &&
 380                 ref($podtree->[2]->[2]) eq "" && $podtree->[2]->[2] eq "NAME" &&
 381                 ref($podtree->[3]) eq "ARRAY" && $podtree->[3]->[0] eq "Para" &&
 382                 @{$podtree->[3]} >= 3 &&
 383                 !(grep { ref($_) ne "" }
 384                     @{$podtree->[3]}[2..$#{$podtree->[3]}]) &&
 385                 (@$podtree == 4 ||
 386                     (ref($podtree->[4]) eq "ARRAY" &&
 387                         $podtree->[4]->[0] eq "head1"))) {
 388             $Title = join("", @{$podtree->[3]}[2..$#{$podtree->[3]}]);
 389         }
 390     }
 391
 392     $Title //= "";
 393     $Title = html_escape($Title);
 394
 395     # set options for the HTML generator
 396     $parser = Pod::Simple::XHTML::LocalPodLinks->new();
 397     $parser->codes_in_verbatim(0);
 398     $parser->anchor_items(1); # the old Pod::Html always did
 399     $parser->backlink($Backlink); # linkify =head1 directives
 400     $parser->force_title($Title);
 401     $parser->htmldir($Htmldir);
 402     $parser->htmlfileurl($Htmlfileurl);
 403     $parser->htmlroot($Htmlroot);
 404     $parser->index($Doindex);
 405     $parser->output_string(\my $output); # written to file later
 406     $parser->pages(\%Pages);
 407     $parser->quiet($Quiet);
 408     $parser->verbose($Verbose);
 409
 410     # We need to add this ourselves because we use our own header, not
 411     # ::XHTML's header. We need to set $parser->backlink to linkify
 412     # the =head1 directives
 413     my $bodyid = $Backlink ? ' id="_podtop_"' : '';
 414
 415     my $csslink = '';
 416     my $tdstyle = ' style="background-color: #cccccc; color: #000"';
 417
 418     if ($Css) {
 419         $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />);
 420         $csslink =~ s,\\,/,g;
 421         $csslink =~ s,(/.):,$1|,;
 422         $tdstyle= '';
 423     }
 424
 425     # header/footer block
 426     my $block = $Header ? <<END_OF_BLOCK : '';
 427 <table border="0" width="100%" cellspacing="0" cellpadding="3">
 428 <tr><td class="_podblock_"$tdstyle valign="middle">
 429 <big><strong><span class="_podblock_">&nbsp;$Title</span></strong></big>
 430 </td></tr>
 431 </table>
 432 END_OF_BLOCK
 433
 434     # create own header/footer because of --header
 435     $parser->html_header(<<"HTMLHEAD");
 436 <?xml version="1.0" ?>
 437 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 438 <html xmlns="http://www.w3.org/1999/xhtml">
 439 <head>
 440 <title>$Title</title>$csslink
 441 <meta http-equiv="content-type" content="text/html; charset=utf-8" />
 442 <link rev="made" href="mailto:$Config{perladmin}" />
 443 </head>
 444
 445 <body$bodyid>
 446 $block
 447 HTMLHEAD
 448
 449     $parser->html_footer(<<"HTMLFOOT");
 450 $block
 451 </body>
 452
 453 </html>
 454 HTMLFOOT
 455
 456     feed_tree_to_parser($parser, $podtree);
 457
 458     # Write output to file
 459     $Htmlfile = "-" unless $Htmlfile; # stdout
 460     my $fhout;
 461     if($Htmlfile and $Htmlfile ne '-') {
 462         open $fhout, ">", $Htmlfile
 463             or die "$0: cannot open $Htmlfile file for output: $!\n";
 464     } else {
 465         open $fhout, ">-";
 466     }
 467     binmode $fhout, ":utf8";
 468     print $fhout $output;
 469     close $fhout or die "Failed to close $Htmlfile: $!";
 470     chmod 0644, $Htmlfile unless $Htmlfile eq '-';
 471 }
 472
 473 ##############################################################################
 474
 475 sub usage {
 476     my $podfile = shift;
 477     warn "$0: $podfile: @_\n" if @_;
 478     die <<END_OF_USAGE;
 479 Usage:  $0 --help --htmldir=<name> --htmlroot=<URL>
 480            --infile=<name> --outfile=<name>
 481            --podpath=<name>:...:<name> --podroot=<name>
 482            --cachedir=<name> --flush --recurse --norecurse
 483            --quiet --noquiet --verbose --noverbose
 484            --index --noindex --backlink --nobacklink
 485            --header --noheader --poderrors --nopoderrors
 486            --css=<URL> --title=<name>
 487
 488   --[no]backlink  - turn =head1 directives into links pointing to the top of
 489                       the page (off by default).
 490   --cachedir      - directory for the directory cache files.
 491   --css           - stylesheet URL
 492   --flush         - flushes the directory cache.
 493   --[no]header    - produce block header/footer (default is no headers).
 494   --help          - prints this message.
 495   --htmldir       - directory for resulting HTML files.
 496   --htmlroot      - http-server base directory from which all relative paths
 497                       in podpath stem (default is /).
 498   --[no]index     - generate an index at the top of the resulting html
 499                       (default behaviour).
 500   --infile        - filename for the pod to convert (input taken from stdin
 501                       by default).
 502   --outfile       - filename for the resulting html file (output sent to
 503                       stdout by default).
 504   --[no]poderrors - include a POD ERRORS section in the output if there were
 505                       any POD errors in the input (default behavior).
 506   --podpath       - colon-separated list of directories containing library
 507                       pods (empty by default).
 508   --podroot       - filesystem base directory from which all relative paths
 509                       in podpath stem (default is .).
 510   --[no]quiet     - suppress some benign warning messages (default is off).
 511   --[no]recurse   - recurse on those subdirectories listed in podpath
 512                       (default behaviour).
 513   --title         - title that will appear in resulting html file.
 514   --[no]verbose   - self-explanatory (off by default).
 515
 516 END_OF_USAGE
 517
 518 }
 519
 520 sub parse_command_line {
 521     my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,
 522         $opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,
 523         $opt_outfile,$opt_poderrors,$opt_podpath,$opt_podroot,
 524         $opt_quiet,$opt_recurse,$opt_title,$opt_verbose);
 525
 526     unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
 527     my $result = GetOptions(
 528                        'backlink!'  => \$opt_backlink,
 529                        'cachedir=s' => \$opt_cachedir,
 530                        'css=s'      => \$opt_css,
 531                        'flush'      => \$opt_flush,
 532                        'help'       => \$opt_help,
 533                        'header!'    => \$opt_header,
 534                        'htmldir=s'  => \$opt_htmldir,
 535                        'htmlroot=s' => \$opt_htmlroot,
 536                        'index!'     => \$opt_index,
 537                        'infile=s'   => \$opt_infile,
 538                        'outfile=s'  => \$opt_outfile,
 539                        'poderrors!' => \$opt_poderrors,
 540                        'podpath=s'  => \$opt_podpath,
 541                        'podroot=s'  => \$opt_podroot,
 542                        'quiet!'     => \$opt_quiet,
 543                        'recurse!'   => \$opt_recurse,
 544                        'title=s'    => \$opt_title,
 545                        'verbose!'   => \$opt_verbose,
 546     );
 547     usage("-", "invalid parameters") if not $result;
 548
 549     usage("-") if defined $opt_help;    # see if the user asked for help
 550     $opt_help = "";                     # just to make -w shut-up.
 551
 552     @Podpath  = split(":", $opt_podpath) if defined $opt_podpath;
 553
 554     $Backlink  =          $opt_backlink   if defined $opt_backlink;
 555     $Cachedir  = _unixify($opt_cachedir)  if defined $opt_cachedir;
 556     $Css       =          $opt_css        if defined $opt_css;
 557     $Header    =          $opt_header     if defined $opt_header;
 558     $Htmldir   = _unixify($opt_htmldir)   if defined $opt_htmldir;
 559     $Htmlroot  = _unixify($opt_htmlroot)  if defined $opt_htmlroot;
 560     $Doindex   =          $opt_index      if defined $opt_index;
 561     $Podfile   = _unixify($opt_infile)    if defined $opt_infile;
 562     $Htmlfile  = _unixify($opt_outfile)   if defined $opt_outfile;
 563     $Poderrors =          $opt_poderrors  if defined $opt_poderrors;
 564     $Podroot   = _unixify($opt_podroot)   if defined $opt_podroot;
 565     $Quiet     =          $opt_quiet      if defined $opt_quiet;
 566     $Recurse   =          $opt_recurse    if defined $opt_recurse;
 567     $Title     =          $opt_title      if defined $opt_title;
 568     $Verbose   =          $opt_verbose    if defined $opt_verbose;
 569
 570     warn "Flushing directory caches\n"
 571         if $opt_verbose && defined $opt_flush;
 572     $Dircache = "$Cachedir/pod2htmd.tmp";
 573     if (defined $opt_flush) {
 574         1 while unlink($Dircache);
 575     }
 576 }
 577
 578 my $Saved_Cache_Key;
 579
 580 sub get_cache {
 581     my($dircache, $podpath, $podroot, $recurse) = @_;
 582     my @cache_key_args = @_;
 583
 584     # A first-level cache:
 585     # Don't bother reading the cache files if they still apply
 586     # and haven't changed since we last read them.
 587
 588     my $this_cache_key = cache_key(@cache_key_args);
 589     return 1 if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
 590     $Saved_Cache_Key = $this_cache_key;
 591
 592     # load the cache of %Pages if possible.  $tests will be
 593     # non-zero if successful.
 594     my $tests = 0;
 595     if (-f $dircache) {
 596         warn "scanning for directory cache\n" if $Verbose;
 597         $tests = load_cache($dircache, $podpath, $podroot);
 598     }
 599
 600     return $tests;
 601 }
 602
 603 sub cache_key {
 604     my($dircache, $podpath, $podroot, $recurse) = @_;
 605     return join('!',$dircache,$recurse,@$podpath,$podroot,stat($dircache));
 606 }
 607
 608 #
 609 # load_cache - tries to find if the cache stored in $dircache is a valid
 610 #  cache of %Pages.  if so, it loads them and returns a non-zero value.
 611 #
 612 sub load_cache {
 613     my($dircache, $podpath, $podroot) = @_;
 614     my $tests = 0;
 615     local $_;
 616
 617     warn "scanning for directory cache\n" if $Verbose;
 618     open(my $cachefh, '<', $dircache) ||
 619         die "$0: error opening $dircache for reading: $!\n";
 620     $/ = "\n";
 621
 622     # is it the same podpath?
 623     $_ = <$cachefh>;
 624     chomp($_);
 625     $tests++ if (join(":", @$podpath) eq $_);
 626
 627     # is it the same podroot?
 628     $_ = <$cachefh>;
 629     chomp($_);
 630     $tests++ if ($podroot eq $_);
 631
 632     # load the cache if its good
 633     if ($tests != 2) {
 634         close($cachefh);
 635         return 0;
 636     }
 637
 638     warn "loading directory cache\n" if $Verbose;
 639     while (<$cachefh>) {
 640         /(.*?) (.*)$/;
 641         $Pages{$1} = $2;
 642     }
 643
 644     close($cachefh);
 645     return 1;
 646 }
 647
 648
 649 #
 650 # html_escape: make text safe for HTML
 651 #
 652 sub html_escape {
 653     my $rest = $_[0];
 654     $rest   =~ s/&/&amp;/g;
 655     $rest   =~ s/</&lt;/g;
 656     $rest   =~ s/>/&gt;/g;
 657     $rest   =~ s/"/&quot;/g;
 658     $rest =~ s/([[:^print:]])/sprintf("&#x%x;", ord($1))/aeg;
 659     return $rest;
 660 }
 661
 662 #
 663 # htmlify - converts a pod section specification to a suitable section
 664 # specification for HTML.  We adopt the mechanism used by the formatter
 665 # that we use.
 666 #
 667 sub htmlify {
 668     my( $heading) = @_;
 669     return Pod::Simple::XHTML->can("idify")->(undef, $heading, 1);
 670 }
 671
 672 #
 673 # similar to htmlify, but turns non-alphanumerics into underscores
 674 #
 675 sub anchorify {
 676     my ($anchor) = @_;
 677     $anchor = htmlify($anchor);
 678     $anchor =~ s/\W/_/g;
 679     return $anchor;
 680 }
 681
 682 #
 683 # store POD files in %Pages
 684 #
 685 sub _save_page {
 686     my ($modspec, $modname) = @_;
 687
 688     # Remove Podroot from path
 689     $modspec = $Podroot eq File::Spec->curdir
 690                ? File::Spec->abs2rel($modspec)
 691                : File::Spec->abs2rel($modspec,
 692                                      File::Spec->canonpath($Podroot));
 693
 694     # Convert path to unix style path
 695     $modspec = Pod::Html::_unixify($modspec);
 696
 697     my ($file, $dir) = fileparse($modspec, qr/\.[^.]*/); # strip .ext
 698     $Pages{$modname} = $dir.$file;
 699 }
 700
 701 sub _unixify {
 702     my $full_path = shift;
 703     return '' unless $full_path;
 704     return $full_path if $full_path eq '/';
 705
 706     my ($vol, $dirs, $file) = File::Spec->splitpath($full_path);
 707     my @dirs = $dirs eq File::Spec->curdir()
 708                ? (File::Spec::Unix->curdir())
 709                : File::Spec->splitdir($dirs);
 710     if (defined($vol) && $vol) {
 711         $vol =~ s/:$// if $^O eq 'VMS';
 712         $vol = uc $vol if $^O eq 'MSWin32';
 713
 714         if( $dirs[0] ) {
 715             unshift @dirs, $vol;
 716         }
 717         else {
 718             $dirs[0] = $vol;
 719         }
 720     }
 721     unshift @dirs, '' if File::Spec->file_name_is_absolute($full_path);
 722     return $file unless scalar(@dirs);
 723     $full_path = File::Spec::Unix->catfile(File::Spec::Unix->catdir(@dirs),
 724                                            $file);
 725     $full_path =~ s|^\/|| if $^O eq 'MSWin32'; # C:/foo works, /C:/foo doesn't
 726     $full_path =~ s/\^\././g if $^O eq 'VMS'; # unescape dots
 727     return $full_path;
 728 }
 729
 730 package Pod::Simple::XHTML::LocalPodLinks;
 731 use strict;
 732 use warnings;
 733 use parent 'Pod::Simple::XHTML';
 734
 735 use File::Spec;
 736 use File::Spec::Unix;
 737
 738 __PACKAGE__->_accessorize(
 739  'htmldir',
 740  'htmlfileurl',
 741  'htmlroot',
 742  'pages', # Page name => relative/path/to/page from root POD dir
 743  'quiet',
 744  'verbose',
 745 );
 746
 747 sub resolve_pod_page_link {
 748     my ($self, $to, $section) = @_;
 749
 750     return undef unless defined $to || defined $section;
 751     if (defined $section) {
 752         $section = '#' . $self->idify($section, 1);
 753         return $section unless defined $to;
 754     } else {
 755         $section = '';
 756     }
 757
 758     my $path; # path to $to according to %Pages
 759     unless (exists $self->pages->{$to}) {
 760         # Try to find a POD that ends with $to and use that.
 761         # e.g., given L<XHTML>, if there is no $Podpath/XHTML in %Pages,
 762         # look for $Podpath/*/XHTML in %Pages, with * being any path,
 763         # as a substitute (e.g., $Podpath/Pod/Simple/XHTML)
 764         my @matches;
 765         foreach my $modname (keys %{$self->pages}) {
 766             push @matches, $modname if $modname =~ /::\Q$to\E\z/;
 767         }
 768
 769         if ($#matches == -1) {
 770             warn "Cannot find \"$to\" in podpath: " .
 771                  "cannot find suitable replacement path, cannot resolve link\n"
 772                  unless $self->quiet;
 773             return '';
 774         } elsif ($#matches == 0) {
 775             warn "Cannot find \"$to\" in podpath: " .
 776                  "using $matches[0] as replacement path to $to\n"
 777                  unless $self->quiet;
 778             $path = $self->pages->{$matches[0]};
 779         } else {
 780             warn "Cannot find \"$to\" in podpath: " .
 781                  "more than one possible replacement path to $to, " .
 782                  "using $matches[-1]\n" unless $self->quiet;
 783             # Use [-1] so newer (higher numbered) perl PODs are used
 784             $path = $self->pages->{$matches[-1]};
 785         }
 786     } else {
 787         $path = $self->pages->{$to};
 788     }
 789
 790     my $url = File::Spec::Unix->catfile(Pod::Html::_unixify($self->htmlroot),
 791                                         $path);
 792
 793     if ($self->htmlfileurl ne '') {
 794         # then $self->htmlroot eq '' (by definition of htmlfileurl) so
 795         # $self->htmldir needs to be prepended to link to get the absolute path
 796         # that will be relativized
 797         $url = Pod::Html::relativize_url(
 798             File::Spec::Unix->catdir(Pod::Html::_unixify($self->htmldir), $url),
 799             $self->htmlfileurl # already unixified
 800         );
 801     }
 802
 803     return $url . ".html$section";
 804 }
 805
 806 package Pod::Html;
 807
 808 #
 809 # relativize_url - convert an absolute URL to one relative to a base URL.
 810 # Assumes both end in a filename.
 811 #
 812 sub relativize_url {
 813     my ($dest, $source) = @_;
 814
 815     # Remove each file from its path
 816     my ($dest_volume, $dest_directory, $dest_file) =
 817         File::Spec::Unix->splitpath( $dest );
 818     $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' );
 819
 820     my ($source_volume, $source_directory, $source_file) =
 821         File::Spec::Unix->splitpath( $source );
 822     $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' );
 823
 824     my $rel_path = '';
 825     if ($dest ne '') {
 826        $rel_path = File::Spec::Unix->abs2rel( $dest, $source );
 827     }
 828
 829     if ($rel_path ne '' && substr( $rel_path, -1 ) ne '/') {
 830         $rel_path .= "/$dest_file";
 831     } else {
 832         $rel_path .= "$dest_file";
 833     }
 834
 835     return $rel_path;
 836 }
 837
 838 1;