File Coverage

blib/lib/Data/Dump/XML.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package Data::Dump::XML;
2              
3 5     5   5966 use Class::Easy;
  5         10  
  5         51  
4              
5 5     5   3116 use XML::LibXML ();
  0            
  0            
6              
7             our $VERSION = '1.19'; # avoid locale issues by stringified version
8              
9             require XSLoader;
10             XSLoader::load ('Data::Dump::XML', $VERSION);
11              
12             our $defaults = {
13             # xml configuration
14             encoding => 'utf-8',
15             dtd_location => '',
16             namespace => {},
17            
18             # xml tree namespace
19             dump_config => 1,
20             root_name => 'data',
21             hash_element => 'key',
22             array_element => 'item',
23             ref_element => 'ref',
24             empty_array => 'empty-array',
25             empty_hash => 'empty-hash',
26             undef => 'undef',
27             key_as_hash_element => 1,
28             hash_element_attribute_name => '_name',
29             at_key_as_attribute => 1,
30            
31             # options
32             sort_keys => 0,
33             granted_restore => 1,
34             ignore_bless => 0,
35            
36             # internal structure
37             doc_object => undef,
38             references => {},
39             ref_count => 0,
40             used => {},
41             };
42              
43             1;
44             ############################################################
45             sub new {
46             my $class = shift;
47             my $params = {@_};
48            
49             my $config = {%$defaults};
50            
51             foreach my $key (keys %$params) {
52             if (exists $config->{$key}) {
53             $config->{$key} = $params->{$key};
54             }
55             }
56              
57             if (exists $config->{'@key_as_attribute'}) {
58             $config->{at_key_as_attribute} = delete $config->{'@key_as_attribute'};
59             }
60            
61             bless $config, $class;
62            
63             return $config;
64             }
65             ############################################################
66             sub dump_xml {
67             my $self = shift;
68              
69             my $structure;
70             my $root;
71              
72             my $dom = XML::LibXML->createDocument ('1.0', $self->{encoding});
73             $self->{doc_object} = $dom;
74            
75            
76             if ($self->{dtd_location} ne '') {
77             $dom->createInternalSubset ('data', undef, $self->{dtd_location});
78             }
79            
80             $root = $dom->createElement ($self->{root_name});
81             $dom->setDocumentElement ($root);
82              
83              
84             if ((scalar @_) == 1) {
85             $structure = shift;
86              
87             if (blessed ($structure) and $structure->can ('TO_XML')) {
88             $root->setAttribute (_class => blessed ($structure));
89             $structure = $structure->TO_XML;
90             $root->setAttribute (_to_xml => 1);
91             }
92              
93             } else {
94             $structure = \@_;
95             }
96            
97            
98             # dump config options if any
99             foreach (qw(ref_element hash_element array_element empty_array empty_hash undef key_as_hash_element at_key_as_attribute)) {
100             $root->setAttribute ("_$_", $self->{$_})
101             if $self->{$_} ne $defaults->{$_};
102             }
103            
104             if (scalar keys %{$self->{namespace}}) {
105             foreach my $key (keys %{$self->{namespace}}) {
106             $root->setAttribute ($key, $self->{namespace}->{$key});
107             #debug "add '$key' namespace";
108             }
109             }
110            
111             $self->{references} = {};
112             $self->{ref_count} = 0;
113             $self->{used} = {};
114            
115             # $self->analyze ($structure);
116            
117             #my $refs = $self->{'references'};
118             #
119             #foreach (keys %$refs)
120             #{
121             # delete $refs->{$_} unless ($refs->{$_});
122             #}
123            
124             $self->simple_dump ($structure);
125            
126             return $self->{doc_object};
127            
128             }
129             ############################################################
130             sub simple_dump {
131             my $self = shift;
132             my $rval = \$_[0]; shift;
133            
134             my $dom = $self->{doc_object};
135              
136             my $tag = shift || $dom->documentElement;
137             my $deref = shift;
138              
139             $rval = $$rval if $deref;
140            
141             my $ref_element = $self->{ref_element};
142             my $array_element = $self->{array_element};
143             my $hash_element = $self->{hash_element};
144             my $empty_array = $self->{empty_array};
145             my $undef = $self->{undef};
146             my $empty_hash = $self->{empty_hash};
147            
148             my ($class, $type, $id) = (
149             blessed ($rval),
150             reftype ($rval),
151             refaddr ($rval)
152             );
153            
154             if (defined $class) {
155             if ($class eq 'XML::LibXML::Element') {
156            
157             if ($rval->localname eq 'include' and (
158             $rval->lookupNamespacePrefix ('http://www.w3.org/2003/XInclude')
159             or $rval->lookupNamespacePrefix ('http://www.w3.org/2001/XInclude')
160             )) {
161             #my $node = $tag->addNewChild ('', 'include');
162             #$node->setNamespace ('http://www.w3.org/2003/XInclude', 'xi');
163             #$node->setAttribute ('href', $rval->getAttribute ('href'));
164            
165             my $parser = XML::LibXML->new;
166             $parser->expand_xinclude(0); # we try this later
167             $parser->load_ext_dtd(0);
168             $parser->expand_entities(0);
169            
170             my $include;
171             eval {
172             $include = $parser->parse_file ($rval->getAttribute ('href'));
173             };
174             #my $xinclude_result;
175             #eval {$xinclude_result = $parser->process_xincludes ($include);};
176              
177             #debug "XInclude processing result is: $xinclude_result, error is: $@";
178            
179             $tag->addChild ($include->documentElement)
180             if not $@ and defined $include;
181            
182             } else {
183             $tag->addChild ($rval);
184             }
185            
186             return;
187             } elsif ($class ne '') {
188            
189             $tag->setAttribute (_class => $class);
190            
191             if ($rval->can ('TO_XML')) {
192             $rval = $rval->TO_XML;
193             $tag->setAttribute (_to_xml => 1);
194             ($class, $type, $id) = (
195             blessed ($rval),
196             reftype ($rval),
197             refaddr ($rval)
198             );
199             }
200            
201              
202             }
203             }
204            
205             #if (my $ref_no = $self->refs ($id)) {
206             # if (defined $self->{'used'}->{$id}
207             # and $self->{'used'}->{$id} eq 'yea'
208             # ) {
209             #
210             # my $node = $tag->addNewChild ('', $ref_element);
211             # $node->setAttribute ('to', $ref_no);
212             # return;
213             #
214             # } else {
215             #
216             # $tag->setAttribute ('id', $ref_no);
217             # $self->{'used'}->{$id} = 'yea';
218             #
219             # }
220             #}
221            
222             if ($type eq "SCALAR" || $type eq "REF"){
223            
224             my $rval_ref = ref $$rval;
225            
226             if ($rval_ref) {
227            
228             if (($rval_ref eq 'SCALAR') or ($rval_ref eq 'REF')) {
229            
230             my $node = $tag->addNewChild ('', $ref_element);
231             return $self->simple_dump ($$rval, $node, 1);
232             }
233            
234             return $self->simple_dump ($$rval, $tag, 1);
235            
236             } elsif (
237             not defined $$rval and defined $rval
238             and defined $class and $class ne ''
239             ) {
240             # regexp. 100% ?
241             # debug "has undefined deref '$$rval' and defined '$rval'";
242             $tag->addNewChild ('', $rval);
243            
244             } elsif (not defined $$rval) {
245            
246             $tag->addNewChild ('', $self->{undef});
247            
248             } else {
249            
250             $tag->appendText ($$rval);
251            
252             }
253            
254             #debug $rval, $$rval, ref $rval, ref $$rval;
255            
256             return;
257             } elsif ($type eq "ARRAY") {
258             my @array;
259            
260             unless (scalar @$rval){
261             $tag->addNewChild ('', $self->{empty_array});
262             return;
263             }
264            
265             my $level_up = 0;
266             my $option_attr = $tag->getAttribute ('_opt');
267             if (defined $option_attr and $option_attr eq 'up') {
268             $level_up = 1;
269             }
270            
271             my $idx = 0;
272             my $tag_name = $tag->nodeName;
273             # debug "tag mane is : $tag_name, level up is : $level_up";
274            
275             foreach (@$rval) {
276             my $node;
277             if ($level_up) {
278             if ($idx) {
279             $node = $tag->parentNode->addNewChild ('', $tag_name);
280             } else {
281             $node = $tag;
282             $tag->removeAttribute ('_opt');
283             }
284             # $tag->setAttribute ('idx', $idx);
285             } else {
286             $node = $tag->addNewChild ('', $array_element);
287             }
288            
289             $idx++;
290             $self->simple_dump ($_, $node);
291             }
292            
293             return;
294             } elsif ($type eq "HASH") {
295            
296             my @keys = keys %$rval;
297            
298             unless (scalar @keys) {
299             $tag->addNewChild ('', $self->{empty_hash});
300             return;
301             }
302            
303             @keys = sort @keys
304             if $self->{sort_keys};
305            
306             #$self->dump_hashref ($rval, \@keys, $tag);
307             $self->dump_hashref_pp ($rval, \@keys, $tag);
308            
309             return;
310            
311             } elsif ($type eq "GLOB") {
312              
313             $tag->addNewChild ('', 'glob');
314             return;
315              
316             } elsif ($type eq "CODE") {
317              
318             $tag->addNewChild ('', 'code');
319             return;
320              
321             } else {
322             my $comment = $dom->createComment ("unknown type: '$type'");
323             $tag->addChild ($comment);
324             return;
325             }
326            
327             die "Assert";
328             }
329             ############################################################
330             sub key_info_pp {
331             my $self = shift;
332             my ($rval, $key, $val_ref) = @_;
333            
334             my $key_prefix = substr $key, 0, 1;
335             my $key_name = substr $key, 1;
336            
337             if ($key_prefix ne '@' and $key_prefix ne '#' and $key_prefix ne '<') {
338             $key_name = $key;
339             }
340            
341             my $val_type = reftype ($val_ref);
342            
343             # [4] NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6] | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF] | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF]
344             # [4a] NameChar ::= NameStartChar | "-" | "." | [0-9] | #xB7 | [#x0300-#x036F] | [#x203F-#x2040]
345             my $key_can_be_tag = $key_name =~ /^[a-zA-Z\:\_][\w\d\_\-\:\.]$/;
346            
347             return ($key_prefix, $key_name, $val_type, $key_can_be_tag);
348            
349             }
350             ############################################################
351             sub dump_hashref_pp {
352             my $self = shift;
353             my ($rval, $keys, $tag) = @_;
354            
355             foreach my $key (@$keys) {
356            
357             my $val = \$rval->{$key};
358             my $node;
359              
360             my ($key_prefix, $key_name, $val_type, $key_can_be_tag) =
361             $self->key_info ($rval, $key, $$val);
362            
363             if ($key_can_be_tag) {
364             if (defined $key_prefix and $key_prefix eq '@' and $self->{at_key_as_attribute}) {
365             # TODO: make something with values other than scalar ref
366            
367             unless (defined $val_type) {
368             $tag->setAttribute ($key_name, $$val);
369             next;
370             }
371            
372             } elsif (defined $key_prefix and $key_prefix eq '#' and $key_name eq 'text') {
373             unless (defined $val_type) {
374             $tag->appendText ($$val);
375             next;
376             }
377             } elsif (
378             $self->{key_as_hash_element}
379             and $key ne $self->{array_element} # for RSS
380             and $key ne $self->{hash_element}
381             and $key ne $self->{ref_element}
382             and $key ne $self->{empty_array}
383             and $key ne $self->{empty_hash}
384             and $key ne $self->{undef}
385             ) {
386             $node = $tag->addNewChild ('', $key_name);
387             if (defined $key_prefix and $key_prefix eq '<') {
388             $node->setAttribute (_opt => 'up');
389             }
390             }
391             } else {
392             $node = $tag->addNewChild ('', $self->{hash_element});
393             $node->setAttribute ($self->{hash_element_attribute_name}, $key);
394             }
395            
396             $self->simple_dump ($$val, $node);
397             }
398            
399             }
400              
401             ############################################################
402             __END__