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

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__