File Coverage

blib/lib/HTML/Blitz/Builder.pm

Criterion	Covered	Total	%
statement	83	84	98.8
branch	51	76	67.1
condition	6	12	50.0
subroutine	11	11	100.0
pod	5	5	100.0
total	156	188	82.9

package HTML::Blitz::Builder;
use HTML::Blitz::pragma;
use Exporter qw(import);
use Carp qw(croak);

our $VERSION = '0.09';

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

{
    package HTML::Blitz::Builder::_Fragment;

    method new($class: @parts) {
        bless {
            parts => \@parts,
        }, $class
    }

    method unwrapped() {
        @{$self->{parts}}
    }
}

fun to_html(@parts) {
    join '',
        map ref($_) eq __PACKAGE__ ? $$_ : s{(?![\n\t])([[:cntrl:]&<])}{ $1 eq '<' ? '<' : $1 eq '&' ? '&' : '&#' . ord($1) . ';' }egr,
        map ref($_) eq __PACKAGE__ . '::_Fragment' ? $_->unwrapped : $_,
        @parts
}

fun fuse_fragment(@parts) {
    return $parts[0]
        if @parts == 1 && (ref($parts[0]) eq __PACKAGE__ || ref($parts[0]) eq __PACKAGE__ . '::_Fragment');
    HTML::Blitz::Builder::_Fragment->new(@parts)
}

fun mk_doctype() {
    my $code = '';
    bless \$code, __PACKAGE__
}

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

fun _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
);

fun 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/;
    @args = map ref($_) eq __PACKAGE__ . '::_Fragment' ? $_->unwrapped : $_, @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 @args;
    } else {
        croak "<$name> tag cannot have child elements" if $is_childless{$lc_name} && grep ref($_) eq __PACKAGE__, @args;
        my $contents;
        if ($lc_name eq 'style') {
            $contents = join '', @args;
            $contents =~ m{(])}aai
                and croak "<$name> tag cannot contain '$1'";
        } elsif ($lc_name eq 'script') {
            $contents = join '', @args;
            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 @args;
        }
        $html .= "$contents";
    }
    bless \$html, __PACKAGE__
}

1
__END__