| File | /usr/local/lib/perl5/site_perl/5.10.1/darwin-2level/XML/Bare.pm |
| Statements Executed | 102 |
| Statement Execution Time | 4.54ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 2 | 557µs | 557µs | XML::Bare::bootstrap (xsub) |
| 1 | 1 | 1 | 242µs | 245µs | XML::Bare::BEGIN@6 |
| 1 | 1 | 1 | 187µs | 190µs | XML::Bare::BEGIN@524 |
| 3 | 1 | 1 | 113µs | 424µs | XML::Bare::xmlin |
| 3 | 1 | 1 | 71µs | 185µs | XML::Bare::simple |
| 3 | 1 | 2 | 66µs | 66µs | XML::Bare::xml2obj_simple (xsub) |
| 3 | 1 | 1 | 58µs | 112µs | XML::Bare::new |
| 3 | 1 | 2 | 53µs | 53µs | XML::Bare::c_parse (xsub) |
| 3 | 1 | 1 | 26µs | 41µs | XML::Bare::free_tree |
| 1 | 1 | 1 | 16µs | 51µs | XML::Bare::BEGIN@3 |
| 3 | 1 | 1 | 16µs | 16µs | XML::Bare::DESTROY |
| 3 | 1 | 2 | 14µs | 14µs | XML::Bare::free_tree_c (xsub) |
| 1 | 1 | 1 | 8µs | 38µs | XML::Bare::BEGIN@15 |
| 1 | 1 | 1 | 8µs | 10µs | XML::Bare::BEGIN@4 |
| 3 | 1 | 2 | 7µs | 7µs | XML::Bare::get_root (xsub) |
| 1 | 1 | 1 | 5µs | 52µs | XML::Bare::BEGIN@5 |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::add_node |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::add_node_after |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::check |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::checkone |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::clean |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::del_by_perl |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::del_node |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::find_by_perl |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::find_node |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::forcearray |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::html |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::lineinfo |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::merge |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::new_node |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::newhash |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::obj2html |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::obj2xml |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::parse |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::readxbs |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::save |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::simplify |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::tohtml |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::xget |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::xml |
| 0 | 0 | 0 | 0s | 0s | XML::Bare::xval |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package XML::Bare; | ||||
| 2 | |||||
| 3 | 3 | 31µs | 2 | 86µ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 # spent 51µs making 1 call to XML::Bare::BEGIN@3
# spent 35µs making 1 call to Exporter::import |
| 4 | 3 | 21µs | 2 | 12µ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 # spent 10µs making 1 call to XML::Bare::BEGIN@4
# spent 2µs making 1 call to strict::import |
| 5 | 3 | 21µs | 2 | 99µ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 # spent 52µs making 1 call to XML::Bare::BEGIN@5
# spent 47µs making 1 call to vars::import |
| 6 | 3 | 279µs | 2 | 248µ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 # spent 245µs making 1 call to XML::Bare::BEGIN@6
# spent 3µs making 1 call to utf8::import |
| 7 | 1 | 800ns | require Exporter; | ||
| 8 | 1 | 800ns | require DynaLoader; | ||
| 9 | 1 | 13µs | @ISA = qw(Exporter DynaLoader); | ||
| 10 | |||||
| 11 | |||||
| 12 | 1 | 300ns | $VERSION = "0.45"; | ||
| 13 | |||||
| 14 | |||||
| 15 | 3 | 2.17ms | 2 | 68µ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 # spent 38µs making 1 call to XML::Bare::BEGIN@15
# spent 30µs making 1 call to vars::import |
| 16 | |||||
| 17 | 1 | 4µs | *AUTOLOAD = \&XML::Bare::AUTOLOAD; | ||
| 18 | 1 | 5µs | 1 | 20.3ms | bootstrap XML::Bare $VERSION; # spent 20.3ms making 1 call to DynaLoader::bootstrap |
| 19 | |||||
| 20 | |||||
| 21 | |||||
| 22 | 1 | 1µs | @EXPORT = qw( ); | ||
| 23 | 1 | 5µ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 | |||||
| 27 | XML::Bare - Minimal XML parser implemented via a C state engine | ||||
| 28 | |||||
| 29 | =head1 VERSION | ||||
| 30 | |||||
| 31 | 0.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 | ||||
| 36 | 15 | 116µs | my $class = shift; | ||
| 37 | my $self = { @_ }; | ||||
| 38 | |||||
| 39 | 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 | } | ||||
| 55 | bless $self, $class; | ||||
| 56 | 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 | ||||
| 61 | 6 | 18µs | my $self = shift; | ||
| 62 | undef $self->{'xml'}; | ||||
| 63 | } | ||||
| 64 | |||||
| 65 | sub xget { | ||||
| 66 | my $hash = shift; | ||||
| 67 | return map $_->{'value'}, @{%$hash}{@_}; | ||||
| 68 | } | ||||
| 69 | |||||
| 70 | sub forcearray { | ||||
| 71 | my $ref = shift; | ||||
| 72 | return [] if( !$ref ); | ||||
| 73 | return $ref if( ref( $ref ) eq 'ARRAY' ); | ||||
| 74 | return [ $ref ]; | ||||
| 75 | } | ||||
| 76 | |||||
| 77 | sub 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 | |||||
| 111 | sub 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 | ||||
| 123 | 27 | 82µs | my $text = shift; | ||
| 124 | my %ops = ( @_ ); | ||||
| 125 | my $ob = new XML::Bare( text => $text ); # spent 112µs making 3 calls to XML::Bare::new, avg 37µs/call | ||||
| 126 | my $simple = $ob->simple(); # spent 185µs making 3 calls to XML::Bare::simple, avg 62µs/call | ||||
| 127 | if( !$ops{'keeproot'} ) { | ||||
| 128 | my @keys = keys %$simple; | ||||
| 129 | my $first = $keys[0]; | ||||
| 130 | $simple = $simple->{ $first } if( $first ); | ||||
| 131 | } | ||||
| 132 | return $simple; | ||||
| 133 | } | ||||
| 134 | |||||
| 135 | sub 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 | ||||
| 142 | sub 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 | |||||
| 171 | sub 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 | ||||
| 195 | sub 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 | |||||
| 210 | sub 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 | |||||
| 276 | sub 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 | ||||
| 358 | 21 | 142µs | my $self = shift; | ||
| 359 | |||||
| 360 | my $res = XML::Bare::xml2obj_simple();#$self->xml2obj(); # spent 66µs making 3 calls to XML::Bare::xml2obj_simple, avg 22µs/call | ||||
| 361 | $self->{'structroot'} = XML::Bare::get_root(); # spent 7µs making 3 calls to XML::Bare::get_root, avg 2µs/call | ||||
| 362 | $self->free_tree(); # spent 41µs making 3 calls to XML::Bare::free_tree, avg 14µs/call | ||||
| 363 | |||||
| 364 | if( $res < 0 ) { croak "Error at ".$self->lineinfo( -$res ); } | ||||
| 365 | $self->{ 'xml' } = $res; | ||||
| 366 | |||||
| 367 | return $self->{ 'xml' }; | ||||
| 368 | } | ||||
| 369 | |||||
| 370 | sub 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 | |||||
| 381 | sub 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 | |||||
| 405 | sub 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 | |||||
| 414 | sub 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 | |||||
| 447 | sub 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 | |||||
| 465 | sub 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 | ||||
| 479 | sub 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 | |||||
| 497 | sub newhash { shift; return { value => shift }; } | ||||
| 498 | |||||
| 499 | sub 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 | |||||
| 511 | sub xval { | ||||
| 512 | return $_[0] ? $_[0]->{'value'} : ( $_[1] || '' ); | ||||
| 513 | } | ||||
| 514 | |||||
| 515 | # Save an XML hash tree into a file | ||||
| 516 | sub save { | ||||
| 517 | my $self = shift; | ||||
| 518 | return if( ! $self->{ 'xml' } ); | ||||
| 519 | |||||
| 520 | my $xml = $self->xml( $self->{'xml'} ); | ||||
| 521 | |||||
| 522 | my $len; | ||||
| 523 | { | ||||
| 524 | 3 | 1.56ms | 2 | 193µ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 # 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 | |||||
| 546 | sub 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 | |||||
| 558 | sub 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 | |||||
| 574 | sub 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 | |||||
| 655 | sub obj2html { | ||||
| 656 | my ( $objs, $name, $pad, $level, $pdex ) = @_; | ||||
| 657 | |||||
| 658 | my $less = "<span class='ang'><</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/&/&/g; | ||||
| 694 | $val =~ s/</</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.' ', $level+1, $#dex ); } | ||||
| 720 | } | ||||
| 721 | elsif( $type eq 'HASH' && $i !~ /^_/ ) { | ||||
| 722 | if( $obj->{ '_att' } ) { | ||||
| 723 | my $val = $obj->{ 'value' }; | ||||
| 724 | $val =~ s/</</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.' ', $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'><!--</span> $_ <span class='com'>--></span></div>"; | ||||
| 774 | } | ||||
| 775 | } | ||||
| 776 | return $xml."<br>\n" if( $level ); | ||||
| 777 | return $xml; | ||||
| 778 | } | ||||
| 779 | return ''; | ||||
| 780 | } | ||||
| 781 | |||||
| 782 | 6 | 43µs | 3 | 14µ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 # spent 14µs making 3 calls to XML::Bare::free_tree_c, avg 5µs/call |
| 783 | |||||
| 784 | 1 | 25µs | 1; | ||
| 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 | |||||
| 822 | This module is a 'Bare' XML parser. It is implemented in C. The parser | ||||
| 823 | itself is a simple state engine that is less than 500 lines of C. The | ||||
| 824 | parser builds a C struct tree from input text. That C struct tree is | ||||
| 825 | converted to a Perl hash by a Perl function that makes basic calls back | ||||
| 826 | to the C to go through the nodes sequentially. | ||||
| 827 | |||||
| 828 | The parser itself will only cease parsing if it encounters tags that | ||||
| 829 | are not closed properly. All other inputs will parse, even invalid | ||||
| 830 | inputs. To allowing checking for validity, a schema checker is included | ||||
| 831 | in the module as well. | ||||
| 832 | |||||
| 833 | The schema format is custom and is meant to be as simple as possible. | ||||
| 834 | It is based loosely around the way multiplicity is handled in Perl | ||||
| 835 | regular expressions. | ||||
| 836 | |||||
| 837 | =head2 Supported XML | ||||
| 838 | |||||
| 839 | To demonstrate what sort of XML is supported, consider the following | ||||
| 840 | examples. 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 | |||||
| 888 | Schema checking is done by providing the module with an XBS (XML::Bare Schema) to check | ||||
| 889 | the XML against. If the XML checks as valid against the schema, parsing will continue as | ||||
| 890 | normal. If the XML is invalid, the parse function will die, providing information about | ||||
| 891 | the failure. | ||||
| 892 | |||||
| 893 | The 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 | |||||
| 956 | The hash structure returned from XML parsing is created in a specific format. | ||||
| 957 | Besides as described above, the structure contains some additional nodes in | ||||
| 958 | order to preserve information that will allow that structure to be correctly | ||||
| 959 | converted back to XML. | ||||
| 960 | |||||
| 961 | Nodes may contain the following 3 additional subnodes: | ||||
| 962 | |||||
| 963 | =over 2 | ||||
| 964 | |||||
| 965 | =item * _i | ||||
| 966 | |||||
| 967 | The character offset within the original parsed XML of where the node | ||||
| 968 | begins. This is used to provide line information for errors when XML | ||||
| 969 | fails a schema check. | ||||
| 970 | |||||
| 971 | =item * _pos | ||||
| 972 | |||||
| 973 | This is a number indicating the ordering of nodes. It is used to allow | ||||
| 974 | items in a perl hash to be sorted when writing back to xml. Note that | ||||
| 975 | items are not sorted after parsing in order to save time if all you | ||||
| 976 | are doing is reading and you do not care about the order. | ||||
| 977 | |||||
| 978 | In future versions of this module an option will be added to allow | ||||
| 979 | you 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 | |||||
| 984 | This is a boolean value that exists and is 1 iff the node is an | ||||
| 985 | attribute. | ||||
| 986 | |||||
| 987 | =back | ||||
| 988 | |||||
| 989 | =head2 Parsing Limitations / Features | ||||
| 990 | |||||
| 991 | =over 2 | ||||
| 992 | |||||
| 993 | =item * CDATA parsed correctly, but stripped if unneeded | ||||
| 994 | |||||
| 995 | Currently the contents of a node that are CDATA are read and | ||||
| 996 | put into the value hash, but the hash structure does not have | ||||
| 997 | a value indicating the node contains CDATA. | ||||
| 998 | |||||
| 999 | When converting back to XML, the contents of the value hash | ||||
| 1000 | are parsed to check for xml incompatible data using a regular | ||||
| 1001 | expression. If 'CDATA like' stuff is encountered, the node | ||||
| 1002 | is output as CDATA. | ||||
| 1003 | |||||
| 1004 | =item * Node position stored, but hash remains unsorted | ||||
| 1005 | |||||
| 1006 | The ordering of nodes is noted using the '_pos' value, but | ||||
| 1007 | the hash itself is not ordered after parsing. Currently | ||||
| 1008 | items will be out of order when looking at them in the | ||||
| 1009 | hash. | ||||
| 1010 | |||||
| 1011 | Note that when converted back to XML, the nodes are then | ||||
| 1012 | sorted and output in the correct order to XML. Note that | ||||
| 1013 | nodes of the same name with the same parent will be | ||||
| 1014 | grouped together; the position of the first item to | ||||
| 1015 | appear will determine the output position of the group. | ||||
| 1016 | |||||
| 1017 | =item * Comments are parsed but only one is stored per node. | ||||
| 1018 | |||||
| 1019 | For each node, there can be a comment within it, and that | ||||
| 1020 | comment will be saved and output back when dumping to XML. | ||||
| 1021 | |||||
| 1022 | =item * Comments override output of immediate value | ||||
| 1023 | |||||
| 1024 | If a node contains only a comment node and a text value, | ||||
| 1025 | only the comment node will be displayed. This is in line | ||||
| 1026 | with treating a comment node as a node and only displaying | ||||
| 1027 | immediate 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 | |||||
| 1037 | No escape character is recognized within quotes. As a result, | ||||
| 1038 | regular quotes cannot be stored to XML, or the written XML | ||||
| 1039 | will not be correct, due to all attributes always being written | ||||
| 1040 | using 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 | |||||
| 1046 | Actually nodes can in fact contain a value as well, but that | ||||
| 1047 | value will be discarded if you write back to XML. That value is | ||||
| 1048 | equal 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 | |||||
| 1069 | Create a new XML object, with the given text as the xml source. | ||||
| 1070 | |||||
| 1071 | =item * C<< $object = new XML::Bare( file => "[filename]" ) >> | ||||
| 1072 | |||||
| 1073 | Create 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 | |||||
| 1077 | Create a new XML object, with the given text as the xml input, and the given | ||||
| 1078 | filename/path as the potential output ( used by save() ) | ||||
| 1079 | |||||
| 1080 | =item * C<< $object = new XML::Bare( file => "data.xml", scheme => { file => "scheme.xbs" } ) >> | ||||
| 1081 | |||||
| 1082 | Create 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 | |||||
| 1086 | Parse the xml of the object and return a tree reference | ||||
| 1087 | |||||
| 1088 | =item * C<< $tree = $object->simple() >> | ||||
| 1089 | |||||
| 1090 | Alternate to the parse function which generates a tree similar to that | ||||
| 1091 | generated by XML::Simple. Note that the sets of nodes are turned into | ||||
| 1092 | arrays always, regardless of whether they have a 'name' attribute, unlike | ||||
| 1093 | XML::Simple. | ||||
| 1094 | |||||
| 1095 | Note that currently the generated tree cannot be used with any of the | ||||
| 1096 | functions in this module that operate upon trees. The function is provided | ||||
| 1097 | purely as a quick and dirty way to read simple XML files. | ||||
| 1098 | |||||
| 1099 | =item * C<< $tree = xmlin( $xmlext, keeproot => 1 ) >> | ||||
| 1100 | |||||
| 1101 | The xmlin function is a shortcut to creating an XML::Bare object and | ||||
| 1102 | parsing it using the simple function. It behaves similarly to the | ||||
| 1103 | XML::Simple function by the same name. The keeproot option is optional | ||||
| 1104 | and if left out the root node will be discarded, same as the function | ||||
| 1105 | in XML::Simple. | ||||
| 1106 | |||||
| 1107 | =item * C<< $text = $object->xml( [root] ) >> | ||||
| 1108 | |||||
| 1109 | Take the hash tree in [root] and turn it into cleanly indented ( 2 spaces ) | ||||
| 1110 | XML text. | ||||
| 1111 | |||||
| 1112 | =item * C<< $text = $object->html( [root], [root node name] ) >> | ||||
| 1113 | |||||
| 1114 | Take the hash tree in [root] and turn it into nicely colorized and styled | ||||
| 1115 | html. [root node name] is optional. | ||||
| 1116 | |||||
| 1117 | =item * C<< $object->save() >> | ||||
| 1118 | |||||
| 1119 | The the current tree in the object, cleanly indent it, and save it | ||||
| 1120 | to the file paramter specified when creating the object. | ||||
| 1121 | |||||
| 1122 | =item * C<< $value = xval $node, $default >> | ||||
| 1123 | |||||
| 1124 | Returns the value of $node or $default if the node does not exist. | ||||
| 1125 | If default is not passed to the function, then '' is returned as | ||||
| 1126 | a default value when the node does not exist. | ||||
| 1127 | |||||
| 1128 | =item * C<< ( $name, $age ) = xget( $personnode, qw/name age/ ) >> | ||||
| 1129 | |||||
| 1130 | Shortcut function to grab a number of values from a node all at the | ||||
| 1131 | same time. Note that this function assumes that all of the subnodes | ||||
| 1132 | exist; it will fail if they do not. | ||||
| 1133 | |||||
| 1134 | =item * C<< $text = XML::Bare::clean( text => "[some xml]" ) >> | ||||
| 1135 | |||||
| 1136 | Shortcut to creating an xml object and immediately turning it into clean xml text. | ||||
| 1137 | |||||
| 1138 | =item * C<< $text = XML::Bare::clean( file => "[filename]" ) >> | ||||
| 1139 | |||||
| 1140 | Similar to previous. | ||||
| 1141 | |||||
| 1142 | =item * C<< XML::Bare::clean( file => "[filename]", save => 1 ) >> | ||||
| 1143 | |||||
| 1144 | Clean 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 | |||||
| 1148 | Clean up the xml provided, and save it into the specified file. | ||||
| 1149 | |||||
| 1150 | =item * C<< XML::Bare::clean( file => "[filename1]", save => "[filename2]" ) >> | ||||
| 1151 | |||||
| 1152 | Clean 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 | |||||
| 1156 | Shortcut to creating an xml object and immediately turning it into html. | ||||
| 1157 | Root 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 | |||||
| 1229 | find_by_perl evaluates some perl code for each node in a set of nodes, and | ||||
| 1230 | returns the nodes where the perl code evaluates as true. In order to | ||||
| 1231 | easily reference node values, node values can be directly referred | ||||
| 1232 | to from within the perl code by the name of the node with a dash(-) in | ||||
| 1233 | front of the name. See the example below. | ||||
| 1234 | |||||
| 1235 | Note that this function returns an array reference as opposed to a single | ||||
| 1236 | node 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 | |||||
| 1268 | Merges the nodes from nodeset2 into nodeset1, matching the contents of | ||||
| 1269 | each node based up the content in the id node. | ||||
| 1270 | |||||
| 1271 | Example: | ||||
| 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 | |||||
| 1312 | Works exactly like find_by_perl, but deletes whatever matches. | ||||
| 1313 | |||||
| 1314 | =item * C<< XML::Bare::forcearray( [noderef] ) >> | ||||
| 1315 | |||||
| 1316 | Turns the node reference into an array reference, whether that | ||||
| 1317 | node is just a single node, or is already an array reference. | ||||
| 1318 | |||||
| 1319 | =item * C<< XML::Bare::new_node( ... ) >> | ||||
| 1320 | |||||
| 1321 | Creates a new node... | ||||
| 1322 | |||||
| 1323 | =item * C<< XML::Bare::newhash( ... ) >> | ||||
| 1324 | |||||
| 1325 | Creates a new hash with the specified value. | ||||
| 1326 | |||||
| 1327 | =item * C<< XML::Bare::simplify( [noderef] ) >> | ||||
| 1328 | |||||
| 1329 | Take a node with children that have immediate values and | ||||
| 1330 | creates a hashref to reference those values by the name of | ||||
| 1331 | each 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 | |||||
| 1349 | In comparison to other available perl xml parsers that create trees, XML::Bare | ||||
| 1350 | is extremely fast. In order to measure the performance of loading and parsing | ||||
| 1351 | compared to the alternatives, a templated speed comparison mechanism has been | ||||
| 1352 | created and included with XML::Bare. | ||||
| 1353 | |||||
| 1354 | The include makebench.pl file runs when you make the module and creates perl | ||||
| 1355 | files within the bench directory corresponding to the .tmpl contained there. | ||||
| 1356 | |||||
| 1357 | Currently there are three types of modules that can be tested against, | ||||
| 1358 | executable parsers ( exe.tmpl ), tree parsers ( tree.tmpl ), and parsers | ||||
| 1359 | that do not generated trees ( notree.tmpl ). | ||||
| 1360 | |||||
| 1361 | A 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 | |||||
| 1385 | To run the comparisons, run the appropriate perl file within the | ||||
| 1386 | bench directory. ( exe.pl, tree.pl, or notree.pl ) | ||||
| 1387 | |||||
| 1388 | The script measures the milliseconds of loading and parsing, and | ||||
| 1389 | compares the time against the time of XML::Bare. So a 7 means | ||||
| 1390 | it takes 7 times as long as XML::Bare. | ||||
| 1391 | |||||
| 1392 | Here is a combined table of the script run against each alternative | ||||
| 1393 | using 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 | |||||
| 1418 | Here is a combined table of the script run against each alternative | ||||
| 1419 | using 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 | |||||
| 1444 | These results show that XML::Bare is, at least on the | ||||
| 1445 | test machine, running all tests within cygwin, faster | ||||
| 1446 | at loading and parsing than everything being tested | ||||
| 1447 | against. | ||||
| 1448 | |||||
| 1449 | The 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 | |||||
| 1456 | Note that the executable parsers are not perl modules | ||||
| 1457 | and are timed using dummy programs that just uses the | ||||
| 1458 | library to load and parse the example files. The | ||||
| 1459 | executables are not included with this program. Any | ||||
| 1460 | source modifications used to generate the shown test | ||||
| 1461 | results can be found in the bench/src directory of | ||||
| 1462 | the 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 |