File Coverage

blib/lib/XML/XForms/Validate.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package XML::XForms::Validate;

use 5.008;
use strict;
use warnings;
our $VERSION = '0.9';

use XML::LibXML;
use XML::LibXML::XPathContext;
use XML::Schema::Type::Builtin;
use Time::Piece;
use Time::Seconds;

use fields qw(base model refs instances submissions parser schemas binds);
use constant NSURI_XF => 'http://www.w3.org/2002/xforms';
use constant NSURI_XSD => 'http://www.w3.org/2001/XMLSchema-datatypes';
use constant NSURI_XSI => 'http://www.w3.org/2001/XMLSchema-instance';
use constant NSURI_XS => 'http://www.w3.org/2001/XMLSchema';
use constant NSURI_XI => 'http://www.w3.org/2001/XInclude';
use Exporter qw(import);
our @EXPORT_OK = qw(&validate &normalize);

# General-purpose globals. Each object uses specialized private instances as well.
my $parser = new XML::LibXML;

my $xpc = new XML::LibXML::XPathContext(new XML::LibXML::Document());
$xpc->registerNs('xf', NSURI_XF);

my $cbs = new XML::LibXML::InputCallback();
$cbs->register_callbacks([ sub {die}, sub {die}, sub {die}, sub {die} ]);

my $doc = new XML::LibXML::Document();

sub normalize {
	shift if UNIVERSAL::isa($_[0],'XML::XForms::Validate');
	my ($dom, $noclean) = @_;
	return $dom if !ref($dom);
	my $parser = new XML::LibXML(ext_ent_handler => sub {die});
	$parser->validation(0);
	$parser->load_ext_dtd(0);
	$parser->expand_xinclude(0);
	$parser->expand_entities(0);
	$parser->input_callbacks($cbs);
	$parser->clean_namespaces(1);
	$parser->no_network(1);
	$dom = { '' => $dom } if ref($dom) ne 'HASH';
	my $result = { };
	foreach my $id (keys %$dom) {
		my $old = $$dom{$id};
		$old = $old->documentElement if $old->can('documentElement');
		my $new = $parser->parse_string($old->toStringC14N(0));
		normalizeRecursive($new->documentElement, $noclean, {});
		$$result{$id} ||= $parser->parse_string($new->documentElement->toStringC14N(0));
		$$result{''} = $$result{$id} if ($id ne '' && $$dom{$id} eq $$dom{''});
	}

	return (ref($_[0]) eq 'HASH'?$result:$$result{''});
}

my %allowed = map { (eval('&XML_'.$_.'_NODE') => 1) } qw(ELEMENT ATTRIBUTE TEXT);
$allowed{&XML_NAMESPACE_DECL} = 1;
sub normalizeRecursive {
	my ($parent, $noclean, $usedns) = @_;

	my %newns;
	$newns{($parent->prefix||'').'='.($parent->namespaceURI||'')} = 1;
	foreach my $attr ($parent->attributes) {
		next if !$attr || $attr->nodeType == XML_NAMESPACE_DECL;
		$newns{($attr->prefix||'').'='.($attr->namespaceURI||'')} = 1;
	}

	foreach my $node ($parent->childNodes) {
		if ($allowed{$node->nodeType} && ($node->namespaceURI||'') ne NSURI_XI) {
			normalizeRecursive($node, \%newns);
		} else {
			$parent->removeChild($node);
		}
	}

	if (!$noclean) {
		foreach my $ns ($parent->getNamespaces) {
			my $prefix = $ns->nodeName || '';
			$prefix =~ s/^xmlns:?//;
			next if delete $newns{$prefix.'='.($ns->nodeValue||'')};
			$parent->setNamespaceDeclURI($prefix, undef);
		}
		%$usedns = (%$usedns, %newns);
	}
}

