#!/usr/bin/perl
package TUWF::XML;
use strict;
use warnings;
use Exporter 'import';
use Carp 'carp', 'croak';
our $VERSION = '1.3';
our(@EXPORT_OK, %EXPORT_TAGS, $OBJ);
# List::Util provides a uniq() since 1.45, but for some reason my Perl comes
# with an even more ancient version.
sub uniq { my %h = map +($_,1), @_; keys %h }
BEGIN {
my @htmltags = 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 h1 h2 h3 h4 h5 h6
head i img input ins kbd label legend li Link Map meta noscript object ol
optgroup option p param pre Q samp script Select small span strong style Sub
sup table tbody td textarea tfoot th thead title Tr tt ul var
|;
my @html5tags = 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 i iframe img input ins kbd label legend li Link
main Map mark meta meter nav noscript object ol optgroup option output p
param pre progress Q rp rt ruby samp script section Select small source
span strong style Sub sup table tbody td textarea tfoot th thead Time title
Tr ul var video
|;
my @Htmltags = map ucfirst, @htmltags;
my @Html5tags = map ucfirst, @html5tags;
my @html_tags = map lc($_).'_', @htmltags;
my @html5_tags = map lc($_).'_', @html5tags;
my @all = uniq @htmltags, @html5tags, @Htmltags, @Html5tags, @html_tags, @html5_tags;
# boolean/empty/self-closing tags
my %htmlbool = map +($_,1), qw{
area base br col command embed hr img input link meta param source
};
# create the subroutines to map to the html tags
no strict 'refs';
for my $e (@all) {
(my $le = lc $e) =~ s/_$//;
*{__PACKAGE__."::$e"} = sub {
my $s = ref($_[0]) eq __PACKAGE__ ? shift : $OBJ;
$s->tag($le, @_, $htmlbool{$le} && $#_%2 ? undef : ());
}
}
# functions to export
@EXPORT_OK = (@all, qw(
xml mkclass xml_escape html_escape
tag html lit txt end
Tag Html Lit Txt End
tag_ html_ lit_ txt_ end_
));
%EXPORT_TAGS = (
html => [ @htmltags, qw(tag html lit txt end ) ],
html5 => [ @html5tags, qw(tag html lit txt end ) ],
Html => [ @Htmltags, qw(Tag Html Lit Txt End ) ],
Html5 => [ @Html5tags, qw(Tag Html Lit Txt End ) ],
html_ => [ @html_tags, qw(tag_ html_ lit_ txt_ end_) ],
html5_=> [ @html5_tags, qw(tag_ html_ lit_ txt_ end_) ],
xml => [ qw(xml tag lit txt end) ],
);
};
# the common (X)HTML doctypes, from http://www.w3.org/QA/2002/04/valid-dtd-list.html
my %doctypes = split /\r?\n/, <<__;
xhtml1-strict
xhtml1-transitional
xhtml1-frameset
xhtml11
xhtml-basic11
xhtml-math-svg
html5
__
sub new {
my($pack, %o) = @_;
$o{write} ||= sub { print @_ };
my $self = bless {
%o,
nesting => 0,
stack => [],
}, $pack;
$OBJ = $self if $o{default};
return $self;
};
# Convenient function to generate a dynamic class attribute.
sub mkclass {
my %c = @_;
my $c = join ' ', grep $c{$_}, keys %c;
return $c ? (class => $c) : ();
}
# XML escape (not a method)
my %XML = qw/& & < < " "/;
sub xml_escape {
local $_ = $_[0];
if(!defined $_) {
carp "Attempting to XML-escape an undefined value";
return '';
}
s/([&<"])/$XML{$1}/g;
$_;
}
# HTML escape, also does \n to
conversion
# (not a method)
sub html_escape {
local $_ = xml_escape shift;
s/\r?\n/
/g;
return $_;
}
# output literal data (not HTML escaped)
sub lit {
my $s = ref($_[0]) eq __PACKAGE__ ? shift : $OBJ;
$s->{write}->($_) for @_;
}
*Lit = \&lit;
*lit_ = \&lit;
# output text (HTML escaped)
sub txt {
my $s = ref($_[0]) eq __PACKAGE__ ? shift : $OBJ;
$s->lit(xml_escape $_) for @_;
}
*Txt = \&txt;
*txt_ = \&txt;
# Output any XML or HTML tag.
# Arguments Output
# 'tagname'
# 'tagname', id => "main"
# 'tagname', '' <bar>
# 'tagname', sub { .. } ..
# 'tagname', id => 'main', '' <bar>
# 'tagname', id => 'main', sub { .. } ..
# 'tagname', id => 'main', undef
# 'tagname', undef
sub tag {
my $s = ref($_[0]) eq __PACKAGE__ ? shift : $OBJ;
my $name = shift;
croak "Invalid XML tag name" if !$name || $name =~ /^[^a-z]/i || $name =~ / /;
my $indent = $s->{pretty} ? "\n".(' 'x($s->{nesting}*$s->{pretty})) : '';
my $t = $indent.'<'.$name;
while(@_ > 1) {
my $attr = shift;
croak "Invalid XML attribute name" if !$attr || $attr =~ /^[^a-z]/i || $attr =~ / /;
$t .= qq{ $attr="}.xml_escape(shift).'"';
}
if(!@_) {
$s->lit($t.'>');
push @{$s->{stack}}, $name;
$s->{nesting}++;
} elsif(!defined $_[0]) {
$s->lit($t.' />');
} elsif(ref $_[0] eq 'CODE') {
$s->lit($t.'>');
local $s->{nesting} = $s->{nesting}+1;
local $s->{stack} = []; # Call the sub with an empty stack, there's nothing to end() now.
$_[0]->();
$s->lit($indent.''.$name.'>');
} else {
$s->lit($t.'>'.xml_escape(shift).''.$name.'>');
}
}
*Tag = \&tag;
*tag_ = \&tag;
# Ends the last opened tag
sub end {
my $s = ref($_[0]) eq __PACKAGE__ ? shift : $OBJ;
my $w = shift;
my $l = pop @{$s->{stack}};
$s->{nesting}--;
croak "No more tags to close" if !$l;
croak "Specified tag to end ($w) is not equal to the last opened tag ($l)" if $w && $w ne $l;
$s->lit("\n".(' 'x($s->{nesting}*$s->{pretty}))) if $s->{pretty};
$s->lit(''.$l.'>');
}
*End = \&end;
*end_ = \&end;
sub html {
my $s = ref($_[0]) eq __PACKAGE__ ? shift : $OBJ;
my $hascontent = @_ % 2 == 1;
my $c = $hascontent && pop;
my %o = @_;
my $doctype = delete $o{doctype} || 'html5';
$s->lit($doctypes{$doctype}."\n");
my $lang = delete $o{lang};
$s->tag('html',
# html5 has no 'xmlns' or 'xml:lang'
$doctype eq 'html5' ? (
$lang ? (lang => $lang) : (),
) : (
xmlns => 'http://www.w3.org/1999/xhtml',
$lang ? ('xml:lang' => $lang, lang => $lang) : (),
),
%o,
$hascontent ? ($c) : ()
);
}
*Html = \&html;
*html_ = \&html;
# Writes an xml header, doesn't open an tag, and doesn't need an
# end() either.
sub xml() {
my $s = ref($_[0]) eq __PACKAGE__ ? shift : $OBJ;
$s->lit(qq||);
}
1;