File Coverage

blib/lib/PRANG/Graph/Element.pm
Criterion Covered Total %
statement 12 14 85.7
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 17 19 89.4


line stmt bran cond sub pod time code
1              
2             package PRANG::Graph::Element;
3             $PRANG::Graph::Element::VERSION = '0.19';
4 7     7   2121 use 5.010;
  7         24  
5 7     7   35 use Moose;
  7         16  
  7         47  
6 7     7   41716 use MooseX::Params::Validate;
  7         16  
  7         56  
7 7     7   2946 use Moose::Util::TypeConstraints;
  7         14  
  7         57  
8 7     7   21071 use XML::LibXML;
  0            
  0            
9              
10             BEGIN {
11             class_type "XML::LibXML::Node";
12             class_type "XML::LibXML::Element";
13             }
14              
15             has 'xmlns' =>
16             is => "ro",
17             isa => "Str",
18             predicate => "has_xmlns",
19             ;
20              
21             has 'nodeName' =>
22             is => "ro",
23             isa => "Str",
24             required => 1,
25             ;
26              
27             has 'nodeClass' =>
28             is => "ro",
29             isa => "Str",
30             predicate => "has_nodeClass",
31             ;
32              
33             has 'nodeName_attr' =>
34             is => "rw",
35             isa => "Str",
36             predicate => "has_nodeName_attr",
37             ;
38              
39             has 'xmlns_attr' =>
40             is => "rw",
41             isa => "Str",
42             predicate => "has_xmlns_attr",
43             ;
44              
45             has 'attrName' =>
46             is => "ro",
47             isa => "Str",
48             required => 1,
49             ;
50              
51             has 'contents' =>
52             is => "rw",
53             isa => "PRANG::Graph::Node",
54             predicate => "has_contents",
55             ;
56              
57             sub node_ok {
58             my $self = shift;
59             my ( $node, $ctx ) = pos_validated_list(
60             \@_,
61             { isa => 'XML::LibXML::Node' },
62             { isa => 'PRANG::Graph::Context' },
63             );
64            
65             return unless $node->nodeType == XML_ELEMENT_NODE;
66             my $got_xmlns;
67              
68             if ($self->has_xmlns
69             or
70             ($node->prefix||"") ne ($ctx->prefix||"")
71             )
72             { my $prefix = $node->prefix//"";
73             $got_xmlns = $ctx->xsi->{$prefix};
74             if ( !defined $got_xmlns ) {
75             $got_xmlns = $node->getAttribute(
76             "xmlns".(length $prefix?":$prefix":"")
77             );
78             }
79             my $wanted_xmlns = ($self->xmlns||"");
80             if ($got_xmlns
81             and $wanted_xmlns ne "*"
82             and
83             $got_xmlns ne $wanted_xmlns
84             )
85             { return;
86             }
87             }
88             my ($ret_nodeName, $ret_xmlns) = ("", "");
89             my $wanted_nodeName = $self->nodeName;
90             if ($wanted_nodeName ne "*"
91             and $wanted_nodeName ne $node->localname
92             )
93             { return;
94             }
95             if ( $self->has_nodeName_attr ) {
96             $ret_nodeName = $node->localname;
97             }
98             if ( $self->has_xmlns_attr ) {
99             $ret_xmlns = $got_xmlns;
100             }
101             if (wantarray) {
102             return ($ret_nodeName, $ret_xmlns);
103             }
104             else {
105             return $ret_nodeName;
106             }
107             }
108              
109             sub accept {
110             my $self = shift;
111             my ( $node, $ctx, $lax ) = pos_validated_list(
112             \@_,
113             { isa => 'XML::LibXML::Node' },
114             { isa => 'PRANG::Graph::Context' },
115             { isa => 'Bool', optional => 1 },
116             );
117            
118             my ($ret_nodeName, $xmlns) = $self->node_ok($node, $ctx);
119             if ( !defined $ret_nodeName ) {
120              
121             # ok, not right, so figure out what we did want, in
122             # the context of the incoming document.
123             my $wanted_xmlns = ($self->xmlns||"");
124             my $wanted_prefix = $ctx->get_prefix($wanted_xmlns);
125              
126             my $nodeName = $self->nodeName;
127             if ( $wanted_prefix ne "" ) {
128             $nodeName = "$wanted_prefix:$nodeName";
129             if ( $ctx->prefix_new($wanted_prefix) ) {
130             $nodeName .= " xmlns:$wanted_prefix="
131             ."\"$wanted_xmlns\"";
132             }
133             }
134             $ctx->exception(
135             "invalid element; expected '$nodeName'",
136             $node, 1,
137             );
138             }
139             undef($ret_nodeName) if !length($ret_nodeName);
140             if ( $self->has_nodeClass ) {
141              
142             # general nested XML support
143             my $marshaller = $ctx->base->get($self->nodeClass);
144             my $value = (
145             $marshaller
146             ? $marshaller->marshall_in_element(
147             $node,
148             $ctx,
149             $lax,
150             )
151             : $node
152             );
153             $ctx->element_ok(1);
154             return ($self->attrName => $value, $ret_nodeName, $xmlns);
155             }
156             else {
157              
158             # XML data types
159             my $type = $self->has_contents
160             ?
161             "XML data"
162             : "presence-only";
163             if ($node->hasAttributes) {
164             $ctx->exception(
165             "Superfluous attributes on $type node",
166             $node
167             );
168             }
169             if ( $self->has_contents ) {
170              
171             # simple types, eg Int, Str
172             my (@childNodes) = grep {
173             !( $_->isa("XML::LibXML::Comment")
174             or
175             $_->isa("XML::LibXML::Text")
176             and $_->data =~ /\A\s+\Z/
177             )
178             } $node->childNodes;
179              
180             if ( @childNodes > 1 ) {
181              
182             # we could maybe merge CDATA nodes...
183             $ctx->exception(
184             "Too many child nodes for $type node",
185             $node,
186             );
187             }
188             my $value;
189             if ( !@childNodes ) {
190             $value = "";
191             }
192             else {
193             (undef, $value) = $self->contents->accept(
194             $childNodes[0],
195             $ctx,
196             $lax,
197             );
198             }
199             $ctx->element_ok(1);
200             return ($self->attrName => $value, $ret_nodeName, $xmlns);
201             }
202             else {
203              
204             # boolean
205             if ( $node->hasChildNodes ) {
206             $ctx->exception(
207             "Superfluous child nodes on $type node",
208             $node,
209             );
210             }
211             $ctx->element_ok(1);
212             return ($self->attrName => 1, $ret_nodeName, $xmlns);
213             }
214             }
215             }
216              
217             sub complete {
218             my $self = shift;
219             my ( $ctx ) = pos_validated_list(
220             \@_,
221             { isa => 'PRANG::Graph::Context' },
222             );
223            
224             $ctx->element_ok;
225             }
226              
227             sub expected {
228             my $self = shift;
229             my ( $ctx ) = pos_validated_list(
230             \@_,
231             { isa => 'PRANG::Graph::Context' },
232             );
233            
234             my $prefix = "";
235             my $nodename = $self->nodeName;
236             if ( $self->has_xmlns ) {
237             my $xmlns = eval { $self->nodeClass->xmlns } ||
238             $self->xmlns;
239             if ( $prefix = $ctx->rxsi->{$xmlns} ) {
240             $prefix .= ":";
241             }
242             else {
243             $prefix = $ctx->get_prefix($xmlns);
244             $nodename .= " xmlns:$prefix='$xmlns'";
245             $prefix .= ":";
246             }
247             }
248             return "<$prefix$nodename".(
249             $self->has_nodeClass
250             ?"..."
251             :
252             $self->has_contents?"":"/"
253             )
254             .">";
255             }
256              
257             sub output {
258             my $self = shift;
259            
260             # First 3 args positional, rest are named
261             # Because we're making 2 validation calls, we have to use different cache keys
262             my ( $item, $node, $ctx ) = pos_validated_list(
263             [@_[0..2]],
264             { isa => 'Object' },
265             { isa => 'XML::LibXML::Element' },
266             { isa => 'PRANG::Graph::Context' },
267             MX_PARAMS_VALIDATE_CACHE_KEY => 'element-output-positional',
268             );
269            
270             my ( $value, $slot, $name, $xmlns ) = validated_list(
271             [@_[3..$#_]],
272             value => { isa => 'Item', optional => 1 },
273             slot => { isa => 'Int', optional => 1 },
274             name => { isa => 'Str', optional => 1 },
275             xmlns => { isa => 'Str', optional => 1 },
276             MX_PARAMS_VALIDATE_CACHE_KEY => 'element-output-named',
277             );
278            
279            
280             $value //= do {
281             my $accessor = $self->attrName;
282             $item->$accessor;
283             };
284             if ( ref $value and ref $value eq "ARRAY" and defined $slot ) {
285             $value = $value->[$slot];
286             }
287             $name //= do {
288             if ( $self->has_nodeName_attr ) {
289             my $attr = $self->nodeName_attr;
290             $item->$attr;
291             }
292             else {
293             $self->nodeName;
294             }
295             };
296             $xmlns //= do {
297             if ( $self->has_xmlns_attr ) {
298             my $attr = $self->xmlns_attr;
299             $item->$attr;
300             }
301             else {
302             $self->xmlns // "";
303             }
304             };
305             if ( ref $name ) {
306             $name = $name->[$slot];
307             }
308             if ( ref $xmlns ) {
309             $xmlns = $xmlns->[$slot];
310             }
311              
312             my $nn;
313             my $doc = $node->ownerDocument;
314             my $newctx;
315             if ( length $name ) {
316             my ($prefix, $new_prefix);
317             $ctx = $ctx->next_ctx( $xmlns, $name, $value );
318             $prefix = $ctx->prefix;
319             my $new_nodeName = ($prefix ? "$prefix:" : "") . $name;
320             $nn = $doc->createElement($new_nodeName);
321             if ( $ctx->prefix_new($prefix) ) {
322             $nn->setAttribute(
323             "xmlns".($prefix?":$prefix":""),
324             $xmlns,
325             );
326             }
327             $node->appendChild($nn);
328              
329             # now proceed with contents...
330             if ( my $class = $self->nodeClass ) {
331             my $m;
332             if ( !defined $value ) {
333             $ctx->exception("required element not set");
334             }
335             elsif ( eval { $value->isa($class) }) {
336             $m = $ctx->base->get($class);
337             }
338             elsif ( eval{$value->isa("XML::LibXML::Element")} ) {
339             if ($value->localname eq $nn->localname
340             and
341             ($value->namespaceURI||"") eq
342             ($xmlns||"")
343             )
344             { my $nn2 = $value->cloneNode(1);
345             $node->appendChild($nn2);
346             $node->removeChild($nn);
347             }
348             else {
349              
350             # it's just not safe to set
351             # the nodeName after the fact,
352             # so copy the children across.
353             for my $att ( $value->attributes ) {
354             next if $att->isa("XML::LibXML::Namespace");
355             $nn->setAttribute(
356             $att->localname,
357             $att->value,
358             );
359             }
360             for my $child ( $value->childNodes ) {
361             my $nn2 = $child->cloneNode(1);
362             $nn->appendChild($nn2);
363             }
364             }
365             $m = "ok";
366             }
367             elsif ( blessed $value ) {
368              
369             # this actually indicates a type
370             # error. currently it is required for
371             # the Whatever mapping.
372             $m = PRANG::Marshaller->get(ref $value);
373             }
374              
375             if ( $m and blessed $m ) {
376             $ctx->exception(
377             "tried to serialize unblessed value $value"
378             )
379             if !blessed $value;
380             $m->to_libxml($value, $nn, $ctx);
381             }
382             elsif ($m) {
383              
384             # allow value-based code above to drop through
385             }
386             else {
387             $ctx->exception("no marshaller for '$value'");
388             }
389             }
390             elsif ( $self->has_contents and defined $value ) {
391             my $tn = $self->createTextNode($doc, $value);
392             $nn->appendChild($tn);
393             }
394             }
395             else {
396             $nn = $self->createTextNode($doc, $value);
397             $node->appendChild($nn);
398             }
399             }
400              
401             with 'PRANG::Graph::Node';
402              
403             1;
404              
405             __END__
406              
407             =head1 NAME
408              
409             PRANG::Graph::Element - accept a particular type of element
410              
411             =head1 SYNOPSIS
412              
413             See L<PRANG::Graph::Meta::Element> source and
414             L<PRANG::Graph::Node> for examples and information.
415              
416             =head1 DESCRIPTION
417              
418             This graph node specifies that the XML graph at this point must accept
419             a particular type of element.
420              
421             If the element only has only simple types (eg Str, Bool), it will not
422             have one of these objects in its graph.
423              
424             Along with L<PRANG::Graph::Text>, this graph node is the only type
425             which may actually consume input XML nodes or emit them on output.
426             The other node types merely change the state in the
427             L<PRANG::Graph::Context> object.
428              
429             =head1 ATTRIBUTES
430              
431             =over
432              
433             =item B<Str xmlns>
434              
435             If set, then the XML namespace of this element is expected to be the
436             value passed (or absent). This is generally not set if the namespace
437             of this portion of the graph is the same as the parent class.
438              
439             =item B<nodeName>
440              
441             This map is used for emitting and generating error messages. Also, if
442             set to C<*> it has special meaning when parsing. Specifies the name
443             of the node.
444              
445             =item B<nodeName_attr>
446              
447             If set, instances have an attribute which stores the name of the XML
448             element.
449              
450             =item B<Str nodeClass>
451              
452             This specifies the next type of element; during parsing and emitting,
453             recursion to the meta-object of this class occurs.
454              
455             This will be undefined if the attribute has C<Bool> type; node
456             presence is true and absence is false.
457              
458             =item B<attrName>
459              
460             Used when emitting; specifies the method to call to retrieve the item
461             to be output. Also used when parsing, to return the Moose attribute
462             slot for construction.
463              
464             =back
465              
466             =head1 SEE ALSO
467              
468             L<PRANG::Graph::Meta::Class>, L<PRANG::Graph::Meta::Element>,
469             L<PRANG::Graph::Context>, L<PRANG::Graph::Node>
470              
471             =head1 AUTHOR AND LICENCE
472              
473             Development commissioned by NZ Registry Services, and carried out by
474             Catalyst IT - L<http://www.catalyst.net.nz/>
475              
476             Copyright 2009, 2010, NZ Registry Services. This module is licensed
477             under the Artistic License v2.0, which permits relicensing under other
478             Free Software licenses.
479              
480             =cut
481