sub new {
	my XML::XForms::Validate $self = shift;
	$self = fields::new($self) unless (ref $self);

	$self->{parser} = new XML::LibXML();
	$self->{parser}->no_network(1);
	$self->{parser}->input_callbacks($cbs);
	$self->{parser}->{ext_ent_handler} = sub { die };
	$self->{parser}->clean_namespaces(1);
	$self->{parser}->expand_xinclude(0);
	$self->{parser}->validation(0);
	$self->{parser}->load_ext_dtd(0);
	$self->{parser}->no_network(1);

	my %options = @_;
	my ($xforms, $model, $base) = @options{'xforms', 'model', 'base'};
	$xforms = $self->getDom($xforms, $base);

	my $default;
	my ($id, $node);
	foreach my $m ($xpc->findnodes('//xf:model', $xforms)) {
		$id = $m->getAttribute('id');
		$id = '' if !defined $id;
		$default = $id if !defined $default;
		next if defined $model && $model ne $id;
		$self->{model} = $m;
		$model = $id;
		last;
	}

	my $anon = 0;
	$self->processBinds($self->{model}, [], $anon);

	$self->{refs} = [];
	$self->processRefs($xpc->findnodes('/*[1]', $xforms), [], $model, $default);

	if (!$xpc->findnodes('./xf:instance', $self->{model})) {
		my $instelt = $xforms->createElementNS(NSURI_XF, 'xf:instance');
		$self->{model}->addChild($instelt);
		$node = $xforms->createElement('instanceData');
		$instelt->addChild($node);

		foreach my $ui (@{$self->{refs}}) {
			next unless @$ui == 1;
			$node->addChild($xforms->createElement($$ui[0]));
		}
	}

	$self->{instances} = {};
	$self->{schemas} = {};
	foreach my $instance ($xpc->findnodes('./xf:instance', $self->{model})) {
		$id = $instance->getAttribute('id');
		$id = '' if !defined $id;
		if (defined (my $link = $instance->getAttribute('src'))) {
			$node = $self->{parser}->parse_file($link);
		} else {
			($node) = $xpc->findnodes('./*', $instance);
			$node = $self->{parser}->parse_string($node->toStringC14N());
		}
		$node = $node->documentElement();
		$self->{instances}{$id} ||= $node;
		$self->{instances}{''} ||= $node;

		my %loc;
		my $loc;
		$loc = $node->getAttributeNS(NSURI_XSI, 'schemaLocation');
		%loc = split(/\s+/, $loc) if $loc;
		$loc = $node->getAttributeNS(NSURI_XSI, 'noNamespaceSchemaLocation');
		$loc{''} = $loc if $loc;
		my $nsuri = $node->namespaceURI || '';
		$self->{schemas}{$id} = new XML::LibXML::Schema(location => $loc{$nsuri})
			if exists $loc{$nsuri};
	}

	$self->{submissions} = {};
	foreach my $s ($xpc->findnodes('./xf:submission', $self->{model})) {
		$id = $s->getAttribute('id');
		next unless defined $id && !$self->{submissions}{$id};
		$self->{submissions}{$id} = { id => $id };
		if (my $b = $s->getAttribute('bind')) {
			die "Invalid XForms document: referenced bind \"$b\" not found" unless exists $self->{binds}{$b};
			$self->{submissions}{$id}{'ref'} = [ @{$self->{binds}{$s->getAttribute('bind')}{nodeset}} ];
		} else {
			$self->{submissions}{$id}{'ref'} = [ $s->getAttribute('ref') || '/' ];
		}
		$self->{submissions}{''} = $self->{submissions}{$id} unless $self->{submissions}{''};
	}
	die "submission element is missing in model $model" unless %{$self->{submissions}};

	return $self;
}

sub getDom {
	my XML::XForms::Validate $self = shift;
	my ($data, $base) = @_;

	if (@_ == 2) {
		$self->{parser}->base_uri($base);
		$self->{base} = $base;
	}

	if (!ref($data)) {
		if (@_ == 2 && !defined $base) {
			$self->{parser}->base_uri($data);
			$self->{base} = $data;
		}
		$data = $parser->parse_file($data);
	} elsif (UNIVERSAL::isa($data, 'GLOB')) {
		$data = $parser->parse_fh($data, $base);
	} elsif (ref($data) eq 'SCALAR') {
		$data = $parser->parse_string($$data, $base);
	}
	die "Not an XML::LibXML DOM" unless UNIVERSAL::isa($data, 'XML::LibXML::Document');

	return $data;
}

