File Coverage

blib/lib/Pod/Tree/HTML.pm
Criterion Covered Total %
statement 322 332 96.9
branch 111 122 90.9
condition 8 11 72.7
subroutine 51 54 94.4
pod 8 13 61.5
total 500 532 93.9


line stmt bran cond sub pod time code
1             package Pod::Tree::HTML;
2 12     12   2056984 use 5.006;
  12         47  
3 12     12   78 use strict;
  12         46  
  12         288  
4 12     12   82 use warnings;
  12         22  
  12         404  
5              
6             # Copyright (c) 1999-2007 by Steven McDougall. This module is free
7             # software; you can redistribute it and/or modify it under the same
8             # terms as Perl itself.
9              
10 12     12   2852 use HTML::Stream;
  12         15517  
  12         596  
11 12     12   1581 use IO::File;
  12         28345  
  12         1688  
12 12     12   6206 use IO::String;
  12         31040  
  12         209  
13 12     12   2139 use Pod::Tree;
  12         28  
  12         191  
14 12     12   8290 use Text::Template;
  12         46144  
  12         591  
15              
16 12     12   4852 use Pod::Tree::BitBucket;
  12         35  
  12         241  
17 12     12   4752 use Pod::Tree::StrStream;
  12         33  
  12         206  
18 12     12   4861 use Pod::Tree::HTML::LinkMap;
  12         32  
  12         219  
19              
20 12     12   389 use constant BGCOLOR => '#ffffff';
  12         30  
  12         1807  
21 12     12   78 use constant TEXT => '#000000';
  12         26  
  12         49838  
