package Pod::Tree::HTML; use 5.006; use strict; use warnings; # Copyright (c) 1999-2007 by Steven McDougall. This module is free # software; you can redistribute it and/or modify it under the same # terms as Perl itself. use HTML::Stream; use IO::File; use IO::String; use Pod::Tree; use Text::Template; use Pod::Tree::BitBucket; use Pod::Tree::StrStream; use Pod::Tree::HTML::LinkMap; use constant BGCOLOR => '#ffffff'; use constant TEXT => '#000000'; our $VERSION = '1.31'; sub new { my ( $class, $source, $dest, %options ) = @_; defined $dest or die "Pod::Tree::HTML::new: not enough arguments\n"; my $tree = _resolve_source($source); my ( $fh, $stream ) = _resolve_dest( $dest, $tree, \%options ); my $options = { bgcolor => BGCOLOR, depth => 0, hr => 1, link_map => Pod::Tree::HTML::LinkMap->new(), text => TEXT, toc => 1, }; my $HTML = { tree => $tree, root => $tree->get_root, stream => $stream, fh => $fh, text_method => 'text', options => $options, }; bless $HTML, $class; $HTML->set_options(%options); $HTML; } sub _resolve_source { my $source = shift; my $ref = ref $source; local *isa = \&UNIVERSAL::isa; isa( $source, 'Pod::Tree' ) and return $source; my $tree = Pod::Tree->new; not $ref and $tree->load_file($source); isa( $source, 'IO::File' ) and $tree->load_fh($source); $ref eq 'SCALAR' and $tree->load_string($$source); $ref eq 'ARRAY' and $tree->load_paragraphs($source); $tree->loaded or die "Pod::Tree::HTML::_resolve_source: Can't load POD from $source\n"; $tree; } sub _resolve_dest { my ( $dest, $tree, $options ) = @_; $tree->has_pod or $options->{empty} or return ( undef, Pod::Tree::BitBucket->new ); local *isa = \&UNIVERSAL::isa; local *can = \&UNIVERSAL::can; isa( $dest, 'HTML::Stream' ) and return ( undef, $dest ); isa( $dest, 'IO::File' ) and return ( $dest, HTML::Stream->new($dest) ); can( $dest, 'print' ) and return ( $dest, HTML::Stream->new($dest) ); if ( ref $dest eq 'SCALAR' ) { my $fh = IO::String->new($$dest); return ( $fh, HTML::Stream->new($fh) ); } if ( ref $dest eq '' and $dest ) { my $fh = IO::File->new; $fh->open( $dest, '>' ) or die "Pod::Tree::HTML::new: Can't open $dest: $!\n"; return ( $fh, HTML::Stream->new($fh) ); } die "Pod::Tree::HTML::_resolve_dest: Can't write HTML to $dest\n"; } sub set_options { my ( $html, %options ) = @_; my ( $key, $value ); while ( ( $key, $value ) = each %options ) { $html->{options}{$key} = $value; } } sub get_options { my ( $html, @options ) = @_; map { $html->{options}{$_} } @options; } sub get_stream { shift->{stream} } sub translate { my ( $html, $template ) = @_; if ($template) { $html->_template($template); } else { $html->_translate; } } sub _translate { my $html = shift; my $stream = $html->{stream}; my $bgcolor = $html->{options}{bgcolor}; my $text = $html->{options}{text}; my $title = $html->_make_title; my $base = $html->{options}{base}; my $css = $html->{options}{css}; $stream->HTML->HEAD; defined $title and $stream->TITLE->text($title)->_TITLE; defined $base and $stream->BASE( href => $base ); defined $css and $stream->LINK( href => $css, type => "text/css", rel => "stylesheet" ); $stream->_HEAD->BODY( BGCOLOR => $bgcolor, TEXT => $text ); $html->emit_toc; $html->emit_body; $stream->nl->_BODY->_HTML; } sub _template { my ( $html, $tSource ) = @_; my $fh = $html->{fh}; my $sStream = Pod::Tree::StrStream->new; $html->{stream} = HTML::Stream->new($sStream); our $bgcolor = $html->{options}{bgcolor}; our $text = $html->{options}{text}; our $title = $html->_make_title; our $base = $html->{options}{base}; our $css = $html->{options}{css}; $html->emit_toc; our $toc = $sStream->get; $html->emit_body; our $body = $sStream->get; my $template = Text::Template->new( SOURCE => $tSource ) or die "Can't create Text::Template object: $Text::Template::ERROR\n"; $template->fill_in( OUTPUT => $fh ) or die $Text::Template::ERROR; } sub _make_title { my $html = shift; my $title = $html->{options}{title}; defined $title and return $title; my $children = $html->{root}->get_children; my $node1; my $i = 0; for my $child (@$children) { $child->is_pod or next; $i++ and $node1 = $child; $node1 and last; } $node1 or return undef; ##no critic (ProhibitExplicitReturnUndef) my $text = $node1->get_deep_text; ($title) = split m(\s+-), $text; $title or return undef; ##no critic (ProhibitExplicitReturnUndef) $title =~ s(\s+$)(); $title; } sub emit_toc { my $html = shift; $html->{options}{toc} or return; my $root = $html->{root}; my $nodes = $root->get_children; my @nodes = @$nodes; $html->_emit_toc_1( \@nodes ); $html->{options}{hr} > 0 and $html->{stream}->HR; } sub _emit_toc_1 { my ( $html, $nodes ) = @_; my $stream = $html->{stream}; $stream->UL; while (@$nodes) { my $node = $nodes->[0]; $node->is_c_head2 and $html->_emit_toc_2($nodes), next; $node->is_c_head1 and $html->_emit_toc_item($node); shift @$nodes; } $stream->_UL; } sub _emit_toc_2 { my ( $html, $nodes ) = @_; my $stream = $html->{stream}; $stream->UL; while (@$nodes) { my $node = $nodes->[0]; $node->is_c_head1 and last; $node->is_c_head2 and $html->_emit_toc_item($node); shift @$nodes; } $stream->_UL; } sub _emit_toc_item { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $target = $html->_make_anchor($node); $stream->LI->A( HREF => "#$target" ); $html->_emit_children($node); $stream->_A; } sub emit_body { my $html = shift; my $root = $html->{root}; $html->_emit_children($root); } sub _emit_children { my ( $html, $node ) = @_; my $children = $node->get_children; for my $child (@$children) { $html->_emit_node($child); } } sub _emit_siblings { my ( $html, $node ) = @_; my $siblings = $node->get_siblings; if ( @$siblings == 1 and $siblings->[0]{type} eq 'ordinary' ) { # don't put
around a single ordinary paragraph $html->_emit_children( $siblings->[0] ); } else { for my $sibling (@$siblings) { $html->_emit_node($sibling); } } } sub _emit_node { my ( $html, $node ) = @_; my $type = $node->{type}; for ($type) { /command/ and $html->_emit_command($node); /for/ and $html->_emit_for($node); /item/ and $html->_emit_item($node); /list/ and $html->_emit_list($node); /ordinary/ and $html->_emit_ordinary($node); /sequence/ and $html->_emit_sequence($node); /text/ and $html->_emit_text($node); /verbatim/ and $html->_emit_verbatim($node); } } my %HeadTag = ( head1 => { 'open' => 'H1', 'close' => '_H1', level => 1 }, head2 => { 'open' => 'H2', 'close' => '_H2', level => 2 }, head3 => { 'open' => 'H3', 'close' => '_H3', level => 3 }, head4 => { 'open' => 'H4', 'close' => '_H4', level => 4 } ); sub _emit_command { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $command = $node->get_command; my $head_tag = $HeadTag{$command}; $head_tag or return; my $anchor = $html->_make_anchor($node); $html->_emit_hr( $head_tag->{level} ); my $tag; $tag = $head_tag->{'open'}; $stream->$tag()->A( NAME => $anchor ); $html->_emit_children($node); $tag = $head_tag->{'close'}; $stream->_A->$tag(); } sub _emit_hr { my ( $html, $level ) = @_; $html->{options}{hr} > $level or return; $html->{skip_first}++ or return; $html->{stream}->HR; } sub _emit_for { my ( $html, $node ) = @_; my $interpreter = lc $node->get_arg; my $emit = "_emit_for_$interpreter"; $html->$emit($node) if $html->can($emit); } sub _emit_for_html { my ( $html, $node ) = @_; my $stream = $html->{stream}; $stream->P; $stream->io->print( $node->get_text ); $stream->_P; } sub _emit_for_image { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $link = $node->get_text; $link =~ s(\s+$)(); $stream->IMG( src => $link ); } sub _emit_item { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $item_type = $node->get_item_type; for ($item_type) { /bullet/ and do { $stream->LI(); $html->_emit_siblings($node); $stream->_LI(); }; /number/ and do { $stream->LI(); $html->_emit_siblings($node); $stream->_LI(); }; /text/ and do { my $anchor = $html->_make_anchor($node); $stream->DT->A( NAME => "$anchor" ); $html->_emit_children($node); $stream->_A->_DT->DD; $html->_emit_siblings($node); $stream->_DD; }; } } my %ListTag = ( bullet => { 'open' => 'UL', 'close' => '_UL' }, number => { 'open' => 'OL', 'close' => '_OL' }, text => { 'open' => 'DL', 'close' => '_DL' } ); sub _emit_list { my ( $html, $node ) = @_; my ( $list_tag, $tag ); # to quiet -w, see beloew my $stream = $html->{stream}; my $list_type = $node->get_list_type; $list_type and $list_tag = $ListTag{$list_type}; $list_tag and $tag = $list_tag->{'open'}; $tag and $stream->$tag(); $html->_emit_children($node); $list_tag and $tag = $list_tag->{'close'}; $tag and $stream->$tag(); } sub _emit_ordinary { my ( $html, $node ) = @_; my $stream = $html->{stream}; $stream->P; $html->_emit_children($node); $stream->_P; } sub _emit_sequence { my ( $html, $node ) = @_; for ( $node->get_letter ) { /I|B|C|F/ and $html->_emit_element($node), last; /S/ and $html->_emit_nbsp($node), last; /L/ and $html->_emit_link($node), last; /X/ and $html->_emit_index($node), last; /E/ and $html->_emit_entity($node), last; } } my %ElementTag = ( I => { 'open' => 'I', 'close' => '_I' }, B => { 'open' => 'B', 'close' => '_B' }, C => { 'open' => 'CODE', 'close' => '_CODE' }, F => { 'open' => 'I', 'close' => '_I' } ); sub _emit_element { my ( $html, $node ) = @_; my $letter = $node->get_letter; my $stream = $html->{stream}; my $tag; $tag = $ElementTag{$letter}{'open'}; $stream->$tag(); $html->_emit_children($node); $tag = $ElementTag{$letter}{'close'}; $stream->$tag(); } sub _emit_nbsp { my ( $html, $node ) = @_; my $old_method = $html->{text_method}; $html->{text_method} = 'text_nbsp'; $html->_emit_children($node); $html->{text_method} = $old_method; } sub _emit_link { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $target = $node->get_target; my $domain = $target->get_domain; my $method = "make_${domain}_URL"; my $url = $html->$method($target); $stream->A( HREF => $url ); $html->_emit_children($node); $stream->_A; } sub make_POD_URL { my ( $html, $target ) = @_; my $link_map = $html->{options}{link_map}; return $link_map->url( $html, $target ) if $link_map->can("url"); $html->make_mapped_URL($target); } sub make_mapped_URL { my ( $html, $target ) = @_; my $link_map = $html->{options}{link_map}; my $base = $html->{options}{base} || ''; my $page = $target->get_page; my $section = $target->get_section; my $depth = $html->{options}{depth}; ( $base, $page, $section ) = $link_map->map( $base, $page, $section, $depth ); $base =~ s(/$)(); $page .= '.html' if $page; my $fragment = $html->escape_2396($section); my $url = $html->assemble_url( $base, $page, $fragment ); $url; } sub make_HTTP_URL { my ( $html, $target ) = @_; $target->get_page; } sub _emit_index { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $anchor = $html->_make_anchor($node); $stream->A( NAME => $anchor )->_A; } sub _emit_entity { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $entity = $node->get_deep_text; $stream->ent($entity); } sub _emit_text { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $text = $node->get_text; my $text_method = $html->{text_method}; $stream->$text_method($text); } sub _emit_verbatim { my ( $html, $node ) = @_; my $stream = $html->{stream}; my $text = $node->get_text; $text =~ s(\n\n$)(); $stream->PRE->text($text)->_PRE; } sub _make_anchor { my ( $html, $node ) = @_; my $text = $node->get_deep_text; $text =~ s( \s*\n\s*/ )( )xg; # close line breaks $text =~ s( ^\s+ | \s+$ )()xg; # clip leading and trailing WS $html->escape_2396($text); } sub bin { oct '0b' . join '', @_ } my @LinkFormat = ( sub { my ( $b, $p, $f ) = @_; "" }, sub { my ( $b, $p, $f ) = @_; "#$f" }, sub { my ( $b, $p, $f ) = @_; "$p" }, sub { my ( $b, $p, $f ) = @_; "$p#$f" }, sub { my ( $b, $p, $f ) = @_; "$b/" }, sub { my ( $b, $p, $f ) = @_; "#$f" }, sub { my ( $b, $p, $f ) = @_; "$b/$p" }, sub { my ( $b, $p, $f ) = @_; "$b/$p#$f" } ); sub assemble_url { my ( $html, $base, $page, $fragment ) = @_; my $i = bin map { length($_) ? 1 : 0 } ( $base, $page, $fragment ); my $url = $LinkFormat[$i]( $base, $page, $fragment ); $url; } sub escape_2396 { my ( $html, $text ) = @_; $text =~ s(([^\w\-.!~*'()]))(sprintf("%%%02x", ord($1)))eg; $text; } __END__ =head1 NAME Pod::Tree::HTML - Generate HTML from a Pod::Tree =head1 SYNOPSIS use Pod::Tree::HTML; $source = Pod::Tree->new(%options); $source = "file.pod"; $source = IO::File->new; $source = \$pod; $source = \@pod; $dest = HTML::Stream->new; $dest = IO::File->new; $dest = "file.html"; $html = Pod::Tree::HTML->new($source, $dest, %options); $html->set_options(%options); @values = $html->get_options(@keys); $html->translate; $html->translate($template); $html->emit_toc; $html->emit_body; $fragment = $html->escape_2396 ($section); $url = $html->assemble_url($base, $page, $fragment); =head1 REQUIRES CFoo
Bar To link to a heading, simply give the text of the heading in an C<< LZ<><> >> markup. The text must match exactly; markups may vary. Either of these would link to the heading shown above L Bar> L To generate destination anchors in other places, use the index (C<< XZ<><> >>) markup We can link to X