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