File Coverage

blib/lib/HTML/Builder.pm

Criterion	Covered	Total	%
statement	79	89	88.7
branch	3	4	75.0
condition	2	2	100.0
subroutine	25	30	83.3
pod	11	12	91.6
total	120	137	87.5

#
# This file is part of HTML-Builder
#
# This software is Copyright (c) 2012 by Chris Weyl.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package HTML::Builder;
{
  $HTML::Builder::VERSION = '0.008';
}

# ABSTRACT: A declarative approach to HTML generation

use v5.10;

use strict;
use warnings;

use Capture::Tiny 0.15 'capture_stdout';
use HTML::Tiny;
use Sub::Install;
use List::MoreUtils 'uniq';

# debugging...
#use Smart::Comments;

our $IN_TAG;


# HTML5 tags from:
# http://en.wikipedia.org/wiki/HTML5#Differences_from_HTML.C2.A04.01_and_XHTML.C2.A01.x
# 18 Feb 2012
#
# Other HTML tags from:
# http://www.w3schools.com/tags/default.asp
# 19 Feb 2012


# !--...--	Defines

sub html5_tags { qw{

    article aside audio bdo canvas command datalist details embed figcaption
    figure footer header hgroup keygen mark meter nav output progress rp rt
    ruby section source summary time video wbr

} }


sub html5_minimal_tags { q{ article aside footer header nav } }

# excl: s
sub deprecated_tags { qw{ applet basefont center dir font menu strike u xmp } }
sub depreciated_tags { deprecated_tags() }


sub conflicting_tags { {
    html_sub => 'sub',
    html_map => 'map',
    html_q   => 'q',
    html_tr  => 'tr',
} }

sub html_tags {

    # excl: sub map q tr

    return qw{

        a        abbr       acronym    address      area       b
        base     bdo        big        blockquote   body       br
        button   caption    cite       code         col        colgroup
        dd       del        dfn        div          dl         dt
        em       fieldset   form       frame        frameset   h1
        head     hr         html       i            iframe     img
        input    ins        kbd        label        legend     li
        link                meta       noframes     noscript   object
        ol       optgroup   option     p            param      pre
                 samp       script     select       small      span
                 strong     style                   sup        table
        tbody    td         textarea   tfoot        th         thead
        title               tt         ul           var

    };
}


sub form_tags { qw{

    form fieldset button input label optgroup option select textarea

}}


sub table_tags { qw{ table tr td th thead tbody tfoot } }


sub minimal_tags {
    return ('h1'..'h5', qw{
        div span p img script br ul ol li style a
    });
}


sub our_tags {
    my @tags = (
        html5_tags(),
        html_tags(),
        deprecated_tags(),
        (keys %{ conflicting_tags() }),
    );
    return uniq sort @tags;
}


sub _attr { die }

sub attr(&) {
    my $code = shift;

    ### in attr...
    _attr($code->());
}

sub _is_autoload_gen {
    my ($attr_href) = @_;

    return sub {
        shift;

        my $field = our $AUTOLOAD;
        $field =~ s/.*:://;

        # XXX
        $field =~ s/__/:/g;   # xml__lang  is 'foo' ====> xml:lang="foo"
        $field =~ s/_/-/g;    # http_equiv is 'bar' ====> http-equiv="bar"

        # Squash empty values, but not '0' values
        my $val = join ' ', grep { defined $_ && $_ ne '' } @_;

        #push @$attr_aref, $field => $val;
        $attr_href->{$field} = $val;

        return;
    };
}

sub _attr_gen {
    my ($attr_href) = @_;

    return sub {

        my %attrs = @_;
        ### %attrs
        @{$attr_href}{keys %attrs} = (values %attrs);

        return;
    };
}

sub tag($&) {
    my ($tag, $inner_coderef) = @_;

    state $h = HTML::Tiny->new;

    ### @_
    my %attrs = ();

    # This is almost completely stolen from Template::Declare::Tags, and
    # completely terrifying in that it confirms my dark suspicions on how
    # it was achieved over there.
    no warnings 'once', 'redefine';
    local *gets::AUTOLOAD = _is_autoload_gen(\%attrs);
    local *_attr = _attr_gen(\%attrs);
    my $inner = q{};
    my $stdout = capture_stdout { local $IN_TAG = 1; $inner .= $inner_coderef->() || q{} };

    my $return = $h->tag($tag, \%attrs, "$stdout$inner");

    ### $return
    if ($IN_TAG) {
        print $return;
        return q{};
    }
    else {
        return $return;
    }
}

use Sub::Exporter -setup => {

    exports => [ our_tags, 'attr', 'tag' ],
    groups  => {

        default     => ':minimal',

        minimal       => sub { _generate_group([       minimal_tags ], @_) },
        html5         => sub { _generate_group([         html5_tags ], @_) },
        html5_minimal => sub { _generate_group([ html5_minimal_tags ], @_) },
        deprecated    => sub { _generate_group([    deprecated_tags ], @_) },
        depreciated   => sub { _generate_group([    deprecated_tags ], @_) },
        table         => sub { _generate_group([         table_tags ], @_) },
        form          => sub { _generate_group([          form_tags ], @_) },
        header        => sub { _generate_group([qw{ header hgroup } ], @_) },
    },
};

sub _generate_group {
    my ($tags, $class, $group, $arg) = @_;

    return {
        attr => \&attr,
        map { my $tag = $_; $tag => sub(&) { unshift @_, $tag; goto \&tag } }
        @$tags
    };
}

{
    my $_install = sub {
        my ($subname, $tag) = @_;
        $tag ||= $subname;
        Sub::Install::install_sub({
            code => sub(&) { unshift @_, $tag; goto \&tag },
            as   => $tag,
        });
    };

    my $conflict = conflicting_tags;
    $_install->($_)  for our_tags;
    $_install->(@$_) for map { [ $_ => $conflict->{$_} ] } keys %$conflict;
}

!!42;

__END__