my @mips = qw(type readonly required relevant constraint calculate p3ptype);
sub processBinds {
	my XML::XForms::Validate $self = shift;
	my $node = shift;
	my $context = shift;
	for my $anon ($_[0]) {
		foreach my $b ($xpc->findnodes('./xf:bind', $node)) {
			my $id = $b->getAttribute('id');
			$id = ' '.($anon++) unless defined $id;
			next if $self->{binds}{$id} || !$b->getAttribute('nodeset');
			my $ctx = [ @$context, $b->getAttribute('nodeset') ];
			$self->{binds}{$id} = { nodeset => $ctx, id => $id, node => $b };
			foreach my $a (@mips) {
				$self->{binds}{$id}{$a} = $b->getAttribute($a) if $b->getAttribute($a);
			}
			$self->processBinds($b, $ctx, $anon);
		}
	}
}

my %formControls = map {$_=>1} qw(input secret textarea output upload range submit select select1 setvalue);
sub processRefs {
	my XML::XForms::Validate $self = shift;
	my ($node, $context, $model, $default) = @_;

	foreach my $ui ($node->childNodes) {
		next unless $ui->isa('XML::LibXML::Element');
		my $ctx = $context;
		my $newdefault = $default;

		if (($ui->namespaceURI||'') eq NSURI_XF) {
			my $id = $ui->localName eq 'model'?($ui->getAttribute('id')||''):($ui->getAttribute('model')||$default);
			next if $id ne $model || $ui->localName eq 'instance';
			$newdefault = $id;
			my @expr;
			if (my $b = $ui->getAttribute('bind')) {
				die "Invalid XForms document: referenced bind \"$b\" not found" unless exists $self->{binds}{$b};
				@expr = @{$self->{binds}{$b}{'nodeset'}}
			}
			$expr[0] ||= $ui->getAttribute('nodeset');
			$expr[0] ||= $ui->getAttribute('ref');

			if (defined $expr[0]) {
				$ctx = [ @$context, @expr ];
				push @{$self->{refs}}, $ctx if exists $formControls{$ui->localName};
			}
		}
		$self->processRefs($ui, $ctx, $model, $newdefault);
	}
}

use Carp qw(cluck);
sub findNodes {
	my XML::XForms::Validate $self = shift;
	my ($expr, $context, $xpath) = @_;
	cluck("undef") if !$expr;
	my @expr = @$expr;
	my $last = pop @expr;
	foreach my $e (@expr) {
		($context) = $xpath->findnodes($e, $context);
	}
	my @nodes = $xpath->findnodes($last, $context);
	return @nodes;
}

sub findBoolean {
	my XML::XForms::Validate $self = shift;
	my ($expr, $context, $xpath) = @_;
	return $xpath->find("boolean($expr)", $context) && 1;
}

sub getInput {
	my XML::XForms::Validate $self = shift;
	my ($input, $orig, $submission) = @_;

	my $dom = {};
	foreach my $key (keys %{$orig}) {
		$$dom{$key} ||= $self->{parser}->parse_string($$orig{$key}->toString())->documentElement();
		$$dom{''} = $$dom{$key} if $key ne '' && $$orig{$key} eq $$orig{''};
	}

	my $ixpc = makeXPathContext(sub {
		my ($id) =  @_;
		my $result = XML::LibXML::NodeList->new;
		$result->push($$dom{$id});
		return $result;
	});

	my ($node) = $self->findNodes($submission, $$dom{''}, $ixpc);

	if (ref($input) eq 'HASH') {
		my @values;
		while (my ($key, $vals) = each %$input) {
			push @values, map { $key => $_ } (ref($vals)?@$vals:$vals);
		}
		$input = \@values;
	}

	if (ref($input) eq 'ARRAY') {
		my %pos;
		while (@$input) {
			my $key = shift @$input;
			my $val;
			if (ref($key)) { ($key, $val) = @$key; }
			else { $val = shift @$input }
			($key) = $key =~ m/([a-zA-Z0-9:_-]*)/; # FIXME: QName.
			my $pos = ++$pos{$key};
			my ($node) = $xpc->findnodes(".//*[local-name() = '${key}' and not(*)][$pos]", $node);
			$node->removeChildNodes();
			$node->appendTextNode($val);
		}
	} else {
		my $parent = $node->parentNode();
		if (!$parent) {
			$parent = $self->{parser}->parse_string($self->getDom($input)->documentElement()->toStringC14N());
			foreach my $key (keys %$dom) {
				$$dom{$key} = $parent->documentElement if ${$$dom{$key}->ownerDocument} eq ${$node->ownerDocument};
			}
			$node = $parent;
		} else {
			my $new = $self->{parser}->parse_balanced_chunk($self->getDom($input)->documentElement()->toStringC14N())->firstChild;
			$parent->replaceChild($new, $node);
			$node = $new;
		}
	}

	return ($dom, $node);
}

