File Coverage

blib/lib/HTML/Blitz/Builder.pm

Criterion	Covered	Total	%
statement	146	148	98.6
branch	62	82	75.6
condition	17	21	80.9
subroutine	22	22	100.0
pod	5	7	71.4
total	252	280	90.0

package HTML::Blitz::Builder 0.1101;
use v5.20;
use warnings qw(all FATAL uninitialized);
no warnings qw(experimental::signatures);
use feature qw(signatures);
use Exporter qw(import);
use Carp qw(croak);
use Scalar::Util qw(refaddr);

our @EXPORT_OK = qw(
    mk_doctype
    mk_comment
    mk_elem
    to_html
    fuse_fragment
);

# data Fragment
#   = Null
#   | Txt Text
#   | Html Text
# instance IsString Fragment where
#   fromString = Txt . T.pack
# instance Monoid Fragment where
#   mempty = Null
#   mappend Null y = y
#   mappend x Null = x
#   mappend (Txt s) (Txt t) = Txt (s <> t)
#   mappend (Html s) (Html t) = Html (s <> t)
#   mappend (Txt s) (Html t) = Html (escape s <> t)
#   mappend (Html s) (Txt t) = Html (s <> escape t)

sub FREEZE($self, $type) { $$self }
sub THAW($class, $type, $str) { bless \$str, $class }

my $Null;
package HTML::Blitz::Builder::_Null {
    $Null = bless do { \my $tmp };

    sub FREEZE($self, $type) { () }
    sub THAW($class, $type) { $Null }
}

package HTML::Blitz::Builder::_Text {
    use overload
        '""'     => sub ($self, @) { $$self },
        fallback => 1;

    sub _mk($str) { bless \$str }

    sub FREEZE($self, $type) { $$self }
    sub THAW($class, $type, $str) { bless \$str, $class }
}

sub fuse_fragment {
    return $Null if !@_;
    my $acc = shift;
    my $can_mod = 0;
    for (@_) {
        next if (refaddr($_) // 0) == $Null;
        if ((refaddr($acc) // 0) == $Null) {
            $acc = $_;
            $can_mod = 0;
            next;
        }
        if (ref($acc) eq __PACKAGE__) {
            if (!$can_mod) {
                my $tmp = $$acc;
                $acc = bless \$tmp;
                $can_mod = 1;
            }
            $$acc .= ref($_) eq __PACKAGE__ ? $$_ : s{(?![\n\t])([[:cntrl:]&<])}{ $1 eq '<' ? '<' : $1 eq '&' ? '&' : '&#' . ord($1) . ';' }egr;
        } else {
            if (ref($_) eq __PACKAGE__) {
                my $tmp =
                    $acc =~ s{(?![\n\t])([[:cntrl:]&<])}{ $1 eq '<' ? '<' : $1 eq '&' ? '&' : '&#' . ord($1) . ';' }egr
                    . $$_;
                $acc = bless \$tmp;
                $can_mod = 1;
            } else {
                $acc .= $_;
            }
        }
    }
    (refaddr($acc) // 0) == $Null
    || ref($acc) eq __PACKAGE__
        ? $acc
        : HTML::Blitz::Builder::_Text::_mk "$acc"
}

sub to_html(@parts) {
    my $item = fuse_fragment @parts;
    ref($item) eq __PACKAGE__ ? $$item
        : (refaddr($item) // 0) == $Null ? ''
        : $item =~ s{(?![\n\t])([[:cntrl:]&<])}{ $1 eq '<' ? '<' : $1 eq '&' ? '&' : '&#' . ord($1) . ';' }egr
}

sub mk_doctype() {
    my $code = '';
    bless \$code
}

sub mk_comment($content) {
    $content =~ /\A(-?>)/
        and croak "HTML comment cannot start with '$1': '$content'";
    $content =~ /(";
    bless \$code
}

sub _mk_attr($name, $value) {
    $name =~ m{\A[^\s/>="'<[:cntrl:]]+\z}
        or croak "Invalid attribute name '$name'";
    my $code = " $name";
    if ($value ne '') {
        $code .= '=';
        if ($value !~ m{[\s"'=<>`]}) {
            $code .= $value =~ s{([[:cntrl:]&])}{ $1 eq '&' ? '&' : '&#' . ord($1) . ';' }egr;
        } else {
            $code .= '"' . $value =~ s{(?![\n\t])([[:cntrl:]&"])}{ $1 eq '"' ? '"' : $1 eq '&' ? '&' : '&#' . ord($1) . ';' }egr . '"';
        }
    }
    $code
}

my %is_void = map +($_ => 1), qw(
    area
    base basefont bgsound br
    col
    embed
    frame
    hr
    img input
    keygen
    link
    meta
    param
    source
    track
    wbr
);

my %is_childless = map +($_ => 1), qw(
    title
    textarea
    script
    style
);

sub mk_elem($name, @args) {
    my $attrs = @args && ref($args[0]) eq 'HASH'
        ? shift @args
        : {};
    $name =~ m{\A[A-Za-z][^\s/>[:cntrl:]]*\z}
        or croak "Invalid tag name '$name'";
    (my $lc_name = $name) =~ tr/A-Z/a-z/;
    my $item = fuse_fragment @args;
    my $attr_str = join '', map _mk_attr($_, $attrs->{$_}), sort keys %$attrs;
    my $html = "<$name$attr_str>";
    if ($is_void{$lc_name}) {
        croak "<$name> tag cannot have contents" if (refaddr($item) // 0) != $Null;
    } else {
        croak "<$name> tag cannot have child elements" if $is_childless{$lc_name} && ref($item) eq __PACKAGE__;
        my $contents;
        if ($lc_name eq 'style') {
            $contents = (refaddr($item) // 0) == $Null ? '' : $item;
            $contents =~ m{(])}aai
                and croak "<$name> tag cannot contain '$1'";
        } elsif ($lc_name eq 'script') {
            $contents = (refaddr($item) // 0) == $Null ? '' : $item;
            SCRIPT_DATA: {
                $contents =~ m{ ( ) | ( < (/?) script [ \t\r\n\f/>] ) }xaaigc
                        or last SCRIPT_DATA;
                    $1 and redo SCRIPT_DATA;
                    $3 and croak "<$name> tag cannot contain '$2'";

                    $contents =~ m{ (-->) | ] }xaaigc
                        or croak "<$name> tag cannot contain '' or ''";
                    $1 and redo SCRIPT_DATA;
                    redo SCRIPT_DATA_ESCAPED;
                }
            }
        } else {
            $contents = to_html $item;
        }
        $html .= "$contents";
    }
    bless \$html
}

1
__END__