| | 110 | =head2 perl_to_xml( I<ref>, I<root_element> ) |
|---|
| | 111 | |
|---|
| | 112 | Similar to the XML::Simple XMLout() feature, perl_to_xml() |
|---|
| | 113 | will take a Perl data structure I<ref> and convert it to XML, |
|---|
| | 114 | using I<root_element> as the top-level element. |
|---|
| | 115 | |
|---|
| | 116 | =cut |
|---|
| | 117 | |
|---|
| | 118 | sub perl_to_xml { |
|---|
| | 119 | my $self = shift; |
|---|
| | 120 | my $perl = shift; |
|---|
| | 121 | my $root = shift || '_root'; |
|---|
| | 122 | unless ( defined $perl ) { |
|---|
| | 123 | croak "perl data struct required"; |
|---|
| | 124 | } |
|---|
| | 125 | |
|---|
| | 126 | if ( !ref $perl ) { |
|---|
| | 127 | return $XML->start_tag($root) |
|---|
| | 128 | . $XML->utf8_safe($perl) |
|---|
| | 129 | . $XML->end_tag($root); |
|---|
| | 130 | } |
|---|
| | 131 | |
|---|
| | 132 | my $xml = $XML->start_tag($root); |
|---|
| | 133 | $self->_ref_to_xml( $perl, '', \$xml ); |
|---|
| | 134 | $xml .= $XML->end_tag($root); |
|---|
| | 135 | return $xml; |
|---|
| | 136 | } |
|---|
| | 137 | |
|---|
| | 138 | sub _ref_to_xml { |
|---|
| | 139 | my ( $self, $perl, $root, $xml_ref ) = @_; |
|---|
| | 140 | my $type = ref $perl; |
|---|
| | 141 | if ( !$type ) { |
|---|
| | 142 | $$xml_ref .= $XML->start_tag($root) if length($root); |
|---|
| | 143 | $$xml_ref .= $XML->utf8_safe($perl); |
|---|
| | 144 | $$xml_ref .= $XML->end_tag($root) if length($root); |
|---|
| | 145 | $$xml_ref .= "\n"; # just for debugging |
|---|
| | 146 | } |
|---|
| | 147 | elsif ( $type eq 'SCALAR' ) { |
|---|
| | 148 | $self->_scalar_to_xml( $perl, $root, $xml_ref ); |
|---|
| | 149 | } |
|---|
| | 150 | elsif ( $type eq 'ARRAY' ) { |
|---|
| | 151 | $self->_array_to_xml( $perl, $root, $xml_ref ); |
|---|
| | 152 | } |
|---|
| | 153 | elsif ( $type eq 'HASH' ) { |
|---|
| | 154 | $self->_hash_to_xml( $perl, $root, $xml_ref ); |
|---|
| | 155 | } |
|---|
| | 156 | else { |
|---|
| | 157 | croak "unsupported ref type: $type"; |
|---|
| | 158 | } |
|---|
| | 159 | |
|---|
| | 160 | } |
|---|
| | 161 | |
|---|
| | 162 | sub _array_to_xml { |
|---|
| | 163 | my ( $self, $perl, $root, $xml_ref ) = @_; |
|---|
| | 164 | for my $thing (@$perl) { |
|---|
| | 165 | if ( ref $thing and length($root) ) { |
|---|
| | 166 | $$xml_ref .= $XML->start_tag($root); |
|---|
| | 167 | } |
|---|
| | 168 | $self->_ref_to_xml( $thing, $root, $xml_ref ); |
|---|
| | 169 | if ( ref $thing and length($root) ) { |
|---|
| | 170 | $$xml_ref .= $XML->end_tag($root); |
|---|
| | 171 | } |
|---|
| | 172 | } |
|---|
| | 173 | } |
|---|
| | 174 | |
|---|
| | 175 | sub _hash_to_xml { |
|---|
| | 176 | my ( $self, $perl, $root, $xml_ref ) = @_; |
|---|
| | 177 | for my $key ( keys %$perl ) { |
|---|
| | 178 | my $thing = $perl->{$key}; |
|---|
| | 179 | $self->_ref_to_xml( $thing, $key, $xml_ref ); |
|---|
| | 180 | } |
|---|
| | 181 | } |
|---|
| | 182 | |
|---|
| | 183 | sub _scalar_to_xml { |
|---|
| | 184 | my ( $self, $perl, $root, $xml_ref ) = @_; |
|---|
| | 185 | $$xml_ref |
|---|
| | 186 | .= $XML->start_tag($root) |
|---|
| | 187 | . $XML->utf8_safe($$perl) |
|---|
| | 188 | . $XML->end_tag($root); |
|---|
| | 189 | } |
|---|
| | 190 | |
|---|
