Profile of /usr/local/lib/perl5/site_perl/5.10.1/darwin-2level/XML/Bare.pm

← 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:11 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
--- | --- | --- | --- | --- | ---
1 | 1 | 2 | 557µs | 557µs | XML::Bare::::bootstrapXML::Bare::bootstrap (xsub)
1 | 1 | 1 | 242µs | 245µs | XML::Bare::::BEGIN@6XML::Bare::BEGIN@6
1 | 1 | 1 | 187µs | 190µs | XML::Bare::::BEGIN@524XML::Bare::BEGIN@524
3 | 1 | 1 | 113µs | 424µs | XML::Bare::::xmlinXML::Bare::xmlin
3 | 1 | 1 | 71µs | 185µs | XML::Bare::::simpleXML::Bare::simple
3 | 1 | 2 | 66µs | 66µs | XML::Bare::::xml2obj_simpleXML::Bare::xml2obj_simple (xsub)
3 | 1 | 1 | 58µs | 112µs | XML::Bare::::newXML::Bare::new
3 | 1 | 2 | 53µs | 53µs | XML::Bare::::c_parseXML::Bare::c_parse (xsub)
3 | 1 | 1 | 26µs | 41µs | XML::Bare::::free_treeXML::Bare::free_tree
1 | 1 | 1 | 16µs | 51µs | XML::Bare::::BEGIN@3XML::Bare::BEGIN@3
3 | 1 | 1 | 16µs | 16µs | XML::Bare::::DESTROYXML::Bare::DESTROY
3 | 1 | 2 | 14µs | 14µs | XML::Bare::::free_tree_cXML::Bare::free_tree_c (xsub)
1 | 1 | 1 | 8µs | 38µs | XML::Bare::::BEGIN@15XML::Bare::BEGIN@15
1 | 1 | 1 | 8µs | 10µs | XML::Bare::::BEGIN@4XML::Bare::BEGIN@4
3 | 1 | 2 | 7µs | 7µs | XML::Bare::::get_rootXML::Bare::get_root (xsub)
1 | 1 | 1 | 5µs | 52µs | XML::Bare::::BEGIN@5XML::Bare::BEGIN@5
0 | 0 | 0 | 0s | 0s | XML::Bare::::add_nodeXML::Bare::add_node
0 | 0 | 0 | 0s | 0s | XML::Bare::::add_node_afterXML::Bare::add_node_after
0 | 0 | 0 | 0s | 0s | XML::Bare::::checkXML::Bare::check
0 | 0 | 0 | 0s | 0s | XML::Bare::::checkoneXML::Bare::checkone
0 | 0 | 0 | 0s | 0s | XML::Bare::::cleanXML::Bare::clean
0 | 0 | 0 | 0s | 0s | XML::Bare::::del_by_perlXML::Bare::del_by_perl
0 | 0 | 0 | 0s | 0s | XML::Bare::::del_nodeXML::Bare::del_node
0 | 0 | 0 | 0s | 0s | XML::Bare::::find_by_perlXML::Bare::find_by_perl
0 | 0 | 0 | 0s | 0s | XML::Bare::::find_nodeXML::Bare::find_node
0 | 0 | 0 | 0s | 0s | XML::Bare::::forcearrayXML::Bare::forcearray
0 | 0 | 0 | 0s | 0s | XML::Bare::::htmlXML::Bare::html
0 | 0 | 0 | 0s | 0s | XML::Bare::::lineinfoXML::Bare::lineinfo
0 | 0 | 0 | 0s | 0s | XML::Bare::::mergeXML::Bare::merge
0 | 0 | 0 | 0s | 0s | XML::Bare::::new_nodeXML::Bare::new_node
0 | 0 | 0 | 0s | 0s | XML::Bare::::newhashXML::Bare::newhash
0 | 0 | 0 | 0s | 0s | XML::Bare::::obj2htmlXML::Bare::obj2html
0 | 0 | 0 | 0s | 0s | XML::Bare::::obj2xmlXML::Bare::obj2xml
0 | 0 | 0 | 0s | 0s | XML::Bare::::parseXML::Bare::parse
0 | 0 | 0 | 0s | 0s | XML::Bare::::readxbsXML::Bare::readxbs
0 | 0 | 0 | 0s | 0s | XML::Bare::::saveXML::Bare::save
0 | 0 | 0 | 0s | 0s | XML::Bare::::simplifyXML::Bare::simplify
0 | 0 | 0 | 0s | 0s | XML::Bare::::tohtmlXML::Bare::tohtml
0 | 0 | 0 | 0s | 0s | XML::Bare::::xgetXML::Bare::xget
0 | 0 | 0 | 0s | 0s | XML::Bare::::xmlXML::Bare::xml
0 | 0 | 0 | 0s | 0s | XML::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
--- | --- | --- | --- | --- | ---
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 use Carp; # 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 use strict; # 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 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
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 use utf8; # 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 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 |  |  |  |  |
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 sub new {
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 sub DESTROY {
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 sub xmlin {
123 | 18 | 63µ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 | 9 | 19µs |  |  | 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 sub simple {
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 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 |  |  |  |  |
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'>&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 |  |  |  |  |
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 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 |  |  |  |  |
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 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