← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 01.HTTP.t
  Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:20 2010

File /usr/local/lib/perl5/site_perl/5.10.1/darwin-2level/XML/Bare.pm
Statements Executed 102
Statement Execution Time 4.54ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
112557µs557µsXML::Bare::::bootstrapXML::Bare::bootstrap (xsub)
111242µs245µsXML::Bare::::BEGIN@6XML::Bare::BEGIN@6
111187µs190µsXML::Bare::::BEGIN@524XML::Bare::BEGIN@524
311113µs424µsXML::Bare::::xmlinXML::Bare::xmlin
31171µs185µsXML::Bare::::simpleXML::Bare::simple
31266µs66µsXML::Bare::::xml2obj_simpleXML::Bare::xml2obj_simple (xsub)
31158µs112µsXML::Bare::::newXML::Bare::new
31253µs53µsXML::Bare::::c_parseXML::Bare::c_parse (xsub)
31126µs41µsXML::Bare::::free_treeXML::Bare::free_tree
11116µs51µsXML::Bare::::BEGIN@3XML::Bare::BEGIN@3
31116µs16µsXML::Bare::::DESTROYXML::Bare::DESTROY
31214µs14µsXML::Bare::::free_tree_cXML::Bare::free_tree_c (xsub)
1118µs38µsXML::Bare::::BEGIN@15XML::Bare::BEGIN@15
1118µs10µsXML::Bare::::BEGIN@4XML::Bare::BEGIN@4
3127µs7µsXML::Bare::::get_rootXML::Bare::get_root (xsub)
1115µs52µsXML::Bare::::BEGIN@5XML::Bare::BEGIN@5
0000s0sXML::Bare::::add_nodeXML::Bare::add_node
0000s0sXML::Bare::::add_node_afterXML::Bare::add_node_after
0000s0sXML::Bare::::checkXML::Bare::check
0000s0sXML::Bare::::checkoneXML::Bare::checkone
0000s0sXML::Bare::::cleanXML::Bare::clean
0000s0sXML::Bare::::del_by_perlXML::Bare::del_by_perl
0000s0sXML::Bare::::del_nodeXML::Bare::del_node
0000s0sXML::Bare::::find_by_perlXML::Bare::find_by_perl
0000s0sXML::Bare::::find_nodeXML::Bare::find_node
0000s0sXML::Bare::::forcearrayXML::Bare::forcearray
0000s0sXML::Bare::::htmlXML::Bare::html
0000s0sXML::Bare::::lineinfoXML::Bare::lineinfo
0000s0sXML::Bare::::mergeXML::Bare::merge
0000s0sXML::Bare::::new_nodeXML::Bare::new_node
0000s0sXML::Bare::::newhashXML::Bare::newhash
0000s0sXML::Bare::::obj2htmlXML::Bare::obj2html
0000s0sXML::Bare::::obj2xmlXML::Bare::obj2xml
0000s0sXML::Bare::::parseXML::Bare::parse
0000s0sXML::Bare::::readxbsXML::Bare::readxbs
0000s0sXML::Bare::::saveXML::Bare::save
0000s0sXML::Bare::::simplifyXML::Bare::simplify
0000s0sXML::Bare::::tohtmlXML::Bare::tohtml
0000s0sXML::Bare::::xgetXML::Bare::xget
0000s0sXML::Bare::::xmlXML::Bare::xml
0000s0sXML::Bare::::xvalXML::Bare::xval
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package XML::Bare;
2
3331µs286µs
# spent 51µs (16+35) within XML::Bare::BEGIN@3 which was called # once (16µs+35µs) by SimpleDB::Client::BEGIN@48 at line 3
use Carp;
# spent 51µs making 1 call to XML::Bare::BEGIN@3 # spent 35µs making 1 call to Exporter::import
4321µs212µs
# spent 10µs (8+2) within XML::Bare::BEGIN@4 which was called # once (8µs+2µs) by SimpleDB::Client::BEGIN@48 at line 4
use strict;
# spent 10µs making 1 call to XML::Bare::BEGIN@4 # spent 2µs making 1 call to strict::import
5321µs299µs
# spent 52µs (5+47) within XML::Bare::BEGIN@5 which was called # once (5µs+47µs) by SimpleDB::Client::BEGIN@48 at line 5
use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
# spent 52µs making 1 call to XML::Bare::BEGIN@5 # spent 47µs making 1 call to vars::import
63279µs2248µs
# spent 245µs (242+3) within XML::Bare::BEGIN@6 which was called # once (242µs+3µs) by SimpleDB::Client::BEGIN@48 at line 6
use utf8;
# spent 245µs making 1 call to XML::Bare::BEGIN@6 # spent 3µs making 1 call to utf8::import
71800nsrequire Exporter;
81800nsrequire DynaLoader;
9113µs@ISA = qw(Exporter DynaLoader);
10
11
121300ns$VERSION = "0.45";
13
14
1532.17ms268µs
# spent 38µs (8+30) within XML::Bare::BEGIN@15 which was called # once (8µs+30µs) by SimpleDB::Client::BEGIN@48 at line 15
use vars qw($VERSION *AUTOLOAD);
# spent 38µs making 1 call to XML::Bare::BEGIN@15 # spent 30µs making 1 call to vars::import
16
1714µs*AUTOLOAD = \&XML::Bare::AUTOLOAD;
1815µs120.3msbootstrap XML::Bare $VERSION;
# spent 20.3ms making 1 call to DynaLoader::bootstrap
19
20
21
2211µs@EXPORT = qw( );
2315µs@EXPORT_OK = qw( xget merge clean add_node del_node find_node del_node forcearray del_by_perl xmlin xval );
24
25=head1 NAME
26
27XML::Bare - Minimal XML parser implemented via a C state engine
28
29=head1 VERSION
30
310.45
32
33=cut
34
35
# spent 112µs (58+53) within XML::Bare::new which was called 3 times, avg 37µs/call: # 3 times (58µs+53µs) by XML::Bare::xmlin at line 125, avg 37µs/call
sub new {
3632µs my $class = shift;
37310µs my $self = { @_ };
38
39376µs353µs if( $self->{ 'text' } ) {
# spent 53µs making 3 calls to XML::Bare::c_parse, avg 18µs/call
40 XML::Bare::c_parse( $self->{'text'} );
41 }
42 else {
43 my $res = open( XML, $self->{ 'file' } );
44 if( !$res ) {
45 $self->{ 'xml' } = 0;
46 return 0;
47 }
48 {
49 local $/ = undef;
50 $self->{'text'} = <XML>;
51 }
52 close( XML );
53 XML::Bare::c_parse( $self->{'text'} );
54 }
55312µs bless $self, $class;
56316µs return $self if( !wantarray );
57 return ( $self, $self->parse() );
58}
59
60
# spent 16µs within XML::Bare::DESTROY which was called 3 times, avg 5µs/call: # 3 times (16µs+0s) by XML::Bare::xmlin at line 245 of ../lib/SimpleDB/Client.pm, avg 5µs/call
sub DESTROY {
6132µs my $self = shift;
62315µs undef $self->{'xml'};
63}
64
65sub xget {
66 my $hash = shift;
67 return map $_->{'value'}, @{%$hash}{@_};
68}
69
70sub forcearray {
71 my $ref = shift;
72 return [] if( !$ref );
73 return $ref if( ref( $ref ) eq 'ARRAY' );
74 return [ $ref ];
75}
76
77sub merge {
78 # shift in the two array references as well as the field to merge on
79 my ( $a, $b, $id ) = @_;
80 my %hash = map { $_->{ $id } ? ( $_->{ $id }->{ 'value' } => $_ ) : ( 0 => 0 ) } @$a;
81 for my $one ( @$b ) {
82 next if( !$one->{ $id } );
83 my $short = $hash{ $one->{ $id }->{ 'value' } };
84 next if( !$short );
85 foreach my $key ( keys %$one ) {
86 next if( $key eq '_pos' || $key eq 'id' );
87 my $cur = $short->{ $key };
88 my $add = $one->{ $key };
89 if( !$cur ) { $short->{ $key } = $add; }
90 else {
91 my $type = ref( $cur );
92 if( $type eq 'HASH' ) {
93 my @arr;
94 $short->{ $key } = \@arr;
95 push( @arr, $cur );
96 }
97 if( ref( $add ) eq 'HASH' ) {
98 push( @{$short->{ $key }}, $add );
99 }
100 else { # we are merging an array
101 push( @{$short->{ $key }}, @$add );
102 }
103 }
104 # we need to deal with the case where this node
105 # is already there, either alone or as an array
106 }
107 }
108 return $a;
109}
110
111sub clean {
112 my $ob = new XML::Bare( @_ );
113 my $root = $ob->parse();
114 if( $ob->{'save'} ) {
115 $ob->{'file'} = $ob->{'save'} if( "$ob->{'save'}" ne "1" );
116 $ob->save();
117 return;
118 }
119 return $ob->xml( $root );
120}
121
122
# spent 424µs (113+312) within XML::Bare::xmlin which was called 3 times, avg 142µs/call: # 3 times (113µs+312µs) by SimpleDB::Client::handle_response at line 245 of ../lib/SimpleDB/Client.pm, avg 142µs/call
sub xmlin {
12333µs my $text = shift;
12434µs my %ops = ( @_ );
125319µs3112µs my $ob = new XML::Bare( text => $text );
# spent 112µs making 3 calls to XML::Bare::new, avg 37µs/call
126314µs3185µs my $simple = $ob->simple();
# spent 185µs making 3 calls to XML::Bare::simple, avg 62µs/call
12733µs if( !$ops{'keeproot'} ) {
128312µs my @keys = keys %$simple;
12932µs my $first = $keys[0];
13035µs $simple = $simple->{ $first } if( $first );
131 }
132320µs return $simple;
133}
134
135sub tohtml {
136 my %ops = ( @_ );
137 my $ob = new XML::Bare( %ops );
138 return $ob->html( $ob->parse(), $ops{'root'} || 'xml' );
139}
140
141# Load a file using XML::DOM, convert it to a hash, and return the hash
142sub parse {
143 my $self = shift;
144
145 my $res = XML::Bare::xml2obj();
146 $self->{'structroot'} = XML::Bare::get_root();
147 $self->free_tree();
148
149 if( defined( $self->{'scheme'} ) ) {
150 $self->{'xbs'} = new XML::Bare( %{ $self->{'scheme'} } );
151 }
152 if( defined( $self->{'xbs'} ) ) {
153 my $xbs = $self->{'xbs'};
154 my $ob = $xbs->parse();
155 $self->{'xbso'} = $ob;
156 readxbs( $ob );
157 }
158
159 if( $res < 0 ) { croak "Error at ".$self->lineinfo( -$res ); }
160 $self->{ 'xml' } = $res;
161
162 if( defined( $self->{'xbso'} ) ) {
163 my $ob = $self->{'xbso'};
164 my $cres = $self->check( $res, $ob );
165 croak( $cres ) if( $cres );
166 }
167
168 return $self->{ 'xml' };
169}
170
171sub lineinfo {
172 my $self = shift;
173 my $res = shift;
174 my $line = 1;
175 my $j = 0;
176 for( my $i=0;$i<$res;$i++ ) {
177 my $let = substr( $self->{'text'}, $i, 1 );
178 if( ord($let) == 10 ) {
179 $line++;
180 $j = $i;
181 }
182 }
183 my $part = substr( $self->{'text'}, $res, 10 );
184 $part =~ s/\n//g;
185 $res -= $j;
186 if( $self->{'offset'} ) {
187 my $off = $self->{'offset'};
188 $line += $off;
189 return "$off line $line char $res \"$part\"";
190 }
191 return "line $line char $res \"$part\"";
192}
193
194# xml bare schema
195sub check {
196 my ( $self, $node, $scheme, $parent ) = @_;
197
198 my $fail = '';
199 if( ref( $scheme ) eq 'ARRAY' ) {
200 for my $one ( @$scheme ) {
201 my $res = $self->checkone( $node, $one, $parent );
202 return 0 if( !$res );
203 $fail .= "$res\n";
204 }
205 }
206 else { return $self->checkone( $node, $scheme, $parent ); }
207 return $fail;
208}
209
210sub checkone {
211 my ( $self, $node, $scheme, $parent ) = @_;
212
213 for my $key ( keys %$node ) {
214 next if( substr( $key, 0, 1 ) eq '_' || $key eq '_att' || $key eq 'comment' );
215 if( $key eq 'value' ) {
216 my $val = $node->{ 'value' };
217 my $regexp = $scheme->{'value'};
218 if( $regexp ) {
219 if( $val !~ m/^($regexp)$/ ) {
220 my $linfo = $self->lineinfo( $node->{'_i'} );
221 return "Value of '$parent' node ($val) does not match /$regexp/ [$linfo]";
222 }
223 }
224 next;
225 }
226 my $sub = $node->{ $key };
227 my $ssub = $scheme->{ $key };
228 if( !$ssub ) { #&& ref( $schemesub ) ne 'HASH'
229 my $linfo = $self->lineinfo( $sub->{'_i'} );
230 return "Invalid node '$key' in xml [$linfo]";
231 }
232 if( ref( $sub ) eq 'HASH' ) {
233 my $res = $self->check( $sub, $ssub, $key );
234 return $res if( $res );
235 }
236 if( ref( $sub ) eq 'ARRAY' ) {
237 my $asub = $ssub;
238 if( ref( $asub ) eq 'ARRAY' ) {
239 $asub = $asub->[0];
240 }
241 if( $asub->{'_t'} ) {
242 my $max = $asub->{'_max'} || 0;
243 if( $#$sub >= $max ) {
244 my $linfo = $self->lineinfo( $sub->[0]->{'_i'} );
245 return "Too many nodes of type '$key'; max $max; [$linfo]"
246 }
247 my $min = $asub->{'_min'} || 0;
248 if( ($#$sub+1)<$min ) {
249 my $linfo = $self->lineinfo( $sub->[0]->{'_i'} );
250 return "Not enough nodes of type '$key'; min $min [$linfo]"
251 }
252 }
253 for( @$sub ) {
254 my $res = $self->check( $_, $ssub, $key );
255 return $res if( $res );
256 }
257 }
258 }
259 if( my $dem = $scheme->{'_demand'} ) {
260 for my $req ( @{$scheme->{'_demand'}} ) {
261 my $ck = $node->{ $req };
262 if( !$ck ) {
263 my $linfo = $self->lineinfo( $node->{'_i'} );
264 return "Required node '$req' does not exist [$linfo]"
265 }
266 if( ref( $ck ) eq 'ARRAY' ) {
267 my $linfo = $self->lineinfo( $node->{'_i'} );
268 return "Required node '$req' is empty array [$linfo]" if( $#$ck == -1 );
269 }
270 }
271 }
272 return 0;
273}
274
275
276sub readxbs { # xbs = xml bare schema
277 my $node = shift;
278 my @demand;
279 for my $key ( keys %$node ) {
280 next if( substr( $key, 0, 1 ) eq '_' || $key eq '_att' || $key eq 'comment' );
281 if( $key eq 'value' ) {
282 my $val = $node->{'value'};
283 delete $node->{'value'} if( $val =~ m/^\W*$/ );
284 next;
285 }
286 my $sub = $node->{ $key };
287
288 if( $key =~ m/([a-z_]+)([^a-z_]+)/ ) {
289 my $name = $1;
290 my $t = $2;
291 my $min;
292 my $max;
293 if( $t eq '+' ) {
294 $min = 1;
295 $max = 1000;
296 }
297 elsif( $t eq '*' ) {
298 $min = 0;
299 $max = 1000;
300 }
301 elsif( $t eq '?' ) {
302 $min = 0;
303 $max = 1;
304 }
305 elsif( $t eq '@' ) {
306 $name = 'multi_'.$name;
307 $min = 1;
308 $max = 1;
309 }
310 elsif( $t =~ m/\{([0-9]+),([0-9]+)\}/ ) {
311 $min = $1;
312 $max = $2;
313 $t = 'r'; # range
314 }
315
316 if( ref( $sub ) eq 'HASH' ) {
317 my $res = readxbs( $sub );
318 $sub->{'_t'} = $t;
319 $sub->{'_min'} = $min;
320 $sub->{'_max'} = $max;
321 }
322 if( ref( $sub ) eq 'ARRAY' ) {
323 for my $item ( @$sub ) {
324 my $res = readxbs( $item );
325 $item->{'_t'} = $t;
326 $item->{'_min'} = $min;
327 $item->{'_max'} = $max;
328 }
329 }
330
331 push( @demand, $name ) if( $min );
332 $node->{$name} = $node->{$key};
333 delete $node->{$key};
334 }
335 else {
336 if( ref( $sub ) eq 'HASH' ) {
337 readxbs( $sub );
338 $sub->{'_t'} = 'r';
339 $sub->{'_min'} = 1;
340 $sub->{'_max'} = 1;
341 }
342 if( ref( $sub ) eq 'ARRAY' ) {
343 for my $item ( @$sub ) {
344 readxbs( $item );
345 $item->{'_t'} = 'r';
346 $item->{'_min'} = 1;
347 $item->{'_max'} = 1;
348 }
349 }
350
351 push( @demand, $key );
352 }
353 }
354 if( @demand ) { $node->{'_demand'} = \@demand; }
355}
356
357
# spent 185µs (71+114) within XML::Bare::simple which was called 3 times, avg 62µs/call: # 3 times (71µs+114µs) by XML::Bare::xmlin at line 126, avg 62µs/call
sub simple {
35832µs my $self = shift;
359
360384µs366µs my $res = XML::Bare::xml2obj_simple();#$self->xml2obj();
# spent 66µs making 3 calls to XML::Bare::xml2obj_simple, avg 22µs/call
361324µs37µs $self->{'structroot'} = XML::Bare::get_root();
# spent 7µs making 3 calls to XML::Bare::get_root, avg 2µs/call
362310µs341µs $self->free_tree();
# spent 41µs making 3 calls to XML::Bare::free_tree, avg 14µs/call
363
36433µs if( $res < 0 ) { croak "Error at ".$self->lineinfo( -$res ); }
36535µs $self->{ 'xml' } = $res;
366
367314µs return $self->{ 'xml' };
368}
369
370sub add_node {
371 my ( $self, $node, $name ) = @_;
372 my @newar;
373 my %blank;
374 $node->{ 'multi_'.$name } = \%blank if( ! $node->{ 'multi_'.$name } );
375 $node->{ $name } = \@newar if( ! $node->{ $name } );
376 my $newnode = new_node( 0, splice( @_, 3 ) );
377 push( @{ $node->{ $name } }, $newnode );
378 return $newnode;
379}
380
381sub add_node_after {
382 my ( $self, $node, $prev, $name ) = @_;
383 my @newar;
384 my %blank;
385 $node->{ 'multi_'.$name } = \%blank if( ! $node->{ 'multi_'.$name } );
386 $node->{ $name } = \@newar if( ! $node->{ $name } );
387 my $newnode = $self->new_node( splice( @_, 4 ) );
388
389 my $cur = 0;
390 for my $anode ( @{ $node->{ $name } } ) {
391 $anode->{'_pos'} = $cur if( !$anode->{'_pos'} );
392 $cur++;
393 }
394 my $opos = $prev->{'_pos'};
395 for my $anode ( @{ $node->{ $name } } ) {
396 $anode->{'_pos'}++ if( $anode->{'_pos'} > $opos );
397 }
398 $newnode->{'_pos'} = $opos + 1;
399
400 push( @{ $node->{ $name } }, $newnode );
401
402 return $newnode;
403}
404
405sub find_by_perl {
406 my $arr = shift;
407 my $cond = shift;
408 $cond =~ s/-([a-z]+)/\$ob->\{'$1'\}->\{'value'\}/g;
409 my @res;
410 foreach my $ob ( @$arr ) { push( @res, $ob ) if( eval( $cond ) ); }
411 return \@res;
412}
413
414sub find_node {
415 my $self = shift;
416 my $node = shift;
417 my $name = shift;
418 my %match = @_;
419 #croak "Cannot search empty node for $name" if( !$node );
420 #$node = $node->{ $name } or croak "Cannot find $name";
421 $node = $node->{ $name } or return 0;
422 return 0 if( !$node );
423 if( ref( $node ) eq 'HASH' ) {
424 foreach my $key ( keys %match ) {
425 my $val = $match{ $key };
426 next if ( !$val );
427 if( $node->{ $key }->{'value'} eq $val ) {
428 return $node;
429 }
430 }
431 }
432 if( ref( $node ) eq 'ARRAY' ) {
433 for( my $i = 0; $i <= $#$node; $i++ ) {
434 my $one = $node->[ $i ];
435 foreach my $key ( keys %match ) {
436 my $val = $match{ $key };
437 croak('undefined value in find') unless defined $val;
438 if( $one->{ $key }->{'value'} eq $val ) {
439 return $node->[ $i ];
440 }
441 }
442 }
443 }
444 return 0;
445}
446
447sub del_node {
448 my $self = shift;
449 my $node = shift;
450 my $name = shift;
451 my %match = @_;
452 $node = $node->{ $name };
453 return if( !$node );
454 for( my $i = 0; $i <= $#$node; $i++ ) {
455 my $one = $node->[ $i ];
456 foreach my $key ( keys %match ) {
457 my $val = $match{ $key };
458 if( $one->{ $key }->{'value'} eq $val ) {
459 delete $node->[ $i ];
460 }
461 }
462 }
463}
464
465sub del_by_perl {
466 my $arr = shift;
467 my $cond = shift;
468 $cond =~ s/-value/\$ob->\{'value'\}/g;
469 $cond =~ s/-([a-z]+)/\$ob->\{'$1'\}->\{'value'\}/g;
470 my @res;
471 for( my $i = 0; $i <= $#$arr; $i++ ) {
472 my $ob = $arr->[ $i ];
473 delete $arr->[ $i ] if( eval( $cond ) );
474 }
475 return \@res;
476}
477
478# Created a node of XML hash with the passed in variables already set
479sub new_node {
480 my $self = shift;
481 my %parts = @_;
482
483 my %newnode;
484 foreach( keys %parts ) {
485 my $val = $parts{$_};
486 if( m/^_/ || ref( $val ) eq 'HASH' ) {
487 $newnode{ $_ } = $val;
488 }
489 else {
490 $newnode{ $_ } = { value => $val };
491 }
492 }
493
494 return \%newnode;
495}
496
497sub newhash { shift; return { value => shift }; }
498
499sub simplify {
500 my $self = shift;
501 my $root = shift;
502 my %ret;
503 foreach my $name ( keys %$root ) {
504 next if( $name =~ m|^_| || $name eq 'comment' || $name eq 'value' );
505 my $val = xval $root->{$name};
506 $ret{ $name } = $val;
507 }
508 return \%ret;
509}
510
511sub xval {
512 return $_[0] ? $_[0]->{'value'} : ( $_[1] || '' );
513}
514
515# Save an XML hash tree into a file
516sub save {
517 my $self = shift;
518 return if( ! $self->{ 'xml' } );
519
520 my $xml = $self->xml( $self->{'xml'} );
521
522 my $len;
523 {
52431.56ms2193µs
# spent 190µs (187+3) within XML::Bare::BEGIN@524 which was called # once (187µs+3µs) by SimpleDB::Client::BEGIN@48 at line 524
use bytes;
# spent 190µs making 1 call to XML::Bare::BEGIN@524 # spent 3µs making 1 call to bytes::import
525 $len = length( $xml );
526 }
527 return if( !$len );
528
529 open F, '>:utf8', $self->{ 'file' };
530 print F $xml;
531
532 seek( F, 0, 2 );
533 my $cursize = tell( F );
534 if( $cursize != $len ) { # concurrency; we are writing a smaller file
535 warn "Truncating File $self->{'file'}";
536 truncate( F, $len );
537 }
538 seek( F, 0, 2 );
539 $cursize = tell( F );
540 if( $cursize != $len ) { # still not the right size even after truncate??
541 die "Write problem; $cursize != $len";
542 }
543 close F;
544}
545
546sub xml {
547 my ( $self, $obj, $name ) = @_;
548 if( !$name ) {
549 my %hash;
550 $hash{0} = $obj;
551 return obj2xml( \%hash, '', 0 );
552 }
553 my %hash;
554 $hash{$name} = $obj;
555 return obj2xml( \%hash, '', 0 );
556}
557
558sub html {
559 my ( $self, $obj, $name ) = @_;
560 my $pre = '';
561 if( $self->{'style'} ) {
562 $pre = "<style type='text/css'>\@import '$self->{'style'}';</style>";
563 }
564 if( !$name ) {
565 my %hash;
566 $hash{0} = $obj;
567 return $pre.obj2html( \%hash, '', 0 );
568 }
569 my %hash;
570 $hash{$name} = $obj;
571 return $pre.obj2html( \%hash, '', 0 );
572}
573
574sub obj2xml {
575 my ( $objs, $name, $pad, $level, $pdex ) = @_;
576 $level = 0 if( !$level );
577 $pad = '' if( $level <= 2 );
578 my $xml = '';
579 my $att = '';
580 my $imm = 1;
581 return '' if( !$objs );
582 #return $objs->{'_raw'} if( $objs->{'_raw'} );
583 my @dex = sort {
584 my $oba = $objs->{ $a };
585 my $obb = $objs->{ $b };
586 my $posa = 0;
587 my $posb = 0;
588 $oba = $oba->[0] if( ref( $oba ) eq 'ARRAY' );
589 $obb = $obb->[0] if( ref( $obb ) eq 'ARRAY' );
590 if( ref( $oba ) eq 'HASH' ) { $posa = $oba->{'_pos'} || 0; }
591 if( ref( $obb ) eq 'HASH' ) { $posb = $obb->{'_pos'} || 0; }
592 return $posa <=> $posb;
593 } keys %$objs;
594 for my $i ( @dex ) {
595 my $obj = $objs->{ $i } || '';
596 my $type = ref( $obj );
597 if( $type eq 'ARRAY' ) {
598 $imm = 0;
599
600 my @dex2 = sort {
601 if( !$a ) { return 0; }
602 if( !$b ) { return 0; }
603 if( ref( $a ) eq 'HASH' && ref( $b ) eq 'HASH' ) {
604 my $posa = $a->{'_pos'};
605 my $posb = $b->{'_pos'};
606 if( !$posa ) { $posa = 0; }
607 if( !$posb ) { $posb = 0; }
608 return $posa <=> $posb;
609 }
610 return 0;
611 } @$obj;
612
613 for my $j ( @dex2 ) {
614 $xml .= obj2xml( $j, $i, $pad.' ', $level+1, $#dex );
615 }
616 }
617 elsif( $type eq 'HASH' && $i !~ /^_/ ) {
618 if( $obj->{ '_att' } ) {
619 $att .= ' ' . $i . '="' . $obj->{ 'value' } . '"' if( $i !~ /^_/ );;
620 }
621 else {
622 $imm = 0;
623 $xml .= obj2xml( $obj , $i, $pad.' ', $level+1, $#dex );
624 }
625 }
626 else {
627 if( $i eq 'comment' ) { $xml .= '<!--' . $obj . '-->' . "\n"; }
628 elsif( $i eq 'value' ) {
629 if( $level > 1 ) { # $#dex < 4 &&
630 if( $obj && $obj =~ /[<>&;]/ ) { $xml .= '<![CDATA[' . $obj . ']]>'; }
631 else { $xml .= $obj if( $obj =~ /\S/ ); }
632 }
633 }
634 elsif( $i =~ /^_/ ) {}
635 else { $xml .= '<' . $i . '>' . $obj . '</' . $i . '>'; }
636 }
637 }
638 my $pad2 = $imm ? '' : $pad;
639 my $cr = $imm ? '' : "\n";
640 if( substr( $name, 0, 1 ) ne '_' ) {
641 if( $name ) {
642 if( $xml ) {
643 $xml = $pad . '<' . $name . $att . '>' . $cr . $xml . $pad2 . '</' . $name . '>';
644 }
645 else {
646 $xml = $pad . '<' . $name . $att . ' />';
647 }
648 }
649 return $xml."\n" if( $level > 1 );
650 return $xml;
651 }
652 return '';
653}
654
655sub obj2html {
656 my ( $objs, $name, $pad, $level, $pdex ) = @_;
657
658 my $less = "<span class='ang'>&lt;</span>";
659 my $more = "<span class='ang'>></span>";
660 my $tn0 = "<span class='tname'>";
661 my $tn1 = "</span>";
662 my $eq0 = "<span class='eq'>";
663 my $eq1 = "</span>";
664 my $qo0 = "<span class='qo'>";
665 my $qo1 = "</span>";
666 my $sp0 = "<span class='sp'>";
667 my $sp1 = "</span>";
668 my $cd0 = "";
669 my $cd1 = "";
670
671 $level = 0 if( !$level );
672 $pad = '' if( $level == 1 );
673 my $xml = '';
674 my $att = '';
675 my $imm = 1;
676 return '' if( !$objs );
677 my @dex = sort {
678 my $oba = $objs->{ $a };
679 my $obb = $objs->{ $b };
680 my $posa = 0;
681 my $posb = 0;
682 $oba = $oba->[0] if( ref( $oba ) eq 'ARRAY' );
683 $obb = $obb->[0] if( ref( $obb ) eq 'ARRAY' );
684 if( ref( $oba ) eq 'HASH' ) { $posa = $oba->{'_pos'} || 0; }
685 if( ref( $obb ) eq 'HASH' ) { $posb = $obb->{'_pos'} || 0; }
686 return $posa <=> $posb;
687 } keys %$objs;
688
689 if( $objs->{'_cdata'} ) {
690 my $val = $objs->{'value'};
691 $val =~ s/^(\s*\n)+//;
692 $val =~ s/\s+$//;
693 $val =~ s/&/&amp;/g;
694 $val =~ s/</&lt;/g;
695 $objs->{'value'} = $val;
696 #$xml = "$less![CDATA[<div class='node'><div class='cdata'>$val</div></div>]]$more";
697 $cd0 = "$less![CDATA[<div class='node'><div class='cdata'>";
698 $cd1 = "</div></div>]]$more";
699 }
700 for my $i ( @dex ) {
701 my $obj = $objs->{ $i } || '';
702 my $type = ref( $obj );
703 if( $type eq 'ARRAY' ) {
704 $imm = 0;
705
706 my @dex2 = sort {
707 if( !$a ) { return 0; }
708 if( !$b ) { return 0; }
709 if( ref( $a ) eq 'HASH' && ref( $b ) eq 'HASH' ) {
710 my $posa = $a->{'_pos'};
711 my $posb = $b->{'_pos'};
712 if( !$posa ) { $posa = 0; }
713 if( !$posb ) { $posb = 0; }
714 return $posa <=> $posb;
715 }
716 return 0;
717 } @$obj;
718
719 for my $j ( @dex2 ) { $xml .= obj2html( $j, $i, $pad.'&nbsp;&nbsp;', $level+1, $#dex ); }
720 }
721 elsif( $type eq 'HASH' && $i !~ /^_/ ) {
722 if( $obj->{ '_att' } ) {
723 my $val = $obj->{ 'value' };
724 $val =~ s/</&lt;/g;
725 if( $val eq '' ) {
726 $att .= " <span class='aname'>$i</span>" if( $i !~ /^_/ );
727 }
728 else {
729 $att .= " <span class='aname'>$i</span>$eq0=$eq1$qo0\"$qo1$val$qo0\"$qo1" if( $i !~ /^_/ );
730 }
731 }
732 else {
733 $imm = 0;
734 $xml .= obj2html( $obj , $i, $pad.'&nbsp;&nbsp;', $level+1, $#dex );
735 }
736 }
737 else {
738 if( $i eq 'comment' ) { $xml .= "$less!--" . $obj . "--$more" . "<br>\n"; }
739 elsif( $i eq 'value' ) {
740 if( $level > 1 ) {
741 if( $obj && $obj =~ /[<>&;]/ && ! $objs->{'_cdata'} ) { $xml .= "$less![CDATA[$obj]]$more"; }
742 else { $xml .= $obj if( $obj =~ /\S/ ); }
743 }
744 }
745 elsif( $i =~ /^_/ ) {}
746 else { $xml .= "$less$tn0$i$tn1$more$obj$less/$tn0$i$tn1$more"; }
747 }
748 }
749 my $pad2 = $imm ? '' : $pad;
750 if( substr( $name, 0, 1 ) ne '_' ) {
751 if( $name ) {
752 if( $imm ) {
753 if( $xml =~ /\S/ ) {
754 $xml = "$sp0$pad$sp1$less$tn0$name$tn1$att$more$cd0$xml$cd1$less/$tn0$name$tn1$more";
755 }
756 else {
757 $xml = "$sp0$pad$sp1$less$tn0$name$tn1$att/$more";
758 }
759 }
760 else {
761 if( $xml =~ /\S/ ) {
762 $xml = "$sp0$pad$sp1$less$tn0$name$tn1$att$more<div class='node'>$xml</div>$sp0$pad$sp1$less/$tn0$name$tn1$more";
763 }
764 else { $xml = "$sp0$pad$sp1$less$tn0$name$tn1$att/$more"; }
765 }
766 }
767 $xml .= "<br>" if( $objs->{'_br'} );
768 if( $objs->{'_note'} ) {
769 $xml .= "<br>";
770 my $note = $objs->{'_note'}{'value'};
771 my @notes = split( /\|/, $note );
772 for( @notes ) {
773 $xml .= "<div class='note'>$sp0$pad$sp1<span class='com'>&lt;!--</span> $_ <span class='com'>--></span></div>";
774 }
775 }
776 return $xml."<br>\n" if( $level );
777 return $xml;
778 }
779 return '';
780}
781
782643µs314µs
# spent 41µs (26+14) within XML::Bare::free_tree which was called 3 times, avg 14µs/call: # 3 times (26µs+14µs) by XML::Bare::simple at line 362, avg 14µs/call
sub free_tree { my $self = shift; XML::Bare::free_tree_c( $self->{'structroot'} ); }
# spent 14µs making 3 calls to XML::Bare::free_tree_c, avg 5µs/call
783
784125µs1;
785
786__END__
787
788=head1 SYNOPSIS
789
790 use XML::Bare;
791
792 my $ob = new XML::Bare( text => '<xml><name>Bob</name></xml>' );
793
794 # Parse the xml into a hash tree
795 my $root = $ob->parse();
796
797 # Print the content of the name node
798 print $root->{xml}->{name}->{value};
799
800 ---
801
802 # Load xml from a file ( assume same contents as first example )
803 my $ob2 = new XML::Bare( file => 'test.xml' );
804
805 my $root2 = $ob2->parse();
806
807 $root2->{xml}->{name}->{value} = 'Tim';
808
809 # Save the changes back to the file
810 $ob2->save();
811
812 ---
813
814 # Load xml and verify against XBS ( XML Bare Schema )
815 my $xml_text = '<xml><item name=bob/></xml>''
816 my $schema_text = '<xml><item* name=[a-z]+></item*></xml>'
817 my $ob = new XML::Bare( text => $xml_text, schema => { text => $schema_text } );
818 $ob->parse(); # this will error out if schema is invalid
819
820=head1 DESCRIPTION
821
822This module is a 'Bare' XML parser. It is implemented in C. The parser
823itself is a simple state engine that is less than 500 lines of C. The
824parser builds a C struct tree from input text. That C struct tree is
825converted to a Perl hash by a Perl function that makes basic calls back
826to the C to go through the nodes sequentially.
827
828The parser itself will only cease parsing if it encounters tags that
829are not closed properly. All other inputs will parse, even invalid
830inputs. To allowing checking for validity, a schema checker is included
831in the module as well.
832
833The schema format is custom and is meant to be as simple as possible.
834It is based loosely around the way multiplicity is handled in Perl
835regular expressions.
836
837=head2 Supported XML
838
839To demonstrate what sort of XML is supported, consider the following
840examples. Each of the PERL statements evaluates to true.
841
842=over 2
843
844=item * Node containing just text
845
846 XML: <xml>blah</xml>
847 PERL: $root->{xml}->{value} eq "blah";
848
849=item * Subset nodes
850
851 XML: <xml><name>Bob</name></xml>
852 PERL: $root->{xml}->{name}->{value} eq "Bob";
853
854=item * Attributes unquoted
855
856 XML: <xml><a href=index.htm>Link</a></xml>
857 PERL: $root->{xml}->{a}->{href}->{value} eq "index.htm";
858
859=item * Attributes quoted
860
861 XML: <xml><a href="index.htm">Link</a></xml>
862 PERL: $root->{xml}->{a}->{href}->{value} eq "index.htm";
863
864=item * CDATA nodes
865
866 XML: <xml><raw><![CDATA[some raw $~<!bad xml<>]]></raw></xml>
867 PERL: $root->{xml}->{raw}->{value} eq "some raw \$~<!bad xml<>";
868
869=item * Multiple nodes; form array
870
871 XML: <xml><item>1</item><item>2</item></xml>
872 PERL: $root->{xml}->{item}->[0]->{value} eq "1";
873
874=item * Forcing array creation
875
876 XML: <xml><multi_item/><item>1</item></xml>
877 PERL: $root->{xml}->{item}->[0]->{value} eq "1";
878
879=item * One comment supported per node
880
881 XML: <xml><!--test--></xml>
882 PERL: $root->{xml}->{comment} eq 'test';
883
884=back
885
886=head2 Schema Checking
887
888Schema checking is done by providing the module with an XBS (XML::Bare Schema) to check
889the XML against. If the XML checks as valid against the schema, parsing will continue as
890normal. If the XML is invalid, the parse function will die, providing information about
891the failure.
892
893The following information is provided in the error message:
894
895=over 2
896
897=item * The type of error
898
899=item * Where the error occured ( line and char )
900
901=item * A short snippet of the XML at the point of failure
902
903=back
904
905=head2 XBS ( XML::Bare Schema ) Format
906
907=over 2
908
909=item * Required nodes
910
911 XML: <xml></xml>
912 XBS: <xml/>
913
914=item * Optional nodes - allow one
915
916 XML: <xml></xml>
917 XBS: <xml item?/>
918 or XBS: <xml><item?/></xml>
919
920=item * Optional nodes - allow 0 or more
921
922 XML: <xml><item/></xml>
923 XBS: <xml item*/>
924
925=item * Required nodes - allow 1 or more
926
927 XML: <xml><item/><item/></xml>
928 XBS: <xml item+/>
929
930=item * Nodes - specified minimum and maximum number
931
932 XML: <xml><item/><item/></xml>
933 XBS: <xml item{1,2}/>
934 or XBS: <xml><item{1,2}/></xml>
935 or XBS: <xml><item{1,2}></item{1,2}></xml>
936
937=item * Multiple acceptable node formats
938
939 XML: <xml><item type=box volume=20/><item type=line length=10/></xml>
940 XBS: <xml><item type=box volume/><item type=line length/></xml>
941
942=item * Regular expressions checking for values
943
944 XML: <xml name=Bob dir=up num=10/>
945 XBS: <xml name=[A-Za-z]+ dir=up|down num=[0-9]+/>
946
947=item * Require multi_ tags
948
949 XML: <xml><multi_item/></xml>
950 XBS: <xml item@/>
951
952=back
953
954=head2 Parsed Hash Structure
955
956The hash structure returned from XML parsing is created in a specific format.
957Besides as described above, the structure contains some additional nodes in
958order to preserve information that will allow that structure to be correctly
959converted back to XML.
960
961Nodes may contain the following 3 additional subnodes:
962
963=over 2
964
965=item * _i
966
967The character offset within the original parsed XML of where the node
968begins. This is used to provide line information for errors when XML
969fails a schema check.
970
971=item * _pos
972
973This is a number indicating the ordering of nodes. It is used to allow
974items in a perl hash to be sorted when writing back to xml. Note that
975items are not sorted after parsing in order to save time if all you
976are doing is reading and you do not care about the order.
977
978In future versions of this module an option will be added to allow
979you to sort your nodes so that you can read them in order.
980( note that multiple nodes of the same name are stored in order )
981
982=item * _att
983
984This is a boolean value that exists and is 1 iff the node is an
985attribute.
986
987=back
988
989=head2 Parsing Limitations / Features
990
991=over 2
992
993=item * CDATA parsed correctly, but stripped if unneeded
994
995Currently the contents of a node that are CDATA are read and
996put into the value hash, but the hash structure does not have
997a value indicating the node contains CDATA.
998
999When converting back to XML, the contents of the value hash
1000are parsed to check for xml incompatible data using a regular
1001expression. If 'CDATA like' stuff is encountered, the node
1002is output as CDATA.
1003
1004=item * Node position stored, but hash remains unsorted
1005
1006The ordering of nodes is noted using the '_pos' value, but
1007the hash itself is not ordered after parsing. Currently
1008items will be out of order when looking at them in the
1009hash.
1010
1011Note that when converted back to XML, the nodes are then
1012sorted and output in the correct order to XML. Note that
1013nodes of the same name with the same parent will be
1014grouped together; the position of the first item to
1015appear will determine the output position of the group.
1016
1017=item * Comments are parsed but only one is stored per node.
1018
1019For each node, there can be a comment within it, and that
1020comment will be saved and output back when dumping to XML.
1021
1022=item * Comments override output of immediate value
1023
1024If a node contains only a comment node and a text value,
1025only the comment node will be displayed. This is in line
1026with treating a comment node as a node and only displaying
1027immediate values when a node contains no subnodes.
1028
1029=item * PI sections are parsed, but discarded
1030
1031=item * Unknown C<< <! >> sections are parsed, but discarded
1032
1033=item * Attributes may use no quotes, single quotes, quotes
1034
1035=item * Quoted attributes cannot contain escaped quotes
1036
1037No escape character is recognized within quotes. As a result,
1038regular quotes cannot be stored to XML, or the written XML
1039will not be correct, due to all attributes always being written
1040using quotes.
1041
1042=item * Attributes are always written back to XML with quotes
1043
1044=item * Nodes cannot contain subnodes as well as an immediate value
1045
1046Actually nodes can in fact contain a value as well, but that
1047value will be discarded if you write back to XML. That value is
1048equal to the first continuous string of text besides a subnode.
1049
1050 <node>text<subnode/>text2</node>
1051 ( the value of node is text )
1052
1053 <node><subnode/>text</node>
1054 ( the value of node is text )
1055
1056 <node>
1057 <subnode/>text
1058 </node>
1059 ( the value of node is "\n " )
1060
1061=back
1062
1063=head2 Module Functions
1064
1065=over 2
1066
1067=item * C<< $ob = new XML::Bare( text => "[some xml]" ) >>
1068
1069Create a new XML object, with the given text as the xml source.
1070
1071=item * C<< $object = new XML::Bare( file => "[filename]" ) >>
1072
1073Create a new XML object, with the given filename/path as the xml source
1074
1075=item * C<< $object = new XML::Bare( text => "[some xml]", file => "[filename]" ) >>
1076
1077Create a new XML object, with the given text as the xml input, and the given
1078filename/path as the potential output ( used by save() )
1079
1080=item * C<< $object = new XML::Bare( file => "data.xml", scheme => { file => "scheme.xbs" } ) >>
1081
1082Create a new XML object and check to ensure it is valid xml by way of the XBS scheme.
1083
1084=item * C<< $tree = $object->parse() >>
1085
1086Parse the xml of the object and return a tree reference
1087
1088=item * C<< $tree = $object->simple() >>
1089
1090Alternate to the parse function which generates a tree similar to that
1091generated by XML::Simple. Note that the sets of nodes are turned into
1092arrays always, regardless of whether they have a 'name' attribute, unlike
1093XML::Simple.
1094
1095Note that currently the generated tree cannot be used with any of the
1096functions in this module that operate upon trees. The function is provided
1097purely as a quick and dirty way to read simple XML files.
1098
1099=item * C<< $tree = xmlin( $xmlext, keeproot => 1 ) >>
1100
1101The xmlin function is a shortcut to creating an XML::Bare object and
1102parsing it using the simple function. It behaves similarly to the
1103XML::Simple function by the same name. The keeproot option is optional
1104and if left out the root node will be discarded, same as the function
1105in XML::Simple.
1106
1107=item * C<< $text = $object->xml( [root] ) >>
1108
1109Take the hash tree in [root] and turn it into cleanly indented ( 2 spaces )
1110XML text.
1111
1112=item * C<< $text = $object->html( [root], [root node name] ) >>
1113
1114Take the hash tree in [root] and turn it into nicely colorized and styled
1115html. [root node name] is optional.
1116
1117=item * C<< $object->save() >>
1118
1119The the current tree in the object, cleanly indent it, and save it
1120to the file paramter specified when creating the object.
1121
1122=item * C<< $value = xval $node, $default >>
1123
1124Returns the value of $node or $default if the node does not exist.
1125If default is not passed to the function, then '' is returned as
1126a default value when the node does not exist.
1127
1128=item * C<< ( $name, $age ) = xget( $personnode, qw/name age/ ) >>
1129
1130Shortcut function to grab a number of values from a node all at the
1131same time. Note that this function assumes that all of the subnodes
1132exist; it will fail if they do not.
1133
1134=item * C<< $text = XML::Bare::clean( text => "[some xml]" ) >>
1135
1136Shortcut to creating an xml object and immediately turning it into clean xml text.
1137
1138=item * C<< $text = XML::Bare::clean( file => "[filename]" ) >>
1139
1140Similar to previous.
1141
1142=item * C<< XML::Bare::clean( file => "[filename]", save => 1 ) >>
1143
1144Clean up the xml in the file, saving the results back to the file
1145
1146=item * C<< XML::Bare::clean( text => "[some xml]", save => "[filename]" ) >>
1147
1148Clean up the xml provided, and save it into the specified file.
1149
1150=item * C<< XML::Bare::clean( file => "[filename1]", save => "[filename2]" ) >>
1151
1152Clean up the xml in filename1 and save the results to filename2.
1153
1154=item * C<< $html = XML::Bare::tohtml( text => "[some xml]", root => 'xml' ) >>
1155
1156Shortcut to creating an xml object and immediately turning it into html.
1157Root is optional, and specifies the name of the root node for the xml
1158( which defaults to 'xml' )
1159
1160=item * C<< $object->add_node( [node], [nodeset name], name => value, name2 => value2, ... ) >>
1161
1162 Example:
1163 $object->add_node( $root->{xml}, 'item', name => 'Bob' );
1164
1165 Result:
1166 <xml>
1167 <item>
1168 <name>Bob</name>
1169 </item>
1170 </xml>
1171
1172=item * C<< $object->add_node_after( [node], [subnode within node to add after], [nodeset name], ... ) >>
1173
1174=item * C<< $object->del_node( [node], [nodeset name], name => value ) >>
1175
1176 Example:
1177 Starting XML:
1178 <xml>
1179 <a>
1180 <b>1</b>
1181 </a>
1182 <a>
1183 <b>2</b>
1184 </a>
1185 </xml>
1186
1187 Code:
1188 $xml->del_node( $root->{xml}, 'a', b=>'1' );
1189
1190 Ending XML:
1191 <xml>
1192 <a>
1193 <b>2</b>
1194 </a>
1195 </xml>
1196
1197=item * C<< $object->find_node( [node], [nodeset name], name => value ) >>
1198
1199 Example:
1200 Starting XML:
1201 <xml>
1202 <ob>
1203 <key>1</key>
1204 <val>a</val>
1205 </ob>
1206 <ob>
1207 <key>2</key>
1208 <val>b</val>
1209 </ob>
1210 </xml>
1211
1212 Code:
1213 $object->find_node( $root->{xml}, 'ob', key => '1' )->{val}->{value} = 'test';
1214
1215 Ending XML:
1216 <xml>
1217 <ob>
1218 <key>1</key>
1219 <val>test</val>
1220 </ob>
1221 <ob>
1222 <key>2</key>
1223 <val>b</val>
1224 </ob>
1225 </xml>
1226
1227=item * C<< $object->find_by_perl( [nodeset], "[perl code]" ) >>
1228
1229find_by_perl evaluates some perl code for each node in a set of nodes, and
1230returns the nodes where the perl code evaluates as true. In order to
1231easily reference node values, node values can be directly referred
1232to from within the perl code by the name of the node with a dash(-) in
1233front of the name. See the example below.
1234
1235Note that this function returns an array reference as opposed to a single
1236node unlike the find_node function.
1237
1238 Example:
1239 Starting XML:
1240 <xml>
1241 <ob>
1242 <key>1</key>
1243 <val>a</val>
1244 </ob>
1245 <ob>
1246 <key>2</key>
1247 <val>b</val>
1248 </ob>
1249 </xml>
1250
1251 Code:
1252 $object->find_by_perl( $root->{xml}->{ob}, "-key eq '1'" )->[0]->{val}->{value} = 'test';
1253
1254 Ending XML:
1255 <xml>
1256 <ob>
1257 <key>1</key>
1258 <val>test</val>
1259 </ob>
1260 <ob>
1261 <key>2</key>
1262 <val>b</val>
1263 </ob>
1264 </xml>
1265
1266=item * C<< XML::Bare::merge( [nodeset1], [nodeset2], [id node name] ) >>
1267
1268Merges the nodes from nodeset2 into nodeset1, matching the contents of
1269each node based up the content in the id node.
1270
1271Example:
1272
1273 Code:
1274 my $ob1 = new XML::Bare( text => "
1275 <xml>
1276 <multi_a/>
1277 <a>bob</a>
1278 <a>
1279 <id>1</id>
1280 <color>blue</color>
1281 </a>
1282 </xml>" );
1283 my $ob2 = new XML::Bare( text => "
1284 <xml>
1285 <multi_a/>
1286 <a>john</a>
1287 <a>
1288 <id>1</id>
1289 <name>bob</name>
1290 <bob>1</bob>
1291 </a>
1292 </xml>" );
1293 my $root1 = $ob1->parse();
1294 my $root2 = $ob2->parse();
1295 merge( $root1->{'xml'}->{'a'}, $root2->{'xml'}->{'a'}, 'id' );
1296 print $ob1->xml( $root1 );
1297
1298 Output:
1299 <xml>
1300 <multi_a></multi_a>
1301 <a>bob</a>
1302 <a>
1303 <id>1</id>
1304 <color>blue</color>
1305 <name>bob</name>
1306 <bob>1</bob>
1307 </a>
1308 </xml>
1309
1310=item * C<< XML::Bare::del_by_perl( ... ) >>
1311
1312Works exactly like find_by_perl, but deletes whatever matches.
1313
1314=item * C<< XML::Bare::forcearray( [noderef] ) >>
1315
1316Turns the node reference into an array reference, whether that
1317node is just a single node, or is already an array reference.
1318
1319=item * C<< XML::Bare::new_node( ... ) >>
1320
1321Creates a new node...
1322
1323=item * C<< XML::Bare::newhash( ... ) >>
1324
1325Creates a new hash with the specified value.
1326
1327=item * C<< XML::Bare::simplify( [noderef] ) >>
1328
1329Take a node with children that have immediate values and
1330creates a hashref to reference those values by the name of
1331each child.
1332
1333=back
1334
1335=head2 Functions Used Internally
1336
1337=over 2
1338
1339=item * C<< check() checkone() readxbs() free_tree_c() >>
1340
1341=item * C<< lineinfo() c_parse() c_parsefile() free_tree() xml2obj() >>
1342
1343=item * C<< obj2xml() get_root() obj2html() xml2obj_simple() >>
1344
1345=back
1346
1347=head2 Performance
1348
1349In comparison to other available perl xml parsers that create trees, XML::Bare
1350is extremely fast. In order to measure the performance of loading and parsing
1351compared to the alternatives, a templated speed comparison mechanism has been
1352created and included with XML::Bare.
1353
1354The include makebench.pl file runs when you make the module and creates perl
1355files within the bench directory corresponding to the .tmpl contained there.
1356
1357Currently there are three types of modules that can be tested against,
1358executable parsers ( exe.tmpl ), tree parsers ( tree.tmpl ), and parsers
1359that do not generated trees ( notree.tmpl ).
1360
1361A full list of modules currently tested against is as follows:
1362
1363 Tiny XML (exe)
1364 EzXML (exe)
1365 XMLIO (exe)
1366 XML::LibXML (notree)
1367 XML::Parser (notree)
1368 XML::Parser::Expat (notree)
1369 XML::Descent (notree)
1370 XML::Parser::EasyTree
1371 XML::Handler::Trees
1372 XML::Twig
1373 XML::Smart
1374 XML::Simple using XML::Parser
1375 XML::Simple using XML::SAX::PurePerl
1376 XML::Simple using XML::LibXML::SAX::Parser
1377 XML::Simple using XML::Bare::SAX::Parser
1378 XML::TreePP
1379 XML::Trivial
1380 XML::SAX::Simple
1381 XML::Grove::Builder
1382 XML::XPath::XMLParser
1383 XML::DOM
1384
1385To run the comparisons, run the appropriate perl file within the
1386bench directory. ( exe.pl, tree.pl, or notree.pl )
1387
1388The script measures the milliseconds of loading and parsing, and
1389compares the time against the time of XML::Bare. So a 7 means
1390it takes 7 times as long as XML::Bare.
1391
1392Here is a combined table of the script run against each alternative
1393using the included test.xml:
1394
1395 -Module- load parse total
1396 XML::Bare 1 1 1
1397 XML::TreePP 2.3063 33.1776 6.1598
1398 XML::Parser::EasyTree 4.9405 25.7278 7.4571
1399 XML::Handler::Trees 7.2303 26.5688 9.6447
1400 XML::Trivial 5.0636 12.4715 7.3046
1401 XML::Smart 6.8138 78.7939 15.8296
1402 XML::Simple (XML::Parser) 2.3346 50.4772 10.7455
1403 XML::Simple (PurePerl) 2.361 261.4571 33.6524
1404 XML::Simple (LibXML) 2.3187 163.7501 23.1816
1405 XML::Simple (XML::Bare) 2.3252 59.1254 10.9163
1406 XML::SAX::Simple 8.7792 170.7313 28.3634
1407 XML::Twig 27.8266 56.4476 31.3594
1408 XML::Grove::Builder 7.1267 26.1672 9.4064
1409 XML::XPath::XMLParser 9.7783 35.5486 13.0002
1410 XML::LibXML (notree) 11.0038 4.5758 10.6881
1411 XML::Parser (notree) 4.4698 17.6448 5.8609
1412 XML::Parser::Expat(notree) 3.7681 50.0382 6.0069
1413 XML::Descent (notree) 6.0525 37.0265 11.0322
1414 Tiny XML (exe) 1.0095
1415 EzXML (exe) 1.1284
1416 XMLIO (exe) 1.0165
1417
1418Here is a combined table of the script run against each alternative
1419using the included feed2.xml:
1420
1421 -Module- load parse total
1422 XML::Bare 1 1 1
1423 XML::TreePP 2.3068 23.7554 7.6921
1424 XML::Parser::EasyTree 4.8799 25.3691 9.6257
1425 XML::Handler::Trees 6.8545 33.1007 13.0575
1426 XML::Trivial 5.0105 32.0043 11.4113
1427 XML::Simple (XML::Parser) 2.3498 41.9007 12.3062
1428 XML::Simple (PurePerl) 2.3551 224.3027 51.7832
1429 XML::Simple (LibXML) 2.3617 88.8741 23.215
1430 XML::Simple (XML::Bare) 2.4319 37.7355 10.2343
1431 XML::Simple 2.7168 90.7203 26.7525
1432 XML::SAX::Simple 8.7386 94.8276 29.2166
1433 XML::Twig 28.3206 48.1014 33.1222
1434 XML::Grove::Builder 7.2021 30.7926 12.9334
1435 XML::XPath::XMLParser 9.6869 43.5032 17.4941
1436 XML::LibXML (notree) 11.0023 5.022 10.5214
1437 XML::Parser (notree) 4.3748 25.0213 5.9803
1438 XML::Parser::Expat(notree) 3.6555 51.6426 7.4316
1439 XML::Descent (notree) 5.9206 155.0289 18.7767
1440 Tiny XML (exe) 1.2212
1441 EzXML (exe) 1.3618
1442 XMLIO (exe) 1.0145
1443
1444These results show that XML::Bare is, at least on the
1445test machine, running all tests within cygwin, faster
1446at loading and parsing than everything being tested
1447against.
1448
1449The following things are shown as well:
1450 - XML::Bare can parse XML and create a hash tree
1451 in less time than it takes LibXML just to parse.
1452 - XML::Bare can parse XML and create a tree
1453 in less time than all three binary parsers take
1454 just to parse.
1455
1456Note that the executable parsers are not perl modules
1457and are timed using dummy programs that just uses the
1458library to load and parse the example files. The
1459executables are not included with this program. Any
1460source modifications used to generate the shown test
1461results can be found in the bench/src directory of
1462the distribution
1463
1464=head1 LICENSE
1465
1466 Copyright (C) 2008 David Helkowski
1467
1468 This program is free software; you can redistribute it and/or
1469 modify it under the terms of the GNU General Public License as
1470 published by the Free Software Foundation; either version 2 of the
1471 License, or (at your option) any later version. You may also can
1472 redistribute it and/or modify it under the terms of the Perl
1473 Artistic License.
1474
1475 This program is distributed in the hope that it will be useful,
1476 but WITHOUT ANY WARRANTY; without even the implied warranty of
1477 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1478 GNU General Public License for more details.
1479
1480=cut
# spent 557µs within XML::Bare::bootstrap which was called # once (557µs+0s) by DynaLoader::bootstrap at line 227 of DynaLoader.pm
sub XML::Bare::bootstrap; # xsub
# spent 53µs within XML::Bare::c_parse which was called 3 times, avg 18µs/call: # 3 times (53µs+0s) by XML::Bare::new at line 39 of XML/Bare.pm, avg 18µs/call
sub XML::Bare::c_parse; # xsub
# spent 14µs within XML::Bare::free_tree_c which was called 3 times, avg 5µs/call: # 3 times (14µs+0s) by XML::Bare::free_tree at line 782 of XML/Bare.pm, avg 5µs/call
sub XML::Bare::free_tree_c; # xsub
# spent 7µs within XML::Bare::get_root which was called 3 times, avg 2µs/call: # 3 times (7µs+0s) by XML::Bare::simple at line 361 of XML/Bare.pm, avg 2µs/call
sub XML::Bare::get_root; # xsub
# spent 66µs within XML::Bare::xml2obj_simple which was called 3 times, avg 22µs/call: # 3 times (66µs+0s) by XML::Bare::simple at line 360 of XML/Bare.pm, avg 22µs/call
sub XML::Bare::xml2obj_simple; # xsub