File Coverage

blib/lib/Pod/L10N/Html.pm
Criterion Covered Total %
statement 304 340 89.4
branch 127 176 72.1
condition 23 39 58.9
subroutine 33 36 91.6
pod 3 11 27.2
total 490 602 81.4


line stmt bran cond sub pod time code
1             package Pod::L10N::Html;
2 21     21   239038 use strict;
  21         207  
  21         914  
3             require Exporter;
4              
5 21     21   122 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  21         41  
  21         2421  
6             $VERSION = '1.05';
7             @ISA = qw(Exporter);
8             @EXPORT = qw(pod2htmll10n htmlify);
9             @EXPORT_OK = qw(anchorify);
10              
11 21     21   151 use Carp;
  21         62  
  21         1843  
12 21     21   142 use Config;
  21         46  
  21         845  
13 21     21   112 use Cwd;
  21         35  
  21         1323  
14 21     21   138 use File::Basename;
  21         41  
  21         2891  
15 21     21   145 use File::Spec;
  21         72  
  21         504  
16 21     21   129 use File::Spec::Unix;
  21         40  
  21         816  
17 21     21   16396 use Getopt::Long;
  21         239438  
  21         125  
18 21     21   17310 use Pod::Simple::Search;
  21         133938  
  21         839  
19              
20 21     21   9720 use Pod::L10N::Model;
  21         69  
  21         718  
21              
22 21     21   10696 use locale; # make \w work right in non-ASCII lands
  21         12835  
  21         128  