sub makeNodeName {
	my ($node) = @_;
	my $name = $node->nodeName;
	$name = '' if !defined $name;
	return '' if $name =~ m/^xmlns/;
	$name =~ s/^[^:]*://;
	my $ns = $node->namespaceURI();
	$ns = (defined $ns?"{$ns}":"");
	return $ns.$name;
}

sub checkTreeRecursive {
	my XML::XForms::Validate $self = shift;
	my ($new, $orig, $added) = @_;

	my $path = $new->nodePath;
	my $ndoc = $new->ownerDocument;

	my $nname = makeNodeName($new);
	my $oname = makeNodeName($orig);
	return "Original node \"$oname\" doesn't match \"$nname\" ($path)"
		if $nname ne $oname;

	my @added;

	my %nattr = map { (makeNodeName($_) => $_) } $new->attributes;
	my %oattr = map { (makeNodeName($_) => $_) } $orig->attributes;
	delete $nattr{''};
	delete $oattr{''};
	foreach my $attr (keys %oattr) {
		delete $nattr{$attr}, next if exists $nattr{$attr};
		$new->setAttributeNS($oattr{$attr}->namespaceURI, $oattr{$attr}->nodeName, $oattr{$attr}->nodeValue);
		my $clone = $new->getAttributeNodeNS($oattr{$attr}->namespaceURI, $oattr{$attr}->nodeName);
		push @added, $clone;
	}

	return "Additional attributes found: ".join(", ", keys %nattr)." ($path)"
		if %nattr;

	my @nelem = grep { $_->isa('XML::LibXML::Element') } $new->childNodes;
	my @oelem = grep { $_->isa('XML::LibXML::Element') } $orig->childNodes;
	my $firstmsg;
	my $lastmsg;
	while (@oelem) {
		last if !@nelem;
		my $nnext = $nelem[0];
		my $onext = shift @oelem;
		my $msg = $self->checkTreeRecursive($nnext, $onext, \@added);
		$firstmsg = undef, shift @nelem, next if !$msg;
		my $clone = $self->{parser}->parse_balanced_chunk($onext->toString())->firstChild;
		$new->insertBefore($clone, $nelem[0]);
		$new->insertAfter($new->ownerDocument->createTextNode(''), $clone) if $onext->nextSibling->nodeType == XML_TEXT_NODE;
		push @added, $clone;
		$firstmsg ||= $msg;
	}

	push(@$added, @added), return undef if !@nelem && !@oelem;

	$_->parentNode->removeChild($_) foreach @added;
	$firstmsg ||= "Additional child elements found: ".join(", ", map { $_->nodeName } @nelem)." ($path)" if @nelem;
	$firstmsg ||= "Child elements missing: ".join(", ", map { $_->nodeName } @oelem)." ($path)" if @oelem;

	return $firstmsg;
}

sub hasParents {
	my ($child, $parents) = @_;
	my $test = $child;
	do {
		return 1 if exists $$parents{${$test}};
	} while ($test = $test->parentNode);
	return 0;
}

sub checkTree {
	my XML::XForms::Validate $self = shift;
	my ($new, $orig, $ixpc, $oxpc, $subtree) = @_;

	my $added = [];
	foreach my $key (keys %$orig) {
		my $result = $self->checkTreeRecursive($$new{$key}, $$orig{$key}, $added);
		return $result if $result;
	}

	$added = { map { ${$_} => $_ } @$added };
	my %leftover = %$added;
	foreach my $bind (values %{$self->{binds}}) {
		next if !exists $$bind{relevant};
		foreach my $node ($self->findNodes($$bind{nodeset}, $$new{''}, $ixpc)) {
			next if $self->findBoolean($$bind{relevant}, $node, $ixpc);
			my $deleted = delete $leftover{${$node}};
			next if hasParents($node, $added) || !hasParents($node, $subtree);
			return "Submission contains non-relevant node: ".$node->nodePath if !$deleted;
		}
	}

	foreach my $rest (values %leftover) {
		delete $$added{${$rest}};
		delete $leftover{${$rest}} if hasParents($rest, $added);
		$$added{${$rest}} = $rest;
	}
	return "Missing relevant nodes: ".join(", ", map { $_->nodePath } values %leftover) if %leftover;

	return undef;
}

