File Coverage

blib/lib/PRANG/Graph/Context.pm
Criterion Covered Total %
statement 22 108 20.3
branch 0 46 0.0
condition 0 26 0.0
subroutine 9 19 47.3
pod 6 10 60.0
total 37 209 17.7


line stmt bran cond sub pod time code
1              
2             package PRANG::Graph::Context;
3             $PRANG::Graph::Context::VERSION = '0.19';
4 7     7   1344 use 5.010;
  7         22  
5 7     7   64 use Moose;
  7         16  
  7         37  
6 7     7   43857 use MooseX::Params::Validate;
  7         478803  
  7         95  
7 7     7   3559 use Moose::Util::TypeConstraints;
  7         15  
  7         47  
8              
9             BEGIN {
10 7     7   14498 class_type "XML::LibXML::Element";
11             }
12              
13             has 'seq_pos' =>
14             is => "rw",
15             isa => "Int",
16             lazy => 1,
17             default => 1,
18             trigger => sub {
19             my $self = shift;
20             $self->clear_quant;
21             $self->clear_chosen;
22             $self->clear_element_ok;
23             },
24             clearer => "clear_seq_pos",
25             ;
26              
27             sub reset {
28 0     0 0   my $self = shift;
29            
30 0           $self->clear_seq_pos;
31             }
32              
33             has 'quant_found' =>
34             is => "rw",
35             isa => "Int",
36             lazy => 1,
37             default => 0,
38             clearer => 'clear_quant',
39             trigger => sub {
40             my $self = shift;
41             $self->clear_chosen;
42             $self->clear_element_ok;
43             },
44             ;
45              
46             has 'chosen' =>
47             is => "rw",
48             isa => "Int",
49             clearer => "clear_chosen",
50             trigger => sub {
51             $_[0]->clear_element_ok;
52             }
53             ;
54              
55             has 'element_ok' =>
56             is => "rw",
57             isa => "Bool",
58             clearer => "clear_element_ok",
59             ;
60              
61             # For recursion, we need to know a couple of extra things.
62             has 'base' =>
63             is => "ro",
64             isa => 'PRANG::Marshaller',
65             ;
66              
67             has 'xpath' =>
68             is => "ro",
69             isa => "Str",
70             ;
71              
72             has 'xsi' =>
73             is => "rw",
74             isa => "HashRef",
75             default => sub { {} },
76             ;
77              
78             has 'old_xsi' =>
79             is => "rw",
80             isa => "HashRef",
81             default => sub { {} },
82             ;
83              
84             has 'rxsi' =>
85             is => "rw",
86             isa => "HashRef",
87             lazy => 1,
88             default => sub {
89             my $self = shift;
90             +{ reverse %{ $self->xsi } };
91             },
92             ;
93              
94             has 'xsi_virgin' =>
95             is => "rw",
96             isa => "Bool",
97             default => 1,
98             ;
99              
100             sub thing_xmlns {
101 0     0 0   my $thing = shift;
102 0 0         return unless blessed $thing;
103 0           my $xmlns = shift;
104 0 0         if ( $thing->can("preferred_prefix") ) {
    0          
105 0           $thing->preferred_prefix($xmlns);
106             }
107             elsif ( $thing->can("xmlns_prefix") ) {
108 0           $thing->xmlns_prefix($xmlns);
109             }
110             }
111              
112             sub next_ctx {
113 0     0 1   my $self = shift;
114 0           my ( $xmlns, $newnode_name, $thing) = pos_validated_list(
115             \@_,
116             { isa => 'Maybe[Str]' },
117             { isa => 'Maybe[Str]' },
118             { optional => 1 },
119             );
120            
121 0           my $prefix = $self->prefix;
122 0           my $new_prefix;
123 0 0         if ($xmlns) {
124 0 0         if ( !exists $self->rxsi->{$xmlns} ) {
125 0           $new_prefix = 1;
126 0   0       $prefix = thing_xmlns($thing, $xmlns) //
127             $self->base->generate_prefix($xmlns);
128             }
129             else {
130 0           $prefix = $self->get_prefix($xmlns);
131             }
132             }
133 0 0 0       my $nodename = (($newnode_name && $prefix) ? "$prefix:" : "") .
      0        
134             ($newnode_name||"text()");
135              
136 0           my $clone = (ref $self)->new(
137             prefix => $prefix,
138             base => $self->base,
139             xpath => $self->xpath."/".$nodename,
140             xsi => $self->xsi,
141             rxsi => $self->rxsi,
142             );
143 0 0         if ($new_prefix) {
144 0           $clone->add_xmlns($prefix, $xmlns);
145             }
146 0           $clone;
147             }
148              
149             sub prefix_new {
150 0     0 1   my $self = shift;
151 0           my ( $prefix) = pos_validated_list(
152             \@_,
153             { isa => 'Str' },
154             );
155            
156 0   0       !$self->xsi_virgin and not exists $self->old_xsi->{$prefix};
157             }
158              
159             # this one is to know if the prefix was different to the parent type.
160             has 'prefix' =>
161             is => "ro",
162             isa => "Str",
163             ;
164              
165 7     7   15544 BEGIN { class_type "XML::LibXML::Node" }
166              
167             sub get_prefix {
168 0     0 1   my $self = shift;
169 0           my ( $xmlns, $thing, $victim ) = pos_validated_list(
170             \@_,
171             { isa => 'Str' },
172             { isa => 'Object', optional => 1 },
173             { isa => 'XML::LibXML::Element', optional => 1 },
174             );
175            
176 0 0         if ( defined(my $prefix = $self->rxsi->{$xmlns}) ) {
177 0           $prefix;
178             }
179             else {
180 0   0       my $new_prefix = thing_xmlns($thing, $xmlns)
181             // $self->base->generate_prefix($xmlns);
182 0           $self->add_xmlns($new_prefix, $xmlns);
183 0 0         if ($victim) {
184 0           $victim->setAttribute(
185             "xmlns:".$new_prefix,
186             $xmlns,
187             );
188             }
189 0           $new_prefix;
190             }
191             }
192              
193             sub add_xmlns {
194 0     0 1   my $self = shift;
195 0           my ( $prefix, $xmlns ) = pos_validated_list(
196             \@_,
197             { isa => 'Str' },
198             { isa => 'Str' },
199             );
200            
201 0 0         if ( $self->xsi_virgin ) {
202 0           $self->xsi_virgin(0);
203 0           $self->old_xsi($self->xsi);
204 0           $self->xsi({ %{$self->xsi}, $prefix => $xmlns });
  0            
205 0 0         if ( $self->rxsi ) {
206 0           $self->rxsi({ %{$self->rxsi}, $xmlns => $prefix });
  0            
207             }
208             }
209             else {
210 0           $self->xsi->{$prefix} = $xmlns;
211 0           $self->rxsi->{$xmlns} = $prefix;
212             }
213             }
214              
215             sub get_xmlns{
216 0     0 1   my $self = shift;
217 0           my ( $prefix, ) = pos_validated_list(
218             \@_,
219             { isa => 'Str' },
220             );
221            
222 0           $self->xsi->{$prefix};
223             }
224              
225             # this is a very convenient class to put a rich and useful exception
226             # method on; all important methods use it, and it has just the
227             # information to make the error message very useful.
228             sub exception {
229 0     0 1   my $self = shift;
230 0           my ( $message, $node, $skip_ok ) = pos_validated_list(
231             \@_,
232             { isa => 'Str' },
233             { isa => 'XML::LibXML::Node', optional => 1 },
234             { isa => 'Bool', optional => 1 },
235             );
236            
237            
238 0 0         my $error = PRANG::Graph::Context::Error->new(
    0          
239             ($node ? (node => $node) : ()),
240             message => $message,
241             xpath => $self->xpath,
242             ($skip_ok ? (skip_ok => 1) : ()),
243             );
244 0           die $error;
245             }
246              
247             package PRANG::Graph::Context::Error;
248             $PRANG::Graph::Context::Error::VERSION = '0.19';
249 7     7   13572 use Moose;
  7         14  
  7         49  
