=pod
=head1 NAME
SVG::XML - Handle the XML generation bits for SVG.pm
=head1 AUTHOR
Ronan Oger, cpan@roitsystems.com
=head1 SEE ALSO
perl(1),L<SVG>,L<SVG::XML>,L<SVG::Element>,L<SVG::Parser>, L<SVG::Manual>
L<http://www.roitsystems.com/> ROASP.com: Serverside SVG server
L<http://www.roitsystems.com/> ROIT Systems: Commercial SVG perl solutions
L<http://www.w3c.org/Graphics/SVG/> SVG at the W3C
=cut
package SVG::XML;
use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT );
$VERSION = "2.50";
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(
xmlesc
xmlescape
xmlescp
cssstyle
xmlattrib
xmlcomment
xmlpi
xmltag
xmltagopen
xmltagclose
xmltag_ln
xmltagopen_ln
xmltagclose_ln
processtag
xmldecl
dtddecl
);
sub xmlescp ($$) {
my ($self,$s) = @_;
$s = '0' unless defined $s;
$s=join(', ',@{$s}) if(ref($s) eq 'ARRAY');
# Special XML entities are escaped
$s=~s/&(?!#(x\w\w|\d+?);)/&/g;
$s=~s/>/>/g;
$s=~s/</</g;
$s=~s/\"/"/g;
$s=~s/\'/'/g;
# Backtick is just a regular XML citizen
#$s=~s/\`/'/g;
# Invalid XML characters are removed, not just escaped: \x00-\x08\x0b\x1f
# Tabs (\x09) and newlines (\x0a) are valid.
while ( $s=~s/([\x00-\x08\x0b\x1f])/''/e ) {
my $char = "'\\x".sprintf('%02X',ord($1))."'";
$self->error( $char => "This forbidden XML character was removed");
}
# Per suggestion from Adam Schneider
$s=~s/([\200-\377])/'&#'.ord($1).';'/ge;
return $s;
}
*xmlesc=\&xmlescp;
*xmlescape=\&xmlescp;
sub cssstyle {
my %attrs=@_;
return(join('; ',map { qq($_: ).$attrs{$_} } keys(%attrs)));
}
# Per suggestion from Adam Schneider
sub xmlattrib {
my %attrs=@_;
return(join(' ',map { qq($_=").$attrs{$_}.q(") } sort keys(%attrs)));
}
sub xmltag ($$;@) {
my ($name,$ns,%attrs)=@_;
$ns=$ns?"$ns:":'';
my $at=' '.xmlattrib(%attrs)||'';
return qq(<$ns$name$at />);
}
sub xmltag_ln ($$;@) {
my ($name,$ns,%attrs)=@_;
return xmltag($name,$ns,%attrs);
}
sub xmltagopen ($$;@) {
my ($name,$ns,%attrs)=@_;
$ns=$ns?"$ns:":'';
my $at=' '.xmlattrib(%attrs)||'';
return qq(<$ns$name$at>);
}
sub xmltagopen_ln ($$;@) {
my ($name,$ns,%attrs)=@_;
return xmltagopen($name,$ns,%attrs);
}
sub xmlcomment ($$) {
my ($self,$r_comment) = @_;
my $ind = $self->{-docref}->{-elsep}.$self->{-docref}->{-indent} x $self->{-docref}->{-level};
return($ind.join($ind,map { qq(<!-- $_ -->)} @$r_comment));
}
sub xmlpi ($$) {
my ($self,$r_pi) = @_;
my $ind = $self->{-docref}->{-elsep}.$self->{-docref}->{-indent} x $self->{-docref}->{-level};
return(join($ind,map { qq(<?$_?>)} @$r_pi));
}
*processinginstruction=\&xmlpi;
sub xmltagclose ($$) {
my ($name,$ns)=@_;
$ns=$ns?"$ns:":'';
return qq(</$ns$name>);
}
sub xmltagclose_ln ($$) {
my ($name,$ns)=@_;
return xmltagclose($name,$ns);
}
sub dtddecl ($) {
my $self = shift;
my $docroot = $self->{-docroot} || 'svg';
my $id;
if ($self->{-pubid}) {
$id = 'PUBLIC "'.$self->{-pubid}.'"';
$id .= ' "'.$self->{-sysid}.'"' if ($self->{-sysid});
} elsif (
$self->{-sysid}) {
$id = 'SYSTEM "'.$self->{-sysid}.'"';
} else {
$id = 'PUBLIC "-//W3C//DTD SVG 1.0//EN"' .
$self->{-docref}->{-elsep}.
"\"$self->{-docref}->{-dtd}\""
}
my $at = join(' ',($docroot, $id));
#>>>TBD: add internal() method to return this
my $extension = (exists $self->{-internal})?$self->{-internal}->render():"";
if (exists $self->{-extension} and $self->{-extension}) {
$extension .= $self->{-docref}{-elsep}.
$self->{-extension}.
$self->{-docref}{-elsep};
}
$extension = " [".$self->{-docref}{-elsep}.$extension."]" if $extension;
return qq[$self->{-docref}{-elsep}<!DOCTYPE $at$extension>];
}
sub xmldecl ($) {
my $self = shift;
my $version= $self->{-version} || '1.0';
my $encoding = $self->{-encoding} || 'UTF-8';
my $standalone = $self->{-standalone} ||'yes';
return qq§<?xml version="$version" encoding="$encoding" standalone="$standalone"?>§;
}
#-------------------------------------------------------------------------------
1;