]> git.llucax.com Git - mecon/scripts.git/blob - embperl/DumperISO.pm
- Se agrega el servidor bal746b a la ronda de cargas matinales
[mecon/scripts.git] / embperl / DumperISO.pm
1
2 # Copyright (c) 1998 Jonathan Eisenzopf <eisen@pobox.com>
3 # XML::DumperISO is free software. You can redistribute it and/or
4 # modify it under the same terms as Perl itself.
5
6 package XML::DumperISO;
7
8 BEGIN {
9     use strict;
10     use vars qw($VAR1 $VERSION);
11     use Data::Dumper;
12     $VERSION = '0.4'; 
13 }
14
15 sub new {
16     my $class = shift;
17     my $self = {};
18     return bless $self,$class;
19 }
20
21 sub pl2xml {
22     my ($obj,$ref) = @_;
23     return $obj->pl2xml_string($ref);
24 }
25
26 sub pl2xml_string {
27     my ($obj,$ref) = @_;
28     return(
29            "<perldata>" .
30            &Tree2XML($ref, 1) .
31            "\n</perldata>\n"
32            );
33 }
34
35 sub Tree2XML {
36     my ($ref, $indent) = @_;
37     my $string = '';
38
39     # SCALAR REFERENCE
40     if (defined(ref($ref)) && (ref($ref) eq 'SCALAR')) {
41         $string .= "\n" . " " x $indent . "<scalarref>" . &QuoteXMLChars($$ref) . "</scalarref>";
42     } 
43
44     # HASH REFERENCE
45     elsif (defined(ref($ref)) && (ref($ref) eq 'HASH')) {
46         $string .= "\n" . " " x $indent . "<hash>"; 
47         $indent++;
48         foreach my $key (keys(%$ref)) {
49             $string .= "\n" . " " x $indent . "<item key=\"" . &QuoteXMLChars($key) . "\">";
50             if (ref($ref->{$key})) {
51                 $string .= &Tree2XML($ref->{$key}, $indent+1);
52                 $string .= "\n" . " " x $indent . "</item>";
53             } else {
54                 $string .= &QuoteXMLChars($ref->{$key}) . "</item>";
55             }
56         }
57         $indent--;
58         $string .= "\n" . " " x $indent . "</hash>";
59     }
60
61     # ARRAY REFERENCE 
62     elsif (defined(ref($ref)) && (ref($ref) eq 'ARRAY')) {
63         $string .= "\n" . " " x $indent . "<array>"; 
64         $indent++;
65         for (my $i=0; $i < @$ref; $i++) {
66             $string .= "\n" . " " x $indent . "<item key=\"$i\">";
67             if (ref($ref->[$i])) {
68                 $string .= &Tree2XML($ref->[$i], $indent+1);
69                 $string .= "\n" . " " x $indent . "</item>";
70             } else {
71                 $string .= &QuoteXMLChars($ref->[$i]) . "</item>";
72             }
73         }
74         $indent--;
75         $string .= "\n" . " " x $indent . "</array>";
76     }
77     
78     ## SCALAR
79     else {
80         $string .= "\n" . " " x $indent . "<scalar>" . &QuoteXMLChars($ref) . "</scalar>";
81     }
82     
83     return($string);
84 }
85
86 sub QuoteXMLChars {
87     $_[0] =~ s/&/&amp;/g;
88     $_[0] =~ s/</&lt;/g;
89     $_[0] =~ s/>/&gt;/g;
90     $_[0] =~ s/'/&apos;/g;
91     $_[0] =~ s/"/&quot;/g;
92     return($_[0]);
93 }
94
95 sub xml2pl {
96     my ($obj,$tree) = @_;
97     
98     ## Skip enclosing "perldata" level
99     my $TopItem = $tree->[1];
100     my $ref = &Undump($TopItem);
101     
102     return($ref);
103 }
104
105 ## Undump
106 ## Takes a parse tree of the XML generated by pl2xml, and recursively
107 ## undumps it to create a data structure in memory.  The top-level
108 ## object is a scalar, a reference to a scalar, a hash, or an array.
109 ## Hashes and arrays may themselves contain scalars, or references to
110 ## scalars, or references to hashes or arrays, with the exception that
111 ## scalar values are never "undef" because there's currently no way to
112 ## represent undef in the dumped data.
113
114 sub Undump {
115     my ($Tree) = shift;
116     my $ref = undef;
117     my $FoundScalar;
118     my $i;
119
120     for ($i = 1; $i < $#$Tree; $i+=2) {         
121         if (lc($Tree->[$i]) eq 'scalar') {
122             ## Make a copy of the string
123             $ref = $Tree->[$i+1]->[2];
124             last;
125         }
126         if (lc($Tree->[$i]) eq 'scalarref') {
127             ## Make a ref to a copy of the string
128             $ref = \ "$Tree->[$i+1]->[2]";
129             last;
130         } elsif (lc($Tree->[$i]) eq 'hash') {
131             $ref = {};
132             my $j;
133             for ($j = 1; $j < $#{$Tree->[$i+1]}; $j+=2) {
134                 next unless $Tree->[$i+1]->[$j] eq 'item';
135                 my $ItemTree = $Tree->[$i+1]->[$j+1];
136                 next unless defined(my $key = $ItemTree->[0]->{key});
137                 $ref->{$key} = &Undump($ItemTree);
138             }
139             last;
140         } elsif (lc($Tree->[$i]) eq 'array') {
141             $ref = [];
142             my $j;
143             for ($j = 1; $j < $#{$Tree->[$i+1]}; $j+=2) {
144                 next unless $Tree->[$i+1]->[$j] eq 'item';
145                 my $ItemTree = $Tree->[$i+1]->[$j+1];
146                 next unless defined(my $key = $ItemTree->[0]->{key});
147                 $ref->[$key] = &Undump($ItemTree);
148             }
149             last;
150         } elsif (lc($Tree->[$i]) eq '0') {
151             $FoundScalar = $Tree->[$i + 1] unless defined $FoundScalar;
152         } else {
153             ## Unrecognized tag.  Just move on.
154         }
155     }
156
157     ## If $ref is not set at this point, it means we've just
158     ## encountered a scalar value directly inside the item tag.
159     
160     $ref = $FoundScalar unless defined($ref);
161
162   done:
163     return ($ref);
164 }
165
166 ### TestRoundTrip
167 ### Tests the conversion of perl data structures into XML and back again
168 ###
169 ### Invoke with:
170 ###
171 ###     perl -e 'use XML::DumperISO; &XML::DumperISO::TestRoundTrip();'
172 ###
173 ### The 5 sets of sample data below show some typical cases:
174
175 sub TestRoundTrip
176 {
177         my $TestRuns = 
178                 [
179                  
180                  <<'END_TEST1',
181 <perldata>
182  <scalar>foo</scalar>
183 </perldata>
184 END_TEST1
185
186                  <<'END_TEST2',
187 <perldata>
188  <scalarref>Hi Mom</scalarref>
189 </perldata>
190 END_TEST2
191
192                  <<'END_TEST3',
193 <perldata>
194  <hash>
195   <item key="key1">value1</item>
196   <item key="key2">value2</item>
197  </hash>
198 </perldata>
199 END_TEST3
200
201                  <<'END_TEST4',
202 <perldata>
203  <array>
204   <item key="0">foo</item>
205   <item key="1">bar</item>
206  </array>
207 </perldata>
208 END_TEST4
209
210                  <<'END_TEST5',
211 <perldata>
212  <array>
213   <item key="0">Scalar</item>
214   <item key="1">
215    <scalarref>ScalarRef</scalarref>
216   </item>
217   <item key="2">
218    <array>
219     <item key="0">foo</item>
220     <item key="1">bar</item>
221    </array>
222   </item>
223   <item key="3">
224    <hash>
225     <item key="key1">value1</item>
226     <item key="key2">value2</item>
227    </hash>
228   </item>
229  </array>
230 </perldata>
231 END_TEST5
232
233                                         ];
234
235         my $TestNum;
236         my $TestData;
237         foreach $TestData (@$TestRuns)
238         {
239                 $TestNum++;
240
241                 use XML::Parser;
242                 my $Parser = XML::Parser->new(Style => 'Tree');
243                 my $Tree = $Parser->parse($TestData);
244                 
245                 my $DumperISO = new XML::DumperISO();
246                 my $Ref = $DumperISO->xml2pl($Tree);
247                 
248                 my $ReDump = $DumperISO->pl2xml_string($Ref);
249                 
250                 if ($TestData eq $ReDump)
251                 {
252                         print STDERR ("Test $TestNum: Success.\n\n" . 
253                                                   "Perl tree:\n" . 
254                                                   &Data::Dumper::Dumper($Ref) . 
255                                                   "\n\n");
256                 }
257                 else
258                 {
259                         print STDERR ("TestRoundTrip: data doesn't match!\n\n" . 
260                                                   "Orig:\n$TestData\nRound Trip:\n$ReDump\n");
261                 }
262         }
263 }
264
265
266
267 1;
268 __END__
269
270 =head1 NAME
271
272 XML::DumperISO - Perl module for dumping Perl objects from/to XML
273
274 =head1 SYNOPSIS
275
276  # Convert Perl code to XML
277  use XML::DumperISO;
278  my $dump = new XML::DumperISO;
279  $data = [
280           {
281             first => 'Jonathan',
282             last => 'Eisenzopf',
283             email => 'eisen@pobox.com'
284           },
285           {
286             first => 'Larry',
287             last => 'Wall',
288             email => 'larry@wall.org'
289           }
290          ];
291  $xml =  $dump->pl2xml($perl);
292
293
294  # Convert XML to Perl code
295  use XML::DumperISO;
296  my $dump = new XML::DumperISO; 
297
298  # some XML
299  my $xml = <<XML;
300 <perldata>
301  <scalar>foo</scalar>
302 </perldata>
303 XML
304
305  # load Perl data structure from dumped XML
306  $data = $dump->xml2pl($Tree);
307
308 =head1 DESCRIPTION
309
310 XML::DumperISO dumps Perl data to a structured XML format.
311 XML::DumperISO can also read XML data that was previously dumped
312 by the module and convert it back to Perl.
313
314 This is done via the following 2 methods:
315 XML::DumperISO::pl2xml
316 XML::DumperISO::xml2pl
317
318 =head1 AUTHOR
319
320 Jonathan Eisenzopf <eisen@pobox.com>
321
322 =head1 CREDITS
323
324 Chris Thorman <ct@ignitiondesign.com>
325 L.M.Orchard <deus_x@pobox.com>
326 DeWitt Clinton <dewitt@eziba.com>
327
328 =head1 SEE ALSO
329
330 perl(1), XML::Parser(3).
331
332 =cut