File Coverage

lib/WebService/Braintree/Xml.pm
Criterion Covered Total %
statement 21 23 91.3
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 29 31 93.5


line stmt bran cond sub pod time code
1             package WebService::Braintree::Xml;
2             $WebService::Braintree::Xml::VERSION = '0.94';
3 20     20   406 use 5.010_001;
  20         69  
4 20     20   113 use strictures 1;
  20         156  
  20         837  
5              
6 20     20   2118 use vars qw(@ISA @EXPORT_OK);
  20         43  
  20         960  
7 20     20   110 use Exporter;
  20         32  
  20         1123  
8             our @ISA = qw(Exporter);
9             our @EXPORT_OK = qw(hash_to_xml xml_to_hash);
10              
11 20     20   10133 use XML::Simple;
  20         134610  
  20         127  
12              
13 20     20   6697 use DateTime::Format::Atom;
  20         61886  
  20         621  
14 20     20   139 use WebService::Braintree::Util qw(is_arrayref is_hashref);
  20         45  
  20         988  
15 20     20   34153 use XML::LibXML;
  0            
  0            
16              
17             sub hash_to_xml {
18             my $hash = shift;
19             my $doc = XML::LibXML::Document->createDocument('1.0', 'UTF-8');
20             my $root_key = (keys %$hash)[0];
21             my $element = XML::LibXML::Element->new($root_key);
22              
23             my $value = $hash->{$root_key};
24             my $node = add_node($element, $value);
25             $doc->setDocumentElement($element);
26              
27             return $doc->toString(1);
28             }
29              
30             sub add_node {
31             my ($parent, $value) = @_;
32             if (is_hashref($value)) {
33             build_from_hash($parent, $value);
34             } elsif (is_arrayref($value)) {
35             build_from_array($parent, $value);
36             } else {
37             $parent->appendText($value) if $value;
38             }
39             }
40              
41             sub build_from_hash {
42             my($parent, $value) = @_;
43             while (my($key, $child_value) = each(%$value)) {
44             build_node($key, $child_value, $parent);
45             }
46             }
47              
48             sub build_from_array {
49             my($parent, $value) = @_;
50             $parent->setAttribute('type', 'array');
51             foreach my $child_value (@$value) {
52             build_node('item', $child_value, $parent);
53             }
54             }
55              
56             sub build_node {
57             my($node_name, $child_value, $parent) = @_;
58             my $child = XML::LibXML::Element->new($node_name);
59             add_node($child, $child_value);
60             $parent->appendChild($child);
61             }
62              
63             sub xml_to_hash {
64             my $return = XMLin(shift, KeyAttr => [], KeepRoot => 1);
65             return scrubbed($return);
66             }
67              
68             sub scrubbed {
69             my $tree = shift;
70             if (is_hashref($tree)) {
71             return collect_from_hash($tree);
72             } elsif (is_arrayref($tree)) {
73             return collect_from_array($tree);
74             } else {
75             return $tree;
76             }
77             }
78              
79             sub collect_from_array {
80             my ($tree) = @_;
81             my @new_array = ();
82             foreach my $value (@$tree) {
83             push(@new_array, scrubbed($value));
84             }
85             return \@new_array;
86             }
87              
88             sub collect_from_hash {
89             my ($tree) = @_;
90             my $new_hash = {};
91              
92             my %types = (
93             array => \&array,
94             boolean => \&boolean,
95             integer => \&integer,
96             datetime => \&datetime,
97             date => \&date
98             );
99              
100             foreach my $type (keys %types) {
101             return $types{$type}->($tree) if is_of_type($type, $tree);
102             }
103             return $tree->{'content'} if exists($tree->{'content'});
104             return undef if is_nil($tree);
105             while (my ($key, $subtree) = each(%$tree)) {
106             $new_hash->{sub_dashes($key)} = scrubbed($subtree);
107             }
108             return $new_hash;
109             }
110              
111             sub is_of_type {
112             my ($type, $tree) = @_;
113             no warnings;
114             return 0 unless $tree->{'type'};
115             return $tree->{'type'} eq $type;
116             }
117              
118             sub is_nil {
119             my $tree = shift;
120             return 0 unless $tree->{'nil'};
121             return $tree->{'nil'} eq "true";
122             }
123              
124             sub boolean {
125             return shift->{'content'} eq 'true' ? 1 : 0;
126             }
127              
128             sub integer {
129             return shift->{'content'};
130             }
131              
132             my $f = DateTime::Format::Atom->new();
133              
134             sub datetime {
135             my $dt = $f->parse_datetime(shift->{'content'});
136             }
137              
138             sub date {
139             my $date = shift->{'content'};
140             $date .= 'T00:00:00Z';
141             my $dt = $f->parse_datetime($date);
142             }
143              
144             sub array {
145             my $tree = shift;
146              
147             delete $tree->{type};
148             my $subtree = (values %$tree)[0];
149             if (is_hashref($subtree)) {
150             return [scrubbed($subtree)];
151             } elsif (is_arrayref($subtree)) {
152             return scrubbed($subtree);
153             } elsif (defined($subtree)) {
154             return [$subtree];
155             } else {
156             return [];
157             }
158             }
159              
160             sub sub_dashes {
161             my $string = shift;
162             $string =~ s/-/_/g;
163             return $string;
164             }
165              
166             1;
167             __END__