File Coverage

blib/lib/Data/Sofu/SofuML.pm
Criterion Covered Total %
statement 204 427 47.7
branch 47 150 31.3
condition 14 58 24.1
subroutine 20 33 60.6
pod 29 29 100.0
total 314 697 45.0


line stmt bran cond sub pod time code
1             ###############################################################################
2             #SofuML.pm
3             #Last Change: 2009-28-01
4             #Copyright (c) 2009 Marc-Seabstian "Maluku" Lucksch
5             #Version 0.3
6             ####################
7             #This file is part of the sofu.pm project, a parser library for an all-purpose
8             #ASCII file format. More information can be found on the project web site
9             #at http://sofu.sourceforge.net/ .
10             #
11             #sofu.pm is published under the terms of the MIT license, which basically means
12             #"Do with it whatever you want". For more information, see the license.txt
13             #file that should be enclosed with libsofu distributions. A copy of the license
14             #is (at the time of this writing) also available at
15             #http://www.opensource.org/licenses/mit-license.php .
16             ###############################################################################
17            
18             =head1 NAME
19            
20             Data::Sofu::SofuML - Interface to various binary drivers
21            
22             =head1 DESCRIPTION
23            
24             This Module is used to convert Sofu Trees to XML Tree.
25            
26             This is mostly for convertig Sofu data via XSLT or similar.
27            
28             You don't need to use this module directly.
29            
30             =head1 Synopsis
31            
32             use Data::Sofu;
33             my $sofu = readSofu("file.sofu");
34             writeSofuML("file.xml",$sofu,getSofucomments());
35             #And back
36             my $xml = readSofu("file.xml"); #readSofu can detect SofuML files.
37             writeSofu("file.sofu",$xml,getSofucomments());
38            
39             Using the Sofu OO syntax:
40            
41             require Data::Sofu;
42             my $s = Data::Sofu::new();
43             my $sofu = $s->read("file.sofu");
44             $s->writeML("file.xml",$sofu,$s->comments());
45             #And back
46             my $xml = $s->read("file.xml"); #read also detects SofuML files.
47             $s->write("file.sofu",$xml,$s->comments());
48            
49             Using scalars instead of files:
50            
51             require Data::Sofu;
52             my $s = Data::Sofu::new();
53             my $sofu = $s->read("file.sofu");
54             my $xmlstring = $s->packML($sofu,$s->comments()); #Contains now the xml files content
55             my $xml = $s->unpack($xmlstring);
56             $s->write($xml,$s->comments());
57            
58             But: $scalar=packML() is not the same as writeML(\$scalar), packML will not indent the file.
59            
60            
61            
62             =head1 SYNTAX
63            
64             This Module is pure OO, exports nothing
65            
66             =cut
67            
68             package Data::Sofu::SofuML;
69 1     1   6 use strict;
  1         3  
  1         44  
70 1     1   6 use warnings;
  1         2  
  1         72  
71            
72             our $VERSION="0.3";
73             #We are really going to need these modules:
74 1     1   6 use Encode;
  1         2  
  1         192  
75 1     1   6 use Carp qw/confess cluck/;
  1         2  
  1         6773  
