File Coverage

blib/lib/Nile/XML.pm
Criterion Covered Total %
statement 6 90 6.6
branch 0 26 0.0
condition 0 9 0.0
subroutine 2 16 12.5
pod 0 12 0.0
total 8 153 5.2


line stmt bran cond sub pod time code
1             # Copyright Infomation
2             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3             # Author : Dr. Ahmed Amin Elsheshtawy, Ph.D.
4             # Website: https://github.com/mewsoft/Nile, http://www.mewsoft.com
5             # Email : mewsoft@cpan.org, support@mewsoft.com
6             # Copyrights (c) 2014-2015 Mewsoft Corp. All rights reserved.
7             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8             package Nile::XML;
9              
10             our $VERSION = '0.54';
11             our $AUTHORITY = 'cpan:MEWSOFT';
12              
13             =pod
14              
15             =encoding utf8
16              
17             =head1 NAME
18              
19             Nile::XML - XML file manager.
20              
21             =head1 SYNOPSIS
22            
23             # get a reference to the framework xml object.
24             $xml = $self->app->xml;
25              
26             # get a reference to a new xml object.
27             $xml = $self->app->xml->new;
28              
29             # keep sort order when reading and writing the xml file data. default is off.
30             #$xml->keep_order(1);
31              
32             # load xml file
33             $xml->load("path/to/xml/file.xml");
34              
35             # load and append another xml file to the same object
36             $xml->load("path/to/xml/another.xml");
37              
38             # get value of email tag <email>ahmed@mewsoft.com</email>
39             say $xml->get('email');
40              
41             # get tag value, if not found return the provided default value.
42             $var = $xml->get($name, $default);
43              
44             # get tag attribute of email tag <email status='expired'>ahmed@mewsoft.com</email>
45             # The prefix '-' is added on every attribute's name.
46             say $xml->get('email')->{'-status'};
47              
48             # if an element has both of a text node and attributes or both of a text node and other child nodes,
49             # value of a text node is moved to #text like child nodes.
50             say $xml->get('email')->{'#text'};
51              
52             # get value of email tag inside other tags
53             # <users><user><contact><email>ahmed@mewsoft.com</email></contact></user></users>
54             say $xml->get('users/user/contact/email');
55              
56             # automatic getter support
57             $email = $xml->email; # same as $xml->get('email');
58              
59             # automatic setter support
60             $xml->email('ahmed@mewsoft.com'); # $xml->set('email', 'ahmed@mewsoft.com');
61              
62             # set value of email tag <email></email>
63             $xml->set('email', 'ahmed@mewsoft.com');
64              
65             # set value of email tag inside other tags
66             # <users><user><contact><email></email></contact></user></users>
67             $xml->set('users/user/contact/email', 'ahmed@mewsoft.com');
68            
69             # access variables as a hash tree
70             $xml->var->{accounts}->{users}->{admin}->{username} = 'admin';
71              
72             # get a list of tags values.
73             ($users, $views, $items) = $xml->list( qw( users views items ) );
74              
75             # delete xml tags by names
76             $xml->delete(@names);
77              
78             # delete entire xml object contents in memory
79             $xml->clear();
80              
81             # load and append another xml file to the object
82             $xml->add_file($another_file);
83              
84             # updated the provided tags and save changes to the file
85             $xml->update(%tags);
86              
87             # Save changes to the output file. If no file name just update the loaded file name.
88             $xml->save($file);
89              
90             # load xml file content and return it as a hash, not added to the object
91             %xml_hash = $xml->get_file($file);
92             say $xml_hash{root}{config}{database}{user};
93              
94             # load xml file content and return it as a hash ref, not added to the object
95             $xml_hash_ref = $xml->get_file($file);
96             say $xml_hash_ref->{root}->{config}->{database}->{user};
97              
98             # get a new xml object
99             #my $xml_other = $xml->object;
100             #my $xml_other = $xml->new;
101            
102             # load and manage another xml files separately
103             #$xml_other->load("xmlfile");
104              
105             =head1 DESCRIPTION
106              
107             Nile::XML - XML file manager.
108              
109             Parsing and writing XML files into a hash tree object supports sorted order and build on the module L<XML::TreePP>.
110              
111             =cut
112              
113 1     1   7 use Nile::Base;
  1         2  
  1         10  