sub checkReadonlyRecursive {
	my XML::XForms::Validate $self = shift;
	my ($new, $orig, $nrw, $orw) = @_;

	my %nattr = map { (makeNodeName($_) => $_) } $new->attributes;
	my %oattr = map { (makeNodeName($_) => $_) } $orig->attributes;
	delete $nattr{''};
	delete $oattr{''};
	foreach my $attr (keys %oattr) {
		next if exists $$nrw{${$nattr{$attr}}} || exists $$orw{${$oattr{$attr}}};
		$nattr{$attr}->setValue($oattr{$attr}->getValue());
	}

	my @nelem = grep { $_->isa('XML::LibXML::Element') } $new->childNodes;
	my @oelem = grep { $_->isa('XML::LibXML::Element') } $orig->childNodes;
	while (@oelem) {
		my $nnext = shift @nelem;
		my $onext = shift @oelem;
		if (!exists $$nrw{${$nnext}} && !exists $$orw{${$onext}}) {
			my ($ntext) = $nnext->findnodes('./text()[1]');
			my ($otext) = $onext->findnodes('./text()[1]');
			$otext = ($otext?$otext->nodeValue:'');
			if (!$ntext) {
				$ntext = $nnext->appendText($otext);
			} else {
				$ntext->setData($otext);
			}
		}
		my $result = $self->checkReadonlyRecursive($nnext, $onext, $nrw, $orw);
		return $result if $result;
	}

	@nelem = grep { $_->isa('XML::LibXML::Text') } $new->childNodes;
	@oelem = grep { $_->isa('XML::LibXML::Text') } $orig->childNodes;
	while (@oelem) {
		my $nnext = shift @nelem;
		my $onext = shift @oelem;
		if (!$nnext) {
			my $val = $onext->nodeValue;
			$val =~ s/^\s*|\s*$//g;
			return "Text node missing for ".$onext->nodePath if length($val) && !exists $$orw{${onext}};
			$new->appendText('') if exists $$orw{${onext}};
			next;
		}
		next if exists $$nrw{${$nnext}} || exists $$orw{${$onext}};
		$nnext->setData($onext->nodeValue);
	}
	foreach my $node (@nelem) {
		$new->removeChild($node) unless exists $$nrw{${$node}};
	}

	return undef;
}

sub setRW {
	my ($rw, $n) = @_;
	if ($n) {
		$$rw{${$n}} = $n;
		($n) = $n->findnodes('./text()[1]');
		$$rw{${$n}} = $n if $n;
	}
}

sub checkReadonly {
	my XML::XForms::Validate $self = shift;
	my ($new, $orig, $ixpc, $oxpc, $subtree) = @_;

	my %nrw;
	my %orw;
	foreach my $expr (@{$self->{refs}}) {
		setRW(\%nrw, $self->findNodes($expr, $$new{''}, $ixpc));
		setRW(\%orw, $self->findNodes($expr, $$orig{''}, $oxpc));
	}

	foreach my $bind (values %{$self->{binds}}) {
		my $ro = $$bind{readonly};
		next if !defined $ro;
		foreach my $node ($self->findNodes($$bind{nodeset}, $$new{''}, $ixpc)) {
			next if defined $ro && !$self->findBoolean($ro, $node, $ixpc);
			delete $nrw{${$_}} foreach $node->findnodes('.|.//*|.//@*|.//text()');
		}
		foreach my $node ($self->findNodes($$bind{nodeset}, $$orig{''}, $oxpc)) {
			next if defined $ro && !$self->findBoolean($ro, $node, $oxpc);
			delete $orw{${$_}} foreach $node->findnodes('.|.//*|.//@*|.//text()');
		}
	}

	foreach my $bind (values %{$self->{binds}}) {
		if (defined $$bind{calculate}) {
			setRW(\%nrw, $_) foreach ($self->findNodes($$bind{nodeset}, $$new{''}, $ixpc));
			setRW(\%orw, $_) foreach ($self->findNodes($$bind{nodeset}, $$orig{''}, $oxpc));
		}
	}

	foreach my $key (keys %$orig) {
		my $result = $self->checkReadonlyRecursive($$new{$key}, $$orig{$key}, \%nrw, \%orw);
		return $result if $result;
	}
}