76             require Data::Sofu;
77            
78             =head1 METHODS
79            
80             Most of these Methods (except pack()) are ony for internal use.
81            
82             =head2 new()
83            
84             Creates a new C and returns it.
85            
86             =cut
87            
88             sub new {
89 1     1 1 4 my $self={};
90 1         4 bless $self,shift;
91 1         16 $self->{IDS} = {};
92 1         3 $self->{ID} = 0;
93 1         3 $self->{INDENT} = "\t";
94 1         6 return $self;
95             }
96            
97             =head2 whiteescape (STRING)
98            
99             Escapes whitespace for use in XML
100            
101             =cut
102            
103             sub whiteescape {
104 52     52 1 59 my $self=shift;
105 52         79 my $data = shift;
106 52 100       207 return $data if ($data eq " ");
107 16         20 my $f = "";
108 16         47 $data=~s/(.)/sprintf("&#x%X;",ord($1))/esg;
  28         77  
109            
110 16         70 return $f.$data;
111             }
112            
113             =head2 XMLescapeOld(STRING,LEVEL)
114            
115             Older version of XMLescape, still need by some.
116            
117             =cut
118            
119             sub XMLescapeOld {
120 0     0 1 0 my $self=shift;
121 0         0 my $string=shift;
122 0         0 my $level=shift;
123 0         0 $string =~ s/\&/&/g;
124 0         0 $string =~ s/\
125 0         0 $string =~ s/\>/>/g;
126 0         0 $string =~ s/\"/"/g;
127 0         0 $string =~ s/\'/'/g;
128 0         0 $string=~s"^([\s\n\x0A]+)"join '',map {sprintf('&#x%X;' ,ord($_))} split //,$1"emg;
  0         0  
  0         0  
129 0         0 $string=~s/([\s\n\x0A]+)$/join '',map {sprintf('&#x%X;' ,ord($_))} split m##,$1/emg;
  0         0  
  0         0  
130 0         0 $string =~ s/([\s]+)/$self->whiteescape($1)/eg;
  0         0  
131 0         0 $string=~s/([\ ]{2,})/join '',map {sprintf('&#x%X;' ,ord($_))} split m##,$1/eg;
  0         0  
  0         0  
132 0         0 $string=~s/\n/"\n".$self->indent($level)/eg;
  0         0  
133             #$string=~s/\n/$self->indent($level)."\n"/eg;
134 0         0 return $string;
135             #return $self->indent($level).$string; #makes bad Juju with XSLT
136             }
137            
138             =head2 XMLescape(STRING,LEVEL)
139            
140             Returns the (quite badly) escaped form of STRING
141            
142             =cut
143            
144             sub XMLescape {
145 74     74 1 78 my $self=shift;
146 74         106 my $string=shift;
147 74         67 my $level=shift;
148 74         95 $string =~ s/\&/&/g;
149 74         83 $string =~ s/\
150 74         82 $string =~ s/\>/>/g;
151 74         109 $string =~ s/\"/"/g;
152 74         77 $string =~ s/\'/'/g;
153 74         182 $string=~s"^([\s\n\x0A]+)"join '',map {sprintf('&#x%X;' ,ord($_))} split //,$1"emg;
  20         55  
  24         135  
154 74         176 $string=~s/([\s\n\x0A]+)$/join '',map {sprintf('&#x%X;' ,ord($_))} split m##,$1/emg;
  16         40  
  20         86  
155 74         134 $string =~ s/([\s\n\x0A]+)/$self->whiteescape($1)/eg;
  52         106  
156             #$string=~s/\n/$self->indent($level)."\n"/eg;
157 74         271 return $string;
158             #return $self->indent($level).$string; #makes bad Juju with XSLT
159             }
160            
161             =head2 XMLunescape(STRING)
162            
163             Inversion of XMLescape
164            
165             =cut
166            
167             sub XMLunescape {
168 0     0 1 0 my $string=shift;
169 0         0 $string =~ s/^\s+//g;
170 0         0 $string =~ s/\s+$//g;
171 0         0 $string =~ s/\s*\n\s*/\n/g;
172 0         0 $string =~ s/[\s[^\n]]+/ /g;
173 0         0 $string =~ s/&#x([\dabcdefABCDEF]+);/chr(hex($1))/eg;
  0         0  
174 0         0 $string =~ s/&#([\dabcdefABCDEF]+);/chr($1)/eg;
  0         0  
175 0         0 $string =~ s/</
176 0         0 $string =~ s/>/>/g;
177 0         0 $string =~ s/"/"/g;
178 0         0 $string =~ s/'/'/g;
179 0         0 $string =~ s/&/&/g;
180 0         0 return $string;
181             }
182            
183             =head2 XMLunescapeRestrictive(STRING)
184            
185             Like XMLunescape, but more restrictive (currently not used)
186            
187             =cut
188            
189             sub XMLunescapeRestrictive {
190 0     0 1 0 my $string=shift;
191 0         0 $string =~ s/^\s+//g;
192 0         0 $string =~ s/\s+$//g;
193 0         0 $string =~ s/\s*\n\s*/ /g;
194 0         0 $string =~ s/[\s[^\n]]+/ /g;
195 0         0 $string =~ s/&#x([\dabcdefABCDEF]+);/chr(hex($1))/eg;
  0         0  
196 0         0 $string =~ s/&#([\dabcdefABCDEF]+);/chr($1)/eg;
  0         0  
197 0         0 $string =~ s/</
198 0         0 $string =~ s/>/>/g;
199 0         0 $string =~ s/"/"/g;
200 0         0 $string =~ s/'/'/g;
201 0         0 $string =~ s/&/&/g;
202 0         0 return $string;
203             }
204            
205             =head2 XMLKeyescape(KEY)
206            
207             Returns the (quite badly) escaped form of KEY
208            
209             =cut
210            
211            
212             sub XMLKeyescape {
213 36     36 1 45 my $self=shift;
214 36         44 my $string=shift;
215 36         55 $string =~ s/\&/&/g;
216 36         41 $string =~ s/\
217 36         40 $string =~ s/\>/>/g;
218 36         41 $string =~ s/\"/"/g;
219 36         42 $string =~ s/\'/'/g;
220 36         57 $string =~ s/([^[:print:]])/sprintf("&#x%X;",ord($1))/eg;
  0         0  
221 36         93 return $string;
222             }
223            
224             =head2 genID()
225            
226             Returns a new unqiue ID
227            
228             =cut
229            
230             sub genID {
231 136     136 1 137 my $self=shift;
232 136         286 return $self->{ID}++;
233             }
234            
235             =head2 indent(LEVEL)
236            
237             Returns the indentation for LEVEL
238            
239             =cut
240            
241             sub indent {
242 248     248 1 272 my $self=shift;
243 248         233 my $level = shift;
244 248         1321 return $self->{INDENT} x $level;
245             }
246            
247             =head2 packObjectComment(OBJECT)
248            
249             Returns the packed comment of OBJECT
250            
251             =cut
252            
253             sub packObjectComment {
254 68     68 1 96 my $self=shift;
255 68         71 my $data=shift;
256 68 100       185 if ($data->hasComment()) {
257 8         12 my $str = join("\n",@{$data->getComment()});
  8         37  
258 8         39 $str=~s/>/&gt;/g;
259 8         12 $str=~s/-->/-->/g;
260 8         44 return "" ;
261             }
262 60         307 return "";
263             }
264            
265             =head2 packComment(TREE)
266            
267             Returns the packed comment of the object reference by TREE
268            
269             =cut
270            
271             sub packComment {
272 68     68 1 74 my $self=shift;
273 68         70 my $tree=shift;
274 68 100       407 return "" unless $self->{COMMENT}->{$tree};
275 8 50       22 return "" unless ref $self->{COMMENT}->{$tree};
276 8 50       24 return "" unless ref $self->{COMMENT}->{$tree} eq "ARRAY";
277 8         8 my $str = join("\n",@{$self->{COMMENT}->{$tree}});
  8         24  
278 8         16 $str=~s/>/&gt;/g;
279 8         13 $str=~s/-->/-->/g;
280 8         37 return "" ;
281             }
282            
283             =head2 packElement(ELEMENT,OBJECT,LEVEL,ID)
284            
285             Returns the ELEMENT for OBJECT
286            
287             =cut
288            
289             sub packElement {
290 20     20 1 27 my $self=shift;
291 20         21 my $elem=shift;
292 20         21 my $data=shift;
293 20         16 my $level=shift;
294 20         22 my $id=shift;
295 20         36 return $self->indent($level)."<$elem id=\"$id\">".$self->packObjectComment($data);
296             }
297            
298             =head2 packElement2(ELEMENT,OBJECT,LEVEL,ID)
299            
300             Same as packElement, without comments.
301            
302             =cut
303            
304             sub packElement2 {
305 34     34 1 36 my $self=shift;
306 34         40 my $elem=shift;
307 34         33 my $data=shift;
308 34         38 my $level=shift;
309 34         33 my $id=shift;
310 34         76 return $self->indent($level)."<$elem id=\"$id\">";
311             }
312            
313             =head2 packItem(ELEMENT,LEVEL,ID,TREE)
314            
315             Returns the the XML version of an item
316            
317             =cut
318            
319             sub packItem {
320 20     20 1 24 my $self=shift;
321 20         25 my $elem=shift;
322 20         21 my $level=shift;
323 20         22 my $id=shift;
324 20         21 my $tree=shift;
325 20         55 return $self->indent($level)."<$elem id=\"$id\">".$self->packComment($tree)
326             }
327            
328             =head2 packItem2(ELEMENT,LEVEL,ID,TREE)
329            
330             Same as packItem, but doesn't write a comment.
331            
332             =cut
333            
334             sub packItem2 {
335 40     40 1 45 my $self=shift;
336 40         46 my $elem=shift;
337 40         34 my $level=shift;
338 40         41 my $id=shift;
339 40         39 my $tree=shift;
340 40         62 return $self->indent($level)."<$elem id=\"$id\">"
341             }
342            
343            
344             =head2 packObjectData(OBJECT,LEVEL)
345            
346             Converts one Data::Sofu::Object into its XML representation
347            
348             =cut
349            
350             sub packObjectData {
351 66     66 1 79 my $self=shift;
352 66         68 my $data=shift;
353 66         70 my $level=shift;
354 66         109 my $id = $self->genID();
355 66         113 my $r = ref $data;
356             #Maybe call packData on unknown Datastructures..... :)
357 66 50 33     629 die ("Unknown Datastructure, can only work with Arrays and Hashes but not $r") unless $r and $r =~ m/Data::Sofu/ and $r->isa("Data::Sofu::Object");
      33        
358            
359 66         77 my $odata=$data;
360 66 100 66     193 if ($data->isReference() and $data->valid()) {
361 10         29 $data=$data->follow();
362             }
363 66 50       146 if ($data->isReference()) { #Reference to a Reference not yet allowed!
364 0         0 croak("No Reference to a Reference allowed for now!");
365 0         0 return $self->indent($level)."\n".$self->packObjectComment($odata)."\n";
366             }
367 66 100       202 if ($self->{IDS}->{$data}) {
368 10         21 return $self->indent($level)."{IDS}->{$data}\" />".$self->packObjectComment($odata)."\n";
369             }
370 56         151 $self->{IDS}->{$data}=$id;
371 56         118 $self->{IDS}->{$odata}=$id;
372 56 100       166 if ($data->isValue()) {
373 36 100       90 return $self->packElement2("Value",$odata,$level,$id).$self->XMLescape($data->toString(),$level+1)."".$self->packObjectComment($odata)."\n" if $data->toString() ne "";
374 2         8 return $self->indent($level)."".$self->packObjectComment($odata)."\n";
375             }
376 20 100       66 if ($data->isMap()) {
377 6         22 my $str=$self->packElement("Map",$odata,$level,$id)."\n";
378 6         22 foreach my $key ($data->orderedKeys()) {
379 8         21 $str.=$self->indent($level+1)."XMLKeyescape($key)."\">\n";
380 8         27 $str.=$self->packObjectData($data->object($key),$level+2);
381 8         29 $str.=$self->indent($level+1)."\n";
382             }
383 6         19 return $str.$self->indent($level)."\n";
384             }
385 14 100       43 if ($data->isList()) {
386 12         29 my $str=$self->packElement("List",$odata,$level,$id)."\n";
387 12         41 while (my $element = $data->next()) {
388 48         143 $str.=$self->packObjectData($element,$level+1);
389             }
390 12         28 return $str.$self->indent($level)."\n"
391             }
392 2         9 return $self->indent($level)."\n".$self->packObjectComment($odata);
393             }
394            
395             =head2 packData(DATA,LEVEL,TREE)
396            
397             Converts one perl structure into its XML representation
398            
399             =cut
400            
401             sub packData {
402 66     66 1 84 my $self=shift;
403 66         80 my $data=shift;
404 66         63 my $level=shift;
405 66         68 my $tree=shift;
406 66         117 my $id = $self->genID();
407 66 100       133 if (ref $data) {
408 22 100       64 if ($self->{IDS}->{$data}) {
409 4         11 return $self->indent($level)."{IDS}->{$data}\" />".$self->packComment($tree)."\n";
410             }
411 18         52 $self->{IDS}->{$data}=$id;
412 18 100       50 if (ref $data eq "HASH") {
413 6         16 my $str=$self->packItem("Map",$level,$id,$tree)."\n";
414 6         11 foreach my $key (sort keys %{$data}) {
  6         33  
415 8         20 $str.=$self->indent($level+1)."XMLKeyescape($key)."\">\n";
416 8         34 $str.=$self->packData($data->{$key},$level+2,$tree."->".Data::Sofu::Sofukeyescape($key));
417 8         23 $str.=$self->indent($level+1)."\n";
418             }
419 6         16 return $str.$self->indent($level)."\n";
420             }
421 12 50       33 if (ref $data eq "ARRAY") {
422 12         27 my $str=$self->packItem("List",$level,$id,$tree)."\n";
423 12         21 my $i=0;
424 12         15 foreach my $element (@{$data}) {
  12         26  
425 48         184 $str.=$self->packData($element,$level+1,$tree."->".$i++);
426             }
427 12         28 return $str.$self->indent($level)."\n"
428             }
429             else {
430 0         0 confess "Can't pack: ",ref $data," @ $tree";
431             }
432             }
433 44 100       77 if (defined ($data)) {
434 42 100       132 return $self->packItem2("Value",$level,$id,$tree).$self->XMLescape($data,$level+1)."".$self->packComment($tree)."\n" if $data ne "";
435 2         6 return $self->indent($level)."".$self->packComment($tree)."\n";
436             }
437 2         7 return $self->indent($level)."\n".$self->packComment($tree);
438             }
439            
440            
441             =head2 packObject(OBJECT,[HEADER])
442            
443             Converts one Data::Sofu::Object into its XML representation
444            
445             =cut
446            
447             sub packObject {
448 2     2 1 4 my $self=shift;
449 2         5 my $data=shift;
450 2         5 my $r = ref $data;
451 2         4 my $header=shift;
452 2   50     16 my $level=int(shift || 0);
453 2 50       6 $level=0 unless $level;
454             #Maybe call packData on unknown Datastructures..... :)
455 2 50 33     32 die ("Unknown Datastructure, can only work with Data::Sofu::Object's but not $r, did you mean pack() ?") unless $r and $r =~ m/Data::Sofu/ and $r->isa("Data::Sofu::Object");
      33        
456 2 50       12 unless ($data->isMap()) {
457 0         0 my $m = new Data::Sofu::Map();
458 0         0 $m->setAttribute("Value",$data);
459 0         0 $data=$m;
460             }
461 2         6 $self->{IDS} = {};
462 2         22 $self->{ID} = 1;
463 2         7 my $id = $self->genID();
464 2         90 $self->{IDS}->{$data}=$id;
465 2         6 my $str="";
466 2 50       10 $str.=qq(\n\n) unless ($header);
467 2 50       8 $str.=$header if $header;
468 2         9 $str.=$self->packElement("Sofu",$data,$level,$id)."\n";
469 2         12 foreach my $key ($data->orderedKeys()) {
470 10         26 $str.=$self->indent($level+1)."XMLKeyescape($key)."\">\n";
471 10         43 $str.=$self->packObjectData($data->object($key),$level+2);
472 10         34 $str.=$self->indent($level+1)."\n";
473             }
474 2         11 return $str.$self->indent($level)."\n";
475             }
476            
477             =head2 pack(TREE,[COMMENTS,[HEADER]])
478            
479             packs TREE to XML using Comments
480            
481             =over
482            
483             =item TREE
484            
485             Perl datastructure to pack. Can be a hash, array or scalar (or array of hashes of hashes of arrays or whatever). Anything NOT a hash will be converted to TREE={Value=>TREE};
486            
487             It can also be a Data::Sofu::Object or derived (Data::Sofu::Map, Data::Sofu::List, Data::Sofu::Value, Data::Sofu::...).
488             Anything not a Data::Sofu::Map will be converted to one (A Map with one attribute called "Value" that holds TREE).
489            
490             =item COMMENTS
491            
492             Comment hash (as returned by Data::Sofu::getSofucomments() or Data::Sofu->new()->comments() after any file was read).
493            
494             These are ignored if TREE is a Data::Sofu::Object or derived. Data::Sofu::Object's store their comments in themselves. See Data::Sofu::Object->importComments() to import them.
495            
496             Can be undef or {}.
497            
498             =back
499            
500             =cut
501            
502             sub pack {
503 4     4 1 11 my $self=shift;
504 4         9 my $data=shift;
505 4         11 my $r = ref $data;
506 4         10 my $comments=shift;
507 4 100       16 $comments = {} unless defined $comments;
508 4 100 66     76 return $self->packObject($data,@_) if $r and $r =~ m/Data::Sofu::/ and $data->isa("Data::Sofu::Object");
      66        
509 2         3 my $header=shift;
510 2 50 33     18 $data = {Value=>$data} unless ref $data and ref $data eq "HASH";
511 2 50 33     21 $data = {Value=>$data} unless ref $data and ref $data eq "HASH";
512             #$self->die("Data format wrong, must be hashref") unless (ref $data and ref $data eq "HASH");
513 2   50     14 my $level=int(shift || 0);
514 2         6 $self->{COMMENT}=$comments;
515 2 50       6 $level=0 unless $level;
516 2         7 $self->{IDS} = {};
517 2         9 $self->{ID} = 1;
518 2         9 my $id = $self->genID();
519 2         7 $self->{IDS}->{$data}=$id;
520 2         5 my $str="";
521 2 50       7 $str.=qq(\n\n) unless ($header);
522 2 50       10 $str.=$header if $header;
523 2         10 $str.=$self->packItem("Sofu",$level,$id,"=")."\n";
524 2         4 foreach my $key (keys %{$data}) {
  2         11  
525 10         27 $str.=$self->indent($level+1)."XMLKeyescape($key)."\">\n";
526 10         40 $str.=$self->packData($data->{$key},$level+2,"->".Data::Sofu::Sofukeyescape($key));
527 10         29 $str.=$self->indent($level+1)."\n";
528             }
529 2         8 return $str.$self->indent($level)."\n";
530            
531             }
532            
533             my @tree = ();
534             my @ids =();
535             my $tree =();
536             my @ref = ();
537             my %id = ();
538             my $ret = "";
539             my @keys = ();
540             my %com = ();
541             my $end=0;
542            
543             =head2 read(STRING)
544            
545             Unpacks a SofuML string to perl datastructures
546            
547             Don't use this, use readSofu("file.xml") instead.
548            
549             =cut
550            
551             sub read {
552 0     0 1   my $self=shift;
553 0           my $data=shift;
554 0           eval {
555 0           local $^W = 0;
556 0           require XML::Parser;
557             };
558 0           @tree = ();
559 0           @ids =();
560 0           $tree =();
561 0           @ref = ();
562 0           %id = ();
563 0           $ret = "";
564 0           @keys = ();
565 0           %com = ();
566 0 0         confess "You will need XML::Parser for reading SofuML files" if ($@);
567             #my $parser =XML::Parser->new(Style=>"Tree");
568             #my $tree=$parser->parse($data);
569             #use Data::Dumper;
570             #print Data::Dumper->Dump([$tree]);
571 0           my $parser =XML::Parser->new(Handlers=>{Start => \&tag_start,End => \&tag_end,Char => \&characters, Comment=>\&comment});
572 0           $parser->parse($data);
573 0           foreach my $e (@ref) {
574 0           my $target = $$$e;
575 0           $$e = undef;
576 0 0         $$e = $id{$target} if $id{$target};
577             }
578             #print Data::Dumper->Dump([\@tree,$ret,\%com,\@ref,\%id,\%com],[qw/@tree $ret %com @ref %id %com/]);
579 0 0         return ($ret,{%com}) if wantarray;
580 0           return $ret;
581             }
582            
583             =head2 load(STRING)
584            
585             Unpacks SofuML string to Data::Sofu::Object's from STRING
586            
587             Don't use this, use readSofu("file.xml") instead.
588            
589             =cut
590            
591             sub load {
592 0     0 1   my $self=shift;
593 0           my $data=shift;
594 0           eval {
595 0           local $^W = 0;
596 0           require XML::Parser;
597             };
598 0           @tree = ();
599 0           @ids =();
600 0           $tree =();
601 0           @ref = ();
602 0           %id = ();
603 0           $ret = "";
604 0           @keys = ();
605 0           %com = ();
606 0 0         confess "You will need XML::Parser for reading SofuML files" if ($@);
607 0           require Data::Sofu::Object;
608             #my $parser =XML::Parser->new(Style=>"Tree");
609             #my $tree=$parser->parse($data);
610             #use Data::Dumper;
611             #print Data::Dumper->Dump([$tree]);
612 0           my $parser =XML::Parser->new(Handlers=>{Start => \&otag_start,End => \&otag_end,Char => \&ocharacters, Comment=>\&ocomment});
613 0           $parser->parse($data);
614 0           foreach my $e (@ref) {
615 0           my $target = $e->follow();
616 0 0         $e->dangle($id{$target}) if $id{$target};
617             }
618             #print Data::Dumper->Dump([\@tree,$ret,\%com,\@ref,\%id],[qw/@tree $ret %com @ref %id/]);
619 0           return $ret;
620             }
621            
622             ## XML Parser Handlers
623            
624             =head2 tag_start
625            
626             Handler for L
627            
628             =cut
629            
630             sub tag_start {
631 0     0 1   my $xp=shift;
632 0           my $tag=lc(shift);
633 0           my $key="";
634 0           my $id = -1;
635 0           my $idref="";
636 0           $end=0;
637 0           while (@_) {
638 0           my $k=lc shift;
639 0           my $v=shift;
640 0 0         $id = $v if $k eq "id";
641 0 0         $idref = $v if $k eq "idref";
642 0 0         $key = $v if $k eq "key";
643             }
644 0 0         if ($tag eq "value") {
    0          
    0          
    0          
    0          
    0          
    0          
645 0           push @tree,"";
646 0           push @ids,$id;
647             }
648             elsif ($tag eq "undefined") {
649 0           push @tree,undef;
650 0           push @ids,$id;
651             }
652             elsif ($tag eq "reference") {
653 0           push @tree,\$idref;
654 0           push @ids,-1;
655             }
656             elsif ($tag eq "sofu") {
657 0           push @tree,{};
658 0           push @ids,$id;
659             }
660             elsif ($tag eq "map") {
661 0           push @tree,{};
662 0           push @ids,$id;
663             }
664             elsif ($tag eq "list") {
665 0           push @tree,[];
666 0           push @ids,$id;
667 0           push @keys,0;
668             }
669             elsif ($tag eq "element") {
670 0           push @keys,$key;
671             }
672             else {
673 0           die "Unknown Tag $tag";
674             }
675            
676             #print Data::Dumper->Dump([\@tree,$ret,\%com,\@ref,$tag,$key],[qw/@tree $ret %com @ref $tag $key/]);<>;
677             }
678            
679             =head2 characters
680            
681             Handler for L
682            
683             =cut
684            
685             sub characters {
686 0     0 1   my $xp=shift;
687 0           my $data=$xp->recognized_string;
688 0 0 0       $tree[-1].= $data unless ref $tree[-1] or not defined $tree[-1]; #Ignore chars in everything but a Value
689             #print Data::Dumper->Dump([\@tree,$ret,\%com,\@ref,$data],[qw/@tree $ret %com @ref $data/]);<>;
690             }
691            
692             =head2 comment
693            
694             Handler for L
695            
696             =cut
697            
698             sub comment {
699 0     0 1   my $xp=shift;
700 0           my $data=shift;
701 0           $data=~s/^ //g;
702 0           $data=~s/ $//g;
703 0 0         $keys[-1]-- if ($end);
704 0           my $tree=join("->",map{Data::Sofu::Sofukeyescape($_)} @keys);
  0            
705 0 0         $tree="->".$tree if $tree;
706 0 0         $tree="=" unless $tree;
707 0           push @{$com{$tree}},split /\n/,$data;
  0            
708 0 0         $keys[-1]++ if ($end);
709             }
710            
711             =head2 tag_end
712            
713             Handler for L
714            
715             =cut
716            
717             sub tag_end {
718 0     0 1   my $xp=shift;
719 0           my $tag=lc(shift);
720             #print Data::Dumper->Dump([\@tree,$ret,\%com,\@ref,$tag],[qw/@tree $ret %com @ref $tag/]);<>;
721 0 0         if ($tag eq "element") {
722 0           my $key = pop @keys;
723 0           $tree[-1]->{$key}=$ret;
724 0 0 0       if (ref $ret and ref $ret eq "SCALAR") {
725 0           push @ref,\$tree[-1]->{$key};
726             }
727 0           return;
728             }
729 0           $ret=pop @tree;
730 0 0 0       $ret = XMLunescape($ret) unless ref $ret or not defined $ret;
731 0 0         pop @keys if ($tag eq "list");
732 0           $id{pop @ids}=$ret;
733 0 0 0       if ($tree[-1] and ref $tree[-1] and ref $tree[-1] eq "ARRAY") {
      0        
734 0           push @{$tree[-1]}, $ret;
  0            
735 0 0 0       if (ref $ret and ref $ret eq "SCALAR") {
736 0           push @ref,\$tree[-1]->[-1];
737             }
738 0           $end = -1;
739 0           $keys[-1]++;
740             }
741             }
742            
743             my $elem = 0;
744            
745             =head2 otag_start
746            
747             Handler for L, object mode
748            
749             =cut
750            
751             sub otag_start {
752 0     0 1   my $xp=shift;
753 0           my $tag=lc(shift);
754 0           my $key="";
755 0           my $id = -1;
756 0           my $idref="";
757 0           $end=0;
758 0           while (@_) {
759 0           my $k=lc shift;
760 0           my $v=shift;
761 0 0         $id = $v if $k eq "id";
762 0 0         $idref = $v if $k eq "idref";
763 0 0         $key = $v if $k eq "key";
764             }
765 0 0         if ($tag eq "value") {
    0          
    0          
    0          
    0          
    0          
    0          
766 0           push @tree,Data::Sofu::Value->new("");
767 0           push @ids,$id;
768             }
769             elsif ($tag eq "undefined") {
770 0           push @tree,Data::Sofu::Undefined->new();
771 0           push @ids,$id;
772             }
773             elsif ($tag eq "reference") {
774 0           my $r=Data::Sofu::Reference->new($idref);
775 0           push @tree,$r;
776 0           push @ref,$r;
777 0           push @ids,-1;
778             }
779             elsif ($tag eq "sofu") {
780 0           $elem=0;
781 0           push @tree,Data::Sofu::Map->new();
782 0           push @ids,$id;
783             }
784             elsif ($tag eq "map") {
785 0           $elem=0;
786 0           push @tree,Data::Sofu::Map->new();
787 0           push @ids,$id;
788             }
789             elsif ($tag eq "list") {
790 0           push @tree,Data::Sofu::List->new();
791 0           push @ids,$id;
792 0           push @keys,0;
793             }
794             elsif ($tag eq "element") {
795 0           push @keys,$key;
796 0           $elem=1;
797             }
798             else {
799 0           die "Unknown Tag $tag";
800             }
801             #print Data::Dumper->Dump([\@tree,$ret,\%com,\@ref,$tag,$key],[qw/@tree $ret %com @ref $tag $key/]);<>;
802             }
803            
804             =head2 ocharacters
805            
806             Handler for L, object mode
807            
808             =cut
809            
810             sub ocharacters {
811 0     0 1   my $xp=shift;
812 0           my $data=$xp->recognized_string;
813 0 0 0       $tree[-1]->set($tree[-1]->toString().$data) if $tree[-1] and $tree[-1]->isValue(); #Ignore chars in everything but a Value
814             #print Data::Dumper->Dump([\@tree,$ret,\%com,\@ref,$data],[qw/@tree $ret %com @ref $data/]);<>;
815             }
816            
817             =head2 ocomment
818            
819             Handler for L, object mode
820            
821             =cut
822            
823             sub ocomment {
824 0     0 1   my $xp=shift;
825 0           my $data=shift;
826 0           $data=~s/^ //g;
827 0           $data=~s/ $//g;
828 0 0 0       if ($end or $elem) {
829 0 0         $ret->appendComment([split /\n/,$data]) if $ret;
830             }
831             else {
832 0 0         $tree[-1]->appendComment([split /\n/,$data]) if $tree[-1];
833             }
834             }
835            
836             =head2 otag_end
837            
838             Handler for L, object mode
839            
840             =cut
841            
842             sub otag_end {
843 0     0 1   my $xp=shift;
844 0           my $tag=lc(shift);
845 0           $end=0;
846             #print Data::Dumper->Dump([\@tree,$ret,\%com,\@ref,$tag],[qw/@tree $ret %com @ref $tag/]);<>;
847 0 0         if ($tag eq "element") {
848 0           my $key = pop @keys;
849 0           $tree[-1]->setAttribute($key,$ret);
850 0           $elem=0;
851 0           return;
852             }
853 0           $ret=pop @tree;
854 0 0         $ret->set(XMLunescape($ret->toString())) if $ret->isValue();
855 0 0         pop @keys if ($tag eq "list");
856 0           $id{pop @ids}=$ret;
857 0 0 0       if ($tree[-1] and $tree[-1]->isList()) {
858 0           $tree[-1]->appendElement($ret);
859 0           $keys[-1]++;
860 0           $end=-1;
861             }
862             }
863            
864            
865            
866             #sub convert { ##Forget it, no comments returned!!!
867             # my $self=shift;
868             # my $tree=shift;
869             # if ($tree[0] eq "Sofu" or $tree[0] eq "Map") {#Don't care if or descripes a Map
870             # my $res = {};
871             # $self->{IDS}->{$tree[1]->{id})}=$res if ($tree[1] and $tree[1]->{id});
872             # while (@{$tree}) {
873             # my $key = shift @{$tree};
874             # my $value = shift @{$tree};
875             # if (lc $key eq "element") {
876             #
877             # }
878             # }
879             # }
880             #
881             #}
882            
883             =head1 BUGS
884            
885             Reading SofuML files need XML::Parser.
886            
887             The Old escaping mechanism didn't escape newlines in Values (at least not the ones in the middle)
888            
889             The new mechanism escapes them all.
890            
891             This Module can read both, but if you encounter NewLines in your Source file that don't belong there it might give you an additional newline you didn't want.
892            
893             =head1 See Also
894            
895             L, L, L
896            
897             =cut
898            
899             1;