File Coverage

blib/lib/Tags/Output/LibXML.pm
Criterion Covered Total %
statement 92 98 93.8
branch 12 22 54.5
condition 1 3 33.3
subroutine 19 19 100.0
pod 2 2 100.0
total 126 144 87.5


line stmt bran cond sub pod time code
1             package Tags::Output::LibXML;
2              
3 12     12   121023 use base qw(Tags::Output);
  12         99  
  12         6910  
4 12     12   375174 use strict;
  12         37  
  12         241  
5 12     12   61 use warnings;
  12         23  
  12         317  
6              
7 12     12   58 use Error::Pure qw(err);
  12         24  
  12         467  
8 12     12   65 use Readonly;
  12         23  
  12         437  
9 12     12   8806 use XML::LibXML;
  12         726721  
  12         79  
10              
11             # Constants.
12             Readonly::Scalar my $EMPTY_STR => q{};
13              
14             our $VERSION = 0.03;
15              
16             # Flush tags in object.
17             sub flush {
18 28     28 1 916 my ($self, $reset_flag) = @_;
19 28         45 my $ret;
20 28         59 my $ouf = $self->{'output_handler'};
21 28 50       72 if ($ouf) {
22 12     12   2471 no warnings;
  12         32  
  12         12049  
23 0         0 print {$ouf} $self->{'doc'}->toString(
24 0 0       0 $self->{'set_indent'} ? 2 : 0)
    0          
25             or err 'Cannot write to output handler.';
26             } else {
27             $ret = $self->{'doc'}->toString(
28 28 50       115 $self->{'set_indent'} ? 2 : 0);
29             }
30              
31             # Reset.
32 28 50       1370 if ($reset_flag) {
33 0         0 $self->reset;
34             }
35              
36 28         86 return $ret;
37             }
38              
39             # Resets internal variables.
40             sub reset {
41 29     29 1 9875 my $self = shift;
42              
43             # Root node.
44             $self->{'doc'} = XML::LibXML::Document->new(
45             $self->{'xml_version'},
46 29         336 $self->{'encoding'},
47             );
48              
49             # First node = root node.
50 29         67 $self->{'first'} = 0;
51              
52             # Printed tags.
53 29         99 $self->{'printed_tags'} = [];
54              
55 29         72 return;
56             }
57              
58             # Check parameters to rigth values.
59             sub _check_params {
60 14     14   211 my $self = shift;
61              
62             # Check to output handler.
63 14 50 33     84 if (defined $self->{'output_handler'}
64             && ref $self->{'output_handler'} ne 'GLOB') {
65              
66 0         0 err 'Output handler is bad file handler.';
67             }
68              
69 14         152 return;
70             }
71              
72             # Default parameters.
73             sub _default_parameters {
74 16     16   8777 my $self = shift;
75              
76             # CDATA callback.
77 16         68 $self->{'cdata_callback'} = undef;
78              
79             # Data callback.
80 16         43 $self->{'data_callback'} = undef;
81              
82             # Document encoding.
83 16         42 $self->{'encoding'} = 'UTF-8';
84              
85             # No simple tags.
86             # TODO not implemented.
87 16         40 $self->{'no_simple'} = [];
88              
89             # Set output handler.
90 16         36 $self->{'output_handler'} = undef;
91              
92             # Preserved tags.
93             # TODO not implemented.
94 16         49 $self->{'preserved'} = [];
95              
96             # Set indent.
97 16         36 $self->{'set_indent'} = 0;
98              
99             # Skip bad tags.
100 16         51 $self->{'skip_bad_tags'} = 0;
101              
102             # XML version.
103 16         41 $self->{'xml_version'} = '1.1';
104              
105 16         46 return;
106             }
107              
108             # Attributes.
109             sub _put_attribute {
110 14     14   250 my ($self, $attr, $value) = @_;
111 14         55 $self->{'printed_tags'}->[0]->setAttribute($attr, $value);
112 14         171 return;
113             }
114              
115             # Begin of tag.
116             sub _put_begin_of_tag {
117 28     28   1031 my ($self, $tag) = @_;
118 28         295 my $begin_node = $self->{'doc'}->createElement($tag);
119 28 100       97 if ($self->{'first'} == 0) {
120 24         105 $self->{'doc'}->setDocumentElement($begin_node);
121 24         395 $self->{'first'} = 1;
122             } else {
123 4 50       62 if (! $self->{'printed_tags'}->[0]) {
124 0         0 err "Second root tag '$tag' is bad.";
125             } else {
126 4         37 $self->{'printed_tags'}->[0]->addChild($begin_node);
127             }
128             }
129 28         51 unshift @{$self->{'printed_tags'}}, $begin_node;
  28         130  
130 28         78 return;
131             }
132              
133             # CData.
134             sub _put_cdata {
135 5     5   69 my ($self, @cdata) = @_;
136 5         26 $self->_process_callback(\@cdata, 'cdata_callback');
137 5         51 my $cdata = join($EMPTY_STR, @cdata);
138 5         46 my $cdata_node = $self->{'doc'}->createCDATASection($cdata);
139 5         33 $self->{'printed_tags'}->[0]->addChild($cdata_node);
140 5         28 return;
141             }
142              
143             # Comment.
144             sub _put_comment {
145 11     11   159 my ($self, @comments) = @_;
146 11         28 my $comment = join($EMPTY_STR, @comments);
147              
148             # HACK LibXML has a bug.
149 11 100       43 if ($comment =~ m/-$/ms) {
150 1         4 $comment .= ' ';
151             }
152              
153 11         56 my $comment_node = $self->{'doc'}->createComment($comment);
154 11 100       30 if (! defined $self->{'printed_tags'}->[0]) {
155 4         28 $self->{'doc'}->appendChild($comment_node);
156             } else {
157 7         29 $self->{'printed_tags'}->[0]->addChild($comment_node);
158             }
159 11         48 return;
160             }
161              
162             # Data.
163             sub _put_data {
164 10     10   121 my ($self, @data) = @_;
165 10         54 $self->_process_callback(\@data, 'data_callback');
166 10         113 my $data = join($EMPTY_STR, @data);
167 10         89 my $data_node = $self->{'doc'}->createTextNode($data);
168 10         62 $self->{'printed_tags'}->[0]->addChild($data_node);
169 10         49 return;
170             }
171              
172             # End of tag.
173             sub _put_end_of_tag {
174 28     28   590 my ($self, $tag) = @_;
175 28         53 shift @{$self->{'printed_tags'}};
  28         53  
176 28         83 return;
177             }
178              
179             # Instruction.
180             sub _put_instruction {
181 1     1   40 my ($self, $target, $code) = @_;
182 1         15 my $instruction_node = $self->{'doc'}->createProcessingInstruction(
183             $target, $code,
184             );
185 1 50       5 if (! defined $self->{'printed_tags'}->[0]) {
186 1         17 $self->{'doc'}->appendChild($instruction_node);
187             } else {
188 0         0 $self->{'printed_tags'}->[0]->addChild($instruction_node);
189             }
190 1         8 return;
191             }
192              
193             # Raw data.
194             sub _put_raw {
195 2     2   116 my ($self, @raw_data) = @_;
196 2         5 return;
197             }
198              
199             1;
200              
201             __END__