sub checkBinds {
	my XML::XForms::Validate $self = shift;
	my ($new, $orig, $ixpc, $oxpc, $subtree) = @_;

	foreach my $bind (values %{$self->{binds}}) {
		my ($prefix, $type) = ($$bind{type}||'') =~ m/^(?:([^:]*):)?(.*)$/;
		$prefix ||= '';
		my $calc = $$bind{calculate};
		my $constraint = $$bind{constraint};
		my $required = $$bind{required};
		my $relevant = $$bind{relevant};
		next unless defined $type || defined $calc || defined $constraint || defined $required;

		foreach my $node ($self->findNodes($$bind{nodeset}, $$new{''}, $ixpc)) {
			next if !hasParents($node, $subtree) || (defined $relevant && !$self->findBoolean($relevant, $node, $ixpc));

			my $val = ($node->isa('XML::LibXML::Element')?$node->findvalue('./text()[1]'):$node->nodeValue);
			my $path = $node->nodePath;

			return "Value required for $path" if defined $required
				&& $self->findBoolean($required, $node, $ixpc) && !length($val);
			return "Constraint error for $path ($constraint)" if defined $constraint
				&& !$self->findBoolean($constraint, $node, $ixpc);
			return "Calculation mismatch for $path ($calc): expected \"".$ixpc->findvalue($calc, $node)."\", found \"$val\"" if defined $calc
				&& $ixpc->findvalue($calc, $node) ne $val;

			next unless $type;
			# FIXME: really needs switch to libxm
			my $nsuri = $$bind{node}->lookupNamespaceURI($prefix) || '';
			my $class;
			$class = XML::Schema::Type::Simple->builtin($type) if $nsuri eq NSURI_XSD || $nsuri eq NSURI_XS;
			$class = "XML::XForms::Validate::Type::$type" if $nsuri eq NSURI_XF;
			my $const = UNIVERSAL::can($class, 'new');
			return "Type $prefix:$type unsupported for $path" if !defined $const;
			my $obj = $const->($class);
			return "Could not create object for $path ($type)" if !$obj;
			return "Type mismatch for $path ($type)"
				if !$obj->instance($val);
		}
	}

	return undef;
}

sub checkSchema {
	my XML::XForms::Validate $self = shift;
	my ($new) = @_;

	foreach my $id (keys %{$self->{schemas}}) {
		eval { $self->{schemas}{$id}->validate($$new{$id}->ownerDocument) };
		return "Schema validation failed for instance \"$id\": $@" if $@;
	}
	return undef;
}

sub validate {
	my XML::XForms::Validate $self;
	$self = shift if UNIVERSAL::isa($_[0], 'XML::XForms::Validate');
	my %options = @_;
	if (!$self) {
		$self = new XML::XForms::Validate(xforms => $options{xforms}, model => $options{model}, base => $options{base});
	}

	my $model = $self->{model};

	my $orig = { %{$self->{instances}} };

	if ($options{instance}) {
		$options{instance} = { '' => $options{instance} } if ref($options{instance}) ne 'HASH';
		foreach my $key (keys %{$options{instance}}) {
			my $replaced = $$orig{$key};
			$$orig{$key} = $self->getDom($options{instance}{$key});
			$$orig{''} = $$orig{$key} if $$orig{''} eq $replaced;
		}
	}

	$options{submission} = '' unless defined $options{submission};
	my $subref = $self->{submissions}{$options{submission}}{'ref'};

	my ($new, $subnode) = $self->getInput($options{input}, $orig, $subref);

	my $oxpc = makeXPathContext(sub {
		my ($id) =  @_;
		my $result = XML::LibXML::NodeList->new;
		$result->push($$orig{$id});
		return $result;
	});
	my $ixpc = makeXPathContext(sub {
		my ($id) =  @_;
		my $result = XML::LibXML::NodeList->new;
		$result->push($$new{$id});
		return $result;
	});

	my ($newsub) = $self->findNodes($subref, $$new{''}, $ixpc);
	return "Submission does not match subtree reference (@$subref)"
		if !$newsub || ${$newsub} ne ${$subnode};

	if ($options{schema}) {
		eval { XML::LibXML::Schema->new(location => $options{schema})->validate($subnode) };
		return "Schema validation failed: $@" if $@;
		return $new;
	}

	my $subtree = { ${$subnode} => $subnode };
	my $result = $self->checkTree($new, $orig, $ixpc, $oxpc, $subtree);
	return $result if $result;
	($newsub) = $self->findNodes($subref, $$new{''}, $ixpc);
	return "Submission does not match subtree reference (@$subref) after relevancy processing"
		if !$newsub || ${$newsub} ne ${$subnode};

	$result = $self->checkReadonly($new, $orig, $ixpc, $oxpc, $subtree);
	return $result if $result;

	$result = $self->checkBinds($new, $orig, $ixpc, $oxpc, $subtree);
	return $result if $result;

	$result = $self->checkSchema($new);
	return $result if $result;

	return $new;
}

