File Coverage

blib/lib/HTML/HTML5/Builder.pm

Criterion	Covered	Total	%
statement	30	32	93.7
branch			n/a
condition			n/a
subroutine	12	12	100.0
pod			n/a
total	42	44	95.4

package HTML::HTML5::Builder;

use 5.010;
use base qw[Exporter];
use common::sense;
use constant { FALSE => 0, TRUE => 1 };
use constant XHTML_NS => 'http://www.w3.org/1999/xhtml';
use overload;
use utf8;
use warnings::register;

BEGIN {
	$HTML::HTML5::Builder::AUTHORITY = 'cpan:TOBYINK';
}
BEGIN {
	$HTML::HTML5::Builder::VERSION   = '0.004';
}

use Carp 0 qw();
use HTML::HTML5::Builder::Document;
use HTML::HTML5::Entities 0.001 qw();
use Scalar::Util 0 qw(blessed);
use XML::LibXML 1.60 qw();

my (@elements, @uc_elements, @conforming);
our (@EXPORT_OK, @EXPORT, %EXPORT_TAGS);
BEGIN
{
	@elements = qw{
		a abbr acronym address applet area article aside audio b base
		basefont bb bdo bgsound big blink blockquote body br button canvas
		caption center cite code col colgroup command datagrid datalist
		dd del details dfn dialog dir div dl dt em embed fieldset figure
		figcaption font footer form frame frameset h1 h2 h3 h4 h5 h6
		head header hgroup hr html i iframe img input ins isindex kbd
		keygen label legend li link listing map mark marquee menu meta
		meter nav nobr noembed noframes noscript object ol optgroup
		option output p param plaintext pre progress q rp rt ruby s
		samp script select section small source spacer span strike
		strong style sub sup summary table tbody td textarea tfoot th
		thead time title tr track tt u ul var video wbr xmp
		};
	@uc_elements = qw{Q Sub Time Map Meta Link S};
	@conforming = qw{
		a abbr address area article aside audio b base bb bdo blockquote
		body br button canvas caption cite code col colgroup command
		datagrid datalist dd del details dfn dialog div dl dt em embed
		fieldset figure footer form h1 h2 h3 h4 h5 h6 head header hr html
		i iframe img input ins kbd label legend li mark menu
		meter nav noscript object ol optgroup option output p param
		pre progress rp rt ruby samp script section select small source
		span strong style sup table tbody td textarea tfoot th thead
		title tr ul var video
		};
	my @cool_stuff  = qw{COMMENT CHUNK XML_CHUNK RAW_CHUNK ELEMENT TEXT};
	my @boilerplate = qw{JQUERY CREATIVE_COMMONS OPENGRAPH};

	@EXPORT_OK   = (@elements, @cool_stuff, @uc_elements, @boilerplate);
	@EXPORT      = ();
	%EXPORT_TAGS = (
		all      => \@EXPORT_OK,
		standard => [@conforming, @cool_stuff, qw{Q Sub Time Map Meta Link}],
		default  => \@EXPORT,
		metadata => [qw(head title base Link Meta style)],
		sections => [qw(body div section nav article aside h1 h2 h3 h4 h5 h6 header footer address)],
		grouping => [qw(p hr br pre dialog blockquote ol ul li dl dt dd)],
		text     => [qw(a cite em strong small mark dfn abbr progress
			meter code var samp kbd sup span i b bdo ruby rt rp Q Sub Time)],
		embedded => [qw(figure img iframe embed object param video audio source
			canvas area Map)],
		tabular  => [qw(table thead tbody tfoot th td colgroup col caption)],
		form     => [qw(form fieldset label input button select datalist
			optgroup option textarea output)],
		);
}

sub new
{
	my ($class, %options) = @_;
	bless \%options, $class;
}

