# Copyrights 2006-2007 by Mark Overmeer.
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 1.02.
use vars '$VERSION';
$VERSION = '0.51';
use strict;
no warnings 'once';
use Log::Report 'xml-compile', syntax => 'SHORT';
use List::Util qw/first/;
use XML::Compile::Util qw/pack_type odd_elements block_label/;
# Each action implementation returns a code reference, which will be
# used to do the run-time work. The mechanism of `closures' is used to
# keep the important information. Be sure that you understand closures
# before you attempt to change anything.
# The returned reader subroutines will always be called
# my @pairs = $reader->($tree);
# Some error messages are labeled with 'misfit' which is used to indicate
# that the structure of found data is not conforming the needs. For optional
# blocks, these errors are caught and un-done.
sub tag_unqualified
{ my $name = $_[3];
$name =~ s/.*?\://; # strip prefix, that's all
$name;
}
*tag_qualified = \&tag_unqualified;
sub element_wrapper
{ my ($path, $args, $processor) = @_;
# no copy of $_[0], because it may be a large string
sub { my $tree;
if(ref $_[0] && $_[0]->isa('XML::LibXML::Iterator'))
{ $tree = $_[0];
}
else
{ my $xml = XML::Compile->dataToXML($_[0])
or return ();
$xml = $xml->documentElement
if $xml->isa('XML::LibXML::Document');
$tree = XML::Compile::Iterator->new($xml, 'top',
sub { $_[0]->isa('XML::LibXML::Element') } );
}
$processor->($tree);
};
}
sub attribute_wrapper
{ my ($path, $args, $processor) = @_;
sub { my $attr = shift;
ref $attr && $attr->isa('XML::LibXML::Attr')
or error __x"expects an attribute node, but got `{something}' at {path}"
, something => (ref $attr || $attr), path => $path;
my $node = XML::LibXML::Element->new('dummy');
$node->addChild($attr);
$processor->($node);
};
}
sub wrapper_ns # no namespaces in the HASH
{ my ($path, $args, $processor, $index) = @_;
$processor;
}
#
## Element
#
sub sequence($@)
{ my ($path, $args, @pairs) = @_;
bless
sub { my $tree = shift;
my @res;
my @do = @pairs;
while(@do)
{ my ($take, $do) = (shift @do, shift @do);
push @res
, ref $do eq 'BLOCK' ? $do->($tree)
: ref $do eq 'ANY' ? $do->($tree)
: ! defined $tree ? $do->($tree)
: $tree->currentLocal eq $take ? $do->($tree)
: $do->(undef);
# is missing permitted? otherwise crash
}
@res;
}, 'BLOCK';
}
sub choice($@)
{ my ($path, $args, %do) = @_;
bless
sub { my $tree = shift;
my $local = $tree->currentLocal
or error __x"no elements left for choice at {path}"
, path => $path, _class => 'misfit';
my $do = $do{$local}
or error __x"no alternative for choice before `{tag}' at {path}"
, tag => $local, path => $path, _class => 'misfit';
$do->($tree);
}, 'BLOCK';
}
sub all($@)
{ my ($path, $args, @pairs) = @_;
bless
sub { my $tree = shift;
my %do = @pairs;
my @res;
while(1)
{ my $local = $tree->currentLocal or last;
my $do = delete $do{$local} or last; # already seen?
push @res, $do->($tree);
}
# saw all of all?
push @res, $_->(undef)
for values %do;
@res;
}, 'BLOCK';
}
sub block_handler
{ my ($path, $args, $label, $min, $max, $process, $kind) = @_;
my $multi = block_label $kind, $label;
# flatten the HASH: when a block appears only once, there will
# not be an additional nesting in the output tree.
if($max ne 'unbounded' && $max==1)
{ return $process if $min==1;
return bless # $min==0
sub { my $tree = shift or return ();
my $starter = $tree->currentChild or last;
my @pairs = try { $process->($tree) };
if($@->wasFatal(class => 'misfit'))
{ # error is ok, if nothing consumed
my $ending = $tree->currentChild;
$@->reportAll if !$ending || $ending!=$starter;
return ();
}
elsif($@) {$@->reportAll};
@pairs;
}, 'BLOCK';
}
if($max ne 'unbounded' && $min>=$max)
{ return bless
sub { my $tree = shift;
my @res;
while(@res < $min)
{ my @pairs = $process->($tree);
push @res, {@pairs};
}
($multi => \@res);
}, 'BLOCK';
}
if($min==0)
{ return bless
sub { my $tree = shift or return ();
my @res;
while($max eq 'unbounded' || @res < $max)
{ my $starter = $tree->currentChild or last;
my @pairs = try { $process->($tree) };
if($@->wasFatal(class => 'misfit'))
{ # misfit error is ok, if nothing consumed
my $ending = $tree->currentChild;
$@->reportAll if !$ending || $ending!=$starter;
last;
}
elsif($@) {$@->reportAll}
@pairs or last;
push @res, {@pairs};
}
@res ? ($multi => \@res) : ();
}, 'BLOCK';
}
bless
sub { my $tree = shift or error __xn
"block with `{name}' is required at least once at {path}"
, "block with `{name}' is required at least {_count} times at {path}"
, $min, name => $label, path => $path;
my @res;
while(@res < $min)
{ my @pairs = $process->($tree);
push @res, {@pairs};
}
while($max eq 'unbounded' || @res < $max)
{ my $starter = $tree->currentChild or last;
my @pairs = try { $process->($tree) };
if($@->wasFatal(class => 'misfit'))
{ # misfit error is ok, if nothing consumed
my $ending = $tree->currentChild;
$@->reportAll if !$ending || $ending!=$starter;
last;
}
elsif($@) {$@->reportAll};
@pairs or last;
push @res, {@pairs};
}
($multi => \@res);
}, 'BLOCK';
}
sub element_handler
{ my ($path, $args, $label, $min, $max, $required, $optional) = @_;
if($max ne 'unbounded' && $max==1)
{ return $min==1
? sub { my $tree = shift;
my @pairs = $required->(defined $tree ? $tree->descend :undef);
$tree->nextChild if defined $tree;
($label => $pairs[1]);
}
: sub { my $tree = shift or return ();
$tree->currentChild or return ();
my @pairs = $optional->($tree->descend);
@pairs or return ();
$tree->nextChild;
($label => $pairs[1]);
};
}
if($max ne 'unbounded' && $min>=$max)
{ return
sub { my $tree = shift;
my @res;
while(@res < $min)
{ my @pairs = $required->(defined $tree ? $tree->descend:undef);
push @res, $pairs[1];
$tree->nextChild if defined $tree;
}
@res ? ($label => \@res) : ();
};
}
if(!defined $required)
{ return
sub { my $tree = shift or return ();
my @res;
while($max eq 'unbounded' || @res < $max)
{ $tree->currentChild or last;
my @pairs = $optional->($tree->descend);
@pairs or last;
push @res, $pairs[1];
$tree->nextChild;
}
@res ? ($label => \@res) : ();
};
}
sub { my $tree = shift;
my @res;
while(@res < $min)
{ my @pairs = $required->(defined $tree ? $tree->descend : undef);
push @res, $pairs[1];
$tree->nextChild if defined $tree;
}
while(defined $tree && ($max eq 'unbounded' || @res < $max))
{ $tree->currentChild or last;
my @pairs = $optional->($tree->descend);
@pairs or last;
push @res, $pairs[1];
$tree->nextChild;
}
($label => \@res);
};
}
sub required
{ my ($path, $args, $label, $do) = @_;
my $req =
sub { my $tree = shift; # can be undef
my @pairs = $do->($tree);
@pairs
or error __x"data for `{tag}' missing at {path}"
, tag => $label, path => $path, _class => 'misfit';
@pairs;
};
bless $req, 'BLOCK' if ref $do eq 'BLOCK';
$req;
}
sub element
{ my ($path, $args, $ns, $childname, $do) = @_;
sub { my $tree = shift;
my $value = defined $tree && $tree->nodeLocal eq $childname
? $do->($tree) : $do->(undef);
defined $value ? ($childname => $value) : ();
};
}
sub element_default
{ my ($path, $args, $ns, $childname, $do, $default) = @_;
my $def = $do->($default);
sub { my $tree = shift;
defined $tree && $tree->nodeLocal eq $childname
or return ($childname => $def);
$do->($tree);
};
}
sub element_fixed
{ my ($path, $args, $ns, $childname, $do, $fixed) = @_;
my $fix = $do->($fixed);
sub { my $tree = shift;
my ($label, $value)
= $tree && $tree->nodeLocal eq $childname ? $do->($tree) : ();
defined $value
or error __x"element `{name}' with fixed value `{fixed}' missing at {path}"
, name => $childname, fixed => $fix, path => $path;
$value eq $fix
or error __x"element `{name}' must have fixed value `{fixed}', got `{value}' at {path}"
, name => $childname, fixed => $fix, value => $value
, path => $path;
($label => $value);
};
}
sub element_nillable
{ my ($path, $args, $ns, $childname, $do) = @_;
sub { my $tree = shift;
my $value;
if(defined $tree && $tree->nodeLocal eq $childname)
{ my $nil = $tree->node->getAttribute('nil') || 'false';
return ($childname => 'NIL')
if $nil eq 'true' || $nil eq '1';
$value = $do->($tree);
}
else
{ $value = $do->(undef);
}
defined $value ? ($childname => $value) : ();
};
}
#
# complexType and complexType/ComplexContent
#
sub complex_element
{ my ($path, $args, $tag, $elems, $attrs, $attrs_any) = @_;
my @elems = odd_elements @$elems;
my @attrs = (odd_elements(@$attrs), @$attrs_any);
sub { my $tree = shift; # or return ();
my $node = $tree->node;
my %complex
= ( (map {$_->($tree)} @elems)
, (map {$_->($node)} @attrs)
);
defined $tree->currentChild
and error __x"element `{name}' not processed at {path}"
, name => $tree->currentLocal, path => $path
, _class => 'misfit';
($tag => \%complex);
};
}
#
# complexType/simpleContent
#
sub tagged_element
{ my ($path, $args, $tag, $st, $attrs, $attrs_any) = @_;
my @attrs = (odd_elements(@$attrs), @$attrs_any);
sub { my $tree = shift or return ();
my $simple = $st->($tree);
my $node = $tree->node;
my @pairs = map {$_->($node)} @attrs;
defined $simple or @pairs or return ();
defined $simple or $simple = 'undef';
($tag => {_ => $simple, @pairs});
};
}
#
# simpleType
#
sub simple_element
{ my ($path, $args, $tag, $st) = @_;
sub { my $value = $st->(@_);
defined $value ? ($tag => $value) : ();
};
}
sub builtin
{ my ($path, $args, $node, $type, $def, $check_values) = @_;
my $check = $check_values ? $def->{check} : undef;
my $parse = $def->{parse};
my $err = $path eq $type
? N__"illegal value `{value}' for type {type}"
: N__"illegal value `{value}' for type {type} at {path}";
$check
? ( defined $parse
? sub { my $value = ref $_[0] ? $_[0]->textContent : $_[0];
defined $value or return undef;
return $parse->($value, $_[0])
if $check->($value);
error __x$err, value => $value, type => $type, path => $path;
}
: sub { my $value = ref $_[0] ? $_[0]->textContent : $_[0];
defined $value or return undef;
return $value if $check->($value);
error __x$err, value => $value, type => $type, path => $path;
}
)
: ( defined $parse
? sub { my $value = ref $_[0] ? shift->textContent : $_[0];
defined $value or return undef;
$parse->($value);
}
: sub { ref $_[0] ? shift->textContent : $_[0] }
);
}
# simpleType
sub list
{ my ($path, $args, $st) = @_;
sub { my $tree = shift or return undef;
my $v = $tree->textContent;
my @v = grep {defined} map {$st->($_) } split(" ",$v);
\@v;
};
}
sub facets_list
{ my ($path, $args, $st, $early, $late) = @_;
sub { defined $_[0] or return undef;
my $v = $st->(@_);
for(@$early) { defined $v or return (); $v = $_->($v) }
my @v = defined $v ? split(" ",$v) : ();
my @r;
EL: for my $e (@v)
{ for(@$late) { defined $e or next EL; $e = $_->($e) }
push @r, $e;
}
@r ? \@r : ();
};
}
sub facets
{ my ($path, $args, $st, @do) = @_;
sub { defined $_[0] or return undef;
my $v = $st->(@_);
for(@do) { defined $v or return (); $v = $_->($v) }
$v;
};
}
sub union
{ my ($path, $args, @types) = @_;
sub { my $tree = shift or return undef;
for(@types) { my $v = try { $_->($tree) }; $@ or return $v }
my $text = $tree->textContent;
substr $text, 20, -1, '...' if length($text) > 73;
error __x"no match for `{text}' in union at {path}"
, text => $text, path => $path;
};
}
# Attributes
sub attribute_required
{ my ($path, $args, $ns, $tag, $do) = @_;
sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag);
defined $node
or error __x"attribute `{name}' is required at {path}"
, name => $tag, path => $path;
defined $node or return ();
my $value = $do->($node);
defined $value ? ($tag => $value) : ();
};
}
sub attribute_prohibited
{ my ($path, $args, $ns, $tag, $do) = @_;
sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag);
defined $node or return ();
error __x"attribute `{name}' is prohibited at {path}"
, name => $tag, path => $path;
();
};
}
sub attribute
{ my ($path, $args, $ns, $tag, $do) = @_;
sub {
use Carp;
$_[0]->isa('XML::LibXML::Node') or confess "$!";
my $node = $_[0]->getAttributeNodeNS($ns, $tag);
defined $node or return ();;
my $val = $do->($node);
defined $val ? ($tag => $val) : ();
};
}
sub attribute_default
{ my ($path, $args, $ns, $tag, $do, $default) = @_;
my $def = $do->($default);
sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag);
($tag => (defined $node ? $do->($node) : $def))
};
}
sub attribute_fixed
{ my ($path, $args, $ns, $tag, $do, $fixed) = @_;
my $def = $do->($fixed);
sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag);
my $value = defined $node ? $do->($node) : undef;
defined $value && $value eq $def
or error __x"value of attribute `{tag}' is fixed to `{fixed}', not `{value}' at {path}"
, tag => $tag, fixed => $def, value => $value, path => $path;
($tag => $def);
};
}
sub attribute_fixed_optional
{ my ($path, $args, $ns, $tag, $do, $fixed) = @_;
my $def = $do->($fixed);
sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag)
or return ($tag => $def);
my $value = $do->($node);
defined $value && $value eq $def
or error __x"value of attribute `{tag}' is fixed to `{fixed}', not `{value}' at {path}"
, tag => $tag, fixed => $def, value => $value, path => $path;
($tag => $def);
};
}
# SubstitutionGroups
sub substgroup
{ my ($path, $args, $type, %do) = @_;
bless
sub { my $tree = shift;
my $local = ($tree ? $tree->currentLocal : undef)
or error __x"no data for substitution group {type} at {path}"
, type => $type, path => $path;
my $do = $do{$local}
or error __x"no substitute for {type} found at {path}"
, type => $type, path => $path;
my @subst = $do->($tree->descend);
$tree->nextChild;
@subst;
}, 'BLOCK';
}
# anyAttribute
sub anyAttribute
{ my ($path, $args, $handler, $yes, $no, $process) = @_;
return () unless defined $handler;
my %yes = map { ($_ => 1) } @{$yes || []};
my %no = map { ($_ => 1) } @{$no || []};
# Takes all, before filtering
my $all =
sub { my @result;
foreach my $attr ($_[0]->attributes)
{ $attr->isa('XML::LibXML::Attr') or next;
my $ns = $attr->namespaceURI || $_[0]->namespaceURI;
next if keys %yes && !$yes{$ns};
next if keys %no && $no{$ns};
my $local = $attr->localName;
push @result, pack_type($ns, $local) => $attr;
}
@result;
};
# Create filter if requested
my $run = $handler eq 'TAKE_ALL'
? $all
: sub { my @attrs = $all->(@_);
my @result;
while(@attrs)
{ my ($type, $data) = (shift @attrs, shift @attrs);
my ($label, $out) = $handler->($type, $data, $path, $args);
push @result, $label, $out if defined $label;
}
@result;
};
bless $run, 'BLOCK';
}
# anyElement
sub anyElement
{ my ($path, $args, $handler, $yes, $no, $process, $min, $max) = @_;
$handler ||= 'SKIP_ALL';
my %yes = map { ($_ => 1) } @{$yes || []};
my %no = map { ($_ => 1) } @{$no || []};
# Takes all, before filtering
my $all = bless
sub { my $tree = shift or return ();
my $count = 0;
my %result;
while( (my $child = $tree->currentChild)
&& ($max eq 'unbounded' || $count < $max))
{ my $ns = $child->namespaceURI;
$yes{$ns} or last if keys %yes;
$no{$ns} and last if keys %no;
my ($k, $v) = (pack_type($ns, $child->localName) => $child);
$count++;
push @{$result{$k}}, $v;
$tree->nextChild;
}
$count >= $min
or error __x"too few any elements, requires {min} and got {found}"
, min => $min, found => $count;
%result;
}, 'ANY';
# Create filter if requested
my $run
= $handler eq 'TAKE_ALL' ? $all
: $handler eq 'SKIP_ALL' ? sub { $all->(@_); () }
: sub { my @elems = $all->(@_);
my @result;
while(@elems)
{ my ($type, $data) = (shift @elems, shift @elems);
my ($label, $out) = $handler->($type, $data, $path, $args);
push @result, $label, $out if defined $label;
}
@result;
};
bless $run, 'ANY';
}
# any kind of hook
sub hook($$$$$$)
{ my ($path, $args, $r, $tag, $before, $replace, $after) = @_;
return $r unless $before || $replace || $after;
return sub { ($_[0]->node->localName => 'SKIPPED') }
if $replace && grep {$_ eq 'SKIP'} @$replace;
my @replace = $replace ? map {_decode_replace($path,$_)} @$replace : ();
my @before = $before ? map {_decode_before($path,$_) } @$before : ();
my @after = $after ? map {_decode_after($path,$_) } @$after : ();
sub
{ my $tree = shift or return ();
my $xml = $tree->node;
foreach (@before)
{ $xml = $_->($xml, $path);
defined $xml or return ();
}
my @h = @replace
? map {$_->($xml,$args,$path,$tag)} @replace
: $r->($tree->descend($xml));
@h or return ();
my $h = @h==1 ? {_ => $h[0]} : $h[1]; # detect simpleType
foreach (@after)
{ $h = $_->($xml, $h, $path);
defined $h or return ();
}
$h;
}
}
sub _decode_before($$)
{ my ($path, $call) = @_;
return $call if ref $call eq 'CODE';
$call eq 'PRINT_PATH' ? sub {print "$_[1]\n"; $_[0] }
: error __x"labeled before hook `{call}' undefined", call => $call;
}
sub _decode_replace($$)
{ my ($path, $call) = @_;
return $call if ref $call eq 'CODE';
error __x"labeled replace hook `{call}' undefined", call => $call;
}
sub _decode_after($$)
{ my ($path, $call) = @_;
return $call if ref $call eq 'CODE';
$call eq 'PRINT_PATH' ? sub {print "$_[2]\n"; $_[1] }
: $call eq 'XML_NODE' ?
sub { my $h = $_[1];
ref $h eq 'HASH' or $h = { _ => $h };
$h->{_XML_NODE} = $_[0];
$h;
}
: $call eq 'ELEMENT_ORDER' ?
sub { my ($xml, $h) = @_;
ref $h eq 'HASH' or $h = { _ => $h };
my @order = map {$_->nodeName}
grep { $_->isa('XML::LibXML::Element') }
$xml->childNodes;
$h->{_ELEMENT_ORDER} = \@order;
$h;
}
: $call eq 'ATTRIBUTE_ORDER' ?
sub { my ($xml, $h) = @_;
ref $h eq 'HASH' or $h = { _ => $h };
my @order = map {$_->nodeName} $xml->attributes;
$h->{_ATTRIBUTE_ORDER} = \@order;
$h;
}
: error __x"labeled after hook `{call}' undefined", call => $call;
}
1;