250 7     7   41112 use MooseX::Params::Validate;
  7         16  
  7         30  
251              
252             has 'node' =>
253             is => "ro",
254             isa => "XML::LibXML::Node",
255             predicate => "has_node",
256             ;
257              
258             has 'message' =>
259             is => "ro",
260             isa => "Str",
261             ;
262              
263             has 'xpath' =>
264             is => "ro",
265             isa => "Str",
266             ;
267              
268             has 'skip_ok' =>
269             is => "ro",
270             isa => "Bool",
271             ;
272              
273             sub show_node {
274 0     0 0   my $self = shift;
275            
276 0 0         return "" unless $self->has_node;
277 0           my $extra = "";
278 0           my $node = $self->node;
279 0 0         if ( $node->isa("XML::LibXML::Element") ) {
    0          
    0          
280 0           $extra = " (parsing: <".$node->nodeName;
281 0 0         if ( $node->hasAttributes ) {
282             $extra .= join(
283             " ", "",
284             map {
285 0           $_->name."='".$_->value."'"
  0            
286             } $node->attributes
287             );
288             }
289             my @nodes = grep {
290 0   0       !( $_->isa("XML::LibXML::Comment")
  0            
291             or
292             $_->isa("XML::LibXML::Text") and $_->data =~ /\A\s+\Z/
293             )
294             } $node->childNodes;
295 0 0 0       if (@nodes > 1
    0 0        
    0 0        
296 0           and grep { !$_->isa("XML::LibXML::Element") }
297             @nodes
298             )
299 0           { $extra .= ">(mixed content)";
300             }
301             elsif (@nodes and $nodes[0]->isa("XML::LibXML::Element")) {
302 0           $extra .= "><!-- ".@nodes
303             ." child XML nodes -->";
304             }
305             elsif ( @nodes and $nodes[0]->isa("XML::LibXML::Text") ) {
306 0           $extra .= ">(text content)";
307             }
308 0 0         if ( @nodes == 0 ) {
309 0           $extra .= " />";
310             }
311             else {
312 0           $extra .= "</".$node->nodeName.">";
313             }
314 0           $extra .= ")";
315             }
316             elsif ( $node->isa("XML::LibXML::Text") ) {
317 0           my $val = $node->data;
318 0 0         if ( length($val) > 15 ) {
319 0           $val = substr($val, 0, 13);
320 0           $val .= "...";
321             }
322 0           $extra .= " (at text node: '$val')";
323             }
324             elsif ($node) {
325 0           my $type = ref $node;
326 0           $type =~ s{XML::LibXML::}{};
327 0           $extra .= " (bogon? $type node)";
328             }
329 0           $extra;
330             }
331              
332             sub build_error {
333 0     0 0   my $self = shift;
334 0           my $message = $self->message;
335 0           my $extra = $self->show_node;
336 0           return "$message at ".$self->xpath."$extra\n";
337             }
338              
339             use overload
340 7         58 '""' => \&build_error,
341 7     7   5499 fallback => 1;
  7         17  