sub ELEMENT
{
	shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);
	my ($el, @params) = @_;

	if (warnings::enabled())
	{
		Carp::carp("Non-standard HTML element <$el>")
			unless grep { lc $el eq $_ } @elements;
	}

	my $EL = XML::LibXML::Element->new($el);
	$EL->setNamespace(XHTML_NS, undef, TRUE);

	if ($el eq 'time' and blessed($params[0]) and $params[0]->isa('DateTime'))
	{
		my $dt = shift @params;
		my $string = $dt->strftime('%FT%T');
		if ($dt->time_zone->is_utc)
		{
			$string .= 'Z';
		}
		elsif (!$dt->time_zone->is_floating)
		{
			my $zone = $dt->strftime('%z');
			$zone =~ s/^(.\d{2})(\d{2})$/$1:$2/;
			$string .= $zone;
		}
		$EL->setAttribute('datetime', $string);
		if (!@params)
		{
			push @params, "$dt";
		}
	}

	PARAM: while (@params)
	{
		my $thing = shift @params;

		if (blessed($thing) and $thing->isa('XML::LibXML::Element'))
		{
			$EL->appendChild($thing);
		}
		elsif (blessed($thing) and $thing->isa('XML::LibXML::Text'))
		{
			$EL->appendChild($thing);
		}
		elsif (blessed($thing) and $thing->isa('XML::LibXML::Comment'))
		{
			$EL->appendChild($thing);
		}
		elsif (blessed($thing) and $thing->isa('XML::LibXML::PI'))
		{
			$EL->appendChild($thing);
		}
		elsif (blessed($thing) and $thing->isa('XML::LibXML::NodeList'))
		{
			$EL->appendChild($_) foreach $thing->get_nodelist;
		}
		elsif (blessed($thing) and $thing->isa('XML::LibXML::Attr'))
		{
			$EL->setAttribute($thing->nodeName, $thing->getValue);
		}
		elsif (ref $thing eq 'IO')
		{
			local $/ = undef;
			my $string = <$thing>;
			$EL->appendText($string);
		}
		elsif (ref $thing eq 'SCALAR')
		{
			$$thing = $EL;
		}
		elsif (ref $thing eq 'ARRAY')
		{
			unshift @params, map
				{ ref $_ ? $_ : XML::LibXML::Text->new($_); }
				@$thing;
			redo PARAM;
		}
		elsif (ref $thing eq 'HASH')
		{
			while (my ($k, $v) = each %$thing)
			{
				$k =~ s/^-//g;
				$EL->setAttribute($k, "$v");
			}
		}
		elsif (!ref $thing and $thing =~ /^-(\S+)$/ and @params)
		{
			my $attr  = $1;
			my $value = shift @params;
			$EL->setAttribute($attr, "$value");
		}
		elsif (defined $thing)
		{
			if (warnings::enabled())
			{
				if (defined ref($thing) and ref($thing) =~ /^(CODE|REF|GLOB|LVALUE|FORMAT|Regexp)$/)
					{ Carp::carp(sprintf("Passed a %s reference", ref($thing))); }
				elsif (blessed($thing) and !overload::Method($thing, '""'))
					{ Carp::carp(sprintf("Passed a blessed reference (%s) that does not overload stringification", ref($thing))); }
			}

			$EL->appendText("$thing");
		}
	}

	if ($el eq 'html')
	{
		my $doc = HTML::HTML5::Builder::Document->new('1.0', 'utf-8');
		$doc->adoptNode($EL);
		$doc->setDocumentElement($EL);
		return $doc;
	}

	return $EL;
}

sub _mksub
{
	no strict 'refs';

	my ($function, $element) = @_;
	$element = lc $function unless defined $element and length $element;

	my $sub = sub
	{
		shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);
		return ELEMENT($element, @_);
	};

	return $sub;
}

