File Coverage

blib/lib/TUWF/XML.pm

Criterion	Covered	Total	%
statement	86	107	80.3
branch	26	54	48.1
condition	6	19	31.5
subroutine	15	21	71.4
pod	11	12	91.6
total	144	213	67.6

#!/usr/bin/perl


package TUWF::XML;


use strict;
use warnings;
use Exporter 'import';
use Carp 'carp', 'croak';


our $VERSION = '1.5';
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 summary 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 xml_string
    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 $_;
}

# Evaluate a function and return XML as a string
sub xml_string {
  my $f = pop;
  my $buf = '';
  local $OBJ = TUWF::XML->new(@_, write => sub { $buf .= shift });
  $f->();
  $buf
}


# 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', class => undef
#  'tagname', '+a' => 1, '+a' => 2
#  '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;
  my %concat;
  while(@_ > 1) {
    my $attr = shift;
    my $val = shift;
    next if !defined $val;
    croak "Invalid XML attribute name" if $attr =~ /[\s'"&<>=]/; # Not comprehensive, just enough to prevent XSS-by-fucking-up-XML-structure
    if($attr =~ /^\+(.+)/) {
      $concat{$1} .= (length $concat{$1} ? ' ' : '') . $val;
    } else {
      $t .= qq{ $attr="}.xml_escape($val).'"';
    }
  }
  $t .= qq{ $_="}.xml_escape($concat{$_}).'"' for sort keys %concat;

  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.'');
  } else {
    $s->lit($t.'>'.xml_escape(shift).'');
  }
}

*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('');
}

*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;