File Coverage

blib/lib/Net/DAVTalk/XMLParser.pm
Criterion Covered Total %
statement 33 44 75.0
branch 13 20 65.0
condition 2 2 100.0
subroutine 5 5 100.0
pod 1 1 100.0
total 54 72 75.0


line stmt bran cond sub pod time code
1             package Net::DAVTalk::XMLParser;
2              
3 3     3   87406 use base 'Exporter';
  3         13  
  3         288  
4              
5             =head1 NAME
6              
7             Net::DAVTalk - Interface to talk to DAV servers
8              
9             =head1 SYNOPSIS
10              
11             Net::DAVTalk::XMLParser is a simple wrapper around XML::Fast, returning
12             a more usable structure like that created by XML::Simple, but running
13             approximately 10 times faster in testing.
14              
15             =head1 SUBROUTINES/METHODS
16              
17             =head2 $hashref = xmlToHash($xmlstring);
18              
19             Converts an XML string to a hashref of the content.
20              
21             =head1 ACKNOWLEDGEMENTS
22              
23              
24             =head1 LICENSE AND COPYRIGHT
25              
26             Copyright 2015 FastMail Pty. Ltd.
27              
28             This program is free software; you can redistribute it and/or modify it
29             under the terms of the the Artistic License (2.0). You may obtain a
30             copy of the full license at:
31              
32             L<http://www.perlfoundation.org/artistic_license_2_0>
33              
34             Any use, modification, and distribution of the Standard or Modified
35             Versions is governed by this Artistic License. By using, modifying or
36             distributing the Package, you accept this license. Do not use, modify,
37             or distribute the Package, if you do not accept this license.
38              
39             If your Modified Version has been derived from a Modified Version made
40             by someone other than you, you are nevertheless required to ensure that
41             your Modified Version complies with the requirements of this license.
42              
43             This license does not grant you the right to use any trademark, service
44             mark, tradename, or logo of the Copyright Holder.
45              
46             This license includes the non-exclusive, worldwide, free-of-charge
47             patent license to make, have made, use, offer to sell, sell, import and
48             otherwise transfer the Package with respect to any patent claims
49             licensable by the Copyright Holder that are necessarily infringed by the
50             Package. If you institute patent litigation (including a cross-claim or
51             counterclaim) against any party alleging that the Package constitutes
52             direct or contributory patent infringement, then this Artistic License
53             to you shall terminate on the date that such litigation is filed.
54              
55             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
56             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
57             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
58             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
59             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
60             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
61             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
62             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
63              
64             =cut
65              
66              
67             our @EXPORT = qw(xmlToHash);
68              
69 3     3   1235 use XML::Fast;
  3         21288  
  3         160  
70 3     3   20 use Carp qw(confess);
  3         17  
  3         1324  
71              
72             sub _nsexpand {
73 8     8   11 my $data = shift;
74 8   100     18 my $ns = shift || {};
75              
76 8 100       18 if (ref($data) eq 'HASH') {
    50          
77 6         9 my @keys;
78             my %res;
79 6         13 foreach my $key (keys %$data) {
80 10 100       25 if ($key eq '@xmlns') {
    100          
    50          
81 2         6 $ns->{''} = $data->{$key};
82             }
83             elsif ($key eq '#text') {
84 2         5 $res{'content'} = $data->{$key};
85             }
86             elsif (substr($key, 0, 7) eq '@xmlns:') {
87 0         0 my $namespace = substr($key, 7);
88 0         0 $ns->{$namespace} = $data->{$key};
89             # this is what XML::Simple does with existing namespaces
90 0         0 $res{"{http://www.w3.org/2000/xmlns/}$namespace"} = $data->{$key};
91             }
92             else {
93 6         10 push @keys, $key;
94             }
95             }
96 6         8 foreach my $key (@keys) {
97 6         12 my %ns = %$ns; # copy, woot
98 6         17 my $sub = _nsexpand($data->{$key}, \%ns);
99 6         11 my $pos = index($key, ':');
100 6 50       21 if ($pos > 0) {
    100          
    100          
101 0         0 my $namespace = substr($key, 0, $pos);
102 0         0 my $rest = substr($key, $pos+1);
103             # move attribute sigil from namespace to value
104 0 0       0 $rest = "\@$rest" if $namespace =~ s/^\@//;
105 0         0 my $expanded = $ns{$namespace};
106 0 0       0 confess "Unknown namespace $namespace" unless $expanded;
107 0         0 $key = "{$expanded}$rest";
108             }
109             elsif ($key =~ m/^\@/) {
110             # Attributes are never subject to the default namespace.
111             # An attribute without an explicit namespace prefix is
112             # considered not to be in any namespace.
113             }
114             elsif ($ns{''}) {
115 2         4 my $expanded = $ns{''};
116 2         10 $key = "{$expanded}$key";
117             }
118 6         17 $res{$key} = $sub;
119             }
120 6         13 return \%res;
121             }
122             elsif (ref($data) eq 'ARRAY') {
123 0         0 return [ map { _nsexpand($_, $ns) } @$data ];
  0         0  
124             }
125             else {
126             # like XML::Simple's ExpandContent option
127 2         9 return { content => $data };
128             }
129             }
130              
131             sub xmlToHash {
132 2     2 1 1361 my $text = shift;
133              
134 2         8 my $Raw = XML::Fast::xml2hash($text, attr => '@');
135             # like XML::Simple's NSExpand option
136 2         59 my $Xml = _nsexpand($Raw);
137              
138             # XML::Simple returns the content of the top level key
139             # (there should only be one)
140 2         5 my ($key) = keys %$Xml;
141              
142 2         9 return $Xml->{$key};
143             }
144              
145             1;