sub AUTOLOAD
{
	my ($func) = our $AUTOLOAD =~ /::(\w+)$/;
	Carp::croak("Undefined function") unless $func =~ /^(([A-Za-z][a-z]*)|([Hh][1-6]))$/;
	Carp::croak("Undefined function") unless grep { lc $func eq $_ } @elements;
	my $sub = *{$func} = _mksub($func);
	return $sub->(@_);
}

sub DESTROY {} # not AUTOLOAD

# Thanks to AUTOLOAD, UNIVERSAL::can is a little broken here, so instead
# we define out own can.
sub can
{
	my ($class, $func) = @_;

	my $answer = UNIVERSAL::can(__PACKAGE__, $func)
		|| __PACKAGE__->SUPER::can($func);
	return $answer if $answer;

	if ($func =~ /^(([A-Za-z][a-z]*)|([Hh][1-6]))$/
	and grep { lc $func eq $_ } @elements)
	{
		return _mksub($func);
	}

	return;
}

sub TEXT
{
	shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);
	return XML::LibXML::TextNode->new($_[0]);
}

sub COMMENT
{
	shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);
	return XML::LibXML::Comment->new($_[0]);
}

{
	my $parser = undef;
	sub CHUNK
	{
		shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);

		unless ($parser)
		{
			eval 'use HTML::HTML5::Parser; 1;'
				or Carp::croak("This feature requires HTML::HTML5::Parser.\n");
			$parser = HTML::HTML5::Parser->new;
		}

		my $dom  = $parser->parse_string($_[0]);
		my @kids = $dom->getElementsByTagName('body')->shift->childNodes;
		return @kids;
	}
}

{
	my $parser = undef;
	sub XML_CHUNK
	{
		shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);

		unless ($parser)
		{
			$parser = XML::LibXML->new;
		}

		my $dom  = $parser->parse_balanced_chunk($_[0]);
		my @kids = $dom->childNodes;
		return @kids;
	}
}

{
	my $dummyDoc = XML::LibXML::Document->new;
	sub RAW_CHUNK
	{
		shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);
		return $dummyDoc->createPI('decode', HTML::HTML5::Entities::encode_numeric($_[0]));
	}
}

sub _find_version
{
	my ($req, @versions) = @_;

	return $versions[-1] unless defined $req;

	my $requested = do {
		my ($maj, $min, $rev) = split /\./, $req;
		($maj||0)*1_000_000 + ($min||0)*1_000 + ($rev||0);
		};
	foreach my $v (@versions)
	{
		my $thisver = do {
			my ($maj, $min, $rev) = split /\./, $v;
			($maj||0)*1_000_000 + ($min||0)*1_000 + ($rev||0);
			};
		if ($thisver >= $requested)
		{
			return $v;
		}
	}
	return $req;
}