# XPath Extensions
# These use an internal XPathContext for calculations to make sure XPath
# semantics are obeyed, especially regarding type conversion.

sub makeXPathContext {
	my ($instancefunc) = @_;
	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerNs('xf', NSURI_XF); # FIXME: must be done on a per-evaluation basis instead
	$xpc->registerFunction('instance', $instancefunc);
	$xpc->registerFunction('boolean-from-string', \&XPath_booleanFromString);
	$xpc->registerFunction('if', \&XPath_if);
	$xpc->registerFunction('avg', \&XPath_avg);
	$xpc->registerFunction('min', \&XPath_min);
	$xpc->registerFunction('max', \&XPath_max);
	$xpc->registerFunction('count-non-empty', \&XPath_countNonEmpty);
	$xpc->registerFunction('index', \&XPath_index);
	$xpc->registerFunction('property', \&XPath_property);
	$xpc->registerFunction('now', \&XPath_now);
	$xpc->registerFunction('days-from-date', \&XPath_daysFromDate);
	$xpc->registerFunction('seconds-from-dateTime', \&XPath_secondsFromDateTime);
	$xpc->registerFunction('seconds', \&XPath_seconds);
	$xpc->registerFunction('months', \&XPath_months);
	return $xpc;
}

sub XPath_booleanFromString {
	my ($str) = @_;
	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $str }, undef);
	$str = $xpc->findvalue('string($str)', $doc);
	return XML::LibXML::Boolean->True if (lc($str) eq 'true' || $str eq '1');
	return XML::LibXML::Boolean->False if (lc($str) eq 'false' || $str eq '0');
	die "Invalid boolean string value: $str";
}

sub XPath_if {
	my ($bool, $true, $false) = @_;
	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $bool }, undef);
	$bool = $xpc->findvalue('boolean($bool)', $doc);
	return ($bool eq 'true'?$true:$false);
}

sub XPath_avg {
	my ($nodeset) = @_;

	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $nodeset }, undef);
	return $xpc->find('sum($x) div count($x)', $doc);
}

sub XPath_min {
	my ($nodeset) = @_;
	return new XML::LibXML::Number('NaN') if (!$nodeset->size());
	my $min = $nodeset->shift;
	my $cur = $min;

	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $min }, undef);
	while ($nodeset->size()) {
		$cur = $nodeset->shift;
		$min = $cur if $xpc->findvalue('. < $min', $cur) eq 'true';
	}

	return $min;
}

sub XPath_max {
	my ($nodeset) = @_;
	return new XML::LibXML::Number('NaN') if (!$nodeset->size());
	my $max = $nodeset->shift;
	my $cur = $max;

	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $max }, undef);
	while ($nodeset->size()) {
		$cur = $nodeset->shift;
		$max = $cur if $xpc->findvalue('. > $max', $cur) eq 'true';
	}

	return $max;
}

sub XPath_countNonEmpty {
	my ($nodeset) = @_;
	my $cur;
	my $result = 0;

	my $xpc = new XML::LibXML::XPathContext;
	while ($nodeset->size()) {
		$cur = $nodeset->shift;
		$result++ if $xpc->findvalue('string-length(.)', $cur) > 0;
	}

	return new XML::LibXML::Number($result);
}

sub XPath_index {
	# Doesn't apply to validation.
	die "index() not supported.";
}