114 1     1   6265 use XML::TreePP;
  1         5323  
  1         1163  
115             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116             =head2 xml()
117            
118             # get a new XML::TreePP object.
119             $xml_obj = $xml->xml(@names);
120             # then you can use $xml_obj as XML::TreePP object.
121              
122             Returns a new L<XML::TreePP> object.
123              
124             =cut
125              
126             has 'xml' => (
127             is => 'rw',
128             default => sub {XML::TreePP->new()},
129             );
130              
131              
132             =head2 file()
133            
134             # set output file name for saving
135             $xml->file($file);
136              
137             # get output file name
138             $file = $xml->file();
139              
140             Get and set the output xml file name used when saving or updating.
141              
142             =cut
143              
144             has 'file' => (
145             is => 'rw',
146             );
147              
148             =head2 encoding()
149            
150             # get encoding used to read/write the file, default is 'UTF-8'.
151             $encoding = $xml->encoding();
152            
153             # set encoding used to read/write the file, default is 'UTF-8'.
154             $xml->encoding('UTF-8');
155              
156             Get and set encoding used to read/write the xml file The default encoding is 'UTF-8'.
157              
158             =cut
159              
160             has 'encoding' => (
161             is => 'rw',
162             default => 'UTF-8',
163             );
164              
165             =head2 indent()
166            
167             # get indent, default 4.
168             $indent = $xml->indent();
169            
170             # set indent.
171             $xml->indent(6);
172              
173             This makes the output more human readable by indenting appropriately.
174              
175             =cut
176              
177             has 'indent' => (
178             is => 'rw',
179             default => 4,
180             );
181              
182             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
183             sub AUTOLOAD {
184 0     0     my ($self) = shift;
185              
186 0           my ($class, $method) = our $AUTOLOAD =~ /^(.*)::(\w+)$/;
187              
188 0 0         if ($self->can($method)) {
189 0           return $self->$method(@_);
190             }
191              
192 0 0         if (@_) {
193 0           $self->set($method, $_[0]);
194             }
195             else {
196 0           return $self->get($method);
197             }
198             }
199             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
200             =head2 load()
201            
202             # get xml object
203             $xml = $self->app->xml->new;
204              
205             # load xml file
206             $xml->load($file);
207            
208             # load and append another xml file
209             $xml->load($another);
210              
211             Loads xml files to the object in memory. This will not clear any previously loaded files. To will add files.
212             This method can be chained C<$xml->load($file)->add_file($another_file)>;
213              
214             =cut
215              
216             sub load {
217            
218 0     0 0   my ($self, $file) = @_;
219            
220 0 0         $file .= ".xml" unless ($file =~ /\.[^.]*$/i);
221 0 0 0       ($file && -f $file) || $self->app->abort("Error reading file '$file'. $!");
222            
223 0           my $xml = $self->xml->parsefile($file);
224              
225             #$self->{vars} ||= +{};
226             #$self->{vars} = {%{$self->{vars}}, %$xml};
227            
228 0 0         if ($self->{vars}) {
229 0           while (my ($k, $v) = each %{$xml}) {
  0            
230 0           $self->{vars}->{$k} = $v;
231             }
232             }
233             else {
234 0           $self->{vars} = $xml;
235 0           $self->file($file);
236             }
237              
238 0           $self;
239             }
240             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
241             =head2 keep_order()
242            
243             # keep sort order when loading and saving the file. default is off.
244             $xml->keep_order(1);
245            
246             # turn it off
247             $xml->keep_order(0);
248              
249             This option keeps the order for each element appeared in XML. L<Tie::IxHash> module is required.
250             This makes parsing performance slow (about 100% slower than default). But sometimes it is required
251             for example when loading url routes files, it is important to keep routes in the same sorted order in the files.
252              
253             =cut
254              
255             sub keep_order {
256 0     0 0   my ($self, $status) = @_;
257             # This option keeps the order for each element appeared in XML. Tie::IxHash module is required.
258             # This makes parsing performance slow. (about 100% slower than default)
259 0           $self->xml->set(use_ixhash => $status);
260 0           return $self;
261             }
262             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
263             =head2 get()
264            
265             # get value of email tag <email>ahmed@mewsoft.com</email>
266             say $xml->get('email'); # returns ahmed@mewsoft.com
267              
268             # get tag value, if not found return the optional provided default value.
269             $var = $xml->get($name, $default);
270              
271             # get value of email tag inside other tags
272             # <users><user><contact><email>ahmed@mewsoft.com</email></contact></user></users>
273             say $xml->get('users/user/contact/email'); # returns ahmed@mewsoft.com
274            
275             # automatic getter support
276             $email = $xml->email; # same as $xml->get('email');
277              
278             # get list
279             # <lang><file>general</file><file>contact</file><file>register</file></lang>
280             @files = $xml->get("lang/file");
281              
282             Returns xml tag value, if not found returns the optional provided default value.
283              
284             =cut
285              
286             sub get {
287            
288 0     0 0   my ($self, $path, $default) = @_;
289            
290 0           my $value;
291              
292 0 0         if ($path !~ /\//) {
293 0 0         $value = exists $self->{vars}->{$path}? $self->{vars}->{$path} : $default;
294             }
295             else {
296 0           $path =~ s/^\/+|\/+$//g;
297 0           my @path = split /\//, $path;
298 0           my $v = $self->{vars};
299            
300 0           while (my $k = shift @path) {
301 0 0         if (!exists $v->{$k}) {
302 0           $v = $default;
303 0           last;
304             }
305 0           $v = $v->{$k};
306             }
307 0           $value = $v;
308             }
309            
310 0 0         if (ref($value) eq "ARRAY" ) {
    0          
311 0           return @{$value};
  0            
312             }
313             elsif (ref($value) eq "HASH" ) {
314             #return %{$value};
315 0           return $value;
316             }
317             else {
318 0           return $value;
319             }
320             }
321             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
322             =head2 set()
323            
324             # set tag value
325             $xml->set('email', 'ahmed@mewsoft.com');
326              
327             # set a group of tags
328             $xml->set(%tags);
329              
330             # set value of nested tags
331             # <users><user><contact><email>ahmed@mewsoft.com</email></contact></user></users>
332             $xml->set('users/user/contact/email', 'ahmed@mewsoft.com');
333              
334             Sets tags values.
335              
336             =cut
337              
338             sub set {
339              
340 0     0 0   my ($self, %vars) = @_;
341             #map { $self->{vars}->{$_} = $vars{$_}; } keys %vars;
342            
343 0           my ($path, $value, @path, $k, $v, $key);
344              
345 0           while ( ($path, $value) = each %vars) {
346              
347             #if ($path !~ /\//) {
348             # $self->{vars}->{$path} = $value;
349             # next;
350             #}
351            
352             # path /accounts/users/admin
353 0           $path =~ s/^\/+|\/+$//g;
354 0           @path = split /\//, $path;
355 0           $v = $self->{vars};
356            
357             # $key = admin, @path= (accounts, users)
358 0           $key = pop @path;
359              
360 0           while ($k = shift @path) {
361 0 0         if (!exists $v->{$k}) {
362 0           $v->{$k} = +{};
363             }
364 0           $v = $v->{$k};
365             }
366            
367             # $v = $self->{vars}->{accounts}->{users}, $key = admin
368 0           $v->{$key} = $value;
369             }
370              
371 0           $self;
372             }
373             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
374             =head2 list()
375            
376             # get a list of tags values.
377             @values = $xml->list(@names);
378             ($users, $views, $items) = $xml->list( qw( users views items ) );
379              
380             Returns a list of tags values.
381              
382             =cut
383              
384             sub list {
385 0     0 0   my ($self, @n) = @_;
386 0           my @v;
387 0           push @v, $self->get($_) for @n;
388             return @v
389 0           }
390             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
391             =head2 var()
392            
393             # get a hash ref to the xml data for direct access.
394             $xml_ref = $xml->var();
395             $xml_ref->{root}->{users}->{user}->{admin} = 'username';
396             say $xml_ref->{root}->{users}->{user}->{admin};
397              
398             Returns a hash reference to the in memory xml data.
399              
400             =cut
401              
402             sub var {
403 0     0 0   my ($self) = @_;
404 0           return $self->{vars};
405             }
406             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
407             =head2 delete()
408            
409             # delete tags from memory, changes will apply when saving file.
410             $xml->delete(@names);
411              
412             Delete a list of tags. Tags will be deleted from the object and memory only and will apply
413             when updating or saving the file.
414              
415             =cut
416              
417             sub delete {
418 0     0 0   my ($self, @vars) = @_;
419 0           delete $self->{vars}->{$_} for @vars;
420 0           $self;
421             }
422             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
423             =head2 clear()
424            
425             # delete entire xml object data.
426             $xml->clear();
427              
428             Completely clears all loaded xml data from memory. This does not apply to the file until file is
429             updated or saved.
430              
431             =cut
432              
433             sub clear {
434 0     0 0   my ($self) = @_;
435 0           $self->{vars} = +{};
436 0           $self;
437             }
438             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
439             =head2 update()
440            
441             # save a list of variables and update the file.
442             $xml->update(%vars);
443              
444             Set list of variables and save to the output file immediately.
445              
446             =cut
447              
448             sub update {
449 0     0 0   my ($self, %vars) = @_;
450 0           $self->set(%vars);
451 0           $self->save();
452 0           $self;
453             }
454             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
455             =head2 save()
456            
457             # write the output file.
458             $xml->save($file);
459              
460             Save changes to the output file. If no file name just update the loaded file name.
461              
462             =cut
463              
464             sub save {
465 0     0 0   my ($self, $file) = @_;
466 0           $self->xml->set(indent => $self->indent);
467 0   0       $self->xml->writefile($file || $self->file, $self->{vars}, $self->encoding);
468 0           $self;
469             }
470             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
471             =head2 get_file()
472            
473             # load xml file content and return it as a hash, not added to the object
474             %xml_hash = $xml->get_file($file);
475             say $xml_hash{root}{config}{database}{user};
476              
477             # load xml file content and return it as a hash ref, not added to the object
478             $xml_hash_ref = $xml->get_file($file);
479             say $xml_hash_ref->{root}->{config}->{database}->{user};
480              
481             Load xml file content and return it as a hash or hash ref, not added to the object.
482              
483             =cut
484              
485             sub get_file {
486 0     0 0   my ($self, $file) = @_;
487 0 0 0       ($file && -f $file) || $self->app->abort("Error reading file '$file'. $!");
488 0           my $xml = $self->xml->parsefile($file);
489 0 0         return wantarray? %{$xml} : $xml;
  0            
490             }
491             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
492             =head2 add_file()
493            
494             # load and append another xml file to the object
495             $xml->add_file($another_file);
496              
497             Load and append another xml file to the object.
498              
499             =cut
500              
501             sub add_file {
502 0     0 0   my ($self, $file) = @_;
503 0           my $xml = $self->get_file($file);
504 0           while (my ($k, $v) = each %{$xml}) {
  0            
505 0           $self->{vars}->{$k} = $v;
506             }
507 0           $self;
508             }
509             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 0     0     sub DESTROY {
511             }
512             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
513              
514             =pod
515              
516             =head1 Bugs
517              
518             This project is available on github at L<https://github.com/mewsoft/Nile>.
519              
520             =head1 HOMEPAGE
521              
522             Please visit the project's homepage at L<https://metacpan.org/release/Nile>.
523              
524             =head1 SOURCE
525              
526             Source repository is at L<https://github.com/mewsoft/Nile>.
527              
528             =head1 SEE ALSO
529              
530             See L<Nile> for details about the complete framework.
531              
532             =head1 AUTHOR
533              
534             Ahmed Amin Elsheshtawy, احمد امين الششتاوى <mewsoft@cpan.org>
535             Website: http://www.mewsoft.com
536              
537             =head1 COPYRIGHT AND LICENSE
538              
539             Copyright (C) 2014-2015 by Dr. Ahmed Amin Elsheshtawy احمد امين الششتاوى mewsoft@cpan.org, support@mewsoft.com,
540             L<https://github.com/mewsoft/Nile>, L<http://www.mewsoft.com>
541              
542             This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
543              
544             =cut
545              
546             1;