File Coverage

blib/lib/Swim/HTML.pm

Criterion	Covered	Total	%
statement	17	142	11.9
branch	1	48	2.0
condition	0	3	0.0
subroutine	5	29	17.2
pod	0	26	0.0
total	23	248	9.2

package Swim::HTML;
use Pegex::Base;
extends 'Swim::Markup';

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_olist {
    my ($self, $node) = @_;
    my $out = $self->render($node);
    chomp $out;
    "\n$out\n\n";
}

sub render_oitem {
    my ($self, $node) = @_;
    $self->render_item($node);
}

sub render_data {
    my ($self, $node) = @_;
    my $out = "\n";
    for my $item (@$node) {
        my ($term, $def, $rest) = @$item;
        $term = $self->render($term);
        $out .= "$term\n";
        if (length $def or $rest) {
            $out .= "";
            if (length $def) {
                $out .= $self->render($def) . "\n";
            }
            if ($rest) {
                $out .= $self->render($rest) . "\n";
            }
            $out .= "\n";
        }
    }
    $out . "\n";
}

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

sub render_pfunc {
    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 ($name, $abstract) = ref $node ? @$node : (undef, $node);

    $name = $self->render($name);
    if (defined $abstract) {
        $abstract = $self->render($abstract);
        $document_title = "$name - $abstract";
        "$name\n\n$abstract\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_under {
    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;

    # XXX Temporary hack for inline grant blog
    # We can solve this in a formal and extensible way later.
    if (defined $ENV{SWIM_LINK_FORMAT_HACK}) {
        $link = "https://metacpan.org/pod/$link";
    }

    "$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;