File Coverage

blib/lib/Data/asXML.pm
Criterion Covered Total %
statement 19 21 90.4
branch n/a
condition n/a
subroutine 7 7 100.0
pod n/a
total 26 28 92.8


line stmt bran cond sub pod time code
1             package Data::asXML;
2              
3             =encoding utf-8
4              
5             =head1 NAME
6              
7             Data::asXML - convert data structures to/from XML
8              
9             =head1 SYNOPSIS
10              
11             use Data::asXML;
12             my $dxml = Data::asXML->new();
13             my $dom = $dxml->encode({
14             'some' => 'value',
15             'in' => [ qw(a data structure) ],
16             });
17              
18             my $data = $dxml->decode(q{
19            
20             value
21            
22            
23             a
24             data
25             structure
26            
27            
28            
29             });
30              
31             my (%hash1, %hash2);
32             $hash1{other}=\%hash2;
33             $hash2{other}=\%hash1;
34             print Data::asXML->new->encode([1, \%hash1, \%hash2])->toString;
35            
36            
37             1
38            
39            
40            
41            
42            
43            
44            
45            
46            
47            
48            
49              
50             For more examples see F.
51              
52             =head1 WARNING
53              
54             experimental, use at your own risk :-)
55              
56             =head1 DESCRIPTION
57              
58             There are couple of modules mapping XML to data structures. (L,
59             L, L, ...) but they aim at making data structures
60             adapt to XML structure. This one defines couple of simple XML tags to represent
61             data structures. It makes the serialization to and from XML possible.
62              
63             For the moment it is an experiment. I plan to use it for passing data
64             structures as DOM to XSLT for transformations, so that I can match them
65             with XPATH similar way how I access them in Perl.
66              
67             /HASH/KEY[@name="key"]/VALUE
68             /HASH/KEY[@name="key2"]/ARRAY/*[3]/VALUE
69             /ARRAY/*[1]/VALUE
70             /ARRAY/*[2]/HASH/KEY[@name="key3"]/VALUE
71              
72             If you are looking for a module to serialize your data, without requirement
73             to do so in XML, you should probably better have a look at L
74             or L.
75              
76             =cut
77              
78 1     1   36109 use warnings;
  1         2  
  1         26  
79 1     1   3 use strict;
  1         2  
  1         26  
80              
81 1     1   3 use utf8;
  1         6  
  1         5  
82 1     1   26 use 5.010;
  1         2  
  1         29  
83 1     1   4 use feature 'state';
  1         3  
  1         86  
84              
85 1     1   4 use Carp 'croak';
  1         1  
  1         53  
86 1     1   269 use XML::LibXML 'XML_ELEMENT_NODE';
  0            
  0            
87             use Scalar::Util 'blessed';
88             use URI::Escape qw(uri_escape uri_unescape);
89             use Test::Deep::NoTest 'eq_deeply';
90             use XML::Char;
91             use MIME::Base64 'decode_base64';
92              
93             our $VERSION = '0.06';
94              
95             use base 'Class::Accessor::Fast';
96              
97             =head1 PROPERTIES
98              
99             =over 4
100              
101             =item pretty
102              
103             (default 1 - true) will insert text nodes to the XML to make the output indented.
104              
105             =item safe_mode
106              
107             (default undef - false)
108              
109             in case of C perform the xml string decoding back and will compare
110             the two data structures to be sure the data can be reconstructed back without
111             errors.
112              
113             in case of a C it will decode to data then encode to xml string and from
114             xml string decode back to data. this two data values are then compared.
115              
116             Both compares is done using L::eq_deeply.
117              
118             =item namespace
119              
120             (default undef - false)
121              
122             adds xml:ns attribute to the root element. if C is set to 1
123             the xml:ns will be L otherwise
124             it will be the value of C.
125              
126             =back
127              
128             =cut
129              
130             __PACKAGE__->mk_accessors(qw{
131             pretty
132             safe_mode
133             namespace
134             });
135              
136             =head1 METHODS
137              
138             =head2 new()
139              
140             Object constructor.
141              
142             =cut
143              
144             sub new {
145             my $class = shift;
146             my $self = $class->SUPER::new({
147             'pretty' => 1,
148             @_
149             });
150            
151             return $self;
152             }
153              
154             sub _xml {
155             my($self) = @_;
156             if(not exists $self->{'_xml'}) {
157             my $xml = XML::LibXML::Document->new("1.0", "UTF-8");
158             $self->{'_xml'} = $xml;
159             }
160             return $self->{'_xml'};
161             }
162              
163              
164             sub _indent {
165             my $self = shift;
166             my $where = shift;
167             my $indent = shift;
168            
169             $where->addChild( $self->_xml->createTextNode( "\n".("\t" x $indent) ) )
170             if $self->pretty;
171             }
172              
173              
174             =head2 encode($what)
175              
176             From structure C<$what> generates L DOM. Call
177             C<< ->toString >> to get XML string. For more actions see L.
178              
179             =cut
180              
181             sub encode {
182             my $self = shift;
183             my $what = shift;
184             my $pos = shift || 1;
185             my $where;
186            
187             my $safe_mode = $self->safe_mode;
188             $self->safe_mode(0);
189             my $add_namespace = $self->namespace || 0;
190             $add_namespace = "http://search.cpan.org/perldoc?Data::asXML"
191             if $add_namespace eq '1';
192             $self->namespace(0);
193            
194             state $indent = 0;
195            
196             if (not $self->{'_cur_xpath_steps'}) {
197             $self->{'_href_mapping'} = {};
198             $self->{'_cur_xpath_steps'} = [];
199             }
200            
201             # create DOM for hash element
202             if (ref($what) eq 'HASH') {
203             $where = $self->_xml->createElement('HASH');
204             $indent++;
205             push @{$self->{'_cur_xpath_steps'}}, $pos;
206             # already encoded reference
207             if (exists $self->{'_href_mapping'}->{$what}) {
208             $where->setAttribute(
209             'href' =>
210             $self->_make_relative_xpath(
211             [ split(',', $self->{'_href_mapping'}->{$what}) ],
212             $self->{'_cur_xpath_steps'}
213             )
214             );
215             $indent--;
216             pop @{$self->{'_cur_xpath_steps'}};
217             return $where;
218             }
219             $self->{'_href_mapping'}->{$what} = $self->_xpath_steps_string();
220            
221             my $key_pos = 0;
222             foreach my $key (sort keys %{$what}) {
223             my $value = $what->{$key};
224             $key_pos++;
225             $self->_indent($where, $indent);
226             $indent++;
227              
228             my $el = $self->_xml->createElement('KEY');
229             push @{$self->{'_cur_xpath_steps'}}, $key_pos;
230             $self->_indent($el, $indent);
231             $el->setAttribute('name', $key);
232             $el->addChild($self->encode($value));
233              
234             $indent--;
235             $self->_indent($el, $indent);
236             pop @{$self->{'_cur_xpath_steps'}};
237              
238             $where->addChild($el);
239             }
240            
241             $indent--;
242             $self->_indent($where, $indent);
243             pop @{$self->{'_cur_xpath_steps'}};
244             }
245             # create DOM for array element
246             elsif (ref($what) eq 'ARRAY') {
247             $where = $self->_xml->createElement('ARRAY');
248             $indent++;
249             push @{$self->{'_cur_xpath_steps'}}, $pos;
250             # already encoded reference
251             if (exists $self->{'_href_mapping'}->{$what}) {
252             $where->setAttribute(
253             'href' =>
254             $self->_make_relative_xpath(
255             [ split(',', $self->{'_href_mapping'}->{$what}) ],
256             $self->{'_cur_xpath_steps'}
257             )
258             );
259             $indent--;
260             pop @{$self->{'_cur_xpath_steps'}};
261             return $where;
262             }
263             $self->{'_href_mapping'}->{$what.''} = $self->_xpath_steps_string();
264            
265             my $array_pos = 0;
266             foreach my $value (@{$what}) {
267             $array_pos++;
268             $self->_indent($where, $indent);
269             $where->addChild($self->encode($value, $array_pos));
270             }
271            
272             $indent--;
273             $self->_indent($where, $indent);
274             pop @{$self->{'_cur_xpath_steps'}};
275             }
276             # create element for pure reference
277             elsif (ref($what) eq 'REF') {
278             $where = $self->_xml->createElement('REF');
279             $indent++;
280             push @{$self->{'_cur_xpath_steps'}}, $pos;
281             # already encoded reference
282             if (exists $self->{'_href_mapping'}->{$what}) {
283             $where->setAttribute(
284             'href' =>
285             $self->_make_relative_xpath(
286             [ split(',', $self->{'_href_mapping'}->{$what}) ],
287             $self->{'_cur_xpath_steps'}
288             )
289             );
290             $indent--;
291             pop @{$self->{'_cur_xpath_steps'}};
292             return $where;
293             }
294             $self->{'_href_mapping'}->{$what.''} = $self->_xpath_steps_string();
295            
296             $self->_indent($where, $indent);
297             $where->addChild($self->encode($$what));
298            
299             $indent--;
300             $self->_indent($where, $indent);
301             pop @{$self->{'_cur_xpath_steps'}};
302             }
303             # scalar reference
304             elsif (ref($what) eq 'SCALAR') {
305             push @{$self->{'_cur_xpath_steps'}}, $pos;
306             # already encoded reference
307             if (exists $self->{'_href_mapping'}->{$what}) {
308             $where = $self->_xml->createElement('VALUE');
309             $where->setAttribute(
310             'href' =>
311             $self->_make_relative_xpath(
312             [ split(',', $self->{'_href_mapping'}->{$what}) ],
313             $self->{'_cur_xpath_steps'}
314             )
315             );
316             pop @{$self->{'_cur_xpath_steps'}};
317             return $where;
318             }
319             $self->{'_href_mapping'}->{$what.''} = $self->_xpath_steps_string();
320              
321             $where = $self->encode($$what);
322             $where->setAttribute('subtype' => 'ref');
323              
324             pop @{$self->{'_cur_xpath_steps'}};
325             }
326             # create text node
327             elsif (ref($what) eq '') {
328             $where = $self->_xml->createElement('VALUE');
329             if (defined $what) {
330             # uri escape if it contains invalid XML characters
331             if (not XML::Char->valid($what)) {
332             $what = join q(), map {
333             (/[[:^print:]]/ or q(%) eq $_) ? uri_escape $_ : $_
334             } split //, $what;
335             $where->setAttribute('type' => 'uriEscape');
336             }
337             $where->addChild( $self->_xml->createTextNode( $what ) );
338             }
339             else {
340             # no better way to distinguish between empty string and undef - see http://rt.cpan.org/Public/Bug/Display.html?id=51442
341             $where->setAttribute('type' => 'undef');
342             }
343            
344             }
345             #
346             else {
347             die 'unknown reference - '.$what;
348             }
349              
350             # cleanup at the end
351             if ($indent == 0) {
352             $self->{'_href_mapping'} = {};
353             $self->{'_cur_xpath_steps'} = [];
354             }
355              
356             # in safe_mode decode back the xml string and compare the data structures
357             if ($safe_mode) {
358             my $xml_string = $where->toString;
359             my $what_decoded = eval { $self->decode($xml_string) };
360            
361             die 'encoding failed '.$@.' of '.eval('use Data::Dumper; Dumper([$what, $xml_string, $what_decoded])').' failed'
362             if not eq_deeply($what, $what_decoded);
363            
364             # set back the safe mode after all was encoded
365             $self->safe_mode($safe_mode);
366             }
367            
368             # add namespace if requested
369             if ($add_namespace) {
370             $where->setAttribute('xmlns' => $add_namespace);
371             $self->namespace($add_namespace);
372             }
373            
374             return $where;
375             }
376              
377             sub _xpath_steps_string {
378             my $self = shift;
379             my $path_array = shift || $self->{'_cur_xpath_steps'};
380             return join(',',@{$path_array});
381             }
382              
383             sub _make_relative_xpath {
384             my $self = shift;
385             my $orig_path = shift;
386             my $cur_path = shift;
387            
388             # find how many elements (from beginning) the paths are sharing
389             my $common_root_index = 0;
390             while (
391             ($common_root_index < @$orig_path)
392             and ($orig_path->[$common_root_index] == $cur_path->[$common_root_index])
393             ) {
394             $common_root_index++;
395             }
396            
397             # add '..' to move up the element hierarchy until the common element
398             my @rel_path = ();
399             my $i = $common_root_index+1;
400             while ($i < scalar @$cur_path) {
401             push @rel_path, '..';
402             $i++;
403             }
404            
405             # add the original element path steps
406             $i = $common_root_index;
407             while ($i < scalar @$orig_path) {
408             push @rel_path, $orig_path->[$i];
409             $i++;
410             }
411            
412             # in case of self referencing the element index is needed
413             if ($i == $common_root_index) {
414             push @rel_path, '..', $orig_path->[-1];
415             }
416            
417             # return relative xpath
418             return join('/', map { $_ eq '..' ? $_ : '*['.$_.']' } @rel_path);
419             }
420              
421             =head2 decode($xmlstring)
422              
423             Takes C<$xmlstring> and converts to data structure.
424              
425             =cut
426              
427             sub decode {
428             my $self = shift;
429             my $xml = shift;
430             my $pos = shift || 1;
431              
432             # in safe_mode "encode+decode" the decoded data for comparing
433             if ($self->safe_mode) {
434             $self->safe_mode(0);
435             my $data = $self->decode($xml, $pos);
436             my $data_redecoded = eval { $self->decode(
437             $self->encode($data)->toString,
438             $pos,
439             )};
440             die 'redecoding failed "'.$@.'" of '.eval('use Data::Dumper; Dumper([$xml, $data, $data_redecoded])').' failed'
441             if not eq_deeply($data, $data_redecoded);
442             $self->safe_mode(1);
443             return $data;
444             }
445              
446             if (not $self->{'_cur_xpath_steps'}) {
447             local $self->{'_href_mapping'} = {};
448             local $self->{'_cur_xpath_steps'} = [];
449             }
450              
451             my $value;
452            
453             if (not blessed $xml) {
454             my $parser = XML::LibXML->new();
455             my $doc = $parser->parse_string($xml);
456             my $root_element = $doc->documentElement();
457            
458             return $self->decode($root_element);
459             }
460            
461             if ($xml->nodeName eq 'HASH') {
462             if (my $xpath_path = $xml->getAttribute('href')) {
463             my $href_key = $self->_href_key($xpath_path);
464             return $self->{'_href_mapping'}->{$href_key} || die 'invalid reference - '.$href_key.' ('.$xml->toString.')';
465             }
466            
467             push @{$self->{'_cur_xpath_steps'}}, $pos;
468            
469             my %data;
470             $self->{'_href_mapping'}->{$self->_xpath_steps_string()} = \%data;
471             my @keys =
472             grep { $_->nodeName eq 'KEY' }
473             grep { $_->nodeType eq XML_ELEMENT_NODE }
474             $xml->childNodes()
475             ;
476             my $key_pos = 1;
477             foreach my $key (@keys) {
478             push @{$self->{'_cur_xpath_steps'}}, $key_pos;
479             my $key_name = $key->getAttribute('name');
480             my $key_value = $self->decode(grep { $_->nodeType eq XML_ELEMENT_NODE } $key->childNodes()); # is always only one
481             $data{$key_name} = $key_value;
482             pop @{$self->{'_cur_xpath_steps'}};
483             $key_pos++;
484             }
485             pop @{$self->{'_cur_xpath_steps'}};
486             return \%data;
487             }
488             elsif ($xml->nodeName eq 'ARRAY') {
489             if (my $xpath_path = $xml->getAttribute('href')) {
490             my $href_key = $self->_href_key($xpath_path);
491            
492             return $self->{'_href_mapping'}->{$href_key} || die 'invalid reference - '.$href_key.' ('.$xml->toString.')';
493             }
494              
495             push @{$self->{'_cur_xpath_steps'}}, $pos;
496              
497             my @data;
498             $self->{'_href_mapping'}->{$self->_xpath_steps_string()} = \@data;
499            
500             my $array_element_pos = 1;
501             @data = map { $self->decode($_, $array_element_pos++) } grep { $_->nodeType eq XML_ELEMENT_NODE } $xml->childNodes();
502             pop @{$self->{'_cur_xpath_steps'}};
503             return \@data;
504             }
505             elsif ($xml->nodeName eq 'REF') {
506             if (my $xpath_path = $xml->getAttribute('href')) {
507             my $href_key = $self->_href_key($xpath_path);
508             return $self->{'_href_mapping'}->{$href_key} || die 'invalid reference - '.$href_key.' ('.$xml->toString.')';
509             }
510              
511             push @{$self->{'_cur_xpath_steps'}}, $pos;
512              
513             my $data;
514             $self->{'_href_mapping'}->{$self->_xpath_steps_string()} = \$data;
515            
516             ($data) = map { $self->decode($_) } grep { $_->nodeType eq XML_ELEMENT_NODE } $xml->childNodes();
517              
518             pop @{$self->{'_cur_xpath_steps'}};
519             return \$data;
520             }
521             elsif ($xml->nodeName eq 'VALUE') {
522             if (my $xpath_path = $xml->getAttribute('href')) {
523             my $href_key = $self->_href_key($xpath_path);
524             return $self->{'_href_mapping'}->{$href_key} || die 'invalid reference - '.$href_key.' ('.$xml->toString.')';
525             }
526              
527             push @{$self->{'_cur_xpath_steps'}}, $pos;
528             my $value;
529             $self->{'_href_mapping'}->{$self->_xpath_steps_string()} = \$value;
530             pop @{$self->{'_cur_xpath_steps'}};
531            
532             my $type = $xml->getAttribute('type') // '';
533             my $subtype = $xml->getAttribute('subtype') // '';
534             if ($type eq 'undef')
535             { $value = undef; }
536             elsif ($type eq 'base64')
537             { $value = decode_base64($xml->textContent) } # left for backwards compatibility, will be removed one day...
538             elsif ($type eq 'uriEscape')
539             { $value = uri_unescape $xml->textContent; }
540             else
541             { $value = $xml->textContent }
542             return \$value
543             if ($subtype eq 'ref');
544             return $value;
545             }
546             else {
547             die 'invalid (unknown) element "'.$xml->toString.'"'
548             }
549            
550             }
551              
552             sub _href_key {
553             my $self = shift;
554             my $xpath_steps_string = shift;
555            
556             my @path = @{$self->{'_cur_xpath_steps'}};
557             my @xpath_steps =
558             map { $_ =~ m/^\*\[(\d+)\]$/xms ? $1 : $_ }
559             split('/', $xpath_steps_string)
560             ;
561            
562             my $i = 0;
563             while ($i < @xpath_steps) {
564             if ($xpath_steps[$i] eq '..') {
565             pop(@path);
566             }
567             else {
568             push(@path, $xpath_steps[$i]);
569             }
570             $i++;
571             }
572             return $self->_xpath_steps_string(\@path)
573             }
574              
575             1;
576              
577              
578             __END__