| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | # ============================================================ | 
| 2 |  |  |  |  |  |  | # XML:: | 
| 3 |  |  |  |  |  |  | #  ____ | 
| 4 |  |  |  |  |  |  | # |  _ \ _   _ _ __ ___  _ __   ___ _ __ | 
| 5 |  |  |  |  |  |  | # | | | | | | | '_ ` _ \| '_ \ / _ \ '__| | 
| 6 |  |  |  |  |  |  | # | |_| | |_| | | | | | | |_) |  __/ | | 
| 7 |  |  |  |  |  |  | # |____/ \__,_|_| |_| |_| .__/ \___|_| | 
| 8 |  |  |  |  |  |  | #                       |_| | 
| 9 |  |  |  |  |  |  | # Perl module for dumping Perl objects from/to XML | 
| 10 |  |  |  |  |  |  | # ============================================================ | 
| 11 |  |  |  |  |  |  |  | 
| 12 |  |  |  |  |  |  | =head1 NAME | 
| 13 |  |  |  |  |  |  |  | 
| 14 |  |  |  |  |  |  | XML::Dumper - Perl module for dumping Perl objects from/to XML | 
| 15 |  |  |  |  |  |  |  | 
| 16 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 17 |  |  |  |  |  |  |  | 
| 18 |  |  |  |  |  |  | # ===== Using an object | 
| 19 |  |  |  |  |  |  | use XML::Dumper; | 
| 20 |  |  |  |  |  |  | $dump = new XML::Dumper; | 
| 21 |  |  |  |  |  |  |  | 
| 22 |  |  |  |  |  |  | $xml  = $dump->pl2xml( $perl ); | 
| 23 |  |  |  |  |  |  | $perl = $dump->xml2pl( $xml ); | 
| 24 |  |  |  |  |  |  | $dump->pl2xml( $perl, "my_perl_data.xml.gz" ); | 
| 25 |  |  |  |  |  |  |  | 
| 26 |  |  |  |  |  |  | # ===== Using function calls | 
| 27 |  |  |  |  |  |  | use XML::Dumper; | 
| 28 |  |  |  |  |  |  |  | 
| 29 |  |  |  |  |  |  | $xml  = pl2xml( $perl ); | 
| 30 |  |  |  |  |  |  | $perl = xml2pl( $xml ); | 
| 31 |  |  |  |  |  |  |  | 
| 32 |  |  |  |  |  |  | =head1 EXTENDED SYNOPSIS | 
| 33 |  |  |  |  |  |  |  | 
| 34 |  |  |  |  |  |  | use XML::Dumper; | 
| 35 |  |  |  |  |  |  | my $dump = new XML::Dumper; | 
| 36 |  |  |  |  |  |  |  | 
| 37 |  |  |  |  |  |  | my $perl  = ''; | 
| 38 |  |  |  |  |  |  | my $xml   = ''; | 
| 39 |  |  |  |  |  |  |  | 
| 40 |  |  |  |  |  |  | # ===== Convert Perl code to XML | 
| 41 |  |  |  |  |  |  | $perl = [ | 
| 42 |  |  |  |  |  |  | { | 
| 43 |  |  |  |  |  |  | fname       => 'Fred', | 
| 44 |  |  |  |  |  |  | lname       => 'Flintstone', | 
| 45 |  |  |  |  |  |  | residence   => 'Bedrock' | 
| 46 |  |  |  |  |  |  | }, | 
| 47 |  |  |  |  |  |  | { | 
| 48 |  |  |  |  |  |  | fname       => 'Barney', | 
| 49 |  |  |  |  |  |  | lname       => 'Rubble', | 
| 50 |  |  |  |  |  |  | residence   => 'Bedrock' | 
| 51 |  |  |  |  |  |  | } | 
| 52 |  |  |  |  |  |  | ]; | 
| 53 |  |  |  |  |  |  | $xml = $dump->pl2xml( $perl ); | 
| 54 |  |  |  |  |  |  |  | 
| 55 |  |  |  |  |  |  | # ===== Dump to a file | 
| 56 |  |  |  |  |  |  | my $file = "dump.xml"; | 
| 57 |  |  |  |  |  |  | $dump->pl2xml( $perl, $file ); | 
| 58 |  |  |  |  |  |  |  | 
| 59 |  |  |  |  |  |  | # ===== Convert XML to Perl code | 
| 60 |  |  |  |  |  |  | $xml = q| | 
| 61 |  |  |  |  |  |  |  | 
| 62 |  |  |  |  |  |  |  | 
| 63 |  |  |  |  |  |  |   | 
| 64 |  |  |  |  |  |  |  | 
| 65 |  |  |  |  |  |  | Fred | 
| 66 |  |  |  |  |  |  | Flintstone | 
| 67 |  |  |  |  |  |  | Bedrock | 
| 68 |  |  |  |  |  |  |  | 
| 69 |  |  |  |  |  |  |  | 
| 70 |  |  |  |  |  |  |   | 
| 71 |  |  |  |  |  |  |  | 
| 72 |  |  |  |  |  |  | Barney | 
| 73 |  |  |  |  |  |  | Rubble | 
| 74 |  |  |  |  |  |  | Bedrock | 
| 75 |  |  |  |  |  |  |  | 
| 76 |  |  |  |  |  |  |  | 
| 77 |  |  |  |  |  |  |  | 
| 78 |  |  |  |  |  |  |  | 
| 79 |  |  |  |  |  |  | |; | 
| 80 |  |  |  |  |  |  |  | 
| 81 |  |  |  |  |  |  | my $perl = $dump->xml2pl( $xml ); | 
| 82 |  |  |  |  |  |  |  | 
| 83 |  |  |  |  |  |  | # ===== Convert an XML file to Perl code | 
| 84 |  |  |  |  |  |  | my $perl = $dump->xml2pl( $file ); | 
| 85 |  |  |  |  |  |  |  | 
| 86 |  |  |  |  |  |  | # ===== And serialize Perl code to an XML file | 
| 87 |  |  |  |  |  |  | $dump->pl2xml( $perl, $file ); | 
| 88 |  |  |  |  |  |  |  | 
| 89 |  |  |  |  |  |  | # ===== USE COMPRESSION | 
| 90 |  |  |  |  |  |  | $dump->pl2xml( $perl, $file.".gz" ); | 
| 91 |  |  |  |  |  |  |  | 
| 92 |  |  |  |  |  |  | # ===== INCLUDE AN IN-DOCUMENT DTD | 
| 93 |  |  |  |  |  |  | $dump->dtd; | 
| 94 |  |  |  |  |  |  | my $xml_with_dtd = $dump->pl2xml( $perl ); | 
| 95 |  |  |  |  |  |  |  | 
| 96 |  |  |  |  |  |  | # ===== USE EXTERNAL DTD | 
| 97 |  |  |  |  |  |  | $dump->dtd( $file, $url ); | 
| 98 |  |  |  |  |  |  | my $xml_with_link_to_dtd = $dump->pl2xml( $perl ); | 
| 99 |  |  |  |  |  |  |  | 
| 100 |  |  |  |  |  |  | =head1 DESCRIPTION | 
| 101 |  |  |  |  |  |  |  | 
| 102 |  |  |  |  |  |  | XML::Dumper dumps Perl data to XML format. XML::Dumper can also read XML data | 
| 103 |  |  |  |  |  |  | that was previously dumped by the module and convert it back to Perl. You can | 
| 104 |  |  |  |  |  |  | use the module read the XML from a file and write the XML to a file. Perl | 
| 105 |  |  |  |  |  |  | objects are blessed back to their original packaging; if the modules are | 
| 106 |  |  |  |  |  |  | installed on the system where the perl objects are reconstituted from xml, they | 
| 107 |  |  |  |  |  |  | will behave as expected. Intuitively, if the perl objects are converted and | 
| 108 |  |  |  |  |  |  | reconstituted in the same environment, all should be well. And it is. | 
| 109 |  |  |  |  |  |  |  | 
| 110 |  |  |  |  |  |  | Additionally, because XML benefits so nicely from compression, XML::Dumper | 
| 111 |  |  |  |  |  |  | understands gzipped XML files. It does so with an optional dependency on | 
| 112 |  |  |  |  |  |  | Compress::Zlib. So, if you dump a Perl variable with a file that has an | 
| 113 |  |  |  |  |  |  | extension of '.xml.gz', it will store and compress the file in gzipped format. | 
| 114 |  |  |  |  |  |  | Likewise, if you read a file with the extension '.xml.gz', it will uncompress | 
| 115 |  |  |  |  |  |  | the file in memory before parsing the XML back into a Perl variable. | 
| 116 |  |  |  |  |  |  |  | 
| 117 |  |  |  |  |  |  | Another fine challenge that this module rises to meet is that it understands | 
| 118 |  |  |  |  |  |  | circular definitions and multiple references to a single object. This includes | 
| 119 |  |  |  |  |  |  | doubly-linked lists, circular references, and the so-called 'Flyweight' pattern of | 
| 120 |  |  |  |  |  |  | Object Oriented programming. So it can take the gnarliest of your perl data, and | 
| 121 |  |  |  |  |  |  | should do just fine. | 
| 122 |  |  |  |  |  |  |  | 
| 123 |  |  |  |  |  |  | One caveat; XML::Dumper does not handle binary data. There have been | 
| 124 |  |  |  |  |  |  | discussions in the expat mailing list archives discussing the challenges | 
| 125 |  |  |  |  |  |  | associated with encoding binary data with XML. I chose the cowardly path | 
| 126 |  |  |  |  |  |  | of making the problem a non-issue by not addressing it. To store binary | 
| 127 |  |  |  |  |  |  | data, one could encode the data into ASCII before encapsulating the data | 
| 128 |  |  |  |  |  |  | as XML, and then reverse the process to restore the data. There are several | 
| 129 |  |  |  |  |  |  | Perl modules that one can use for this, Convert::UU, for example. | 
| 130 |  |  |  |  |  |  |  | 
| 131 |  |  |  |  |  |  | =head2 FUNCTIONS AND METHODS | 
| 132 |  |  |  |  |  |  |  | 
| 133 |  |  |  |  |  |  | =over 4 | 
| 134 |  |  |  |  |  |  |  | 
| 135 |  |  |  |  |  |  | =cut | 
| 136 |  |  |  |  |  |  |  | 
| 137 |  |  |  |  |  |  | package XML::Dumper; | 
| 138 |  |  |  |  |  |  |  | 
| 139 |  |  |  |  |  |  | require 5.005_62; | 
| 140 | 19 |  |  | 19 |  | 181447 | use strict; | 
|  | 19 |  |  |  |  | 46 |  | 
|  | 19 |  |  |  |  | 795 |  | 
| 141 | 19 |  |  | 19 |  | 111 | use warnings; | 
|  | 19 |  |  |  |  | 358 |  | 
|  | 19 |  |  |  |  | 701 |  | 
| 142 |  |  |  |  |  |  |  | 
| 143 |  |  |  |  |  |  | require Exporter; | 
| 144 | 19 |  |  | 19 |  | 44976 | use XML::Parser; | 
|  | 0 |  |  |  |  |  |  | 
|  | 0 |  |  |  |  |  |  | 
| 145 |  |  |  |  |  |  | use overload; | 
| 146 |  |  |  |  |  |  |  | 
| 147 |  |  |  |  |  |  | our @ISA = qw( Exporter ); | 
| 148 |  |  |  |  |  |  | our %EXPORT_TAGS = ( ); | 
| 149 |  |  |  |  |  |  | our @EXPORT_OK = ( ); | 
| 150 |  |  |  |  |  |  | our @EXPORT = qw( xml2pl pl2xml xml_compare xml_identity ); | 
| 151 |  |  |  |  |  |  | our $VERSION = '0.81'; | 
| 152 |  |  |  |  |  |  |  | 
| 153 |  |  |  |  |  |  | our $COMPRESSION_AVAILABLE; | 
| 154 |  |  |  |  |  |  |  | 
| 155 |  |  |  |  |  |  | BEGIN { | 
| 156 |  |  |  |  |  |  | eval { require Compress::Zlib; }; | 
| 157 |  |  |  |  |  |  | if( $@ ) { | 
| 158 |  |  |  |  |  |  | $COMPRESSION_AVAILABLE = 0; | 
| 159 |  |  |  |  |  |  | } else { | 
| 160 |  |  |  |  |  |  | $COMPRESSION_AVAILABLE = 1; | 
| 161 |  |  |  |  |  |  | } | 
| 162 |  |  |  |  |  |  | } | 
| 163 |  |  |  |  |  |  |  | 
| 164 |  |  |  |  |  |  | our $dump = new XML::Dumper; | 
| 165 |  |  |  |  |  |  |  | 
| 166 |  |  |  |  |  |  | # ============================================================ | 
| 167 |  |  |  |  |  |  | sub new { | 
| 168 |  |  |  |  |  |  | # ============================================================ | 
| 169 |  |  |  |  |  |  |  | 
| 170 |  |  |  |  |  |  | =item * new() - XML::Dumper constructor. | 
| 171 |  |  |  |  |  |  |  | 
| 172 |  |  |  |  |  |  | Creates a lean, mean, XML dumping machine. It's also completely | 
| 173 |  |  |  |  |  |  | at your disposal. | 
| 174 |  |  |  |  |  |  |  | 
| 175 |  |  |  |  |  |  | =cut | 
| 176 |  |  |  |  |  |  |  | 
| 177 |  |  |  |  |  |  | # ------------------------------------------------------------ | 
| 178 |  |  |  |  |  |  | my ($class) = map { ref || $_ } shift; | 
| 179 |  |  |  |  |  |  | my $self = bless {}, $class; | 
| 180 |  |  |  |  |  |  |  | 
| 181 |  |  |  |  |  |  | $self->init( @_ ); | 
| 182 |  |  |  |  |  |  |  | 
| 183 |  |  |  |  |  |  | return $self; | 
| 184 |  |  |  |  |  |  | } | 
| 185 |  |  |  |  |  |  |  | 
| 186 |  |  |  |  |  |  | # ============================================================ | 
| 187 |  |  |  |  |  |  | sub init { | 
| 188 |  |  |  |  |  |  | # ============================================================ | 
| 189 |  |  |  |  |  |  | my $self = shift; | 
| 190 |  |  |  |  |  |  | $self->{ perldata }          = {}; | 
| 191 |  |  |  |  |  |  | $self->{ xml }               = {}; | 
| 192 |  |  |  |  |  |  | $self->{ xml_parser_params } = { @_ }; | 
| 193 |  |  |  |  |  |  | 1; | 
| 194 |  |  |  |  |  |  | } | 
| 195 |  |  |  |  |  |  |  | 
| 196 |  |  |  |  |  |  | # ============================================================ | 
| 197 |  |  |  |  |  |  | sub dtd { | 
| 198 |  |  |  |  |  |  | # ============================================================ | 
| 199 |  |  |  |  |  |  |  | 
| 200 |  |  |  |  |  |  | =item * dtd - | 
| 201 |  |  |  |  |  |  |  | 
| 202 |  |  |  |  |  |  | Generates a Document Type Dictionary for the 'perldata' data | 
| 203 |  |  |  |  |  |  | type. The default behaviour is to embed the DTD in the XML, | 
| 204 |  |  |  |  |  |  | thereby creating valid XML. Given a filename, the DTD will be | 
| 205 |  |  |  |  |  |  | written out to that file and the XML document for your Perl data | 
| 206 |  |  |  |  |  |  | will link to the file. Given a filename and an URL, the DTD will | 
| 207 |  |  |  |  |  |  | be written out the file and the XML document will link to the URL. | 
| 208 |  |  |  |  |  |  | XML::Dumper doesn't try really hard to determine where your DTD's | 
| 209 |  |  |  |  |  |  | ought to go or relative paths or anything, so be careful with | 
| 210 |  |  |  |  |  |  | what arguments you supply this method, or just go with the default | 
| 211 |  |  |  |  |  |  | with the embedded DTD. Between DTD's and Schemas, the potential | 
| 212 |  |  |  |  |  |  | for more free-form data to be imported and exported becomes | 
| 213 |  |  |  |  |  |  | feasible. | 
| 214 |  |  |  |  |  |  |  | 
| 215 |  |  |  |  |  |  | Usage: | 
| 216 |  |  |  |  |  |  |  | 
| 217 |  |  |  |  |  |  | dtd();				# Causes XML to include embedded DTD | 
| 218 |  |  |  |  |  |  | dtd( $file );			# DTD saved to $file; XML will link to $file | 
| 219 |  |  |  |  |  |  | dtd( $file, $url );	# DTD saved to $file; XML will link to $url | 
| 220 |  |  |  |  |  |  | dtd( 0 );				# Prevents XML from including embedded DTD | 
| 221 |  |  |  |  |  |  |  | 
| 222 |  |  |  |  |  |  | =cut | 
| 223 |  |  |  |  |  |  |  | 
| 224 |  |  |  |  |  |  | # ------------------------------------------------------------ | 
| 225 |  |  |  |  |  |  | my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump; | 
| 226 |  |  |  |  |  |  | my $file = shift; | 
| 227 |  |  |  |  |  |  | my $url = shift; | 
| 228 |  |  |  |  |  |  |  | 
| 229 |  |  |  |  |  |  | my $dtd = qq{ | 
| 230 |  |  |  |  |  |  |  | 
| 231 |  |  |  |  |  |  |  | 
| 232 |  |  |  |  |  |  | blessed_package CDATA #IMPLIED | 
| 233 |  |  |  |  |  |  | memory_address CDATA #IMPLIED> | 
| 234 |  |  |  |  |  |  |  | 
| 235 |  |  |  |  |  |  |  | 
| 236 |  |  |  |  |  |  | blessed_package CDATA #IMPLIED | 
| 237 |  |  |  |  |  |  | memory_address CDATA #IMPLIED> | 
| 238 |  |  |  |  |  |  |  | 
| 239 |  |  |  |  |  |  |  | 
| 240 |  |  |  |  |  |  | blessed_package CDATA #IMPLIED | 
| 241 |  |  |  |  |  |  | memory_address CDATA #IMPLIED> | 
| 242 |  |  |  |  |  |  |  | 
| 243 |  |  |  |  |  |  |  | 
| 244 |  |  |  |  |  |  | key CDATA #REQUIRED | 
| 245 |  |  |  |  |  |  | defined CDATA #IMPLIED> | 
| 246 |  |  |  |  |  |  |  | 
| 247 |  |  |  |  |  |  | }; | 
| 248 |  |  |  |  |  |  |  | 
| 249 |  |  |  |  |  |  | if( defined $file && $file ) { | 
| 250 |  |  |  |  |  |  | open DTD, ">$file" or die $!; | 
| 251 |  |  |  |  |  |  | print DTD $dtd; | 
| 252 |  |  |  |  |  |  | close DTD; | 
| 253 |  |  |  |  |  |  | $url = defined $url ? $url : $file; | 
| 254 |  |  |  |  |  |  | $self->{ dtd } = qq{ | 
| 255 |  |  |  |  |  |  |  | 
| 256 |  |  |  |  |  |  | }; | 
| 257 |  |  |  |  |  |  | } elsif( not defined $file ) { | 
| 258 |  |  |  |  |  |  | $self->{ dtd } = join( "\n", | 
| 259 |  |  |  |  |  |  | "", | 
| 260 |  |  |  |  |  |  | " | 
| 261 |  |  |  |  |  |  | ( map { /^\t/ ? $_ : "  $_" } split /\n/, $dtd ), | 
| 262 |  |  |  |  |  |  | ']>', | 
| 263 |  |  |  |  |  |  | ''); | 
| 264 |  |  |  |  |  |  | } else { | 
| 265 |  |  |  |  |  |  | delete $self->{ dtd }; | 
| 266 |  |  |  |  |  |  | return; | 
| 267 |  |  |  |  |  |  | } | 
| 268 |  |  |  |  |  |  |  | 
| 269 |  |  |  |  |  |  | $self->{ dtd }; | 
| 270 |  |  |  |  |  |  | } | 
| 271 |  |  |  |  |  |  |  | 
| 272 |  |  |  |  |  |  | # ============================================================ | 
| 273 |  |  |  |  |  |  | sub dump { | 
| 274 |  |  |  |  |  |  | # ============================================================ | 
| 275 |  |  |  |  |  |  | my $self = shift; | 
| 276 |  |  |  |  |  |  | my $ref = shift; | 
| 277 |  |  |  |  |  |  | my $indent = shift; | 
| 278 |  |  |  |  |  |  |  | 
| 279 |  |  |  |  |  |  | my $string = ''; | 
| 280 |  |  |  |  |  |  |  | 
| 281 |  |  |  |  |  |  | # ===== HANDLE REFERENCE DUMPING | 
| 282 |  |  |  |  |  |  | if( ref $ref ) { | 
| 283 |  |  |  |  |  |  | no warnings; | 
| 284 |  |  |  |  |  |  | local $_ = ref( $ref ); | 
| 285 |  |  |  |  |  |  | my $class = ''; | 
| 286 |  |  |  |  |  |  | my $address = ''; | 
| 287 |  |  |  |  |  |  | my $reused = ''; | 
| 288 |  |  |  |  |  |  |  | 
| 289 |  |  |  |  |  |  | # ===== HANDLE THE VARIETY OF THINGS A PERL REFERENCE CAN REFER TO | 
| 290 |  |  |  |  |  |  | REFERENCE: { | 
| 291 |  |  |  |  |  |  | # ---------------------------------------- | 
| 292 |  |  |  |  |  |  | OBJECT: { | 
| 293 |  |  |  |  |  |  | # ---------------------------------------- | 
| 294 |  |  |  |  |  |  | last OBJECT if /^(?:SCALAR|HASH|ARRAY)$/; | 
| 295 |  |  |  |  |  |  | $class = $_; | 
| 296 |  |  |  |  |  |  | $class = xml_escape( $class ); | 
| 297 |  |  |  |  |  |  | ($_,$address) = overload::StrVal( $ref ) =~ /$class=([^(]+)\(([x0-9A-Fa-f]+)\)/; | 
| 298 |  |  |  |  |  |  | } | 
| 299 |  |  |  |  |  |  |  | 
| 300 |  |  |  |  |  |  | # ---------------------------------------- | 
| 301 |  |  |  |  |  |  | HAS_MEMORY_ADDRESS: { | 
| 302 |  |  |  |  |  |  | # ---------------------------------------- | 
| 303 |  |  |  |  |  |  | # References which refer to the same memory space point to the | 
| 304 |  |  |  |  |  |  | # same thing | 
| 305 |  |  |  |  |  |  | last HAS_MEMORY_ADDRESS if( $class ); | 
| 306 |  |  |  |  |  |  | ($_,$address) = overload::StrVal( $ref ) =~ /([^(]+)\(([x0-9A-Fa-f]+)\)/; | 
| 307 |  |  |  |  |  |  | } | 
| 308 |  |  |  |  |  |  |  | 
| 309 |  |  |  |  |  |  | $reused = exists( $self->{ xml }{ $address } ); | 
| 310 |  |  |  |  |  |  |  | 
| 311 |  |  |  |  |  |  | # ---------------------------------------- | 
| 312 |  |  |  |  |  |  | if( /^SCALAR$/ ) { | 
| 313 |  |  |  |  |  |  | # ---------------------------------------- | 
| 314 |  |  |  |  |  |  | my $type = | 
| 315 |  |  |  |  |  |  | " | 
| 316 |  |  |  |  |  |  | ($class ? " blessed_package=\"$class\"" : '' ) . | 
| 317 |  |  |  |  |  |  | ($address ? " memory_address=\"$address\"" : '' ) . | 
| 318 |  |  |  |  |  |  | ( defined $$ref ? '' : " defined=\"false\"" ) . | 
| 319 |  |  |  |  |  |  | ">"; | 
| 320 |  |  |  |  |  |  | $self->{ xml }{ $address }++ if( $address ); | 
| 321 |  |  |  |  |  |  | $string = "\n" . " " x $indent .  $type . ($reused ? '' : xml_escape($$ref)) . ""; | 
| 322 |  |  |  |  |  |  | last REFERENCE; | 
| 323 |  |  |  |  |  |  | } | 
| 324 |  |  |  |  |  |  |  | 
| 325 |  |  |  |  |  |  | # ---------------------------------------- | 
| 326 |  |  |  |  |  |  | if( /^HASH$/ ) { | 
| 327 |  |  |  |  |  |  | # ---------------------------------------- | 
| 328 |  |  |  |  |  |  | $self->{ xml }{ $address }++ if( $address ); | 
| 329 |  |  |  |  |  |  | my $type = | 
| 330 |  |  |  |  |  |  | " | 
| 331 |  |  |  |  |  |  | ($class ? " blessed_package=\"$class\"" : '' ). | 
| 332 |  |  |  |  |  |  | ($address && $self->{ xml }{ $address } ? " memory_address=\"$address\"" : '' ). | 
| 333 |  |  |  |  |  |  | ">"; | 
| 334 |  |  |  |  |  |  | $string = "\n" . " " x $indent . $type; | 
| 335 |  |  |  |  |  |  | if( not $reused ) { | 
| 336 |  |  |  |  |  |  | $indent++; | 
| 337 |  |  |  |  |  |  | foreach my $key (sort keys(%$ref)) { | 
| 338 |  |  |  |  |  |  | my $type = | 
| 339 |  |  |  |  |  |  | " 
 | 
| 340 |  |  |  |  |  |  | "key=\"" . xml_escape( $key ) . "\"" . | 
| 341 |  |  |  |  |  |  | ( defined $ref->{ $key } ? '' : " defined=\"false\"" ) . | 
| 342 |  |  |  |  |  |  | ">"; | 
| 343 |  |  |  |  |  |  | $string .= "\n" . " " x $indent . $type; | 
| 344 |  |  |  |  |  |  | if (ref($ref->{$key})) { | 
| 345 |  |  |  |  |  |  | $string .= $self->dump( $ref->{$key}, $indent+1); | 
| 346 |  |  |  |  |  |  | $string .= "\n" . " " x $indent . ""; | 
| 347 |  |  |  |  |  |  | } else { | 
| 348 |  |  |  |  |  |  | $string .= xml_escape($ref->{$key}) . ""; | 
| 349 |  |  |  |  |  |  | } | 
| 350 |  |  |  |  |  |  | } | 
| 351 |  |  |  |  |  |  | $indent--; | 
| 352 |  |  |  |  |  |  | } | 
| 353 |  |  |  |  |  |  | $string .= "\n" . " " x $indent . ""; | 
| 354 |  |  |  |  |  |  | last REFERENCE; | 
| 355 |  |  |  |  |  |  | } | 
| 356 |  |  |  |  |  |  |  | 
| 357 |  |  |  |  |  |  | # ---------------------------------------- | 
| 358 |  |  |  |  |  |  | if( /^ARRAY$/ ) { | 
| 359 |  |  |  |  |  |  | # ---------------------------------------- | 
| 360 |  |  |  |  |  |  | my $type = | 
| 361 |  |  |  |  |  |  | " | 
| 362 |  |  |  |  |  |  | ($class ? " blessed_package=\"$class\"" : '' ). | 
| 363 |  |  |  |  |  |  | ($address ? " memory_address=\"$address\"" : '' ). | 
| 364 |  |  |  |  |  |  | ">"; | 
| 365 |  |  |  |  |  |  | $string .= "\n" . " " x $indent . $type; | 
| 366 |  |  |  |  |  |  | $self->{ xml }{ $address }++ if( $address ); | 
| 367 |  |  |  |  |  |  | if( not $reused ) { | 
| 368 |  |  |  |  |  |  | $indent++; | 
| 369 |  |  |  |  |  |  | for (my $i=0; $i < @$ref; $i++) { | 
| 370 |  |  |  |  |  |  | my $defined; | 
| 371 |  |  |  |  |  |  | my $type = | 
| 372 |  |  |  |  |  |  | " 
 | 
| 373 |  |  |  |  |  |  | "key=\"" . xml_escape( $i ) . "\"" . | 
| 374 |  |  |  |  |  |  | ( defined $ref->[ $i ] ? '' : " defined=\"false\"" ) . | 
| 375 |  |  |  |  |  |  | ">"; | 
| 376 |  |  |  |  |  |  |  | 
| 377 |  |  |  |  |  |  | $string .= "\n" . " " x $indent . $type; | 
| 378 |  |  |  |  |  |  | if (ref($ref->[$i])) { | 
| 379 |  |  |  |  |  |  | $string .= $self->dump($ref->[$i], $indent+1); | 
| 380 |  |  |  |  |  |  | $string .= "\n" . " " x $indent . ""; | 
| 381 |  |  |  |  |  |  | } else { | 
| 382 |  |  |  |  |  |  | $string .= xml_escape($ref->[$i]) . ""; | 
| 383 |  |  |  |  |  |  | } | 
| 384 |  |  |  |  |  |  | } | 
| 385 |  |  |  |  |  |  | $indent--; | 
| 386 |  |  |  |  |  |  | } | 
| 387 |  |  |  |  |  |  | $string .= "\n" . " " x $indent . ""; | 
| 388 |  |  |  |  |  |  | last REFERENCE; | 
| 389 |  |  |  |  |  |  | } | 
| 390 |  |  |  |  |  |  |  | 
| 391 |  |  |  |  |  |  | } | 
| 392 |  |  |  |  |  |  |  | 
| 393 |  |  |  |  |  |  | # ===== HANDLE SCALAR DUMPING | 
| 394 |  |  |  |  |  |  | } else { | 
| 395 |  |  |  |  |  |  | my $type = | 
| 396 |  |  |  |  |  |  | " | 
| 397 |  |  |  |  |  |  | ( defined $ref ? '' : " defined=\"false\"" ) . | 
| 398 |  |  |  |  |  |  | ">"; | 
| 399 |  |  |  |  |  |  |  | 
| 400 |  |  |  |  |  |  | $string .= "\n" . " " x $indent . $type . xml_escape( $ref ) . ""; | 
| 401 |  |  |  |  |  |  | } | 
| 402 |  |  |  |  |  |  |  | 
| 403 |  |  |  |  |  |  | return( $string ); | 
| 404 |  |  |  |  |  |  | } | 
| 405 |  |  |  |  |  |  |  | 
| 406 |  |  |  |  |  |  | # ============================================================ | 
| 407 |  |  |  |  |  |  | sub perl2xml { | 
| 408 |  |  |  |  |  |  | # ============================================================ | 
| 409 |  |  |  |  |  |  | pl2xml( @_ ); | 
| 410 |  |  |  |  |  |  | } | 
| 411 |  |  |  |  |  |  |  | 
| 412 |  |  |  |  |  |  | # ============================================================ | 
| 413 |  |  |  |  |  |  | sub pl2xml { | 
| 414 |  |  |  |  |  |  | # ============================================================ | 
| 415 |  |  |  |  |  |  |  | 
| 416 |  |  |  |  |  |  | =item * pl2xml( $xml, [ $file ] ) - | 
| 417 |  |  |  |  |  |  |  | 
| 418 |  |  |  |  |  |  | (Also perl2xml(), for those who enjoy readability over brevity). | 
| 419 |  |  |  |  |  |  |  | 
| 420 |  |  |  |  |  |  | Converts Perl data to XML. If a second argument is given, then the Perl data | 
| 421 |  |  |  |  |  |  | will be stored to disk as XML, using the second argument as a filename. | 
| 422 |  |  |  |  |  |  |  | 
| 423 |  |  |  |  |  |  | Usage: See Synopsis | 
| 424 |  |  |  |  |  |  |  | 
| 425 |  |  |  |  |  |  | =cut | 
| 426 |  |  |  |  |  |  |  | 
| 427 |  |  |  |  |  |  | # ------------------------------------------------------------ | 
| 428 |  |  |  |  |  |  | my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump; | 
| 429 |  |  |  |  |  |  | my $ref = shift; | 
| 430 |  |  |  |  |  |  | my $file = shift; | 
| 431 |  |  |  |  |  |  |  | 
| 432 |  |  |  |  |  |  | $self->init; | 
| 433 |  |  |  |  |  |  |  | 
| 434 |  |  |  |  |  |  | my $xml = | 
| 435 |  |  |  |  |  |  | ( defined $self->{ dtd } ? $self->{ dtd } : '' ) . | 
| 436 |  |  |  |  |  |  | "" . $self->dump( $ref, 1 ) . "\n\n"; | 
| 437 |  |  |  |  |  |  |  | 
| 438 |  |  |  |  |  |  | if( defined $file ) { | 
| 439 |  |  |  |  |  |  | if( $file =~ /\.xml\.gz$/i ) { | 
| 440 |  |  |  |  |  |  | if( $COMPRESSION_AVAILABLE ) { | 
| 441 |  |  |  |  |  |  | my $compressed_xml = Compress::Zlib::memGzip( $xml ) or die "Failed to compress xml $!"; | 
| 442 |  |  |  |  |  |  | open FILE, ">:utf8", $file or die "Can't open '$file' for writing $!"; | 
| 443 |  |  |  |  |  |  | binmode FILE; | 
| 444 |  |  |  |  |  |  | print FILE $compressed_xml; | 
| 445 |  |  |  |  |  |  | close FILE; | 
| 446 |  |  |  |  |  |  |  | 
| 447 |  |  |  |  |  |  | } else { | 
| 448 |  |  |  |  |  |  | my $uncompressed_file = $file; | 
| 449 |  |  |  |  |  |  | $uncompressed_file =~ s/\.gz$//i; | 
| 450 |  |  |  |  |  |  | warn "Compress::Zlib not installed. Saving '$file' as '$uncompressed_file'\n"; | 
| 451 |  |  |  |  |  |  |  | 
| 452 |  |  |  |  |  |  | open FILE, ">:utf8", $uncompressed_file or die "Can't open '$uncompressed_file' for writing $!"; | 
| 453 |  |  |  |  |  |  | print FILE $xml; | 
| 454 |  |  |  |  |  |  | close FILE; | 
| 455 |  |  |  |  |  |  | } | 
| 456 |  |  |  |  |  |  | } else { | 
| 457 |  |  |  |  |  |  | no warnings; # to shut Perl up about Wide characters for UTF8 output | 
| 458 |  |  |  |  |  |  | open FILE, ">$file" or die "Can't open '$file' for writing $!"; | 
| 459 |  |  |  |  |  |  | print FILE $xml; | 
| 460 |  |  |  |  |  |  | close FILE; | 
| 461 |  |  |  |  |  |  | } | 
| 462 |  |  |  |  |  |  | } | 
| 463 |  |  |  |  |  |  | return $xml; | 
| 464 |  |  |  |  |  |  | } | 
| 465 |  |  |  |  |  |  |  | 
| 466 |  |  |  |  |  |  | # ============================================================ | 
| 467 |  |  |  |  |  |  | sub undump { | 
| 468 |  |  |  |  |  |  | # ============================================================ | 
| 469 |  |  |  |  |  |  | # undump | 
| 470 |  |  |  |  |  |  | # Takes the XML generated by pl2xml, and recursively undumps it to | 
| 471 |  |  |  |  |  |  | # create a data structure in memory.  The top-level object is a scalar, | 
| 472 |  |  |  |  |  |  | # a reference to a scalar, a hash, or an array. Hashes and arrays may | 
| 473 |  |  |  |  |  |  | # themselves contain scalars, or references to scalars, or references to | 
| 474 |  |  |  |  |  |  | # hashes or arrays, with the exception that scalar values are never | 
| 475 |  |  |  |  |  |  | # "undef" because there's currently no way to represent undef in the | 
| 476 |  |  |  |  |  |  | # dumped data. | 
| 477 |  |  |  |  |  |  | # | 
| 478 |  |  |  |  |  |  | # The key to understanding undump is to understand XML::Parser's | 
| 479 |  |  |  |  |  |  | # Tree parsing format: | 
| 480 |  |  |  |  |  |  | # | 
| 481 |  |  |  |  |  |  | # , [ { , <[children tag-array pair value(s)]...> ] | 
| 482 |  |  |  |  |  |  | # ------------------------------------------------------------ | 
| 483 |  |  |  |  |  |  | my $self = shift; | 
| 484 |  |  |  |  |  |  | my $tree = shift; | 
| 485 |  |  |  |  |  |  | my $callback = shift; | 
| 486 |  |  |  |  |  |  |  | 
| 487 |  |  |  |  |  |  | my $ref = undef; | 
| 488 |  |  |  |  |  |  | my $item; | 
| 489 |  |  |  |  |  |  |  | 
| 490 |  |  |  |  |  |  | # make Perl stop whining about deep recursion and soft references | 
| 491 |  |  |  |  |  |  | no warnings; | 
| 492 |  |  |  |  |  |  |  | 
| 493 |  |  |  |  |  |  | TREE: for (my $i = 1; $i < $#$tree; $i+=2) { | 
| 494 |  |  |  |  |  |  | local $_ = lc( $tree->[ $i ] ); | 
| 495 |  |  |  |  |  |  | my $class = ''; | 
| 496 |  |  |  |  |  |  | my $address = ''; | 
| 497 |  |  |  |  |  |  |  | 
| 498 |  |  |  |  |  |  | PERL_TYPES: { | 
| 499 |  |  |  |  |  |  | # ---------------------------------------- | 
| 500 |  |  |  |  |  |  | if( /^scalar$/ ) { | 
| 501 |  |  |  |  |  |  | # ---------------------------------------- | 
| 502 |  |  |  |  |  |  | $ref = defined $tree->[ $i+1 ][ 2 ] ? $tree->[ $i +1 ][ 2 ] : ''; | 
| 503 |  |  |  |  |  |  | if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) { | 
| 504 |  |  |  |  |  |  | if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) { | 
| 505 |  |  |  |  |  |  | $ref = undef; | 
| 506 |  |  |  |  |  |  | } | 
| 507 |  |  |  |  |  |  | } | 
| 508 |  |  |  |  |  |  | last TREE; | 
| 509 |  |  |  |  |  |  | } | 
| 510 |  |  |  |  |  |  |  | 
| 511 |  |  |  |  |  |  | # ===== FIND PACKAGE | 
| 512 |  |  |  |  |  |  | if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) { | 
| 513 |  |  |  |  |  |  | if( exists $tree->[ $i+1 ][0]{ blessed_package } ) { | 
| 514 |  |  |  |  |  |  | $class = $tree->[ $i+1 ][ 0 ]{ blessed_package }; | 
| 515 |  |  |  |  |  |  | } | 
| 516 |  |  |  |  |  |  | } | 
| 517 |  |  |  |  |  |  |  | 
| 518 |  |  |  |  |  |  | # ===== FIND MEMORY ADDRESS | 
| 519 |  |  |  |  |  |  | if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) { | 
| 520 |  |  |  |  |  |  | if( exists $tree->[ $i+1 ][0]{ memory_address } ) { | 
| 521 |  |  |  |  |  |  | $address = $tree->[ $i+1 ][ 0 ]{ memory_address }; | 
| 522 |  |  |  |  |  |  | } | 
| 523 |  |  |  |  |  |  | } | 
| 524 |  |  |  |  |  |  |  | 
| 525 |  |  |  |  |  |  | ALREADY_EXISTS_IN_MEMORY: { | 
| 526 |  |  |  |  |  |  | if( exists $self->{ perldata }{ $address } ) { | 
| 527 |  |  |  |  |  |  | $ref = $self->{ perldata }{ $address }; | 
| 528 |  |  |  |  |  |  | last TREE; | 
| 529 |  |  |  |  |  |  | } | 
| 530 |  |  |  |  |  |  | } | 
| 531 |  |  |  |  |  |  |  | 
| 532 |  |  |  |  |  |  | # ---------------------------------------- | 
| 533 |  |  |  |  |  |  | if( /^scalarref/ ) { | 
| 534 |  |  |  |  |  |  | # ---------------------------------------- | 
| 535 |  |  |  |  |  |  | $ref = defined $tree->[ $i+1 ][ 2 ] ? \ $tree->[ $i +1 ][ 2 ] : \''; | 
| 536 |  |  |  |  |  |  | if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) { | 
| 537 |  |  |  |  |  |  | if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) { | 
| 538 |  |  |  |  |  |  | $ref = \ undef; | 
| 539 |  |  |  |  |  |  | } | 
| 540 |  |  |  |  |  |  | } | 
| 541 |  |  |  |  |  |  |  | 
| 542 |  |  |  |  |  |  | $self->{ perldata }{ $address } = $ref if( $address ); | 
| 543 |  |  |  |  |  |  | if( $class ) { | 
| 544 |  |  |  |  |  |  | # Check class name for nasty stuff... | 
| 545 |  |  |  |  |  |  | $class =~ m/^[\w-]+(?:::[\w-]+)*$/ | 
| 546 |  |  |  |  |  |  | or die "Refusing to load unsafe class name '$class'\n"; | 
| 547 |  |  |  |  |  |  |  | 
| 548 |  |  |  |  |  |  | unless( int( eval( "\%$class"."::")) ) { | 
| 549 |  |  |  |  |  |  | eval "require $class;"; | 
| 550 |  |  |  |  |  |  | if( $@ ) { | 
| 551 |  |  |  |  |  |  | warn $@; | 
| 552 |  |  |  |  |  |  | } | 
| 553 |  |  |  |  |  |  | } | 
| 554 |  |  |  |  |  |  |  | 
| 555 |  |  |  |  |  |  | bless $ref, $class; | 
| 556 |  |  |  |  |  |  | if( defined $callback && $ref->can( $callback ) ) { | 
| 557 |  |  |  |  |  |  | $ref->$callback(); | 
| 558 |  |  |  |  |  |  | } | 
| 559 |  |  |  |  |  |  | } | 
| 560 |  |  |  |  |  |  | last TREE; | 
| 561 |  |  |  |  |  |  | } | 
| 562 |  |  |  |  |  |  |  | 
| 563 |  |  |  |  |  |  | # ---------------------------------------- | 
| 564 |  |  |  |  |  |  | if( /^hash(?:ref)?/ ) { | 
| 565 |  |  |  |  |  |  | # ---------------------------------------- | 
| 566 |  |  |  |  |  |  | $ref = {}; | 
| 567 |  |  |  |  |  |  | $self->{ perldata }{ $address } = $ref if( $address ); | 
| 568 |  |  |  |  |  |  | for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) { | 
| 569 |  |  |  |  |  |  | next unless $tree->[$i+1][$j] eq 'item'; | 
| 570 |  |  |  |  |  |  | my $item_tree = $tree->[$i+1][$j+1]; | 
| 571 |  |  |  |  |  |  | if( exists $item_tree->[0]{ key } ) { | 
| 572 |  |  |  |  |  |  | my $key = $item_tree->[ 0 ]{ key }; | 
| 573 |  |  |  |  |  |  | if( exists $item_tree->[ 0 ]{ 'defined' } ) { | 
| 574 |  |  |  |  |  |  | if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) { | 
| 575 |  |  |  |  |  |  | $ref->{ $key } = undef; | 
| 576 |  |  |  |  |  |  | next; | 
| 577 |  |  |  |  |  |  | } | 
| 578 |  |  |  |  |  |  | } | 
| 579 |  |  |  |  |  |  | # ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS | 
| 580 |  |  |  |  |  |  | # It indicates the presence of a zero-length string by | 
| 581 |  |  |  |  |  |  | # not having the array portion of the tag-name/array pair | 
| 582 |  |  |  |  |  |  | # values be of length 1. (Which is to say it captures only | 
| 583 |  |  |  |  |  |  | # the attributes of the tag and acknowledges that the tag | 
| 584 |  |  |  |  |  |  | # is an empty one. | 
| 585 |  |  |  |  |  |  | if( int( @{ $item_tree } ) == 1 ) { | 
| 586 |  |  |  |  |  |  | $ref->{ $key } = ''; | 
| 587 |  |  |  |  |  |  | next; | 
| 588 |  |  |  |  |  |  | } | 
| 589 |  |  |  |  |  |  | $ref->{ $key } = $self->undump( $item_tree, $callback ); | 
| 590 |  |  |  |  |  |  | } | 
| 591 |  |  |  |  |  |  | } | 
| 592 |  |  |  |  |  |  | if( $class ) { | 
| 593 |  |  |  |  |  |  | # Check class name for nasty stuff... | 
| 594 |  |  |  |  |  |  | $class =~ m/^[\w-]+(?:::[\w-]+)*$/ | 
| 595 |  |  |  |  |  |  | or die "Refusing to load unsafe class name '$class'\n"; | 
| 596 |  |  |  |  |  |  |  | 
| 597 |  |  |  |  |  |  | unless( int( eval( "\%$class"."::")) ) { | 
| 598 |  |  |  |  |  |  | eval "require $class;"; | 
| 599 |  |  |  |  |  |  | if( $@ ) { | 
| 600 |  |  |  |  |  |  | warn $@; | 
| 601 |  |  |  |  |  |  | } | 
| 602 |  |  |  |  |  |  | } | 
| 603 |  |  |  |  |  |  |  | 
| 604 |  |  |  |  |  |  | bless $ref, $class; | 
| 605 |  |  |  |  |  |  | if( defined $callback && $ref->can( $callback ) ) { | 
| 606 |  |  |  |  |  |  | $ref->$callback(); | 
| 607 |  |  |  |  |  |  | } | 
| 608 |  |  |  |  |  |  | } | 
| 609 |  |  |  |  |  |  | last TREE; | 
| 610 |  |  |  |  |  |  | } | 
| 611 |  |  |  |  |  |  |  | 
| 612 |  |  |  |  |  |  | # ---------------------------------------- | 
| 613 |  |  |  |  |  |  | if( /^arrayref/ ) { | 
| 614 |  |  |  |  |  |  | # ---------------------------------------- | 
| 615 |  |  |  |  |  |  | $ref = []; | 
| 616 |  |  |  |  |  |  | $self->{ perldata }{ $address } = $ref if( $address ); | 
| 617 |  |  |  |  |  |  | for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) { | 
| 618 |  |  |  |  |  |  | next unless $tree->[$i+1][$j] eq 'item'; | 
| 619 |  |  |  |  |  |  | my $item_tree = $tree->[$i+1][$j+1]; | 
| 620 |  |  |  |  |  |  | if( exists $item_tree->[0]{ key } ) { | 
| 621 |  |  |  |  |  |  | my $key = $item_tree->[0]{ key }; | 
| 622 |  |  |  |  |  |  | if( exists $item_tree->[ 0 ]{ 'defined' } ) { | 
| 623 |  |  |  |  |  |  | if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) { | 
| 624 |  |  |  |  |  |  | $ref->[ $key ] = undef; | 
| 625 |  |  |  |  |  |  | next; | 
| 626 |  |  |  |  |  |  | } | 
| 627 |  |  |  |  |  |  | } | 
| 628 |  |  |  |  |  |  | # ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS | 
| 629 |  |  |  |  |  |  | # See note above. | 
| 630 |  |  |  |  |  |  | if( int( @{ $item_tree } ) == 1 ) { | 
| 631 |  |  |  |  |  |  | $ref->[ $key ] = ''; | 
| 632 |  |  |  |  |  |  | next; | 
| 633 |  |  |  |  |  |  | } | 
| 634 |  |  |  |  |  |  | $ref->[ $key ] = $self->undump( $item_tree, $callback ); | 
| 635 |  |  |  |  |  |  | } | 
| 636 |  |  |  |  |  |  | } | 
| 637 |  |  |  |  |  |  | if( $class ) { | 
| 638 |  |  |  |  |  |  | # Check class name for nasty stuff... | 
| 639 |  |  |  |  |  |  | $class =~ m/^[\w-]+(?:::[\w-]+)*$/ | 
| 640 |  |  |  |  |  |  | or die "Refusing to load unsafe class name '$class'\n"; | 
| 641 |  |  |  |  |  |  |  | 
| 642 |  |  |  |  |  |  | unless( int( eval( "\%$class"."::")) ) { | 
| 643 |  |  |  |  |  |  | eval "require $class;"; | 
| 644 |  |  |  |  |  |  | if( $@ ) { | 
| 645 |  |  |  |  |  |  | warn $@; | 
| 646 |  |  |  |  |  |  | } | 
| 647 |  |  |  |  |  |  | } | 
| 648 |  |  |  |  |  |  |  | 
| 649 |  |  |  |  |  |  | bless $ref, $class; | 
| 650 |  |  |  |  |  |  | if( defined $callback && $ref->can( $callback ) ) { | 
| 651 |  |  |  |  |  |  | $ref->$callback(); | 
| 652 |  |  |  |  |  |  | } | 
| 653 |  |  |  |  |  |  | } | 
| 654 |  |  |  |  |  |  | last TREE; | 
| 655 |  |  |  |  |  |  | } | 
| 656 |  |  |  |  |  |  |  | 
| 657 |  |  |  |  |  |  | # ---------------------------------------- | 
| 658 |  |  |  |  |  |  | if( /^0$/ ) { # SIMPLE SCALAR | 
| 659 |  |  |  |  |  |  | # ---------------------------------------- | 
| 660 |  |  |  |  |  |  | $item = $tree->[$i + 1]; | 
| 661 |  |  |  |  |  |  | } | 
| 662 |  |  |  |  |  |  | } | 
| 663 |  |  |  |  |  |  | } | 
| 664 |  |  |  |  |  |  |  | 
| 665 |  |  |  |  |  |  | ## If $ref is not set at this point, it means we've just | 
| 666 |  |  |  |  |  |  | ## encountered a scalar value directly inside the item tag. | 
| 667 |  |  |  |  |  |  |  | 
| 668 |  |  |  |  |  |  | $ref = $item unless defined( $ref ); | 
| 669 |  |  |  |  |  |  |  | 
| 670 |  |  |  |  |  |  | return ($ref); | 
| 671 |  |  |  |  |  |  | } | 
| 672 |  |  |  |  |  |  |  | 
| 673 |  |  |  |  |  |  | # ============================================================ | 
| 674 |  |  |  |  |  |  | sub xml_escape { | 
| 675 |  |  |  |  |  |  | # ============================================================ | 
| 676 |  |  |  |  |  |  | # Transforms and filters input characters to acceptable XML characters | 
| 677 |  |  |  |  |  |  | # (or filters them out completely). There's probably a better | 
| 678 |  |  |  |  |  |  | # implementation of this in another module, by now. | 
| 679 |  |  |  |  |  |  | # ------------------------------------------------------------ | 
| 680 |  |  |  |  |  |  | local $_ = shift; | 
| 681 |  |  |  |  |  |  | return $_ if not defined $_; | 
| 682 |  |  |  |  |  |  | s/&/&/g; | 
| 683 |  |  |  |  |  |  | s/</g; | 
| 684 |  |  |  |  |  |  | s/>/>/g; | 
| 685 |  |  |  |  |  |  | s/[\0\ca\cb\cc\cd\ce\cf\cg\ch\ck\cl\cn\co\cp\cq\cr\cs\ct\cu\cv\cw\cx\cy\cz\c[\c\\c]\c^\c_]//g; | 
| 686 |  |  |  |  |  |  | s/'/'/g; | 
| 687 |  |  |  |  |  |  | s/"/"/g; | 
| 688 |  |  |  |  |  |  | return $_; | 
| 689 |  |  |  |  |  |  | } | 
| 690 |  |  |  |  |  |  |  | 
| 691 |  |  |  |  |  |  | # ============================================================ | 
| 692 |  |  |  |  |  |  | sub xml2perl { | 
| 693 |  |  |  |  |  |  | # ============================================================ | 
| 694 |  |  |  |  |  |  | xml2pl( @_ ); | 
| 695 |  |  |  |  |  |  | } | 
| 696 |  |  |  |  |  |  |  | 
| 697 |  |  |  |  |  |  | # ============================================================ | 
| 698 |  |  |  |  |  |  | sub xml2pl { | 
| 699 |  |  |  |  |  |  | # ============================================================ | 
| 700 |  |  |  |  |  |  |  | 
| 701 |  |  |  |  |  |  | =item * xml2pl( $xml_or_filename, [ $callback ] ) - | 
| 702 |  |  |  |  |  |  |  | 
| 703 |  |  |  |  |  |  | (Also xml2perl(), for those who enjoy readability over brevity.) | 
| 704 |  |  |  |  |  |  |  | 
| 705 |  |  |  |  |  |  | Converts XML to a Perl datatype. If this method is given a second argument, | 
| 706 |  |  |  |  |  |  | XML::Dumper will use the second argument as a callback (if possible). If | 
| 707 |  |  |  |  |  |  | the first argument isn't XML and exists as a file, that file will be read | 
| 708 |  |  |  |  |  |  | and its contents will be used as the input XML. | 
| 709 |  |  |  |  |  |  |  | 
| 710 |  |  |  |  |  |  | Currently, the only supported invocation of callbacks is through soft | 
| 711 |  |  |  |  |  |  | references. That is to say, the callback argument ought to be a string | 
| 712 |  |  |  |  |  |  | that matches the name of a callable method for your classes. If you have | 
| 713 |  |  |  |  |  |  | a congruent interface, this should work like a peach. If your class | 
| 714 |  |  |  |  |  |  | interface doesn't have such a named method, it won't be called. | 
| 715 |  |  |  |  |  |  |  | 
| 716 |  |  |  |  |  |  | =cut | 
| 717 |  |  |  |  |  |  |  | 
| 718 |  |  |  |  |  |  | # ------------------------------------------------------------ | 
| 719 |  |  |  |  |  |  | my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/) ? shift : $dump; | 
| 720 |  |  |  |  |  |  | my $xml = shift; | 
| 721 |  |  |  |  |  |  | my $callback = shift; | 
| 722 |  |  |  |  |  |  |  | 
| 723 |  |  |  |  |  |  | $self->init; | 
| 724 |  |  |  |  |  |  |  | 
| 725 |  |  |  |  |  |  | if( $xml !~ /\ ) { | 
| 726 |  |  |  |  |  |  | my $file = $xml; | 
| 727 |  |  |  |  |  |  | if( -e $file ) { | 
| 728 |  |  |  |  |  |  | my $gzip_header_signature = pack "H4", "1f8b"; | 
| 729 |  |  |  |  |  |  | my $first_two_bytes; | 
| 730 |  |  |  |  |  |  |  | 
| 731 |  |  |  |  |  |  | open FILE, "<". $file or die "Can't open '$file' for reading $!"; | 
| 732 |  |  |  |  |  |  | defined read FILE, $first_two_bytes, 2 or die "Can't read first two bytes of '$file' $!"; | 
| 733 |  |  |  |  |  |  | close FILE; | 
| 734 |  |  |  |  |  |  |  | 
| 735 |  |  |  |  |  |  | if( $first_two_bytes eq $gzip_header_signature ) { | 
| 736 |  |  |  |  |  |  | if( $COMPRESSION_AVAILABLE ) { | 
| 737 |  |  |  |  |  |  | my $gz = Compress::Zlib::gzopen( $file, "rb" ); | 
| 738 |  |  |  |  |  |  | my @xml; | 
| 739 |  |  |  |  |  |  | my $buffer; | 
| 740 |  |  |  |  |  |  | while( $gz->gzread( $buffer ) > 0 ) { | 
| 741 |  |  |  |  |  |  | push @xml, $buffer; | 
| 742 |  |  |  |  |  |  | } | 
| 743 |  |  |  |  |  |  | $gz->gzclose(); | 
| 744 |  |  |  |  |  |  | $xml = join "", @xml; | 
| 745 |  |  |  |  |  |  |  | 
| 746 |  |  |  |  |  |  | } else { | 
| 747 |  |  |  |  |  |  | die "Compress::Zlib is not installed. Cannot read gzipped file '$file'"; | 
| 748 |  |  |  |  |  |  | } | 
| 749 |  |  |  |  |  |  | } else { | 
| 750 |  |  |  |  |  |  |  | 
| 751 |  |  |  |  |  |  | open FILE, $file or die "Can't open file '$file' for reading $!"; | 
| 752 |  |  |  |  |  |  | my @xml = ; | 
| 753 |  |  |  |  |  |  | close FILE; | 
| 754 |  |  |  |  |  |  | $xml = join "", @xml; | 
| 755 |  |  |  |  |  |  | } | 
| 756 |  |  |  |  |  |  |  | 
| 757 |  |  |  |  |  |  | } else { | 
| 758 |  |  |  |  |  |  | die "'$file' does not exist as a file and is not XML.\n"; | 
| 759 |  |  |  |  |  |  | } | 
| 760 |  |  |  |  |  |  | } | 
| 761 |  |  |  |  |  |  |  | 
| 762 |  |  |  |  |  |  | my $parser = new XML::Parser( %{ $self->{ xml_parser_params }}, Style => 'Tree' ); | 
| 763 |  |  |  |  |  |  | my $tree = $parser->parse($xml); | 
| 764 |  |  |  |  |  |  |  | 
| 765 |  |  |  |  |  |  | # Skip enclosing "perldata" level | 
| 766 |  |  |  |  |  |  | my $topItem = $tree->[1]; | 
| 767 |  |  |  |  |  |  | my $ref = $self->undump($topItem, $callback); | 
| 768 |  |  |  |  |  |  |  | 
| 769 |  |  |  |  |  |  | return($ref); | 
| 770 |  |  |  |  |  |  | } | 
| 771 |  |  |  |  |  |  |  | 
| 772 |  |  |  |  |  |  | # ============================================================ | 
| 773 |  |  |  |  |  |  | sub xml_compare { | 
| 774 |  |  |  |  |  |  | # ============================================================ | 
| 775 |  |  |  |  |  |  |  | 
| 776 |  |  |  |  |  |  | =item * xml_compare( $xml1, $xml2 ) - Compares xml for content | 
| 777 |  |  |  |  |  |  |  | 
| 778 |  |  |  |  |  |  | Compares two dumped Perl data structures (that is, compares the xml) for | 
| 779 |  |  |  |  |  |  | identity in content. Use this function rather than perl's built-in string | 
| 780 |  |  |  |  |  |  | comparison. This function will return true for any two perl data that are | 
| 781 |  |  |  |  |  |  | either deep clones of each other, or identical. This method is exported | 
| 782 |  |  |  |  |  |  | by default. | 
| 783 |  |  |  |  |  |  |  | 
| 784 |  |  |  |  |  |  | =cut | 
| 785 |  |  |  |  |  |  |  | 
| 786 |  |  |  |  |  |  | # ------------------------------------------------------------ | 
| 787 |  |  |  |  |  |  | my $self = shift; | 
| 788 |  |  |  |  |  |  | my $xml1 = shift; | 
| 789 |  |  |  |  |  |  | my $xml2 = shift; | 
| 790 |  |  |  |  |  |  |  | 
| 791 |  |  |  |  |  |  | my $class = ref $self; | 
| 792 |  |  |  |  |  |  | if( $class ne 'XML::Dumper' ) { | 
| 793 |  |  |  |  |  |  | $xml2 = $xml1; | 
| 794 |  |  |  |  |  |  | $xml1 = $self; | 
| 795 |  |  |  |  |  |  | } | 
| 796 |  |  |  |  |  |  |  | 
| 797 |  |  |  |  |  |  | $xml1 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g; | 
| 798 |  |  |  |  |  |  | $xml2 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g; | 
| 799 |  |  |  |  |  |  | $xml1 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # For backwards | 
| 800 |  |  |  |  |  |  | $xml2 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # compatibility | 
| 801 |  |  |  |  |  |  | $xml1 =~ s/<\?xml .*>//; # Ignore XML declaration | 
| 802 |  |  |  |  |  |  | $xml2 =~ s/<\?xml .*>//; | 
| 803 |  |  |  |  |  |  | $xml1 =~ s/<\!DOCTYPE perldata \[.*\]>//s; # Remove DTD | 
| 804 |  |  |  |  |  |  | $xml2 =~ s/<\!DOCTYPE perldata \[.*\]>//s; | 
| 805 |  |  |  |  |  |  | $xml1 =~ s/^\s*; # Remove empty space | 
| 806 |  |  |  |  |  |  | $xml2 =~ s/^\s*; | 
| 807 |  |  |  |  |  |  | $xml1 =~ s/>\s*> | 
| 808 |  |  |  |  |  |  | $xml2 =~ s/>\s*> | 
| 809 |  |  |  |  |  |  | $xml1 =~ s/>\s*$/>/; | 
| 810 |  |  |  |  |  |  | $xml2 =~ s/>\s*$/>/; | 
| 811 |  |  |  |  |  |  |  | 
| 812 |  |  |  |  |  |  | return $xml1 eq $xml2; | 
| 813 |  |  |  |  |  |  | } | 
| 814 |  |  |  |  |  |  |  | 
| 815 |  |  |  |  |  |  | # ============================================================ | 
| 816 |  |  |  |  |  |  | sub xml_identity { | 
| 817 |  |  |  |  |  |  | # ============================================================ | 
| 818 |  |  |  |  |  |  |  | 
| 819 |  |  |  |  |  |  | =item * xml_identity( $xml1, $xml2 ) - Compares xml for identity | 
| 820 |  |  |  |  |  |  |  | 
| 821 |  |  |  |  |  |  | Compares two dumped Perl data structures (that is, compares the xml) for | 
| 822 |  |  |  |  |  |  | identity in instantiation. This function will return true for any two | 
| 823 |  |  |  |  |  |  | perl data that are identical, but not for deep clones of each other. This | 
| 824 |  |  |  |  |  |  | method is also exported by default. | 
| 825 |  |  |  |  |  |  |  | 
| 826 |  |  |  |  |  |  | =cut | 
| 827 |  |  |  |  |  |  |  | 
| 828 |  |  |  |  |  |  | # ------------------------------------------------------------ | 
| 829 |  |  |  |  |  |  | my $self = shift; | 
| 830 |  |  |  |  |  |  | my $xml1 = shift; | 
| 831 |  |  |  |  |  |  | my $xml2 = shift; | 
| 832 |  |  |  |  |  |  |  | 
| 833 |  |  |  |  |  |  | my $class = ref $self; | 
| 834 |  |  |  |  |  |  | if( $class ne 'XML::Dumper' ) { | 
| 835 |  |  |  |  |  |  | $xml2 = $xml1; | 
| 836 |  |  |  |  |  |  | $xml1 = $self; | 
| 837 |  |  |  |  |  |  | } | 
| 838 |  |  |  |  |  |  |  | 
| 839 |  |  |  |  |  |  | return ( $xml1 eq $xml2 ); | 
| 840 |  |  |  |  |  |  | } | 
| 841 |  |  |  |  |  |  |  | 
| 842 |  |  |  |  |  |  | 1; | 
| 843 |  |  |  |  |  |  | __END__ |