23              
24             =head1 NAME
25              
26             Pod::L10N::Html - module to convert pod files to HTML with L10N
27              
28             =head1 SYNOPSIS
29              
30             use Pod::L10N::Html;
31             pod2htmll10n([options]);
32              
33             =head1 DESCRIPTION
34              
35             Converts files from pod format (see L) to HTML format.
36              
37             Its API is fully compatible with L.
38              
39             If input files support L extended format,
40             Pod::L10N::Html do some more works to print translated text pretty well.
41              
42             =head1 ADDITIONAL FEATURES
43              
44             Additional features from L 1.2202 are:
45              
46             =over
47              
48             =item *
49              
50             Support L extended format.
51              
52             =back
53              
54             =head1 FUNCTIONS
55              
56             =head2 pod2htmll10n
57              
58             pod2htmll10n("pod2htmll10n",
59             "--podpath=lib:ext:pod:vms",
60             "--podroot=/usr/src/perl",
61             "--htmlroot=/perl/nmanual",
62             "--recurse",
63             "--infile=foo.pod",
64             "--outfile=/perl/nmanual/foo.html");
65              
66             See L for details.
67              
68             =head2 htmlify
69              
70             htmlify($heading);
71              
72             See L for details.
73              
74             =head2 anchorify
75              
76             anchorify(@heading);
77              
78             See L for details.
79              
80             =head1 ENVIRONMENT
81              
82             Uses C<$Config{pod2html}> to setup default options.
83              
84             =head1 AUTHOR
85              
86             C is based on L Version 1.2202 written by
87             Marc Green, Emarcgreen@cpan.orgE.
88              
89             Modification to C is written by SHIRAKATA Kentaro,
90             Eargrath@cpan.orgE.
91              
92             =head1 SEE ALSO
93              
94             L, L, L
95              
96             =head1 COPYRIGHT
97              
98             This program is distributed under the Artistic License.
99              
100             =cut
101              
102             # "
103              
104             my $Cachedir;
105             my $Dircache;
106             my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl);
107             my($Podfile, @Podpath, $Podroot);
108             my $Poderrors;
109             my $Css;
110              
111             my $Recurse;
112             my $Quiet;
113             my $Verbose;
114             my $Doindex;
115              
116             my $Backlink;
117              
118             my($Title, $Header);
119              
120             my %Pages = (); # associative array used to find the location
121             # of pages referenced by L<> links.
122              
123             my $Curdir = File::Spec->curdir;
124              
125             init_globals();
126              
127             sub init_globals {
128 49     49 0 618 $Cachedir = "."; # The directory to which directory caches
129             # will be written.
130              
131 49         328 $Dircache = "pod2htmd.tmp";
132              
133 49         326 $Htmlroot = "/"; # http-server base directory from which all
134             # relative paths in $podpath stem.
135 49         251 $Htmldir = ""; # The directory to which the html pages
136             # will (eventually) be written.
137 49         302 $Htmlfile = ""; # write to stdout by default
138 49         233 $Htmlfileurl = ""; # The url that other files would use to
139             # refer to this file. This is only used
140             # to make relative urls that point to
141             # other files.
142              
143 49         312 $Poderrors = 1;
144 49         259 $Podfile = ""; # read from stdin by default
145 49         220 @Podpath = (); # list of directories containing library pods.
146 49         207 $Podroot = $Curdir; # filesystem base directory from which all
147             # relative paths in $podpath stem.
148 49         246 $Css = ''; # Cascading style sheet
149 49         111 $Recurse = 1; # recurse on subdirectories in $podpath.
150 49         107 $Quiet = 0; # not quiet by default
151 49         94 $Verbose = 0; # not verbose by default
152 49         88 $Doindex = 1; # non-zero if we should generate an index
153 49         111 $Backlink = 0; # no backlinks added by default
154 49         84 $Header = 0; # produce block header/footer
155 49         197 $Title = ''; # title to give the pod(s)
156             }
157              
158             sub pod2htmll10n {
159 28     28 1 9193 local(@ARGV) = @_;
160 28         249 local $_;
161              
162 28         256 init_globals();
163 28         314 parse_command_line();
164              
165             # prevent '//' in urls
166 28 100       128 $Htmlroot = "" if $Htmlroot eq "/";
167 28         293 $Htmldir =~ s#/\z##;
168              
169 28 100 66     558 if ( $Htmlroot eq ''
      100        
      100        
170             && defined( $Htmldir )
171             && $Htmldir ne ''
172             && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir
173             ) {
174             # Set the 'base' url for this file, so that we can use it
175             # as the location from which to calculate relative links
176             # to other files. If this is '', then absolute links will
177             # be used throughout.
178             #$Htmlfileurl = "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
179             # Is the above not just "$Htmlfileurl = $Htmlfile"?
180 10         42 $Htmlfileurl = Pod::L10N::Html::_unixify($Htmlfile);
181              
182             }
183              
184             # load or generate/cache %Pages
185 28 100       267 unless (get_cache($Dircache, \@Podpath, $Podroot, $Recurse)) {
186             # generate %Pages
187 25         357 my $pwd = getcwd();
188 25 50       523 chdir($Podroot) ||
189             die "$0: error changing to directory $Podroot: $!\n";
190              
191             # find all pod modules/pages in podpath, store in %Pages
192             # - callback used to remove Podroot and extension from each file
193             # - laborious to allow '.' in dirnames (e.g., /usr/share/perl/5.14.1)
194 25         1056 Pod::Simple::Search->new->inc(0)->verbose($Verbose)->laborious(1)
195             ->callback(\&_save_page)->recurse($Recurse)->survey(@Podpath);
196              
197 25 50       25426 chdir($pwd) || die "$0: error changing to directory $pwd: $!\n";
198              
199             # cache the directory list for later use
200 25 100       247 warn "caching directories for later use\n" if $Verbose;
201 25 50       3316 open my $cache, '>', $Dircache
202             or die "$0: error open $Dircache for writing: $!\n";
203              
204 25         1137 print $cache join(":", @Podpath) . "\n$Podroot\n";
205 25   33     714 my $_updirs_only = ($Podroot =~ /\.\./) && !($Podroot =~ /[^\.\\\/]/);
206 25         361 foreach my $key (keys %Pages) {
207 492 50       831 if($_updirs_only) {
208 0         0 my $_dirlevel = $Podroot;
209 0         0 while($_dirlevel =~ /\.\./) {
210 0         0 $_dirlevel =~ s/\.\.//;
211             # Assume $Pages{$key} has '/' separators (html dir separators).
212 0         0 $Pages{$key} =~ s/^[\w\s\-\.]+\///;
213             }
214             }
215 492         968 print $cache "$key $Pages{$key}\n";
216             }
217              
218 25 50       1517 close $cache or die "error closing $Dircache: $!";
219             }
220              
221             # set options for the parser
222 28         2136 my $parser = Pod::L10N::Html::LocalPodLinks->new();
223 28         12163 $parser->codes_in_verbatim(0);
224 28         713 $parser->anchor_items(1); # the old Pod::Html always did
225 28         444 $parser->backlink($Backlink); # linkify =head1 directives
226 28         482 $parser->htmldir($Htmldir);
227 28         435 $parser->htmlfileurl($Htmlfileurl);
228 28         466 $parser->htmlroot($Htmlroot);
229 28         724 $parser->index($Doindex);
230 28         925 $parser->no_errata_section(!$Poderrors); # note the inverse
231 28         621 $parser->output_string(\my $output); # written to file later
232 28         63119 $parser->pages(\%Pages);
233 28         537 $parser->quiet($Quiet);
234 28         297 $parser->verbose($Verbose);
235              
236             # $parser->html_charset('UTF-8');
237 28         460 $parser->html_encode_chars('&<>">');
238             # $parser->html_header_tags('');
239              
240             # XXX: implement default title generator in pod::simple::xhtml
241             # copy the way the old Pod::Html did it
242 28         333 $Title = html_escape($Title);
243              
244             # We need to add this ourselves because we use our own header, not
245             # ::XHTML's header. We need to set $parser->backlink to linkify
246             # the =head1 directives
247 28 100       168 my $bodyid = $Backlink ? ' id="_podtop_"' : '';
248              
249 28         78 my $csslink = '';
250 28         57 my $tdstyle = ' style="background-color: #cccccc; color: #000"';
251              
252 28 100       113 if ($Css) {
253 4         19 $csslink = qq(\n);
254 4         12 $csslink =~ s,\\,/,g;
255 4         34 $csslink =~ s,(/.):,$1|,;
256 4         11 $tdstyle= '';
257             }
258              
259 28         56 my $input;
260 28 50 33     151 unless (@ARGV && $ARGV[0]) {
261 28 50 33     366 if ($Podfile and $Podfile ne '-') {
262 28         97 $input = $Podfile;
263             } else {
264 0         0 $input = '-'; # XXX: make a test case for this
265             }
266             } else {
267 0         0 $Podfile = $ARGV[0];
268 0         0 $input = *ARGV;
269             }
270              
271 28         158 my ($content, $encoding) = arrange($Podfile);
272 28 100       124 if(!defined $encoding){
273 25         66 $encoding = 'utf-8';
274             }
275              
276             # header/footer block
277 28 100       147 my $block = $Header ? <
278            
279            
280              $Title
281            
282            
283             END_OF_BLOCK
284              
285             # create own header/footer because of --header
286 28         3583 $parser->html_header(<<"HTMLHEAD");
287            
288            
289            
290            
291             $Title$csslink
292            
293            
294            
295              
296            
297             $block
298             HTMLHEAD
299              
300 28         510 $parser->html_footer(<<"HTMLFOOT");
301             $block
302            
303              
304            
305             HTMLFOOT
306              
307 28 100       237 warn "Converting input file $Podfile\n" if $Verbose;
308             # $parser->parse_file($input);
309 28         514 $parser->parse_string_document($content);
310             # $parser->html_charset($parser->encoding());
311              
312             # Write output to file
313 28 50       25758 $Htmlfile = "-" unless $Htmlfile; # stdout
314 28         99 my $fhout;
315 28 50 33     391 if($Htmlfile and $Htmlfile ne '-') {
316 28 50       3053 open $fhout, ">", $Htmlfile
317             or die "$0: cannot open $Htmlfile file for output: $!\n";
318             } else {
319 0         0 open $fhout, ">-";
320             }
321 28     20   1679 binmode $fhout, ":encoding($encoding)";
  20         399  
  20         64  
  20         414  
322 28         234743 print $fhout $output;
323 28 50       1593 close $fhout or die "Failed to close $Htmlfile: $!";
324 28 50       2295 chmod 0644, $Htmlfile unless $Htmlfile eq '-';
325             }
326              
327             ##############################################################################
328              
329             sub usage {
330 0     0 0 0 my $podfile = shift;
331 0 0       0 warn "$0: $podfile: @_\n" if @_;
332 0         0 die <
333             Usage: $0 --help --htmldir= --htmlroot=
334             --infile= --outfile=
335             --podpath=:...: --podroot=
336             --cachedir= --flush --recurse --norecurse
337             --quiet --noquiet --verbose --noverbose
338             --index --noindex --backlink --nobacklink
339             --header --noheader --poderrors --nopoderrors
340             --css= --title=
341              
342             --[no]backlink - turn =head1 directives into links pointing to the top of
343             the page (off by default).
344             --cachedir - directory for the directory cache files.
345             --css - stylesheet URL
346             --flush - flushes the directory cache.
347             --[no]header - produce block header/footer (default is no headers).
348             --help - prints this message.
349             --htmldir - directory for resulting HTML files.
350             --htmlroot - http-server base directory from which all relative paths
351             in podpath stem (default is /).
352             --[no]index - generate an index at the top of the resulting html
353             (default behaviour).
354             --infile - filename for the pod to convert (input taken from stdin
355             by default).
356             --outfile - filename for the resulting html file (output sent to
357             stdout by default).
358             --[no]poderrors - include a POD ERRORS section in the output if there were
359             any POD errors in the input (default behavior).
360             --podpath - colon-separated list of directories containing library
361             pods (empty by default).
362             --podroot - filesystem base directory from which all relative paths
363             in podpath stem (default is .).
364             --[no]quiet - suppress some benign warning messages (default is off).
365             --[no]recurse - recurse on those subdirectories listed in podpath
366             (default behaviour).
367             --title - title that will appear in resulting html file.
368             --[no]verbose - self-explanatory (off by default).
369              
370             END_OF_USAGE
371              
372             }
373              
374             sub parse_command_line {
375 28     28 0 205 my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,
376             $opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,
377             $opt_outfile,$opt_poderrors,$opt_podpath,$opt_podroot,
378             $opt_quiet,$opt_recurse,$opt_title,$opt_verbose);
379              
380 28 50       4733 unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
381 28         790 my $result = GetOptions(
382             'backlink!' => \$opt_backlink,
383             'cachedir=s' => \$opt_cachedir,
384             'css=s' => \$opt_css,
385             'flush' => \$opt_flush,
386             'help' => \$opt_help,
387             'header!' => \$opt_header,
388             'htmldir=s' => \$opt_htmldir,
389             'htmlroot=s' => \$opt_htmlroot,
390             'index!' => \$opt_index,
391             'infile=s' => \$opt_infile,
392             'outfile=s' => \$opt_outfile,
393             'poderrors!' => \$opt_poderrors,
394             'podpath=s' => \$opt_podpath,
395             'podroot=s' => \$opt_podroot,
396             'quiet!' => \$opt_quiet,
397             'recurse!' => \$opt_recurse,
398             'title=s' => \$opt_title,
399             'verbose!' => \$opt_verbose,
400             );
401 28 50       76684 usage("-", "invalid parameters") if not $result;
402              
403 28 50       148 usage("-") if defined $opt_help; # see if the user asked for help
404 28         135 $opt_help = ""; # just to make -w shut-up.
405              
406 28 100       256 @Podpath = split(":", $opt_podpath) if defined $opt_podpath;
407              
408 28 100       135 $Backlink = $opt_backlink if defined $opt_backlink;
409 28 100       123 $Cachedir = _unixify($opt_cachedir) if defined $opt_cachedir;
410 28 100       115 $Css = $opt_css if defined $opt_css;
411 28 100       122 $Header = $opt_header if defined $opt_header;
412 28 100       136 $Htmldir = _unixify($opt_htmldir) if defined $opt_htmldir;
413 28 100       177 $Htmlroot = _unixify($opt_htmlroot) if defined $opt_htmlroot;
414 28 100       143 $Doindex = $opt_index if defined $opt_index;
415 28 50       150 $Podfile = _unixify($opt_infile) if defined $opt_infile;
416 28 50       188 $Htmlfile = _unixify($opt_outfile) if defined $opt_outfile;
417 28 100       124 $Poderrors = $opt_poderrors if defined $opt_poderrors;
418 28 100       258 $Podroot = _unixify($opt_podroot) if defined $opt_podroot;
419 28 100       129 $Quiet = $opt_quiet if defined $opt_quiet;
420 28 100       107 $Recurse = $opt_recurse if defined $opt_recurse;
421 28 100       103 $Title = $opt_title if defined $opt_title;
422 28 100       120 $Verbose = $opt_verbose if defined $opt_verbose;
423              
424 28 50 66     109 warn "Flushing directory caches\n"
425             if $opt_verbose && defined $opt_flush;
426 28         93 $Dircache = "$Cachedir/pod2htmd.tmp";
427 28 50       145 if (defined $opt_flush) {
428 0         0 1 while unlink($Dircache);
429             }
430             }
431              
432             my $Saved_Cache_Key;
433              
434             sub get_cache {
435 28     28 0 169 my($dircache, $podpath, $podroot, $recurse) = @_;
436 28         129 my @cache_key_args = @_;
437              
438             # A first-level cache:
439             # Don't bother reading the cache files if they still apply
440             # and haven't changed since we last read them.
441              
442 28         139 my $this_cache_key = cache_key(@cache_key_args);
443 28 100 100     241 return 1 if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
444 26         65 $Saved_Cache_Key = $this_cache_key;
445              
446             # load the cache of %Pages if possible. $tests will be
447             # non-zero if successful.
448 26         72 my $tests = 0;
449 26 100       293 if (-f $dircache) {
450 1 50       5 warn "scanning for directory cache\n" if $Verbose;
451 1         6 $tests = load_cache($dircache, $podpath, $podroot);
452             }
453              
454 26         154 return $tests;
455             }
456              
457             sub cache_key {
458 28     28 0 146 my($dircache, $podpath, $podroot, $recurse) = @_;
459 28         667 return join('!',$dircache,$recurse,@$podpath,$podroot,stat($dircache));
460             }
461              
462             #
463             # load_cache - tries to find if the cache stored in $dircache is a valid
464             # cache of %Pages. if so, it loads them and returns a non-zero value.
465             #
466             sub load_cache {
467 1     1 0 4 my($dircache, $podpath, $podroot) = @_;
468 1         2 my $tests = 0;
469 1         2 local $_;
470              
471 1 50       4 warn "scanning for directory cache\n" if $Verbose;
472 1 50       39 open(my $cachefh, '<', $dircache) ||
473             die "$0: error opening $dircache for reading: $!\n";
474 1         5 $/ = "\n";
475              
476             # is it the same podpath?
477 1         17 $_ = <$cachefh>;
478 1         4 chomp($_);
479 1 50       5 $tests++ if (join(":", @$podpath) eq $_);
480              
481             # is it the same podroot?
482 1         3 $_ = <$cachefh>;
483 1         2 chomp($_);
484 1 50       4 $tests++ if ($podroot eq $_);
485              
486             # load the cache if its good
487 1 50       3 if ($tests != 2) {
488 0         0 close($cachefh);
489 0         0 return 0;
490             }
491              
492 1 50       4 warn "loading directory cache\n" if $Verbose;
493 1         11 while (<$cachefh>) {
494 0         0 /(.*?) (.*)$/;
495 0         0 $Pages{$1} = $2;
496             }
497              
498 1         19 close($cachefh);
499 1         7 return 1;
500             }
501              
502              
503             #
504             # html_escape: make text safe for HTML
505             #
506             sub html_escape {
507 28     28 0 194 my $rest = $_[0];
508 28         116 $rest =~ s/&/&/g;
509 28         67 $rest =~ s/
510 28         57 $rest =~ s/>/>/g;
511 28         91 $rest =~ s/"/"/g;
512             # ' is only in XHTML, not HTML4. Be conservative
513             #$rest =~ s/'/'/g;
514 28         157 return $rest;
515             }
516              
517             # "
518              
519             #
520             # htmlify - converts a pod section specification to a suitable section
521             # specification for HTML. Note that we keep spaces and special characters
522             # except ", ? (Netscape problem) and the hyphen (writer's problem...).
523             #
524             sub htmlify {
525 0     0 1 0 my( $heading) = @_;
526 0         0 $heading =~ s/(\s+)/ /g;
527 0         0 $heading =~ s/\s+\Z//;
528 0         0 $heading =~ s/\A\s+//;
529             # The hyphen is a disgrace to the English language.
530             # $heading =~ s/[-"?]//g;
531 0         0 $heading =~ s/["?]//g;
532 0         0 $heading = lc( $heading );
533 0         0 return $heading;
534             }
535              
536             # "
537              
538             #
539             # similar to htmlify, but turns non-alphanumerics into underscores
540             #
541             sub anchorify {
542 0     0 1 0 my ($anchor) = @_;
543 0         0 $anchor = htmlify($anchor);
544 0         0 $anchor =~ s/\W/_/g;
545 0         0 return $anchor;
546             }
547              
548             #
549             # store POD files in %Pages
550             #
551             sub _save_page {
552 444     444   386496 my ($modspec, $modname) = @_;
553              
554             # Remove Podroot from path
555 444 100       26932 $modspec = $Podroot eq File::Spec->curdir
556             ? File::Spec->abs2rel($modspec)
557             : File::Spec->abs2rel($modspec,
558             File::Spec->canonpath($Podroot));
559              
560             # Convert path to unix style path
561 444         1875 $modspec = Pod::L10N::Html::_unixify($modspec);
562              
563 444         12445 my ($file, $dir) = fileparse($modspec, qr/\.[^.]*/); # strip .ext
564 444         2901 $Pages{$modname} = $dir.$file;
565             }
566              
567             sub _unixify {
568 669     669   142260 my $full_path = shift;
569 669 100       2589 return '' unless $full_path;
570 624 100       1665 return $full_path if $full_path eq '/';
571              
572 597         9535 my ($vol, $dirs, $file) = File::Spec->splitpath($full_path);
573 597 50       5082 my @dirs = $dirs eq File::Spec->curdir()
574             ? (File::Spec::Unix->curdir())
575             : File::Spec->splitdir($dirs);
576 597 50 33     3424 if (defined($vol) && $vol) {
577 0 0       0 $vol =~ s/:$// if $^O eq 'VMS';
578 0 0       0 $vol = uc $vol if $^O eq 'MSWin32';
579              
580 0 0       0 if( $dirs[0] ) {
581 0         0 unshift @dirs, $vol;
582             }
583             else {
584 0         0 $dirs[0] = $vol;
585             }
586             }
587 597 100       3438 unshift @dirs, '' if File::Spec->file_name_is_absolute($full_path);
588 597 100       1761 return $file unless scalar(@dirs);
589 577         4213 $full_path = File::Spec::Unix->catfile(File::Spec::Unix->catdir(@dirs),
590             $file);
591 577 50       2585 $full_path =~ s|^\/|| if $^O eq 'MSWin32'; # C:/foo works, /C:/foo doesn't
592 577 50       1313 $full_path =~ s/\^\././g if $^O eq 'VMS'; # unescape dots
593 577         1729 return $full_path;
594             }
595              
596             sub arrange {
597 28     28 0 77 my $fn = shift;
598 28         115 my $base;
599             my $ret;
600 28         0 my $encoding;
601              
602 28         211 $base = Pod::L10N::Model::decode_file($fn);
603              
604 28         108 for (@$base){
605 354         588 my($o, $t) = @$_;
606 354 100       901 if($o =~ /^=encoding (.+)/){
607 3         15 $encoding = $1;
608 3         12 $ret .= $o . "\n\n";
609 3         9 next;
610             }
611 351 100       804 if($o =~ /^=/){
612 141 100       288 if(defined $t){
613 4         32 $t =~ /\((.+)\)/;
614 4         23 $ret .= $o . '@@@@@@@@@@' . $1;
615             } else {
616 137         222 $ret .= $o;
617             }
618             } else {
619 210 50       348 if(defined $t){
620 0         0 $ret .= $t;
621             } else {
622 210         304 $ret .= $o;
623             }
624             }
625 351         536 $ret .= "\n\n";
626             }
627              
628 28         178 return ($ret, $encoding);
629             }
630              
631             package Pod::L10N::Html::LocalPodLinks;
632 21     21   105191 use strict;
  21         49  
  21         709  
633 21     21   126 use warnings;
  21         39  
  21         970  
634 21     21   11308 use parent 'Pod::Simple::XHTML';
  21         6697  
  21         121  
635              
636 21     21   930184 use File::Spec;
  21         54  
  21         588  
637 21     21   123 use File::Spec::Unix;
  21         47  
  21         30019  
638              
639             __PACKAGE__->_accessorize(
640             'htmldir',
641             'htmlfileurl',
642             'htmlroot',
643             'pages', # Page name => relative/path/to/page from root POD dir
644             'quiet',
645             'verbose',
646             );
647              
648              
649             sub idify {
650 159     159   379 my ($self, $t, $not_unique) = @_;
651 159         355 for ($t) {
652 159         629 s/<[^>]+>//g; # Strip HTML.
653 159         1383 s/&[^;]+;//g; # Strip entities.
654 159         1422 s/^\s+//; s/\s+$//; # Strip white space.
  159         1349  
655 159         1443 s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
656 159         1338 s/^[^a-zA-Z]+//; # First char must be a letter.
657 159         1227 s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
658 159         2124 s/[-:.]+$//; # Strip trailing punctuation.
659             }
660 159 100       878 return $t if $not_unique;
661 83         252 my $i = '';
662 83         590 $i++ while $self->{ids}{"$t$i"}++;
663 83         285 return "$t$i";
664             }
665              
666             sub resolve_pod_page_link {
667 118     118   106183 my ($self, $to, $section) = @_;
668              
669 118 50 66     698 return undef unless defined $to || defined $section;
670 118 100       246 if (defined $section) {
671 76         198 $section = '#' . $self->idify($section, 1);
672 76 100       596 return $section unless defined $to;
673             } else {
674 42         118 $section = '';
675             }
676              
677 71         131 my $path; # path to $to according to %Pages
678 71 100       215 unless (exists $self->pages->{$to}) {
679             # Try to find a POD that ends with $to and use that.
680             # e.g., given L, if there is no $Podpath/XHTML in %Pages,
681             # look for $Podpath/*/XHTML in %Pages, with * being any path,
682             # as a substitute (e.g., $Podpath/Pod/Simple/XHTML)
683 27         600 my @matches;
684 27         44 foreach my $modname (keys %{$self->pages}) {
  27         75  
685 627 100       9979 push @matches, $modname if $modname =~ /::\Q$to\E\z/;
686             }
687              
688 27 100       458 if ($#matches == -1) {
    50          
689 22 50       100 warn "Cannot find \"$to\" in podpath: " .
690             "cannot find suitable replacement path, cannot resolve link\n"
691             unless $self->quiet;
692 22         264 return '';
693             } elsif ($#matches == 0) {
694 5 50       15 warn "Cannot find \"$to\" in podpath: " .
695             "using $matches[0] as replacement path to $to\n"
696             unless $self->quiet;
697 5         39 $path = $self->pages->{$matches[0]};
698             } else {
699 0 0       0 warn "Cannot find \"$to\" in podpath: " .
700             "more than one possible replacement path to $to, " .
701             "using $matches[-1]\n" unless $self->quiet;
702             # Use [-1] so newer (higher numbered) perl PODs are used
703 0         0 $path = $self->pages->{$matches[-1]};
704             }
705             } else {
706 44         1031 $path = $self->pages->{$to};
707             }
708              
709 49         839 my $url = File::Spec::Unix->catfile(Pod::L10N::Html::_unixify($self->htmlroot),
710             $path);
711              
712 49 100       190 if ($self->htmlfileurl ne '') {
713             # then $self->htmlroot eq '' (by definition of htmlfileurl) so
714             # $self->htmldir needs to be prepended to link to get the absolute path
715             # that will be relativized
716 23         222 $url = relativize_url(
717             File::Spec::Unix->catdir(Pod::L10N::Html::_unixify($self->htmldir), $url),
718             $self->htmlfileurl # already unixified
719             );
720             }
721              
722 49         391 return $url . ".html$section";
723             }
724              
725             #
726             # relativize_url - convert an absolute URL to one relative to a base URL.
727             # Assumes both end in a filename.
728             #
729             sub relativize_url {
730 23     23   179 my ($dest, $source) = @_;
731              
732             # Remove each file from its path
733 23         207 my ($dest_volume, $dest_directory, $dest_file) =
734             File::Spec::Unix->splitpath( $dest );
735 23         174 $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' );
736              
737 23         179 my ($source_volume, $source_directory, $source_file) =
738             File::Spec::Unix->splitpath( $source );
739 23         117 $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' );
740              
741 23         59 my $rel_path = '';
742 23 50       63 if ($dest ne '') {
743 23         1248 $rel_path = File::Spec::Unix->abs2rel( $dest, $source );
744             }
745              
746 23 50 33     213 if ($rel_path ne '' && substr( $rel_path, -1 ) ne '/') {
747 23         416 $rel_path .= "/$dest_file";
748             } else {
749 0         0 $rel_path .= "$dest_file";
750             }
751              
752 23         69 return $rel_path;
753             }
754              
755             sub _end_head {
756 67     67   118487 my $h = delete $_[0]{in_head};
757              
758 67         431 my $add = $_[0]->html_h_level;
759 67 50       603 $add = 1 unless defined $add;
760 67         173 $h += $add - 1;
761              
762 67         404 my ($orig, $trans) = split /@@@@@@@@@@/, $_[0]{scratch};
763 67 100       6797 if(!defined $trans){
764 65         126 $trans = $orig;
765             }
766 67         218 my $id = $_[0]->idify($orig);
767 67         127 my $text = $trans;
768 67 100 66     266 $_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0)
769             # backlinks enabled && =head1
770             ? qq{$text}
771             : qq{$text};
772 67         902 $_[0]->emit;
773 67         971 push @{ $_[0]{'to_index'} }, [$h, $id, $text];
  67         328  
774             }
775              
776             sub end_item_text {
777 16     16   49801 my ($orig, $trans) = split /@@@@@@@@@@/, $_[0]{scratch};
778 16 100       67 if(!defined $trans){
779 14         32 $trans = $orig;
780             }
781              
782             # idify and anchor =item content if wanted
783 16 50       103 my $dt_id = $_[0]{'anchor_items'}
784             ? ' id="'. $_[0]->idify($orig) .'"'
785             : '';
786              
787             # reset scratch
788 16         35 my $text = $trans;
789 16         36 $_[0]{'scratch'} = '';
790              
791 16 100       69 if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
792 6         11 $_[0]{'scratch'} = "\n";
793 6         12 $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
794             }
795              
796 16         63 $_[0]{'scratch'} .= qq{$text\n
};
797 16         52 $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
798 16         58 $_[0]->emit;
799             }
800              
801             1;