342              
343             1;
344              
345             __END__
346              
347             =head1 NAME
348              
349             PRANG::Graph::Context - parse/emit state for Marshalling operations
350              
351             =head1 SYNOPSIS
352              
353             my $context = PRANG::Graph::Context->new(
354             base => PRANG::Marshaller->get($class),
355             xpath => "/nodename",
356             );
357              
358             =head1 DESCRIPTION
359              
360             This is a data class, it basically is like a loop counter for parsing
361             (or emitting). Except instead of walking over a list, it 'walks' over
362             a tree of a certain, bound shape.
363              
364             The shape of the XML Graph at each node is limited to:
365              
366             Seq -> Quant -> Choice -> Element -> ( Text | Null )
367              
368             (any of the above may be absent)
369              
370             There are assumptions that nodes only connect as above, and not just
371             in this class.
372              
373             These state in this object allows the code to remember where it is. A
374             new instance is created for each node which may have children for the
375             parsing efforts for that node.
376              
377             =head1 ATTRIBUTES
378              
379             =over
380              
381             =item B<seq_pos>
382              
383             =item B<quant_found>
384              
385             =item B<chosen>
386              
387             =item B<element_ok>
388              
389             The above four properties are state information for any
390             L<PRANG::Graph::Seq>, L<PRANG::Graph::Quant>, L<PRANG::Graph::Choice>
391             or L<PRANG::Graph::Element> objects which exist in the graph for a
392             given class. As the nodes always connect in a particular order,
393             setting one value will clear all of the values for the settings which
394             follow.
395              
396             =item B<xpath>
397              
398             The XML location of the current node. Used for helpful error messages.
399              
400             =item B<xsi>
401              
402             =item B<rxsi>
403              
404             These attributes contain mappings from XML prefixes to namespace URIs
405             and vice versa. They should not be modified, as they are
406             copy-on-write from the parent Context objects.
407              
408             =item B<old_xsi>
409              
410             The B<xsi> attribute from the parent object. Used for C<prefix_new>
411              
412             =item B<xsi_virgin>
413              
414             Unset the first time a prefix is defined.
415              
416             =back
417              
418             =head1 METHODS
419              
420             This API is probably subject to quite some change. It is mainly
421             provided for assisting understanding with internal code.
422              
423             =head2 B<$ctx-E<gt>exception("message", $node?, $skip_ok?)>
424              
425             Raise a context-sensitive exception via C<die>. The XPath that the
426             current node was constructed with is appended with the nodename of the
427             passed node to provide an XML path for the error.
428              
429             Where parsing or emitting errors happen with one of these objects
430             around, it should always be used for reporting the error. The error
431             is a structured object (of type C<PRANG::Graph::Context::Error>) which
432             knows how to stringify into a readable error message.
433              
434             =head2 B<next_ctx( Maybe[Str] $xmlns, Str $newnode_name, $thing? ) returns PRANG::Graph::Context>
435              
436             This returns a new C<PRANG::Graph::Context> object, for the next level
437             of parsing.
438              
439             =head2 B<get_xmlns( Str $prefix ) returns Str>
440              
441             Returns the XML namespace associated with the passed prefix.
442              
443             =head2 B<get_prefix( Str $xmlns, Object $thing?, XML::LibXML::Element $victim? ) returns Str>
444              
445             Used for emitting. This is an alternative to reading the C<rxsi> hash
446             attribute directly. It returns the prefix for the given namespace URI
447             (C<$xmlns>), and if it is not already defined it will figure out based
448             on the type of C<$thing> what prefix to use, and add XML namespace
449             nodes to the C<$victim> XML namespace node. If the C<$thing> does not
450             specify a default XML namespace prefix, then one is chosen for it.
451              
452             =head2 B<add_xmlns( Str $prefix, Str $xmlns )>
453              
454             Used for parsing. This associates the given prefix with the given XML
455             namespace URI.
456              
457             =head2 B<prefix_new( Str $prefix )>
458              
459             This tells you whether or not the passed prefix was declared with this
460             Context or not. Used for emitting.
461              
462             =head1 SEE ALSO
463              
464             L<PRANG::Graph::Meta::Class>, L<PRANG::Graph::Meta::Attr>,
465             L<PRANG::Graph::Meta::Element>, L<PRANG::Marshaller>,
466              
467             Implementations:
468              
469             L<PRANG::Graph::Seq>, L<PRANG::Graph::Quant>, L<PRANG::Graph::Choice>,
470             L<PRANG::Graph::Element>, L<PRANG::Graph::Text>
471              
472             =head1 AUTHOR AND LICENCE
473              
474             Development commissioned by NZ Registry Services, and carried out by
475             Catalyst IT - L<http://www.catalyst.net.nz/>
476              
477             Copyright 2009, 2010, NZ Registry Services. This module is licensed
478             under the Artistic License v2.0, which permits relicensing under other
479             Free Software licenses.
480              
481             =cut