# 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 0.99. package XML::Compile::Schema::XmlReader; use vars '$VERSION'; $VERSION = '0.17'; use strict; use warnings; no warnings 'once'; use List::Util qw/first/; use Carp qw/croak/; # Each action implementation returns a code reference, which will be # used to do the run-time work. The principle 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 # $reader->($xml_node) sub tag_unqualified { my $name = $_[3]; $name =~ s/.*?\://; # strip prefix, that's all $name; } *tag_qualified = \&tag_unqualified; sub wrapper { my $processor = shift; sub { my $xml = XML::Compile->dataToXML($_[0]); defined $xml or return (); $xml = $xml->documentElement if $xml->isa('XML::LibXML::Document'); $processor->($xml); }; } sub wrapper_ns # no namespaces in the HASH { my ($path, $args, $processor, $index) = @_; $processor; } # ## Element # sub element_repeated { my ($path, $args, $ns, $childname, $do, $min, $max) = @_; my $err = $args->{err}; sub { my @nodes = $_[0]->getChildrenByLocalName($childname); $err->($path,scalar @nodes,"too few values (need $min)") if @nodes < $min; $err->($path,scalar @nodes,"too many values (max $max)") if $max ne 'unbounded' && @nodes > $max; my @r = map { $do->($_) } @nodes; @r ? ($childname => \@r) : (); }; } sub element_array { my ($path, $args, $ns, $childname, $do) = @_; sub { my @r = map { $do->($_) } $_[0]->getChildrenByLocalName($childname); @r ? ($childname => \@r) : (); }; } sub element_obligatory { my ($path, $args, $ns, $childname, $do) = @_; my $err = $args->{err}; sub { # This should work with namespaces (but doesn't yet) # because the wrong namespace is passed in $ns # my @nodes = $_[0]->getChildrenByTagNameNS($ns,$childname); my @nodes = $_[0]->getChildrenByLocalName($childname); my $node = (@nodes==0 || !defined $nodes[0]) ? $err->($path, undef, "one value required") : shift @nodes; $node = $err->($path, 'found '.@nodes, "only one value expected") if @nodes; defined $node ? ($childname => $do->($node)) : (); }; } sub element_default { my ($path, $args, $ns, $childname, $do, $min, $max, $default) = @_; my $err = $args->{err}; my $def = $do->($default); sub { my @nodes = $_[0]->getChildrenByLocalName($childname); my $node = shift @nodes; $node = $err->($path, 'found '.@nodes, "only one value expected") if @nodes; ( $childname => (defined $node ? $do->($node) : $def) ); }; } sub element_fixed { my ($path, $args, $ns, $childname, $do, $min, $max, $fixed) = @_; my $err = $args->{err}; my $def = $do->($fixed); sub { my @nodes = $_[0]->getChildrenByLocalName($childname); my $node = shift @nodes; $node = $err->($path, 'found '.@nodes, "only one value expected") if @nodes; my $value = defined $node ? $do->($node) : undef; $err->($path, $value,"value fixed to '".$fixed->value."'") if !defined $value || $value ne $def; ($childname => $def); }; } sub element_fixed_optional { my ($path, $args, $ns, $childname, $do, $min, $max, $fixed) = @_; my $err = $args->{err}; my $def = $do->($fixed); sub { my @nodes = $_[0]->getChildrenByLocalName($childname); my $node = shift @nodes or return (); $node = $err->($path, 'found '.@nodes, "only one value expected") if @nodes; my $value = defined $node ? $do->($node) : undef; $err->($path, $value,"value fixed to '".$fixed->value."'") if !defined $value || $value ne $def; ($childname => $def); }; } sub element_nillable { my ($path, $args, $ns, $childname, $do) = @_; my $err = $args->{err}; sub { my @nodes = $_[0]->getChildrenByLocalName($childname); my $node = (@nodes==0 || !defined $nodes[0]) ? $err->($path, undef, "one value required") : shift @nodes; $err->($path, 'found '.@nodes, "only one value expected") if @nodes; my $nil = $node->getAttribute('nil') || 'false'; $childname => ($nil eq 'true' ? undef : $do->($node)); }; } sub element_optional { my ($path, $args, $ns, $childname, $do) = @_; my $err = $args->{err}; sub { my @nodes = $_[0]->getChildrenByLocalName($childname) or return (); $err->($path, scalar @nodes, "only one value expected") if @nodes > 1; my $val = $do->($nodes[0]); defined $val ? ($childname => $val) : (); }; } # # complexType/ComplexContent # sub create_complex_element { my ($path, $args, $tag, $childs, $any_elem, $any_attr) = @_; my @childs = @$childs; my @do; while(@childs) {shift @childs; push @do, shift @childs} push @do, @$any_elem, @$any_attr; sub { my @pairs = map {$_->(@_)} @do; @pairs ? {@pairs} : (); }; } # # complexType/simpleContent # sub create_tagged_element { my ($path, $args, $tag, $st, $attrs, $attrs_any) = @_; my @attrs = @$attrs; my @do; while(@attrs) {shift @attrs; push @do, shift @attrs} push @do, @$attrs_any; sub { my @a = @do; my $simple = $st->(@_); my @pairs = map {$_->(@_)} @do; defined $simple or @pairs or return (); defined $simple or $simple = 'undef'; {_ => $simple, @pairs}; }; } # # simpleType # sub create_simple_element { my ($path, $args, $tag, $st) = @_; sub { my $value = $st->(@_); defined $value ? $value : undef; }; } sub builtin_checked { my ($path, $args, $node, $type, $def) = @_; my $check = $def->{check}; defined $check or return builtin_unchecked(@_); my $parse = $def->{parse}; my $err = $args->{err}; defined $parse ? sub { my $value = ref $_[0] ? $_[0]->textContent : $_[0]; defined $value or return undef; $check->($value) ? $parse->($value, $_[0]) : $err->($path, $value, "illegal value for $type"); } : sub { my $value = ref $_[0] ? $_[0]->textContent : $_[0]; defined $value or return undef; $check->($value) ? $value : $err->($path, $value, "illegal value for $type"); }; } sub builtin_unchecked { my $parse = $_[4]->{parse}; defined $parse ? sub { my $v = $_[0]->textContent; defined $v ? $parse->($v,$_[0]) :undef} : sub { $_[0]->textContent } } # simpleType sub list { my ($path, $args, $st) = @_; sub { defined $_[0] or return undef; my $v = $_[0]->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, $err, @types) = @_; sub { defined $_[0] or return undef; for(@types) {my $v = $_->($_[0]); defined $v and return $v } my $text = $_[0]->textContent; substr $text, 10, -1, '...' if length($text) > 13; $err->($path, $text, "no match in union"); }; } # Attributes sub attribute_required { my ($path, $args, $ns, $tag, $do) = @_; my $err = $args->{err}; sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag) || $err->($path, undef, "attribute $tag required"); defined $node or return (); my $value = $do->($node); defined $value ? ($tag => $value) : (); }; } sub attribute_prohibited { my ($path, $args, $ns, $tag, $do) = @_; my $err = $args->{err}; sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag); defined $node or return (); $err->($path, $node->textContent, "attribute $tag prohibited"); (); }; } sub attribute_optional { my ($path, $args, $ns, $tag, $do) = @_; my $err = $args->{err}; sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag) or return (); my $val = $do->($node); defined $val ? ($tag => $val) : (); }; } sub attribute_default { my ($path, $args, $ns, $tag, $do, $default) = @_; my $err = $args->{err}; 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 $err = $args->{err}; my $def = $do->($fixed); sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag); my $value = defined $node ? $do->($node) : undef; $err->($path, $value, "attr value fixed to '".$fixed->value."'") if !defined $value || $value ne $def; ($tag => $def); }; } sub attribute_fixed_optional { my ($path, $args, $ns, $tag, $do, $fixed) = @_; my $err = $args->{err}; my $def = $do->($fixed); sub { my $node = $_[0]->getAttributeNodeNS($ns, $tag) or return (); my $value = $do->($node); $err->($path, $value, "attr value fixed to '".$fixed->value."'") if !defined $value || $value ne $def; ($tag => $def); }; } # SubstitutionGroups sub element_substgroup { my ($path, $args, $name, $defs) = @_; my $err = $args->{err}; sub { foreach my $def (@$defs) { my $node = $_[0]->getChildrenByLocalName($def->[1]) or next; return $def->[2]->(@_); } $err->($path, $name, "none of the substitution alternatives found."); }; } # 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, "{$ns}$local" => $attr; } @result; }; # Create filter if requested $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; }; } # anyElement sub anyElement { my ($path, $args, $handler, $yes, $no, $process, $min, $max) = @_; defined $handler or return sub { () }; $handler = sub { @_ } if $handler eq 'TAKE_ALL'; my %yes = map { ($_ => 1) } @{$yes || []}; my %no = map { ($_ => 1) } @{$no || []}; # Takes all, before filtering my $all = sub { my %result; my @elems = grep {$_->isa('XML::LibXML::Element')} $_[0]->childNodes; foreach my $elem (@elems) { my $ns = $elem->namespaceURI || $_[0]->namespaceURI; next if keys %yes && !$yes{$ns}; next if keys %no && $no{$ns}; my ($k, $v) = $handler->("{$ns}".$elem->localName => $elem); push @{$result{$k}}, $v; } %result; }; } # any kind of hook sub create_hook($$$$$) { my ($path, $args, $r, $before, $replace, $after) = @_; return $r unless $before || $replace || $after; return sub {()} 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 $xml = shift; foreach (@before) { $xml = $_->($xml, $path); defined $xml or return (); } my @h = @replace ? map {$_->($xml, $args, $path)} @replace : $r->($xml); @h or return (); my $h = @h > 1 ? {@h} : $h[0]; # 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] } : croak "ERROR: labeled hook '$call' undefined."; } sub _decode_replace($$) { my ($path, $call) = @_; return $call if ref $call eq 'CODE'; croak "ERROR: labeled hook '$call' undefined."; } 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 $values = $_[1]; $values = { _ => $values } if ref $values ne 'HASH'; $values->{_XML_NODE} = $_[0]; $values; } : $call eq 'ELEMENT_ORDER' ? sub { my ($xml, $values) = @_; $values = { _ => $values } if ref $values ne 'HASH'; my @order = map {$_->nodeName} grep {$_->isa('XML::LibXML::Element')} $xml->childNodes; $values->{_ELEMENT_ORDER} = \@order; $values; } : $call eq 'ATTRIBUTE_ORDER' ? sub { my ($xml, $values) = @_; $values = { _ => $values } if ref $values ne 'HASH'; my @order = map {$_->nodeName} $xml->attributes; $values->{_ATTRIBUTE_ORDER} = \@order; $values; } : croak "ERROR: labeled hook '$call' undefined."; } 1;