File Coverage

blib/lib/Tree/Persist/File/XML.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package Tree::Persist::File::XML;
2              
3 1     1   2430 use strict;
  1         2  
  1         26  
4 1     1   3 use warnings;
  1         2  
  1         27  
5              
6 1     1   3 use base qw( Tree::Persist::File );
  1         1  
  1         56  
7              
8 1     1   3 use Module::Runtime;
  1         2  
  1         4  
9              
10 1     1   25 use Scalar::Util qw( blessed refaddr );
  1         1  
  1         39  
11              
12 1     1   169 use XML::Parser;
  0            
  0            
13              
14             our $VERSION = '1.11';
15              
16             # ----------------------------------------------
17              
18             sub _reload
19             {
20             my($self) = shift;
21             my($linenum) = 0;
22              
23             my @stack;
24             my $tree;
25              
26             my $parser = XML::Parser -> new
27             (
28             Handlers =>
29             {
30             Start => sub
31             {
32             my($dummy, $name, %args) = @_;
33             my($class) = $args{class} ? $args{class} : $self->{_class};
34             my($node) = Module::Runtime::use_module($class)->new( $args{value} );
35              
36             if ( @stack )
37             {
38             $stack[-1] -> add_child( $node );
39             }
40             else
41             {
42             $tree = $node;
43             }
44              
45             push @stack, $node;
46             },
47             End => sub
48             {
49             $linenum++;
50              
51             pop @stack;
52             },
53             },
54             );
55              
56             $parser -> parsefile( $self->{_filename} );
57              
58             $self -> _set_tree( $tree );
59              
60             return $self;
61              
62             } # End of _reload.
63              
64             # ----------------------------------------------
65              
66             my $pad = ' ' x 4;
67              
68             # ----------------------------------------------
69              
70             sub _build_string
71             {
72             my($self) = shift;
73             my($tree) = @_;
74             my(%encode) = ('<' => '<', '>' => '>', '&' => '&', "'" => ''', '"' => '"');
75             my($str) = '';
76             my($curr_depth) = $tree->depth;
77              
78             my(@char, @closer);
79             my($new_depth);
80              
81             for my $node ( $tree->traverse )
82             {
83             $new_depth = $node->depth;
84             $str .= pop(@closer) while @closer && $curr_depth-- >= $new_depth;
85             $curr_depth = $new_depth;
86             @char = map{$encode{$_} ? $encode{$_} : $_} split(//, $node -> value);
87             $str .= ($pad x $curr_depth)
88             . ' 89             . blessed($node)
90             . '" value="'
91             . join('', @char)
92             . '">' . $/;
93              
94             push @closer, ($pad x $curr_depth) . "\n";
95             }
96              
97             $str .= pop(@closer) while @closer;
98              
99             return $str;
100              
101             } # End of _build_string.
102              
103             # ----------------------------------------------
104              
105             1;
106              
107             __END__