sub JQUERY
{
	shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);
	my (%opts) = (scalar @_==1) ? (-version => $_[0]) : @_;
	my @rv;

	my $templates = {
		official => {
			jQuery     => 'http://code.jquery.com/jquery-%s.%s',
			jQuery_v   => '1.2.1, 1.2.2, 1.2.3, 1.2.4, 1.2.5, 1.2.6, 1.3.0, 1.3.1, 1.3.2, 1.4.0, 1.4.1, 1.4.2, 1.4.3, 1.4.4, 1.5.0, 1.5.1, 1.5.2, 1.6.0, 1.6.1, 1.6.2, 1.6.3, 1.6.4',
			jQueryUI   => 'http://code.jquery.com/ui/%s/jquery-ui.%s',
			jQueryUI_v => '1.7.0, 1.7.1, 1.7.2, 1.7.3, 1.8.0, 1.8.1, 1.8.2, 1.8.4, 1.8.5, 1.8.6, 1.8.7, 1.8.8, 1.8.9, 1.8.10, 1.8.11, 1.8.12, 1.8.13, 1.8.14, 1.8.15, 1.8.16',
			Style      => 'http://code.jquery.com/ui/%s/themes/%s/jquery-ui.css',
			Themes     => 'base black-tie blitzer cupertino dark-hive dot-luv eggplant excite-bike flick hot-sneaks humanity le-frog mint-choc overcast pepper-grinder redmond smoothness south-street start sunny swanky-purse trontastic ui-darkness ui-lightness vader',
			},
		google    => {
			jQuery     => 'https://ajax.googleapis.com/ajax/libs/jquery/%s/jquery.%s',
			jQuery_v   => '1.2.3, 1.2.6, 1.3.0, 1.3.1, 1.3.2, 1.4.0, 1.4.1, 1.4.2, 1.4.3, 1.4.4, 1.5.0, 1.5.1, 1.5.2, 1.6.0, 1.6.1, 1.6.2, 1.6.3, 1.6.4',
			jQueryUI   => 'https://ajax.googleapis.com/ajax/libs/jqueryui/%s/jquery-ui.%s',
			jQueryUI_v => '1.5.2, 1.5.3, 1.6.0, 1.7.0, 1.7.1, 1.7.2, 1.7.3, 1.8.0, 1.8.1, 1.8.2, 1.8.4, 1.8.5, 1.8.6, 1.8.7, 1.8.8, 1.8.9, 1.8.10, 1.8.11, 1.8.12, 1.8.13, 1.8.14, 1.8.15, 1.8.16',
			Style      => 'http://ajax.googleapis.com/ajax/libs/jqueryui/%s/themes/%s/jquery-ui.css',
			Themes     => 'base black-tie blitzer cupertino dark-hive dot-luv eggplant excite-bike flick hot-sneaks humanity le-frog mint-choc overcast pepper-grinder redmond smoothness south-street start sunny swanky-purse trontastic ui-darkness ui-lightness vader',
			},
		microsoft => {
			jQuery     => 'http://ajax.aspnetcdn.com/ajax/jquery/jquery-%s.%s',
			jQuery_v   => '1.3.2, 1.4, 1.4.1, 1.4.2, 1.4.3, 1.4.4, 1.5, 1.5.1, 1.5.2, 1.6, 1.6.1, 1.6.2, 1.6.3, 1.6.4',
			jQueryUI   => 'http://ajax.aspnetcdn.com/ajax/jquery.ui/%s/jquery-ui.%s',
			jQueryUI_v => '1.8.5, 1.8.6, 1.8.7, 1.8.8, 1.8.9, 1.8.10, 1.8.11, 1.8.12, 1.8.13, 1.8.14, 1.8.15, 1.8.16',
			Style      => 'http://ajax.aspnetcdn.com/ajax/jquery.ui/%s/themes/%s/jquery-ui.css',
			Themes     => 'base black-tie blitzer cupertino dark-hive dot-luv eggplant excite-bike flick hot-sneaks humanity le-frog mint-choc overcast pepper-grinder redmond smoothness south-street start sunny swanky-purse trontastic ui-darkness ui-lightness vader',
			},
		};
	my $template = $templates->{ lc $opts{-source}||'google' } || $templates->{'google'};

	my @jquery_versions = split /\s*\,\s*/, $template->{jQuery_v};
	my $url = sprintf($template->{jQuery},
		_find_version($opts{-version}, @jquery_versions),
		(!defined $opts{-min} or $opts{-min})?'min.js':'js',
		);
	push @rv, script(
		-type  => 'text/javascript',
		-src   => $url,
		);

	if ((defined $opts{-ui} or defined $opts{-ui_version} or defined $opts{-theme})
	and not (defined $opts{-ui} and !$opts{-ui}))
	{
		my @jqueryui_versions = split /\s*\,\s*/, $template->{jQueryUI_v};
		my $url = sprintf($template->{jQueryUI},
			_find_version($opts{-ui_version}, @jqueryui_versions),
			(!defined $opts{-min} or $opts{-min})?'min.js':'js',
			);
		push @rv, script(
			-type  => 'text/javascript',
			-src   => $url,
			);

		if (defined $opts{-theme})
		{
			my $theme = $opts{-theme};
			$theme = 'base' unless $template->{Themes} =~ /\b$theme\b/;

			my $url = sprintf($template->{Style},
				_find_version($opts{-ui_version}, @jqueryui_versions),
				$theme,
				);
			push @rv, Link(
				-rel   => 'stylesheet',
				-media => 'screen',
				-type  => 'text/css',
				-src   => $url,
				);
		}
	}

	return wantarray ? @rv : XML::LibXML::NodeList->new_from_ref(\@rv, 1);
}