22              
23             our $VERSION = '1.31';
24              
25             sub new {
26 60     60 1 94044 my ( $class, $source, $dest, %options ) = @_;
27 60 50       227 defined $dest or die "Pod::Tree::HTML::new: not enough arguments\n";
28              
29 60         213 my $tree = _resolve_source($source);
30 60         226 my ( $fh, $stream ) = _resolve_dest( $dest, $tree, \%options );
31              
32 60         1497 my $options = {
33             bgcolor => BGCOLOR,
34             depth => 0,
35             hr => 1,
36             link_map => Pod::Tree::HTML::LinkMap->new(),
37             text => TEXT,
38             toc => 1,
39             };
40              
41 60         250 my $HTML = {
42             tree => $tree,
43             root => $tree->get_root,
44             stream => $stream,
45             fh => $fh,
46             text_method => 'text',
47             options => $options,
48             };
49              
50 60         198 bless $HTML, $class;
51              
52 60         252 $HTML->set_options(%options);
53 60         208 $HTML;
54             }
55              
56             sub _resolve_source {
57 60     60   113 my $source = shift;
58 60         136 my $ref = ref $source;
59 60         232 local *isa = \&UNIVERSAL::isa;
60              
61 60 100       455 isa( $source, 'Pod::Tree' ) and return $source;
62              
63 51         256 my $tree = Pod::Tree->new;
64 51 100       243 not $ref and $tree->load_file($source);
65 51 100       504 isa( $source, 'IO::File' ) and $tree->load_fh($source);
66 51 100       162 $ref eq 'SCALAR' and $tree->load_string($$source);
67 51 100       132 $ref eq 'ARRAY' and $tree->load_paragraphs($source);
68              
69 51 50       183 $tree->loaded
70             or die "Pod::Tree::HTML::_resolve_source: Can't load POD from $source\n";
71              
72 51         221 $tree;
73             }
74              
75             sub _resolve_dest {
76 60     60   157 my ( $dest, $tree, $options ) = @_;
77              
78             $tree->has_pod
79             or $options->{empty}
80 60 100 100     207 or return ( undef, Pod::Tree::BitBucket->new );
81              
82 59         208 local *isa = \&UNIVERSAL::isa;
83 59         133 local *can = \&UNIVERSAL::can;
84              
85 59 100       273 isa( $dest, 'HTML::Stream' ) and return ( undef, $dest );
86 58 100       205 isa( $dest, 'IO::File' ) and return ( $dest, HTML::Stream->new($dest) );
87 51 100       234 can( $dest, 'print' ) and return ( $dest, HTML::Stream->new($dest) );
88              
89 50 100       175 if ( ref $dest eq 'SCALAR' ) {
90 42         300 my $fh = IO::String->new($$dest);
91 42         2651 return ( $fh, HTML::Stream->new($fh) );
92             }
93              
94 8 50 33     43 if ( ref $dest eq '' and $dest ) {
95 8         35 my $fh = IO::File->new;
96 8 50       314 $fh->open( $dest, '>' ) or die "Pod::Tree::HTML::new: Can't open $dest: $!\n";
97 8         1016 return ( $fh, HTML::Stream->new($fh) );
98             }
99              
100 0         0 die "Pod::Tree::HTML::_resolve_dest: Can't write HTML to $dest\n";
101             }
102              
103             sub set_options {
104 118     118 1 482 my ( $html, %options ) = @_;
105              
106 118         228 my ( $key, $value );
107 118         417 while ( ( $key, $value ) = each %options ) {
108 61         468 $html->{options}{$key} = $value;
109             }
110             }
111              
112             sub get_options {
113 0     0 1 0 my ( $html, @options ) = @_;
114              
115 0         0 map { $html->{options}{$_} } @options;
  0         0  
116             }
117              
118 0     0 0 0 sub get_stream { shift->{stream} }
119              
120             sub translate {
121 58     58 1 326 my ( $html, $template ) = @_;
122              
123 58 100       149 if ($template) {
124 12         36 $html->_template($template);
125             }
126             else {
127 46         114 $html->_translate;
128             }
129             }
130              
131             sub _translate {
132 46     46   90 my $html = shift;
133 46         94 my $stream = $html->{stream};
134 46         115 my $bgcolor = $html->{options}{bgcolor};
135 46         98 my $text = $html->{options}{text};
136 46         143 my $title = $html->_make_title;
137 46         114 my $base = $html->{options}{base};
138 46         90 my $css = $html->{options}{css};
139              
140 46         1292 $stream->HTML->HEAD;
141              
142 46 100       11456 defined $title and $stream->TITLE->text($title)->_TITLE;
143 46 100       8503 defined $base and $stream->BASE( href => $base );
144 46 50       776 defined $css and $stream->LINK(
145             href => $css,
146             type => "text/css",
147             rel => "stylesheet"
148             );
149              
150 46         712 $stream->_HEAD->BODY( BGCOLOR => $bgcolor, TEXT => $text );
151              
152 46         10282 $html->emit_toc;
153 46         1211 $html->emit_body;
154              
155 46         1139 $stream->nl->_BODY->_HTML;
156             }
157              
158             sub _template {
159 12     12   27 my ( $html, $tSource ) = @_;
160              
161 12         75 my $fh = $html->{fh};
162 12         77 my $sStream = Pod::Tree::StrStream->new;
163 12         36 $html->{stream} = HTML::Stream->new($sStream);
164              
165 12         204 our $bgcolor = $html->{options}{bgcolor};
166 12         21 our $text = $html->{options}{text};
167 12         32 our $title = $html->_make_title;
168 12         28 our $base = $html->{options}{base};
169 12         25 our $css = $html->{options}{css};
170              
171 12         43 $html->emit_toc;
172 12         61 our $toc = $sStream->get;
173              
174 12         41 $html->emit_body;
175 12         38 our $body = $sStream->get;
176              
177 12 50       98 my $template = Text::Template->new( SOURCE => $tSource )
178             or die "Can't create Text::Template object: $Text::Template::ERROR\n";
179              
180 12 50       3172 $template->fill_in( OUTPUT => $fh )
181             or die $Text::Template::ERROR;
182             }
183              
184             sub _make_title {
185 58     58   95 my $html = shift;
186              
187 58         128 my $title = $html->{options}{title};
188 58 50       157 defined $title and return $title;
189              
190 58         160 my $children = $html->{root}->get_children;
191 58         105 my $node1;
192 58         100 my $i = 0;
193 58         145 for my $child (@$children) {
194 144 100       326 $child->is_pod or next;
195 112 100       269 $i++ and $node1 = $child;
196 112 100       249 $node1 and last;
197             }
198              
199 58 100       142 $node1 or return undef; ##no critic (ProhibitExplicitReturnUndef)
200              
201 56         165 my $text = $node1->get_deep_text;
202 56         249 ($title) = split m(\s+-), $text;
203              
204 56 100       146 $title or return undef; ##no critic (ProhibitExplicitReturnUndef)
205 50         319 $title =~ s(\s+$)();
206              
207 50         146 $title;
208             }
209              
210             sub emit_toc {
211 59     59 1 200 my $html = shift;
212 59 100       212 $html->{options}{toc} or return;
213              
214 22         41 my $root = $html->{root};
215 22         64 my $nodes = $root->get_children;
216 22         81 my @nodes = @$nodes;
217              
218 22         75 $html->_emit_toc_1( \@nodes );
219              
220 22 100       1020 $html->{options}{hr} > 0 and $html->{stream}->HR;
221             }
222              
223             sub _emit_toc_1 {
224 22     22   51 my ( $html, $nodes ) = @_;
225 22         81 my $stream = $html->{stream};
226              
227 22         495 $stream->UL;
228              
229 22         1093 while (@$nodes) {
230 130         764 my $node = $nodes->[0];
231 130 100       271 $node->is_c_head2 and $html->_emit_toc_2($nodes), next;
232 116 100       260 $node->is_c_head1 and $html->_emit_toc_item($node);
233 116         1110 shift @$nodes;
234             }
235              
236 22         438 $stream->_UL;
237             }
238              
239             sub _emit_toc_2 {
240 14     14   36 my ( $html, $nodes ) = @_;
241 14         33 my $stream = $html->{stream};
242              
243 14         237 $stream->UL;
244              
245 14         580 while (@$nodes) {
246 156         209 my $node = $nodes->[0];
247 156 100       286 $node->is_c_head1 and last;
248 151 100       293 $node->is_c_head2 and $html->_emit_toc_item($node);
249 151         847 shift @$nodes;
250             }
251              
252 14         236 $stream->_UL;
253             }
254              
255             sub _emit_toc_item {
256 69     69   142 my ( $html, $node ) = @_;
257 69         101 my $stream = $html->{stream};
258 69         147 my $target = $html->_make_anchor($node);
259              
260 69         1230 $stream->LI->A( HREF => "#$target" );
261 69         4469 $html->_emit_children($node);
262 69         1210 $stream->_A;
263             }
264              
265             sub emit_body {
266 59     59 1 109 my $html = shift;
267 59         104 my $root = $html->{root};
268 59         156 $html->_emit_children($root);
269             }
270              
271             sub _emit_children {
272 1751     1751   3021 my ( $html, $node ) = @_;
273              
274 1751         3665 my $children = $node->get_children;
275              
276 1751         3497 for my $child (@$children) {
277 3487         9835 $html->_emit_node($child);
278             }
279             }
280              
281             sub _emit_siblings {
282 252     252   465 my ( $html, $node ) = @_;
283              
284 252         573 my $siblings = $node->get_siblings;
285              
286 252 100 100     1123 if ( @$siblings == 1 and $siblings->[0]{type} eq 'ordinary' ) {
287              
288             # don't put

around a single ordinary paragraph
289 210         430 $html->_emit_children( $siblings->[0] );
290             }
291             else {
292 42         91 for my $sibling (@$siblings) {
293 72         130 $html->_emit_node($sibling);
294             }
295             }
296              
297             }
298              
299             sub _emit_node {
300 3559     3559   5585 my ( $html, $node ) = @_;
301 3559         5999 my $type = $node->{type};
302              
303 3559         5404 for ($type) {
304 3559 100       7084 /command/ and $html->_emit_command($node);
305 3559 100       31024 /for/ and $html->_emit_for($node);
306 3559 100       7590 /item/ and $html->_emit_item($node);
307 3559 100       10931 /list/ and $html->_emit_list($node);
308 3559 100       12745 /ordinary/ and $html->_emit_ordinary($node);
309 3559 100       22468 /sequence/ and $html->_emit_sequence($node);
310 3559 100       31024 /text/ and $html->_emit_text($node);
311 3559 100       52025 /verbatim/ and $html->_emit_verbatim($node);
312             }
313             }
314              
315             my %HeadTag = (
316             head1 => { 'open' => 'H1', 'close' => '_H1', level => 1 },
317             head2 => { 'open' => 'H2', 'close' => '_H2', level => 2 },
318             head3 => { 'open' => 'H3', 'close' => '_H3', level => 3 },
319             head4 => { 'open' => 'H4', 'close' => '_H4', level => 4 }
320             );
321              
322             sub _emit_command {
323 230     230   384 my ( $html, $node ) = @_;
324 230         353 my $stream = $html->{stream};
325 230         501 my $command = $node->get_command;
326 230         529 my $head_tag = $HeadTag{$command};
327 230 100       496 $head_tag or return;
328 212         483 my $anchor = $html->_make_anchor($node);
329              
330 212         662 $html->_emit_hr( $head_tag->{level} );
331              
332 212         1029 my $tag;
333 212         495 $tag = $head_tag->{'open'};
334 212         3917 $stream->$tag()->A( NAME => $anchor );
335              
336 212         25526 $html->_emit_children($node);
337              
338 212         388 $tag = $head_tag->{'close'};
339 212         3810 $stream->_A->$tag();
340             }
341              
342             sub _emit_hr {
343 212     212   409 my ( $html, $level ) = @_;
344 212 100       558 $html->{options}{hr} > $level or return;
345 8 100       22 $html->{skip_first}++ or return;
346 6         113 $html->{stream}->HR;
347             }
348              
349             sub _emit_for {
350 24     24   49 my ( $html, $node ) = @_;
351              
352 24         79 my $interpreter = lc $node->get_arg;
353 24         55 my $emit = "_emit_for_$interpreter";
354              
355 24 100       144 $html->$emit($node) if $html->can($emit);
356             }
357              
358             sub _emit_for_html {
359 12     12   30 my ( $html, $node ) = @_;
360              
361 12         25 my $stream = $html->{stream};
362 12         259 $stream->P;
363 12         767 $stream->io->print( $node->get_text );
364 12         346 $stream->_P;
365             }
366              
367             sub _emit_for_image {
368 6     6   20 my ( $html, $node ) = @_;
369              
370 6         17 my $stream = $html->{stream};
371 6         17 my $link = $node->get_text;
372 6         34 $link =~ s(\s+$)();
373              
374 6         106 $stream->IMG( src => $link );
375             }
376              
377             sub _emit_item {
378 252     252   409 my ( $html, $node ) = @_;
379              
380 252         364 my $stream = $html->{stream};
381 252         540 my $item_type = $node->get_item_type;
382 252         422 for ($item_type) {
383 252 100       538 /bullet/ and do {
384 120         2131 $stream->LI();
385 120         5115 $html->_emit_siblings($node);
386 120         2939 $stream->_LI();
387             };
388              
389 252 100       7398 /number/ and do {
390 48         829 $stream->LI();
391 48         1921 $html->_emit_siblings($node);
392 48         876 $stream->_LI();
393             };
394              
395 252 100       3007 /text/ and do {
396 84         181 my $anchor = $html->_make_anchor($node);
397 84         1494 $stream->DT->A( NAME => "$anchor" );
398 84         8384 $html->_emit_children($node);
399 84         1513 $stream->_A->_DT->DD;
400 84         13760 $html->_emit_siblings($node);
401 84         1447 $stream->_DD;
402             };
403             }
404              
405             }
406              
407             my %ListTag = (
408             bullet => { 'open' => 'UL', 'close' => '_UL' },
409             number => { 'open' => 'OL', 'close' => '_OL' },
410             text => { 'open' => 'DL', 'close' => '_DL' }
411             );
412              
413             sub _emit_list {
414 114     114   193 my ( $html, $node ) = @_;
415 114         157 my ( $list_tag, $tag ); # to quiet -w, see beloew
416              
417 114         172 my $stream = $html->{stream};
418 114         254 my $list_type = $node->get_list_type;
419              
420 114 100       261 $list_type and $list_tag = $ListTag{$list_type};
421 114 100       273 $list_tag and $tag = $list_tag->{'open'};
422 114 100       1968 $tag and $stream->$tag();
423              
424 114         7144 $html->_emit_children($node);
425              
426 114 100       282 $list_tag and $tag = $list_tag->{'close'};
427 114 100       1720 $tag and $stream->$tag();
428             }
429              
430             sub _emit_ordinary {
431 474     474   728 my ( $html, $node ) = @_;
432 474         693 my $stream = $html->{stream};
433              
434 474         7850 $stream->P;
435 474         33723 $html->_emit_children($node);
436 474         8303 $stream->_P;
437             }
438              
439             sub _emit_sequence {
440 567     567   931 my ( $html, $node ) = @_;
441              
442 567         1212 for ( $node->get_letter ) {
443 567 100       2295 /I|B|C|F/ and $html->_emit_element($node), last;
444 272 100       643 /S/ and $html->_emit_nbsp($node), last;
445 260 100       767 /L/ and $html->_emit_link($node), last;
446 38 50       168 /X/ and $html->_emit_index($node), last;
447 0 0       0 /E/ and $html->_emit_entity($node), last;
448             }
449             }
450              
451             my %ElementTag = (
452             I => { 'open' => 'I', 'close' => '_I' },
453             B => { 'open' => 'B', 'close' => '_B' },
454             C => { 'open' => 'CODE', 'close' => '_CODE' },
455             F => { 'open' => 'I', 'close' => '_I' }
456             );
457              
458             sub _emit_element {
459 295     295   557 my ( $html, $node ) = @_;
460              
461 295         547 my $letter = $node->get_letter;
462 295         448 my $stream = $html->{stream};
463              
464 295         359 my $tag;
465 295         559 $tag = $ElementTag{$letter}{'open'};
466 295         5489 $stream->$tag();
467 295         13969 $html->_emit_children($node);
468 295         546 $tag = $ElementTag{$letter}{'close'};
469 295         5217 $stream->$tag();
470             }
471              
472             sub _emit_nbsp {
473 12     12   35 my ( $html, $node ) = @_;
474              
475 12         27 my $old_method = $html->{text_method};
476 12         23 $html->{text_method} = 'text_nbsp';
477 12         41 $html->_emit_children($node);
478 12         31 $html->{text_method} = $old_method;
479             }
480              
481             sub _emit_link {
482 222     222   412 my ( $html, $node ) = @_;
483              
484 222         370 my $stream = $html->{stream};
485 222         452 my $target = $node->get_target;
486 222         464 my $domain = $target->get_domain;
487 222         455 my $method = "make_${domain}_URL";
488 222         525 my $url = $html->$method($target);
489              
490 222         4512 $stream->A( HREF => $url );
491 222         12362 $html->_emit_children($node);
492 222         3988 $stream->_A;
493             }
494              
495             sub make_POD_URL {
496 206     206 0 319 my ( $html, $target ) = @_;
497              
498 206         329 my $link_map = $html->{options}{link_map};
499              
500 206 100       837 return $link_map->url( $html, $target ) if $link_map->can("url");
501              
502 25         56 $html->make_mapped_URL($target);
503             }
504              
505             sub make_mapped_URL {
506 25     25 0 38 my ( $html, $target ) = @_;
507              
508 25         44 my $link_map = $html->{options}{link_map};
509 25   50     87 my $base = $html->{options}{base} || '';
510 25         58 my $page = $target->get_page;
511 25         51 my $section = $target->get_section;
512 25         44 my $depth = $html->{options}{depth};
513              
514 25         59 ( $base, $page, $section ) = $link_map->map( $base, $page, $section, $depth );
515              
516 25         187 $base =~ s(/$)();
517 25 100       57 $page .= '.html' if $page;
518 25         64 my $fragment = $html->escape_2396($section);
519 25         60 my $url = $html->assemble_url( $base, $page, $fragment );
520              
521 25         56 $url;
522             }
523              
524             sub make_HTTP_URL {
525 16     16 0 40 my ( $html, $target ) = @_;
526              
527 16         44 $target->get_page;
528             }
529              
530             sub _emit_index {
531 38     38   84 my ( $html, $node ) = @_;
532              
533 38         76 my $stream = $html->{stream};
534 38         84 my $anchor = $html->_make_anchor($node);
535 38         703 $stream->A( NAME => $anchor )->_A;
536             }
537              
538             sub _emit_entity {
539 0     0   0 my ( $html, $node ) = @_;
540              
541 0         0 my $stream = $html->{stream};
542 0         0 my $entity = $node->get_deep_text;
543 0         0 $stream->ent($entity);
544             }
545              
546             sub _emit_text {
547 1855     1855   2923 my ( $html, $node ) = @_;
548 1855         2567 my $stream = $html->{stream};
549 1855         3719 my $text = $node->get_text;
550 1855         2928 my $text_method = $html->{text_method};
551              
552 1855         4643 $stream->$text_method($text);
553             }
554              
555             sub _emit_verbatim {
556 29     29   76 my ( $html, $node ) = @_;
557 29         61 my $stream = $html->{stream};
558 29         76 my $text = $node->get_text;
559 29         163 $text =~ s(\n\n$)();
560              
561 29         509 $stream->PRE->text($text)->_PRE;
562             }
563              
564             sub _make_anchor {
565 403     403   737 my ( $html, $node ) = @_;
566 403         863 my $text = $node->get_deep_text;
567 403         1555 $text =~ s( \s*\n\s*/ )( )xg; # close line breaks
568 403         1782 $text =~ s( ^\s+ | \s+$ )()xg; # clip leading and trailing WS
569 403         984 $html->escape_2396($text);
570             }
571              
572 206     206 0 678 sub bin { oct '0b' . join '', @_ }
573              
574             my @LinkFormat = (
575             sub { my ( $b, $p, $f ) = @_; "" },
576             sub { my ( $b, $p, $f ) = @_; "#$f" },
577             sub { my ( $b, $p, $f ) = @_; "$p" },
578             sub { my ( $b, $p, $f ) = @_; "$p#$f" },
579             sub { my ( $b, $p, $f ) = @_; "$b/" },
580             sub { my ( $b, $p, $f ) = @_; "#$f" },
581             sub { my ( $b, $p, $f ) = @_; "$b/$p" },
582             sub { my ( $b, $p, $f ) = @_; "$b/$p#$f" }
583             );
584              
585             sub assemble_url {
586 206     206 1 477 my ( $html, $base, $page, $fragment ) = @_;
587              
588 206 100       383 my $i = bin map { length($_) ? 1 : 0 } ( $base, $page, $fragment );
  618         1366  
589 206         589 my $url = $LinkFormat[$i]( $base, $page, $fragment );
590              
591 206         455 $url;
592             }
593              
594             sub escape_2396 {
595 609     609 1 1156 my ( $html, $text ) = @_;
596 609         1556 $text =~ s(([^\w\-.!~*'()]))(sprintf("%%%02x", ord($1)))eg;
  459         2048  
597 609         1432 $text;
598             }
599              
600             __END__