File Coverage

File:blib/lib/XML/Parser/Lite/Tree.pm
Coverage:95.6%

linestmtbrancondsubtimecode
1package XML::Parser::Lite::Tree;
2
3
8
8
8
8
74
14
13
use 5.006;
4
8
8
8
8
38
11
47
use strict;
5
8
8
8
8
41
10
37
use warnings;
6
8
8
8
8
48
13
100
use XML::Parser::LiteCopy;
7
8our $VERSION = '0.12';
9
10
8
8
8
8
40
11
31
use vars qw( $parser );
11
12sub instance {
13
4
50
4
23
        return $parser if $parser;
14
4
18
        $parser = __PACKAGE__->new;
15}
16
17sub new {
18
9
9
71
        my $class = shift;
19
9
46
        my $self = bless {}, $class;
20
21
9
0
0
50
63
0
        my %opts = (ref $_[0]) ? ((ref $_[0] eq 'HASH') ? %{$_[0]} : () ) : @_;
22
9
43
        $self->{opts} = \%opts;
23
24        $self->{__parser} = new XML::Parser::LiteCopy
25                Handlers => {
26
29
29
98
                        Start => sub { $self->_start_tag(@_); },
27
21
21
70
                        Char => sub { $self->_do_char(@_); },
28
1
1
4
                        CData => sub { $self->_do_cdata(@_); },
29
29
29
94
                        End => sub { $self->_end_tag(@_); },
30
1
1
4
                        Comment => sub { $self->_do_comment(@_); },
31
2
2
8
                        PI => sub { $self->_do_pi(@_); },
32
1
1
5
                        Doctype => sub { $self->_do_doctype(@_); },
33
9
267
                };
34
9
100
119
        $self->{process_ns} = $self->{opts}->{process_ns} || 0;
35
9
100
80
        $self->{skip_white} = $self->{opts}->{skip_white} || 0;
36
37
9
36
        return $self;
38}
39
40sub parse {
41
9
9
78
        my ($self, $content) = @_;
42
43
9
52
        my $root = {
44                'type' => 'root',
45                'children' => [],
46        };
47
48
9
43
        $self->{tag_stack} = [$root];
49
50
9
47
        $self->{__parser}->parse($content);
51
52
9
36
        $self->cleanup($root);
53
54
9
100
44
        if ($self->{skip_white}){
55
5
16
                $self->strip_white($root);
56        }
57
58
9
100
39
        if ($self->{process_ns}){
59
1
3
                $self->{ns_stack} = {};
60
1
4
                $self->mark_namespaces($root);
61        }
62
63
9
35
        return $root;
64}
65
66sub _start_tag {
67
29
29
75
        my $self = shift;
68
29
58
        shift;
69
70
29
188
        my $new_tag = {
71                'type' => 'element',
72                'name' => shift,
73                'attributes' => {},
74                'children' => [],
75        };
76
77
29
130
        while (my $a_name = shift @_){
78
14
35
                my $a_value = shift @_;
79
14
91
                $new_tag->{attributes}->{$a_name} = $a_value;
80        }
81
82
29
29
54
131
        push @{$self->{tag_stack}->[-1]->{children}}, $new_tag;
83
29
29
56
98
        push @{$self->{tag_stack}}, $new_tag;
84
29
98
        1;
85}
86
87sub _do_char {
88
21
21
50
        my $self = shift;
89
21
43
        shift;
90
91
21
58
        for my $content(@_){
92
93
21
89
                my $new_tag = {
94                        'type' => 'text',
95                        'content' => $content,
96                };
97
98
21
21
45
125
                push @{$self->{tag_stack}->[-1]->{children}}, $new_tag;
99        }
100
21
51
        1;
101}
102
103sub _do_cdata {
104
1
1
3
        my $self = shift;
105
1
3
        shift;
106
107
1
4
        for my $content(@_){
108
109
1
5
                my $new_tag = {
110                        'type' => 'cdata',
111                        'content' => $content,
112                };
113
114
1
1
3
7
                push @{$self->{tag_stack}->[-1]->{children}}, $new_tag;
115        }
116
1
2
        1;
117}
118
119sub _end_tag {
120
29
29
73
        my $self = shift;
121
122
29
29
46
89
        pop @{$self->{tag_stack}};
123
29
93
        1;
124}
125
126sub _do_comment {
127
1
1
3
        my $self = shift;
128
1
3
        shift;
129
130
1
3
        for my $content(@_){
131
132
1
5
                my $new_tag = {
133                        'type' => 'comment',
134                        'content' => $content,
135                };
136
137
1
1
2
6
                push @{$self->{tag_stack}->[-1]->{children}}, $new_tag;
138        }
139
1
3
        1;
140}
141
142sub _do_pi {
143
2
2
6
        my $self = shift;
144
2
4
        shift;
145
146
2
2
4
16
        push @{$self->{tag_stack}->[-1]->{children}}, {
147                'type' => 'pi',
148                'content' => shift,
149        };
150
2
6
        1;
151}
152
153sub _do_doctype {
154
1
1
4
        my $self = shift;
155
1
2
        shift;
156
157
1
1
2
10
        push @{$self->{tag_stack}->[-1]->{children}}, {
158                'type' => 'dtd',
159                'content' => shift,
160        };
161
1
3
        1;
162}
163
164sub mark_namespaces {
165
5
5
14
        my ($self, $obj) = @_;
166
167
5
8
        my @ns_keys;
168
169        #
170        # mark
171        #
172
173
5
100
22
        if ($obj->{type} eq 'element'){
174
175                #
176                # first, add any new NS's to the stack
177                #
178
179
4
4
6
17
                my @keys = keys %{$obj->{attributes}};
180
181
4
13
                for my $k(@keys){
182
183
4
100
15
                        if ($k =~ /^xmlns:(.*)$/){
184
185
2
2
4
12
                                push @{$self->{ns_stack}->{$1}}, $obj->{attributes}->{$k};
186
2
8
                                push @ns_keys, $1;
187
2
6
                                delete $obj->{attributes}->{$k};
188                        }
189
190
4
100
17
                        if ($k eq 'xmlns'){
191
192
2
2
4
12
                                push @{$self->{ns_stack}->{__default__}}, $obj->{attributes}->{$k};
193
2
4
                                push @ns_keys, '__default__';
194
2
10
                                delete $obj->{attributes}->{$k};
195                        }
196                }
197
198
199                #
200                # now - does this tag have a NS?
201                #
202
203
4
100
17
                if ($obj->{name} =~ /^(.*?):(.*)$/){
204
205
1
4
                        $obj->{local_name} = $2;
206
1
5
                        $obj->{ns_key} = $1;
207
1
5
                        $obj->{ns} = $self->{ns_stack}->{$1}->[-1];
208                }else{
209
3
11
                        $obj->{local_name} = $obj->{name};
210
3
15
                        $obj->{ns} = $self->{ns_stack}->{__default__}->[-1];
211                }
212
213
214                #
215                # finally, add xpath-style namespace nodes
216                #
217
218
4
11
                $obj->{namespaces} = {};
219
220
4
4
9
16
                for my $key (keys %{$self->{ns_stack}}){
221
222
9
9
50
13
39
                        if (scalar @{$self->{ns_stack}->{$key}}){
223
224
9
33
                                my $uri = $self->{ns_stack}->{$key}->[-1];
225
9
40
                                $obj->{namespaces}->{$key} = $uri;
226                        }
227                }
228        }
229
230
231        #
232        # descend
233        #
234
235
5
50
67
44
        if ($obj->{type} eq 'root' || $obj->{type} eq 'element'){
236
237
5
5
10
19
                for my $child (@{$obj->{children}}){
238
239
4
29
                        $self->mark_namespaces($child);
240                }
241        }
242
243
244        #
245        # pop from stack
246        #
247
248
5
19
        for my $k (@ns_keys){
249
4
4
10
23
                pop @{$self->{ns_stack}->{$k}};
250        }
251}
252
253sub strip_white {
254
20
20
56
        my ($self, $obj) = @_;
255
256
20
50
67
156
        if ($obj->{type} eq 'root' || $obj->{type} eq 'element'){
257
258
20
44
                my $new_kids = [];
259
260
20
20
36
70
                for my $child (@{$obj->{children}}){
261
262
38
100
100
187
                        if ($child->{type} eq 'text'){
263
264
19
100
94
                                if ($child->{content} =~ m/\S/){
265
266
1
1
2
5
                                        push @{$new_kids}, $child;
267                                }
268
269                        }elsif ($child->{type} eq 'element'){
270
271
15
61
                                $self->strip_white($child);
272
15
15
34
55
                                push @{$new_kids}, $child;
273                        }else{
274
4
4
7
18
                                push @{$new_kids}, $child;
275                        }
276                }
277
278
20
68
                $obj->{children} = $new_kids;
279        }
280}
281
282sub cleanup {
283
64
64
178
        my ($self, $obj) = @_;
284
285        #
286        # cleanup PIs
287        #
288
289
64
100
236
        if ($obj->{type} eq 'pi'){
290
291
2
15
                my ($x, $y) = split /\s+/, $obj->{content}, 2;
292
2
6
                $obj->{target} = $x;
293
2
5
                $obj->{content} = $y;
294        }
295
296
297        #
298        # cleanup DTDs
299        #
300
301
64
100
233
        if ($obj->{type} eq 'dtd'){
302
303
1
6
                my ($x, $y) = split /\s+/, $obj->{content}, 2;
304
1
3
                $obj->{name} = $x;
305
1
4
                $obj->{content} = $y;
306        }
307
308
309        #
310        # recurse
311        #
312
313
64
100
100
547
        if ($obj->{type} eq 'root' || $obj->{type} eq 'element'){
314
315
38
38
70
165
                for my $child (@{$obj->{children}}){
316
317
55
200
                        $self->cleanup($child);
318                }
319        }
320}
321
322
3231;