← Back to branch summary

~ubuntu-branches/ubuntu/vivid/libxml-bare-perl/vivid

« back to all changes in this revision

Viewing changes to lib/XML/Bare.pm

  • Committer: Package Import Robot
  • Author(s): Nuno Carvalho, gregor herrmann, Salvatore Bonaccorso, Axel Beckert, Nuno Carvalho
  • Date: 2013-09-17 15:54:28 UTC
  • mfrom: (1.1.4)
  • Revision ID: package-import@ubuntu.com-20130917155428-4d0xb5cissw2323f
Tags: 0.53-1
* Team upload.

[ gregor herrmann ]
* debian/control: update {versioned,alternative} (build) dependencies.

[ Salvatore Bonaccorso ]
* Change Vcs-Git to canonical URI (git://anonscm.debian.org)
* Change search.cpan.org based URIs to metacpan.org based URIs

[ Axel Beckert ]
* debian/copyright: migrate pre-1.0 format to 1.0 using "cme fix dpkg-
  copyright"

[ Nuno Carvalho ]
* New upstream release.
* debian/copyright: update copyright years.
* debian/control: update standards version.
* debian/control: update debhelper required version, in order to pass all
  the hardening flags to EUMM.
* Add lintian override to apparently false-positive warning.
* Add set of patches accepted upstream but still not included in this
  release, visit https://rt.cpan.org/Public/Bug/Display.html?id=88155
  for details.

Show diffs side-by-side

added added

removed removed

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