This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8f7999b8355c10cfb8c491016d4ab5b587f46161
[perl5.git] / ext / Pod-Html / lib / Pod / Html.pm
1 package Pod::Html;
2 use strict;
3 require Exporter;
4
5 our $VERSION = 1.23;
6 our @ISA = qw(Exporter);
7 our @EXPORT = qw(pod2html htmlify);
8 our @EXPORT_OK = qw(anchorify);
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/([^ -~])/sprintf("&#x%x;", ord($1))/eg;
659     return $rest;
660 }
661
662 #
663 # htmlify - converts a pod section specification to a suitable section
664 # specification for HTML. Note that we keep spaces and special characters
665 # except ", ? (Netscape problem) and the hyphen (writer's problem...).
666 #
667 sub htmlify {
668     my( $heading) = @_;
669     $heading =~ s/(\s+)/ /g;
670     $heading =~ s/\s+\Z//;
671     $heading =~ s/\A\s+//;
672     # The hyphen is a disgrace to the English language.
673     # $heading =~ s/[-"?]//g;
674     $heading =~ s/["?]//g;
675     $heading = lc( $heading );
676     return $heading;
677 }
678
679 #
680 # similar to htmlify, but turns non-alphanumerics into underscores
681 #
682 sub anchorify {
683     my ($anchor) = @_;
684     $anchor = htmlify($anchor);
685     $anchor =~ s/\W/_/g;
686     return $anchor;
687 }
688
689 #
690 # store POD files in %Pages
691 #
692 sub _save_page {
693     my ($modspec, $modname) = @_;
694
695     # Remove Podroot from path
696     $modspec = $Podroot eq File::Spec->curdir
697                ? File::Spec->abs2rel($modspec)
698                : File::Spec->abs2rel($modspec,
699                                      File::Spec->canonpath($Podroot));
700
701     # Convert path to unix style path
702     $modspec = Pod::Html::_unixify($modspec);
703
704     my ($file, $dir) = fileparse($modspec, qr/\.[^.]*/); # strip .ext
705     $Pages{$modname} = $dir.$file;
706 }
707
708 sub _unixify {
709     my $full_path = shift;
710     return '' unless $full_path;
711     return $full_path if $full_path eq '/';
712
713     my ($vol, $dirs, $file) = File::Spec->splitpath($full_path);
714     my @dirs = $dirs eq File::Spec->curdir()
715                ? (File::Spec::Unix->curdir())
716                : File::Spec->splitdir($dirs);
717     if (defined($vol) && $vol) {
718         $vol =~ s/:$// if $^O eq 'VMS';
719         $vol = uc $vol if $^O eq 'MSWin32';
720
721         if( $dirs[0] ) {
722             unshift @dirs, $vol;
723         }
724         else {
725             $dirs[0] = $vol;
726         }
727     }
728     unshift @dirs, '' if File::Spec->file_name_is_absolute($full_path);
729     return $file unless scalar(@dirs);
730     $full_path = File::Spec::Unix->catfile(File::Spec::Unix->catdir(@dirs),
731                                            $file);
732     $full_path =~ s|^\/|| if $^O eq 'MSWin32'; # C:/foo works, /C:/foo doesn't
733     $full_path =~ s/\^\././g if $^O eq 'VMS'; # unescape dots
734     return $full_path;
735 }
736
737 package Pod::Simple::XHTML::LocalPodLinks;
738 use strict;
739 use warnings;
740 use parent 'Pod::Simple::XHTML';
741
742 use File::Spec;
743 use File::Spec::Unix;
744
745 __PACKAGE__->_accessorize(
746  'htmldir',
747  'htmlfileurl',
748  'htmlroot',
749  'pages', # Page name => relative/path/to/page from root POD dir
750  'quiet',
751  'verbose',
752 );
753
754 sub resolve_pod_page_link {
755     my ($self, $to, $section) = @_;
756
757     return undef unless defined $to || defined $section;
758     if (defined $section) {
759         $section = '#' . $self->idify($section, 1);
760         return $section unless defined $to;
761     } else {
762         $section = '';
763     }
764
765     my $path; # path to $to according to %Pages
766     unless (exists $self->pages->{$to}) {
767         # Try to find a POD that ends with $to and use that.
768         # e.g., given L<XHTML>, if there is no $Podpath/XHTML in %Pages,
769         # look for $Podpath/*/XHTML in %Pages, with * being any path,
770         # as a substitute (e.g., $Podpath/Pod/Simple/XHTML)
771         my @matches;
772         foreach my $modname (keys %{$self->pages}) {
773             push @matches, $modname if $modname =~ /::\Q$to\E\z/;
774         }
775
776         if ($#matches == -1) {
777             warn "Cannot find \"$to\" in podpath: " . 
778                  "cannot find suitable replacement path, cannot resolve link\n"
779                  unless $self->quiet;
780             return '';
781         } elsif ($#matches == 0) {
782             warn "Cannot find \"$to\" in podpath: " .
783                  "using $matches[0] as replacement path to $to\n" 
784                  unless $self->quiet;
785             $path = $self->pages->{$matches[0]};
786         } else {
787             warn "Cannot find \"$to\" in podpath: " .
788                  "more than one possible replacement path to $to, " .
789                  "using $matches[-1]\n" unless $self->quiet;
790             # Use [-1] so newer (higher numbered) perl PODs are used
791             $path = $self->pages->{$matches[-1]};
792         }
793     } else {
794         $path = $self->pages->{$to};
795     }
796
797     my $url = File::Spec::Unix->catfile(Pod::Html::_unixify($self->htmlroot),
798                                         $path);
799
800     if ($self->htmlfileurl ne '') {
801         # then $self->htmlroot eq '' (by definition of htmlfileurl) so
802         # $self->htmldir needs to be prepended to link to get the absolute path
803         # that will be relativized
804         $url = relativize_url(
805             File::Spec::Unix->catdir(Pod::Html::_unixify($self->htmldir), $url),
806             $self->htmlfileurl # already unixified
807         );
808     }
809
810     return $url . ".html$section";
811 }
812
813 #
814 # relativize_url - convert an absolute URL to one relative to a base URL.
815 # Assumes both end in a filename.
816 #
817 sub relativize_url {
818     my ($dest, $source) = @_;
819
820     # Remove each file from its path
821     my ($dest_volume, $dest_directory, $dest_file) =
822         File::Spec::Unix->splitpath( $dest );
823     $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' );
824
825     my ($source_volume, $source_directory, $source_file) =
826         File::Spec::Unix->splitpath( $source );
827     $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' );
828
829     my $rel_path = '';
830     if ($dest ne '') {
831        $rel_path = File::Spec::Unix->abs2rel( $dest, $source );
832     }
833
834     if ($rel_path ne '' && substr( $rel_path, -1 ) ne '/') {
835         $rel_path .= "/$dest_file";
836     } else {
837         $rel_path .= "$dest_file";
838     }
839
840     return $rel_path;
841 }
842
843 1;