"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Pod/Html.pm" (10 Mar 2019, 25403 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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;