sub CREATIVE_COMMONS
{
	shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);
	my (%opts) = (scalar @_==1) ? (-licence => $_[0]) : @_;
	$opts{-licence} ||= delete $opts{-license}; # be kind to Americans
	$opts{-licence} ||= 'by-sa';
	my @rv;

	if (warnings::enabled())
	{
		Carp::carp("Unknown licence")
			unless lc $opts{-licence} =~ /^by(-(sa|nd|nc|nc-sa|nc-nd))?$/;
	}

	my $size = {
		'small'  => '80x15',
		'large'  => '88x31',
		'80x15'  => '80x15',
		'88x31'  => '88x31',
		}->{ lc $opts{-size} || 'large' } || '88x31';

	push @rv, a(
		-rel   => 'license',
		-href  => sprintf("http://creativecommons.org/licenses/%s/3.0/", lc $opts{-licence}),
		img(
			-alt   => ($opts{-alt} || sprintf("Creative Commons %s Licence", uc $opts{-licence})),
			-style => 'border:0',
			-src   => sprintf("http://i.creativecommons.org/l/%s/3.0/%s.png", lc $opts{-licence}, $size),
			),
		);

	if (defined $opts{-attributionName}
	or  defined $opts{-attributionURL}
	or  defined $opts{-type}
	or  defined $opts{-title})
	{
		my ($this_work, $attribution);
		push @rv, br(), span(
			span(\$this_work, $opts{-title}||'This work'),
			defined $opts{-attributionName} ? [' by ', span(\$attribution, -property=>'cc:attributionName', [$opts{-attributionName}])] : [],
			' is licensed under a ',
			a(
				-rel   => 'license',
				-href  => sprintf("http://creativecommons.org/licenses/%s/3.0/", lc $opts{-licence}),
				[$opts{-alt} || sprintf("Creative Commons %s Licence", uc $opts{-licence})],
				),
			);

		if (defined $opts{-title})
		{
			$this_work->setAttribute(property => 'dc:title');
		}
		if (defined $opts{-type} and length $opts{-type})
		{
			$this_work->setAttribute(rel      => 'dc:type');
			$this_work->setAttribute(resource => sprintf('http://purl.org/dc/dcmitype/%s', ucfirst lc $opts{-type}));
		}
		if (defined $attribution and defined $opts{-attributionURL})
		{
			$this_work->setAttribute(rel      => 'cc:attributionURL');
			$this_work->setAttribute(resource => $opts{-attributionURL});
		}
	}

	return span(@rv,
		-class=>'creative_commons',
		(defined $opts{-url} ? { -about => $opts{-url} } : {}),
		);
}

sub OPENGRAPH
{
	shift if blessed($_[0]) && $_[0]->isa(__PACKAGE__);
	my (%opts) = (scalar @_==1) ? %{$_[0]} : @_;

	my $map = {
		title       => 'og:title dc:title',
		url         => 'og:url dc:identifier',
		description => 'og:description dc:description',
		};

	my @rv;
	while (my ($key, $value) = each %opts)
	{
		$key = lc $key;
		$key =~ s/^-//;

		push @rv, Meta(-property => ($map->{$key}||sprintf('og:%s', $key)), -content => $value);
	}

	return wantarray ? @rv : XML::LibXML::NodeList->new_from_ref(\@rv, 1);
}

1;

__END__