sub XPath_property {
	my ($str) = @_;
	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $str }, undef);
	$str = $xpc->findvalue('string($str)', $doc);
	return new XML::LibXML::Literal('1.0') if ($str eq 'version');
	return new XML::LibXML::Literal('full') if ($str eq 'conformance-level');
	return new XML::LibXML::Literal('');
}

sub XPath_now {
	my $now = localtime;
	my $off = $now->tzoffset;
	my $time = $now->datetime().sprintf('%+03d:%02d', int($off->hours), abs($off->minutes)%60);
	return new XML::LibXML::Literal($time);
}

sub XPath_daysFromDate {
	my ($day) = @_;
	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $day }, undef);
	$day = $xpc->findvalue('string($day)', $doc);
	$day =~ s/T.*//;
	my $time = Time::Piece->strptime($day, "%Y-%m-%d")->epoch / ONE_DAY;
	return new XML::LibXML::Number($time);
}

sub XPath_secondsFromDateTime {
	my ($date) = @_;
	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $date }, undef);
	$date = $xpc->findvalue('string($date)', $doc);
	my ($day, $sign, $h, $m) = $date =~ m/^(.*?)(?:\.[0-9]*)?(?:Z|([+-])([0-9]{2}):([0-9]{2}))?$/;
	my $time = Time::Piece->strptime($day, "%Y-%m-%dT%H:%M:%S")->epoch;
	$sign ||= '';
	if ($sign eq '+') {
		$time -= $h*60+$m;
	} elsif ($sign eq '-') {
		$time += $h*60+$m;
	}
	return new XML::LibXML::Number($time);
}

sub XPath_seconds {
	my ($duration) = @_;
	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $duration }, undef);
	$duration = $xpc->findvalue('string($duration)', $doc);
	my ($sign, $d, $h, $m, $s) = $duration =~ m/^([+-]?)P.*?(?:([0-9]+)D)?(?:T(?:([0-9]+)H)?(?:([0-9]+)M)?(?:([0-9.]+)S)?)?$/;
	$sign .= 1;
	return new XML::LibXML::Number(((($d*24+$h)*60+$m)*60+$s)*$sign);
}

sub XPath_months {
	my ($duration) = @_;
	my $xpc = new XML::LibXML::XPathContext;
	$xpc->registerVarLookupFunc(sub { return $duration }, undef);
	$duration = $xpc->findvalue('string($duration)', $doc);
	my ($sign, $y, $m) = $duration =~ m/^([+-]?)P(?:([0-9]+)Y)?(?:([0-9]+)M)?.*$/;
	$sign .= 1;
	return new XML::LibXML::Number(($y*12+$m)*$sign);
}

package XML::Schema::Type::duration;
use base qw( XML::Schema::Type::timeDuration );
# FIXME: hack for XML::Schema bug

package XML::Schema::Type::dateTime;
use base qw( XML::Schema::Type::recurringDuration );
use vars qw( $ERROR @FACETS );
@FACETS = (
    period   => { value => 'P10000Y', fixed => 1 },
    duration => { value => 'P0Y', fixed => 1 },
);
# FIXME: hack for XML::Schema bug

package XML::XForms::Validate::Type::listItem;
use base qw( XML::Schema::Type::string );
use vars qw( $ERROR @FACETS );

@FACETS = (
    pattern => {
        value  => '^\S+$',
        errmsg => 'value is not a valid listItem',
    }
);

package XML::XForms::Validate::Type::listItems;
use base qw( XML::Schema::Type::string );
use vars qw( $ERROR @FACETS );
# FIXME: this is technically wrong, but sufficient for our purposes.

@FACETS = (
    pattern => {
        value  => '^((\S+\s+)*\S+)?$',
        errmsg => 'value is not a valid listItem list',
    }
);

package XML::XForms::Validate::Type::dayTimeDuration;
use base qw( XML::Schema::Type::duration );
use vars qw( $ERROR @FACETS );
# FIXME: no idea if this works as intended.

@FACETS = (
    duration => { value => 'P0Y0M', fixed => 1 },
);

package XML::XForms::Validate::Type::yearMonthDuration;
use base qw( XML::Schema::Type::duration );
use vars qw( $ERROR @FACETS );
# FIXME: no idea if this works as intended.

@FACETS = (
    duration => { value => 'P0DT0H0M0S', fixed => 1 },
);


1;
__END__