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+?);)/&amp;/g;
63    $s =~ s/>/&gt;/g;
64    $s =~ s/</&lt;/g;
65    $s =~ s/\"/&quot;/g;
66    $s =~ s/\'/&apos;/g;
67
68    # Backtick is just a regular XML citizen
69    #$s=~s/\`/&apos;/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