File Coverage

blib/lib/SVG/XML.pm
Criterion Covered Total %
statement 73 76 96.0
branch 18 28 64.2
condition 10 15 66.6
subroutine 16 16 100.0
pod 0 13 0.0
total 117 148 79.0


line stmt bran cond sub pod time code
1             package SVG::XML;
2 25     25   137 use strict;
  25         44  
  25         580  
3 25     25   118 use warnings;
  25         33  
  25         897  
4              
5             our $VERSION = '2.87';
6              
7             =pod
8              
9             =head1 NAME
10              
11             SVG::XML - Handle the XML generation bits for SVG.pm
12              
13             =head1 AUTHOR
14              
15             Ronan Oger, cpan@roitsystems.com
16              
17             =head1 SEE ALSO
18              
19             L,
20             L,
21             L,
22             L,
23             L
24              
25             =cut
26              
27 25     25   125 use Exporter;
  25         54  
  25         31326  
28              
29             our @ISA = ('Exporter');
30              
31             our @EXPORT = qw(
32             xmlesc
33             xmlescape
34             xmlescp
35             cssstyle
36             xmlattrib
37             xmlcomment
38             xmlpi
39             xmltag
40             xmltagopen
41             xmltagclose
42             xmltag_ln
43             xmltagopen_ln
44             xmltagclose_ln
45             processtag
46             xmldecl
47             dtddecl
48             );
49              
50             sub xmlescp {
51 13     13 0 43 my ( $self, $s ) = @_;
52              
53 13 50       45 $s = '0' unless defined $s;
54 13 50       30 $s = join( ', ', @{$s} ) if ( ref($s) eq 'ARRAY' );
  0         0  
55              
56             # Special XML entities are escaped
57 13         36 $s =~ s/&(?!#(x\w\w|\d+?);)/&/g;
58 13         20 $s =~ s/>/>/g;
59 13         19 $s =~ s/
60 13         18 $s =~ s/\"/"/g;
61 13         17 $s =~ s/\'/'/g;
62              
63             # Backtick is just a regular XML citizen
64             #$s=~s/\`/'/g;
65              
66             # Invalid XML characters are removed, not just escaped: \x00-\x08\x0b\x1f
67             # Tabs (\x09) and newlines (\x0a) are valid.
68 13         38 while ( $s =~ s/([\x00-\x08\x0b\x1f])/''/e ) {
  10         26  
69 10         26 my $char = q{'\\x} . sprintf( '%02X', ord($1) ) . q{'};
70 10         15 $self->error( $char => 'This forbidden XML character was removed' );
71             }
72              
73             # Per suggestion from Adam Schneider
74 13         19 $s =~ s/([\200-\377])/'&#'.ord($1).';'/ge;
  0         0  
75              
76 13         38 return $s;
77             }
78              
79             *xmlesc = \&xmlescp;
80              
81             *xmlescape = \&xmlescp;
82              
83             sub cssstyle {
84 5     5 0 15 my %attrs = @_;
85 5         18 return ( join( '; ', map { qq($_: ) . $attrs{$_} } sort keys(%attrs) ) );
  13         57  
86             }
87              
88             # Per suggestion from Adam Schneider
89             sub xmlattrib {
90 85     85 0 202 my %attrs = @_;
91 85 100       234 return '' unless ( scalar( keys %attrs ) );
92             return (
93             ' '
94             . join( ' ',
95 61         227 map { qq($_=") . $attrs{$_} . q(") } sort keys(%attrs) )
  275         780  
96             );
97             }
98              
99             sub xmltag {
100 36     36 0 87 my ( $name, $ns, %attrs ) = @_;
101 36 50       64 $ns = $ns ? "$ns:" : '';
102 36   100     87 my $at = xmlattrib(%attrs) || '';
103 36         149 return qq(<$ns$name$at />);
104             }
105              
106             sub xmltag_ln {
107 36     36 0 83 my ( $name, $ns, %attrs ) = @_;
108 36         116 return xmltag( $name, $ns, %attrs );
109             }
110              
111             sub xmltagopen {
112 49     49 0 111 my ( $name, $ns, %attrs ) = @_;
113 49 50       113 $ns = $ns ? "$ns:" : '';
114 49   100     134 my $at = xmlattrib(%attrs) || '';
115 49         209 return qq(<$ns$name$at>);
116             }
117              
118             sub xmltagopen_ln {
119 49     49 0 135 my ( $name, $ns, %attrs ) = @_;
120 49         141 return xmltagopen( $name, $ns, %attrs );
121             }
122              
123             sub xmlcomment {
124 22     22 0 62 my ( $self, $r_comment ) = @_;
125             my $ind = $self->{-docref}->{-elsep}
126 22         81 . $self->{-docref}->{-indent} x $self->{-docref}->{-level};
127              
128             # If the comment starts with newline character then do not prefix
129             # with space (RT #123896).
130             return (
131             $ind . join(
132             $ind,
133             map {
134 22 50       48 ( (/^\n/) ? (q()) : (q( -->)) );
136             } @$r_comment
137             )
138             );
139             }
140              
141             sub xmlpi {
142 2     2 0 4 my ( $self, $r_pi ) = @_;
143             my $ind = $self->{-docref}->{-elsep}
144 2         5 . $self->{-docref}->{-indent} x $self->{-docref}->{-level};
145 2         3 return ( join( $ind, map {qq()} @$r_pi ) );
  5         15  
146             }
147              
148             *processinginstruction = \&xmlpi;
149              
150             sub xmltagclose {
151 49     49 0 93 my ( $name, $ns ) = @_;
152 49 50       109 $ns = $ns ? "$ns:" : '';
153 49         134 return qq();
154             }
155              
156             sub xmltagclose_ln {
157 49     49 0 91 my ( $name, $ns ) = @_;
158 49         83 return xmltagclose( $name, $ns );
159             }
160              
161             sub dtddecl {
162 26     26 0 54 my $self = shift;
163 26   50     56 my $docroot = $self->{-docroot} || 'svg';
164 26         46 my $id;
165              
166 26 100       79 if ( $self->{-pubid} ) {
    50          
167 25         63 $id = 'PUBLIC "' . $self->{-pubid} . '"';
168 25 50       120 $id .= ' "' . $self->{-sysid} . '"' if ( $self->{-sysid} );
169             }
170             elsif ( $self->{-sysid} ) {
171 1         3 $id = 'SYSTEM "' . $self->{-sysid} . '"';
172             }
173             else {
174             $id
175             = 'PUBLIC "-//W3C//DTD SVG 1.0//EN"'
176             . $self->{-docref}->{-elsep}
177 0         0 . "\"$self->{-docref}->{-dtd}\"";
178             }
179              
180 26         74 my $at = join( ' ', ( $docroot, $id ) );
181              
182             #>>>TBD: add internal() method to return this
183             my $extension
184             = ( exists $self->{-internal} )
185             ? $self->{-internal}->render()
186 26 50       83 : q{};
187 26 100 66     111 if ( exists $self->{-extension} and $self->{-extension} ) {
188             $extension
189             .= $self->{-docref}{-elsep}
190             . $self->{-extension}
191 1         4 . $self->{-docref}{-elsep};
192             }
193 26 100       60 $extension = ' [' . $self->{-docref}{-elsep} . $extension . ']'
194             if $extension;
195              
196 26         114 return qq[$self->{-docref}{-elsep}];
197             }
198              
199             sub xmldecl {
200 21     21 0 34 my $self = shift;
201              
202 21   50     61 my $version = $self->{-version} || '1.0';
203 21   50     65 my $encoding = $self->{-encoding} || 'UTF-8';
204 21   50     50 my $standalone = $self->{-standalone} || 'yes';
205              
206             return
207 21         88 qq{};
208             }
209              
210             #-------------------------------------------------------------------------------
211              
212             1;