File Coverage

blib/lib/Kwim/HTML.pm

Criterion	Covered	Total	%
statement	111	123	90.2
branch	29	40	72.5
condition			n/a
subroutine	25	27	92.5
pod	0	22	0.0
total	165	212	77.8

use strict; use warnings;
package Kwim::HTML;

use base 'Kwim::Markup';
# use XXX -with => 'YAML::XS';

use HTML::Escape;

use constant top_block_separator => "\n";

my $document_title = '';
my $info = {
    verse => {
        tag => 'p',
        style => 'block',
        transform => 'transform_verse',
        attrs => ' class="verse"',
    },
};

sub render_text {
    my ($self, $text) = @_;
    $text =~ s/\n/ /g;
    escape_html($text);
}

sub render_para {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    chomp $out;
    my $spacer = $out =~ /\n/ ? "\n" : '';
    "$spacer$out$spacer\n";
}

sub render_rule {
    "\n";
}

sub render_blank {
    "\n";
}

sub render_list {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    chomp $out;
    "\n$out\n\n";
}

sub render_item {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    $out =~ s/(.)(<(?:ul|pre|p)(?: |>))/$1\n$2/;
    my $spacer = $out =~ /\n/ ? "\n" : '';
    "$out$spacer\n";
}

sub render_pref {
    my ($self, $node) = @_;
    my $out = escape_html($node);
    "$out\n\n";
}

sub render_func {
    my ($self, $node) = @_;
    if ($node =~ /^(\w[\-\w]*) ?((?s:.*)?)$/) {
        my ($name, $args) = ($1, $2);
        $name =~ s/-/_/g;
        my $method = "phrase_func_$name";
        if ($self->can($method)) {
            my $out = $self->$method($args);
            return $out if defined $out;
        }
    }
    "<$node>";
}

sub render_title {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    chomp $out;
    my ($name, $text) = ref $node ? @$node : (undef, $node);
    if (defined $text) {
        $document_title = "$name - $text";
        "$name\n\n$text\n";
    }
    else {
        $document_title = "$name";
        my $spacer = $name =~ /\n/ ? "\n" : '';
        "$spacer$name$spacer\n";
    }
}

sub render_head {
    my ($self, $node, $number) = @_;
    my $out = $self->render($node);
    chomp $out;
    "$out\n";
}

sub render_comment {
    my ($self, $node) = @_;
    my $out = escape_html($node);
    if ($out =~ /\n/) {
        "\n";
    }
    else {
        "\n";
    }
}

sub render_code {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    "$out";
}

sub render_bold {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    "$out";
}

sub render_emph {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    "$out";
}

sub render_del {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    "$out";
}

sub render_hyper {
    my ($self, $node) = @_;
    my ($link, $text) = @{$node}{qw(link text)};
    $text = $link if not length $text;
    "$text";
}

sub render_link {
    my ($self, $node) = @_;
    my ($link, $text) = @{$node}{qw(link text)};
    $text = $link if not length $text;
    "$text";
}

sub render_complete {
    my ($self, $out) = @_;
    chomp $out;
    <<"..."




  $document_title





$out




...
}

#------------------------------------------------------------------------------
sub format_phrase_func_html {
    my ($self, $tag, $class, $attrib, $content) = @_;
    my $attribs = '';
    if (@$class) {
        $attribs = ' class="' . join(' ', @$class) . '"';
    }
    if (@$attrib) {
        $attribs = ' ' . join(' ', map {
            /=".*"$/ ? $_ : do { s/=(.*)/="$1"/; $_ }
        } @$attrib);
    }
    length($content)
    ? "<$tag$attribs>$content"
    : "<$tag$attribs/>";
}

sub phrase_func_bold {
    my ($self, $args) = @_;
    my ($success, $class, $attrib, $content) =
        $self->parse_phrase_func_args_html($args);
    return unless $success;
    $self->format_phrase_func_html('strong', $class, $attrib, $content);
}

sub parse_phrase_func_args_html {
    my ($self, $args) = @_;
    my ($class, $attrib, $content) = ([], [], '');
    $args =~ s/^ //;
    if ($args =~ /\A((?:\\:|[^\:])*):((?s:.*))\z/) {
        $attrib = $1;
        $content = $2;
        $attrib =~ s/\\:/:/g;
        ($class, $attrib) = $self->parse_attrib($attrib);
    }
    else {
        $content = $args;
    }
    return 1, $class, $attrib, $content;
}

sub parse_attrib {
    my ($self, $text) = @_;
    my ($class, $attrib) = ([], []);
    while (length $text) {
        if ($text =~ s/^\s*(\w[\w\-]*)(?=\s|\z)\s*//) {
            push @$class, $1;
        }
        elsif ($text =~ s/^\s*(\w[\w\-]*="[^"]*")(?=\s|\z)s*//) {
            push @$attrib, $1;
        }
        elsif ($text =~ s/^\s*(\w[\w\-]*=\S+)(?=\s|\z)s*//) {
            push @$attrib, $1;
        }
        else {
            last;
        }
    }
    return $class, $attrib;
}

1;