From c5866f304210618979d03c561b1e3f6f83200bce Mon Sep 17 00:00:00 2001 From: ribet Date: Wed, 21 Mar 2007 10:19:39 +0000 Subject: Import initial --- src/SVG/SVG2zinc.pm | 2245 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2245 insertions(+) create mode 100644 src/SVG/SVG2zinc.pm (limited to 'src/SVG/SVG2zinc.pm') diff --git a/src/SVG/SVG2zinc.pm b/src/SVG/SVG2zinc.pm new file mode 100644 index 0000000..f344b96 --- /dev/null +++ b/src/SVG/SVG2zinc.pm @@ -0,0 +1,2245 @@ +package SVG::SVG2zinc; +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU LGPL Libray General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU Library General Public License for more details. +# +# You should have received a copy of the GNU Library General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA, +# or refer to http://www.gnu.org/copyleft/lgpl.html +# +################################################################## + +# +# convertisseur SVG->TkZinc +# +# Copyright 2002-2003 +# Centre d'?tudes de la Navigation A?rienne +# +# Author: Christophe Mertz +# previously +# with many helps from +# Alexandre Lemort +# Celine Schlienger +# St?phane Chatty +# +# $Id: SVG2zinc.pm,v 1.6 2007-03-06 07:53:22 merlin Exp $ +############################################################################# +# +# this is the main module of the a converter from SVG file +# to either perl script/module (an eventually other scripting language) +# It is also usable to display SVG graphic file in Tk::Zinc + +############################################################################# +# limitations are now listed in the POD at the end of this file +############################################################################# + +use strict; +use XML::Parser; +use Carp; +use Math::Trig; +use English; +use File::Basename; + +use SVG::SVG2zinc::Conversions; + +use vars qw($VERSION $REVISION @ISA @EXPORT); +@EXPORT = qw( parsefile findINC ); + +$REVISION = q$Revision: 1.6 $ ; +$VERSION = "0.10"; + +# to suppress some stupid warning usefull for debugging only +my $warn=0; + +my $verbose; + +my $current_group; +my @prev_groups = (); +my %current_context; +my @prev_contexts = (); + +my $itemCount = 0; +my $effectiveItemCount = 0; # to know if some groups are empty (cf &defs et &defs_) +my $prefix; # prefix used in tags associated to generated items +my $colorSep = ";"; + +my $includeFollowingItems = 0; +my $targetName = ''; +my @nameStack = (); + +sub InitVars { + @prev_groups = (); + %current_context = (); + @prev_contexts = (); + $itemCount = 0; + $effectiveItemCount = 0; + $colorSep = ";"; + $includeFollowingItems = 0; + $targetName = ''; + @nameStack = (); +} + +# This hash table indicates all non-implemented extensions +# Normaly, the href extension is the only implemented extension listed in the SVG entity +# The hash-value associated to a not implemented etension is 0 +# The hash-value is then set to 1 when an warning message has been printed once +my %notImplementedExtensionPrefix; + + +# events on "graphics and container elements" +my @EVENT_ON_GRAPHICS = qw/ + onfocusin onfocusout onactivate onclick + onmousedown onmouseup onmouseover onmousemove onmouseout onload +/; +# events on "Document-level event attributes" +my @EVENT_ON_DOC = qw /onunload onabort onerror onresize onscroll onzoom/; +# events "Animation event attributes" +my @EVENT_ON_ANIM = qw /onbegin onend onrepeat/ ; + +my %EVENT_ON_GRAPHICS = map { $_ => 1 } @EVENT_ON_GRAPHICS; +my %EVENT_ON_DOC = map { $_ => 1 } @EVENT_ON_DOC; +my %EVENT_ON_ANIM = map { $_ => 1 } @EVENT_ON_ANIM; + + +### @STYLE_ATTRS and %STYLE_ATTRS are "constant" array and hash used in +#### &analyze_style , &analyze_text_style , &groupContext , &attrs_implemented +my @STYLE_ATTRS = qw( + class style display ddisplay fill fill-opacity fill-rule stroke + stroke-width stroke-opacity opacity font-size font-family + font-weight stroke-linejoin stroke-linecap stroke-dasharray text-anchor +) ; +my %STYLE_ATTRS = map { $_ => 1 } @STYLE_ATTRS; + +#### not implemented / not implementable attributes +#### these attributes will generate only limited warning +#### used in &attrs_implemented +my @STYLE_ATTRS_NYI = qw ( + stroke-miterlimit + gradientUnits gradientTransform spreadMethod + clip-rule clip-path + name +) ; # what is the foolish name? +my %STYLE_ATTRS_NYI = map { $_ => 1 } @STYLE_ATTRS_NYI; + +#### not yet implemented tags (to avoid many many error messages) +#### this list could be used to clearly distinguishe TAGS +#### not yet implemented or not implementable. +#### This list is curently not used! consider it as a piece of comment! +my @NO_YET_IMPLEMENTED_TAGS = qw ( midPointStop filter feColorMatrix feComponentTransfer feFuncA); + +my $fileDir; ## in fact this could be a part of an url + ## but we currently only get files in the some directories +my $backend; ## the backend used to produce/interpret perl or tcl or whatever... + +my $expat; +sub parsefile { + my ($svgfile, $backendName, %args) = @_; + &InitVars; + $fileDir = dirname($svgfile)."/"; + $targetName = defined $args{-target} ? $args{-target}: ''; + delete ($args{"-target"}); + $includeFollowingItems = $targetName ne '' ? 0 : 1; + $verbose = defined $args{-verbose} ? $args{-verbose}: 0; + $prefix = defined $args{-prefix} ? $args{-prefix} : ""; + delete $args{-prefix}; + my $namespace = defined $args{-namespace} ? $args{-namespace} : 0; + delete $args{-namespace}; + &SVG::SVG2zinc::Conversions::InitConv(\&myWarn, \¤t_line); + require SVG::SVG2zinc::Backend::PerlClass; + $backend = SVG::SVG2zinc::Backend::PerlClass -> new (-in => $svgfile, %args); + $current_group = $backend -> _topgroup; + $backend -> fileHeader; + my $parser = new XML::Parser( + Style => 'SVG2zinc', + Namespaces => $namespace, # well this works for dia shape dtd! + Pkg => 'SVG::SVG2zinc', + ErrorContext => 3, + ); + $parser -> setHandlers( + Char => \&Char, + Init => \&Init, + Final => \&Final, + XMLDecl => \&XMLDecl, + ); + my $svg = $parser->parsefile($svgfile); + $backend -> fileTail; + &print_warning_for_not_implemented_attr; +} + +## as it seems that some svg files are using differencies between dtd 1.0 and 1.1 +## we need to know which version of the dtd we are using (defaulted to 1.0) +my $dtdVersion; +sub XMLDecl { + my ($parser, $Version, $Encoding, $Standalone) = @_; + if (defined $Version) + { + $dtdVersion = $Version; + } + else + { + $dtdVersion = 1.0; + } +} + + + +# the svg tags are translated in group items. +# If the SVG tag contains both width and height properties +# they will be reported in the generated group as tags : +# 'height=xxx' 'width=xxx' + +sub svg { +} + +sub svgold { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + delete $attrs{xmlns}; # this attribute is mandatory, but useless for SVG2zinc + + my ($width,$height)=&sizesConvert( \%attrs , qw (width height)); #! this defines the Zinc size! + # case when the width or height is defined in % + # the % refers to the size of an including document + undef $width if defined $attrs{width} and $attrs{width} =~ /%/ ; + undef $height if defined $attrs{height} and $attrs{height}=~ /%/ ; + my $widthHeightTags=""; + if (defined $width and defined $height) + { + $widthHeightTags = ", 'width=" . &float2int($width) . + "', 'height=" . &float2int($height) . "'"; + } + if (!@prev_contexts) + { # we are in the very top svg group! + $widthHeightTags .= ", 'svg_top'"; + } + my $res = "->add('group',$current_group, -tags => [$name$widthHeightTags], -priority => 10"; + unshift @prev_contexts, \%current_context; + my $prop; + ($prop, %current_context) = &groupContext ($name, %attrs); + $res .= $prop . ");"; + + unshift @prev_groups, $current_group; + foreach my $attr (keys %attrs) + { + if ($attr =~ /^xmlns:(.+)/ ) + { + my $extensionPrefix = $1; + # this xlink extension is only partly implemented + # (ie. when the url refers an image file in the same directory than the SVG file) + next if ($extensionPrefix eq 'xlink'); + print "$extensionPrefix is not implemented\n"; + $notImplementedExtensionPrefix{$extensionPrefix} = 0; + } + } + &attrs_implemented ( 'svg', $name, + [qw ( id width height viewBox preserveAspectRatio xmlns), + # the following attributes are not currently implementable + qw ( enable-background overflow )], %attrs + ); + &stackPort($name, $width,$height, $attrs{viewBox}, $attrs{preserveAspectRatio}); + &display ($res); +} + +my @portStack; +sub stackPort { +# my ($name, $width,$height,$viewbox,$aspectRatio)=@_; + unshift @portStack, [ @_ ]; +} + +## to treat the viewbox, preserveAspectRatio attributes +## of the svg, symbol, image, foreignObject... entities +sub viewPortTransforms { + my $portRef = shift @portStack; + my ($name, $width,$height,$viewbox,$aspectRatio)=@{$portRef}; + $viewbox = "" unless defined $viewbox; + $aspectRatio = "" unless defined $aspectRatio; + $width = "" unless defined $width; + $height = "" unless defined $height; +# print "In $name: width=$width height=$height viewbox=$viewbox aspectRatio=$aspectRatio\n"; + if ($viewbox and $width and $height ) { + my $expr = "->adaptViewport($name, $width,$height, '$viewbox', '$aspectRatio');"; +# print "Expr = $expr\n"; + &display($expr); +# if (!$aspectRatio or $aspectRatio eq "none") { +# my $translateX = $minx; +# my $translateY = $miny; +# my $scaleX= $width / ($portWidth - $minx); +# my $scaleY= $height / ($portHeight - $miny); +# @transfs = ("->translate($name, $translateX, $translateY);", +# "->scale($name, $scaleX, $scaleY);"); +# &display(@transfs); + } +} + + +sub svgold_ { + my ($parser, $elementname) = @_; + print "############ End of $elementname:\n" if $verbose; + &viewPortTransforms; + $current_group = shift @prev_groups; + %current_context = %{shift @prev_contexts}; +} + +# just to avoid useless warning messages +sub desc {} +sub desc_ { } + +# just to avoid useless warning messages +sub title {} +sub title_ { } + +# just to avoid useless warning messages in svg tests suites +sub Paragraph {} +sub Paragraph_ { } + +## return either the id of the object or a name of the form '____<$counter>' +## the returned named includes single quotes! +## it also increments two counters: +## - the itemCount used for naming any item +## - the effectiveItemCount for counting graphic items only +## This counter is used at the end of a defs to see if a group +## must be saved, or if the group is just empty +sub name { + my ($type, $id) = @_; + print "############ In $type:\n" if $verbose; + $itemCount++; + $effectiveItemCount++ if (defined $id and + $type ne 'defs' and + $type ne 'switch' and + $type ne 'g' and + $type ne 'svg' and + $type !~ /Gradient/ + ); + if (defined $id) { + $id = &cleanName ($id); + return ("'$id'", 1); + } else { + return ("'" . $prefix . "__$type"."__$itemCount'",0); + } +} + +sub g { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + %attrs = &expandAttributes ($elementname, %attrs); + my ($name,$natural) = &name ($elementname, $attrs {id}); + my $res = '$parent = $previous = '." -> add ('group', $current_group, -tags => [$name], -priority => 10"; + unshift @prev_groups, $current_group; + $current_group = '$parent'; + unshift @prev_contexts, \%current_context; + my $prop; + ($prop, %current_context) = &groupContext ($name, %attrs); + $res .= $prop . ");\n"; + $res .= 'push (@parents, $parent);'; + &attrs_implemented ( 'g', $name, [qw ( id transform ) , @EVENT_ON_GRAPHICS ], %attrs ); ### les styles attrs sont ? traiter ? part! + &ddisplay ($res, &transform('$previous', $attrs{transform})); + &treatGroupEvent ($name, %attrs); +} + +## returns true if the parameter is an EVENT_ON_GRAPHICS (ie. applies only to group-like tags) +sub isGroupEvent { + my ($attr) = @_; + return $EVENT_ON_GRAPHICS{$attr} or 0; +} + +## should bing callbacks to group, depending on events and scripts... +## not yet implemented +sub treatGroupEvent { + my ($objname, %attr) = (@_); + foreach my $event (@EVENT_ON_GRAPHICS) + { + my $value = $attr{$event}; + next unless defined $value; + # print "## $objname HAS EVENT $event = $value\n"; + # XXX what should I do here? + } +} + +sub groupContext { + my ($name, %attrs) = @_; + my %childrenContext; + my $prop = ""; + foreach my $attr (keys %attrs) + { + my $value = $attrs{$attr}; + if (!defined $value) + { + &myWarn ("!! Undefined value for attribute $attr in group $name !?"); + next; + } + elsif (&isGroupEvent ($attr)) + { + next; + } + $value = &removeComment($value); + if ($attr eq 'opacity') + { + $value = &convertOpacity ($value); + $prop = sprintf ", -alpha => %i", &float2int($value * 100); + } + elsif ($attr eq 'id' or $attr eq 'transform') + { + next; + } + elsif ($attr eq 'display' and $value eq 'none') + { + $prop .= ", -visible => 0, -sensitive => 0"; + &myWarn ("!! The following group is not visible: $name !?\n"); + } + elsif (&isAnExtensionAttr($attr)) + { + next; + } + elsif ($attr eq 'viewBox' or $attr eq 'preserveAspectRatio' or $attr eq 'height' or $attr eq 'width') + { + + } + elsif (!defined $STYLE_ATTRS{$attr}) + { + if (defined $STYLE_ATTRS_NYI{$attr}) + { + ¬_implemented_attr($attr); + } + else + { + &myWarn ("!!! Unimplemented attribute '$attr' (='$value') in group $name\n"); + } + next; + } + else + { + $childrenContext{$attr} = $value; + } + } + print "children context: ", join (", ", (%childrenContext)) , "\n" if $verbose; + return ($prop, %childrenContext); +} + + +sub g_ { + my ($parser, $elementname, %attrs) = @_; + if( !$includeFollowingItems ) + { + return; + } +# $current_group = shift @prev_groups; + if (!defined $attrs{opacity_group}) + { + %current_context = %{shift @prev_contexts}; + } + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } + my $res = 'pop (@parents);'."\n"; + $res .= '$parent = $parents [$#parents];'."\n"; + &ddisplay ($res); +} + +## A switch is implemented as a group. +## BUG: In fact, we should select either the first if the tag is implemented +## or the secund sub-tag if not. +## In practice, the first sub-tag is not implemented in standard SVG, so we +## we forget it and take the second one. +## A problem will appear if the first tag is implemented, because, in this case +## we will instanciantes both the first and second +sub switch { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + my ($name) = &name ($elementname, $attrs{id}); + $name =~ s/\'//g; + $attrs{id} = $name; + &g($parser, $elementname, %attrs); +} + +sub switch_ { + &g_; +} + +# a clipath is a not-visible groupe whose items define a clipping area +# usable with the clip-path attribute +# BUG: currently, the clipping is not implemented, but at least clipping +## items are put in a invisible sub-group and are not displayed +sub clipPath { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + print "In clippath $name NYI\n"; + my $res = "->add('group',$current_group, -tags => [$name, '__clipPath'], -priority => 10, -atomic => 1, -visible => 0"; + unshift @prev_groups, $current_group; + unshift @prev_contexts, \%current_context; + my $prop; + ($prop, %current_context) = &groupContext ($name, %attrs); + $res .= $prop . ");"; + &display ($res, &transform('$previous', $attrs{transform})); +} + +sub clipPath_ { + my ($parser, $elementname) = @_; + print "############ End of $elementname:\n" if $verbose; + %current_context = %{shift @prev_contexts}; +} + +# a symbol is a non-visible group which will be instancianted (cloned) +# latter in a tag +sub symbol { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + ## should we verify that the clippath has an Id? + ## should we verify that is defined inside a tag? + my $res = "-> add('group', $current_group, -tags => [$name], -priority => 10, -atomic => 1, -visible => 0"; + unshift @prev_groups, $current_group; + unshift @prev_contexts, \%current_context; + my $prop; + ($prop, %current_context) = &groupContext ($name, %attrs); + $res .= $prop . ");"; +# &attrs_implemented ( 'g', $name, [qw ( id transform ) , @EVENT_ON_GRAPHICS ], %attrs ); ### les styles attrs sont ? traiter ? part! + &display ($res, &transform('$previous', $attrs{transform})); +# &treatGroupEvent ($name, %attrs); +} + +sub symbol_ { + my ($parser, $elementname) = @_; + print "############ End of $elementname:\n" if $verbose; +# $current_group = shift @prev_groups; + %current_context = %{shift @prev_contexts}; +} + +# this will clone and make visible either symbols or other items based on the Id refered by the xlink:href attribute +sub use { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + my $ref = $attrs{'xlink:href'}; + if (!defined $ref) { + &myWarn ("!! $elementname must have a xlink:href attribute\n"); + return; + } + $ref =~ s/\#//; + my $cleanedId = &cleanName($ref); # to make the name zinc compliant + my $res = "-> clone ('$cleanedId', -visible => 1, -tags => [$name, 'cloned_$cleanedId']"; + $res .= &analyze_style (\%attrs); + $res .=");"; + my ($x,$y,$width,$height) = ($attrs{x},$attrs{y},$attrs{width},$attrs{height}); + my @transforms = "-> chggroup ($name, $current_group);"; + if (defined $x) + { + push @transforms, "-> translate ($name, $x,$y);"; + } + &display ($res,@transforms); +} + +{ ## start of defs block to share $res and other variables between many functions + + ## XXX: BUG this code DOES NOT allow recursive defs! (this is also probably a bug in the SVG file) + my $defsCounter = 0; + my $insideGradient = 0; ## should never exceed 1! + my $res; # the current gradient/object being defined + my $defsId; # the group id containing items to be cloned + # this group will be deleted later if it is empty + + my $effectiveItem; + ## a will generate the creation of an invisible group in Tk::Zinc + ## to be cloned latter in a tag + ## This group can be potentialy empty and in this cas it would be better + ## not to create it, or at least delete it latter if it is empty + + sub defs { + } + + sub defsold { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + ($defsId) = &name ($elementname, $attrs{id}); + $defsId =~ s/\'//g; + $attrs{id} = $defsId; + &g($parser, $elementname, %attrs); + &display("-> itemconfigure ('$defsId', -visible => 0);"); + $defsCounter++; + $effectiveItem = $effectiveItemCount; + print "############ $elementname: $defsId\n" if $verbose; + } + +sub defsold_ { + my ($parser, $elementname) = @_; + $defsCounter++; +# print "end of defs $defsId:", $effectiveItemCount , $effectiveItem, "\n"; + &g_; + if ($effectiveItemCount == $effectiveItem) { + &display ("-> remove ('$defsId');"); + } +} + + +###################################################################### +### CSS : Cascading Style Sheet +###################################################################### +{ ### css + my @styles; + my %classes; + my %elementClasses; + my %idClasses; + my $in_css=0; +sub nextStyle { + my $text = shift; + push @styles,$text; +# print "Style: $text\n"; +} + +## returns a reference to a hash-table defining pair of (attribut value) describing +## a CSS style associated to a Class +## returns undef if such class is not defined +sub getClass { + my $class = shift; + my $ref_styles = $classes{$class}; +# print "in getClass: $class ",%classes, "\n"; +# my %styles = %{$ref_styles}; print "in getClass: $class ", (%styles), "\n"; + return ($ref_styles); +} + +## returns a reference to a hash-table defining pair of (attribut value) describing +## a CSS style associated to an element type +## returns undef if such element type is not defined +sub getElementClass { + my $element = shift; + my $ref_styles = $elementClasses{$element}; +# my %styles = %{$ref_styles}; +# print "in getElementClass: $element ", (%styles), "\n"; + return ($ref_styles); +} + +## returns a reference to a hash-table defining pair of (attribut value) describing +## a CSS style associated to an Id +## returns undef if such class is not defined +sub getIdClass { + my $id = shift; + my $ref_styles = $idClasses{$id}; +# my %styles = %{$ref_styles}; +# print "in getIdClass: $id ", (%styles), "\n"; + return ($ref_styles); +} + +sub style { + my ($parser, $elementname, %attrs) = @_; + if ($attrs{type} eq "text/css") { + $in_css=1; + } +} # end of style + +sub style_ { + my ($parser, $elementname) = @_; + my $str = ""; + foreach my $s (@styles) { + $s = &removeComment($s); + $s =~ s/\s(\s+)//g ; # removing blocks of blanks + $str .= " " . $s; + } +# print "in style_: $str\n"; + while ($str) { +# print "remaning str in style_: $str\n"; + if ($str =~ /^\s*\.(\S+)\s*\{\s*([^\}]*)\}\s*(.*)/ ) { + # class styling + my ($name,$value) = ($1,$2); + $str = $3; +# $value =~ s/\s+$//; + print "STYLE of class: '$name' => '$value'\n"; + ## and now do something! + my %style = &expandStyle($value); + $classes{$1} = \%style; + } elsif ( $str =~ /^\s*\#([^\{]+)\s*\{\s*([^\}]*)\}\s*(.*)/ ) { + my ($ids,$value) = ($1,$2); + $str = $3; + print "STYLE of ids: '$ids' => '$value'\n"; + ## and now do something! + } elsif ( $str =~ /^\s*\[([^\{]+)\]\s*\{\s*([^\}]*)\}\s*(.*)/ ) { + my ($attr_val,$value) = ($1,$2); + $str = $3; + print "STYLE of attr_values: '$attr_val' => '$value'\n"; + ## and now do something! + } elsif ( $str =~ /^\s*\@font-face\s*\{\s*[^\}]*\}\s*(.*)/ ) { + print "STYLE of font-face", substr($str, 0, 100),"....\n"; + $str = $1; + } elsif ( $str =~ /^\s*([^\s\{]+)\s*\{\s*([^\}]*)\}\s*(.*)/ ) { + my ($name,$value) = ($1,$2); + $str = $3; + print "STYLE of tags: '$name' => '$value'\n"; + ## and now do something... NYI + } else { + &myWarn ("unknown style : $str\nskipping this style"); + return; + } + } + $in_css=0; + @styles=(); +} # end of style_ + +} ### end of css + +###################################################################### +### gradients +###################################################################### + +my $gname; +my @stops; +my @inheritedStops; +my $angle; +my $center; +my $gradientUnits; +my @linearCoords; +my @transformsGrad; + +sub radialGradient { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + &myWarn ("!! $elementname must have an id\n") unless $natural; + $gname = substr ($name,1,-1); # remove quote (') at the very beginning and end of $name + $insideGradient ++; + &myWarn ("Gradient '$gname' definition inside a previous gradient definition. This is bug in svg source\n") + unless $insideGradient == 1; + @stops = (); + @inheritedStops = (); + if (defined $attrs{'xlink:href'}) + { + my $unused; + my $link = delete $attrs{'xlink:href'}; + if ($link =~ /^\#(.+)$/) + { + $link = $1; + @inheritedStops = @{getGradient ($link)}; + } + else + { + # BUG??: we only treat internal links like #gradientName + carp "bad link towards a gradient: $link"; + } + } + my ($fx,$fy,$cx,$cy, $r) = &sizesConvert( \%attrs , qw (fx fy cx cy r)); + # BUG: a serious limitation is that TkZinc (3.2.6i) does not support + # the cx, cy and r parameters + $gradientUnits = $attrs{gradientUnits} ? $attrs{gradientUnits} : 'objectBoundingBox'; + if (defined $cx and $cx == $fx) { delete $attrs{cx}; } # to avoid needless warning of &attrs_implemented + if (defined $cy and $cy == $fy) { delete $attrs{cy}; } # to avoid needless warning of &attrs_implemented + &attrs_implemented ( 'radialGradient', $name, [qw ( id fx fy r gradientUnits)], %attrs ); + + $fx = &float2int(($fx -0.5) * 100); + $fy = &float2int(($fy -0.5) * 100); + @linearCoords = ($fx, $fy); +# $center = "$fx $fy"; +} + +sub radialGradient_ { + $insideGradient --; + if (!@stops) { + if (@inheritedStops) { + @stops = @inheritedStops; + } else { + carp ("Bad gradient def: nor stops, neither xlink;href"); + } + } + my @stps = @stops; + my @co = @linearCoords; + my $gradientDefs = {type => 'radial', coords => \@co, stops => \@stps, gradientUnits => $gradientUnits, transform => []}; + recordGradient ($gname, $gradientDefs); + @stops = (); +} + +sub linearGradient { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + &myWarn ("!! $elementname must have an id\n") unless $natural; + $gname = substr ($name,1,-1); # remove quote (') at the very beginning and end of $name + $insideGradient ++; + &myWarn ("Gradient '$gname' definition inside a previous gradient Definition. This will bug\n") + unless $insideGradient == 1; + @stops = (); + @inheritedStops = (); + if (defined $attrs{'xlink:href'}) + { + my $unused; + my $link = delete $attrs{'xlink:href'}; + if ($link =~ /^\#(.+)$/) + { + $link = $1; + @inheritedStops = @{getGradient ($link)}; + } + else + { + # BUG??: we only treat internal links like #gradientName + carp "bad link towards a gradient: $link"; + } + } + &attrs_implemented ( 'linearGradient', $name, [qw (gradientTransform x1 x2 y1 y2 id gradientUnits)], %attrs ); + @linearCoords = &sizesConvert( \%attrs , qw (x1 y1 x2 y2)); + @transformsGrad = parseGradientTransforms ($attrs{'gradientTransform'}); + $gradientUnits = $attrs{gradientUnits} ? $attrs{gradientUnits} : 'objectBoundingBox'; +} + +sub linearGradient_ { + $insideGradient --; + if (!@stops) + { + if (@inheritedStops) + { + @stops = @inheritedStops; + } + else + { + carp ("Bad gradient def: nor stops, neither xlink;href"); + } + } + my @stps = @stops; + my @co = @linearCoords; + + my @transform = @transformsGrad; + my $gradientDefs = {type => 'axial', coords => \@co, stops => \@stps, gradientUnits => $gradientUnits, transform => \@transform}; + recordGradient ($gname, $gradientDefs); +} + +sub parseGradientTransforms { + my ($str) = @_; + return (1,0,0,1,0,0) if !defined $str; + my @fullTrans; + + while ($str) { + my ($trans, $params, $rest) = $str =~ /\s*(\w+)\s*\(([^\)]*)\)\s*(.*)/ ; + + my @params = (defined $params) ? split (/[\s,]+/, $params) : (); + + if (!(defined $trans)) { + } elsif ($trans eq 'translate') { + $params[1] = 0 if scalar @params == 1; + push @fullTrans, [1,0,0,1,@params]; + + } elsif ($trans eq 'rotate') { + my $angle = $params[0] = °2rad($params[0]); + push @fullTrans, [cos($angle),sin($angle),-sin($angle),cos($angle),0,0]; + + } elsif ($trans eq 'scale') { + $params[1] = $params[0] if scalar @params == 1; + push @fullTrans, [$params[0],0,0,$params[1],0,0]; + + } elsif ($trans eq 'matrix') { + push @fullTrans, [@params]; + + } elsif ($trans eq 'skewX') { + $params[0] = °2rad($params[0]); + push @fullTrans, [1,0,tan($params[0]),1,0,0]; + + } elsif ($trans eq 'skewY') { + $params[0] = °2rad($params[0]); + push @fullTrans, [1,tan($params[0]),0,1,0,0]; + + } elsif ($trans eq 'skew'){ + myWarn ("!!! Transformation $trans NOT implemented\n"); + + } else { + myWarn ("!!! Unkown transformation '$trans'\n"); + } + $str = $rest; + } + + my @transList = reverse @fullTrans; + my @matrix = (1,0,0,1,0,0); + + foreach my $trans (@transList) { + my @t = @{$trans}; + + my $a00 = $t[0] * $matrix[0] + $t[2] * $matrix[1]; + my $a01 = $t[1] * $matrix[0] + $t[3] * $matrix[1]; + my $a10 = $t[0] * $matrix[2] + $t[2] * $matrix[3]; + my $a11 = $t[1] * $matrix[2] + $t[3] * $matrix[3]; + my $a20 = $t[0] * $matrix[4] + $t[2] * $matrix[5] + $t[4]; + my $a21 = $t[1] * $matrix[4] + $t[3] * $matrix[5] + $t[5]; + + @matrix = ($a00,$a01,$a10,$a11,$a20,$a21); + } + return (@matrix); +} + +sub stop { + my ($parser, $elementname, %attrs) = @_; + %attrs = &expandAttributes ($elementname,%attrs); + &myWarn ("$elementname should be defined inside or \n") unless $insideGradient; + + my $style = delete $attrs{'style'}; + if (defined $style) { + my %keyvalues = &expandStyle($style); + %attrs = (%attrs , %keyvalues); + } + my $offset = $attrs{'offset'}; + my $color = $attrs{'stop-color'}; + if (!defined $color) { + &myWarn ("!! Undefined stop-color in a \n"); + } elsif (!defined $offset) { + &myWarn ("!! Undefined offset in a \n"); + } else { + if ($offset =~ /([\.\d]+)%/){ + $offset = &float2int($1); +# } elsif ($offset =~ /^([.\d]+)$/) { +# $offset = &float2int($1*100); + } else { + $offset = &float2int($offset*100); + } + my ($newcol, $gd) = &colorConvert($color); + if ($newcol ne '') + { + $color = $newcol; + } + if (defined (my $stopOpacity = $attrs{'stop-opacity'})) { + $stopOpacity = &float2int($stopOpacity*100); + push @stops, "$color$colorSep$stopOpacity $offset"; + } else { + push @stops, "$color $offset"; + } + } +} # end of stop + +} # end of gradient closure + + +my $opacity_group = 100; +my $start_opacity_group = 0; + +sub start_opacity_gp { + my ($parser, $elementname, $alpha) = @_; + if ($start_opacity_group) + { + my $res = '$parent ='." -> add ('group', $current_group, -priority => 10, -alpha => $opacity_group);"; + unshift @prev_groups, $current_group; + $current_group = '$parent'; + $res .= 'push (@parents, $parent);'; + return $res; + } + return ''; +} + +sub close_opacity_gp { + my ($parser, $elementname, $alpha) = @_; + if ($start_opacity_group) + { + my $res = 'pop (@parents);'."\n"; + $res .= '$parent = $parents [$#parents];'."\n"; + $start_opacity_group = 0; + return $res; + } + return ''; +} + +my %convertFormat = ( + 'jpg' => 'jpeg', + 'jpeg' => 'jpeg', + 'png' => 'png', +); + +sub image { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + + my $group = $current_group; + my @RES; + if (my $opacity = $attrs{'opacity'}) + { + # creating an intermediate group for managing the transparency + # BUG: we could used the attribute -color := white:$opacity + $opacity = &convertOpacity ($opacity); + if ($opacity != 1) + { + ## on cr?e un groupe pour g?rer la transparence + my $opacity = &float2int(100 * $opacity); + my $newgroup = substr ($name, 0, -1) . "transparency'"; + push @RES , '$previous = '." -> add('group', $current_group, -alpha => $opacity, -tags => [ $newgroup ], -priority => 10);\n"; + $group = $newgroup; + } + } + my $res = ""; + my $ref = ""; + if ($ref = $attrs {'xlink:href'}) + { + if ($ref =~ /^data:image\/(\w+);base64,(.+)/) + { + my $format = $1; + my $data = $2; + $ref = "data:image/$format;base64"; # $ref is used later in a tag of the icon + $format = $convertFormat {lc($format)}; + $res .= '$previous = '." -> add ('icon', $group, -image => -> Photo (-data => '$data', -format => '$format')"; + } + elsif ($ref =~ /^data:;base64,(.+)/) + { + ## the following piece of code works more or less ?! + ## BUG: there is a pb with scaling (ex: data-svg/vero_data/propal_crea_boutons.svg) + my $data = $1; + $ref = "data:;base64"; + $res .= '$previous = '." -> add ('icon',$group, -image => -> Photo (-data => '$data')"; + } + else + { + if (open REF, "$fileDir$ref") + { + close REF; + $res .= '$previous = '." -> add ('icon',$group, -image => -> Photo ('$ref', -file => '$fileDir$ref')"; + } + else + { + &myWarn ("When parsing the image '$name': no such file: '" . substr ("$fileDir$ref", 0,50) . "'\n") ; + return; + } + } + } + else + { + &myWarn ("Unable to parse the image '$name'") ; + return; + } + + $res .= ", -tags => [$name, '$ref'], -composescale => 1, -composerotation => 1, -priority => 10);"; + push @RES, $res ; + + my ($x, $y, $width, $height) = &sizesConvert ( \%attrs , qw (x y width height)); + if ($width == 0 or $height == 0) + { + &myWarn ("Skipping a 0 sized image: '$name' size is $width x $height\n"); + } + elsif ($width < 0 or $height < 0) + { + &myWarn ("Error in the size of the image '$name' : $width x $height\n"); + } + else + { + #push @RES, " -> adaptViewport ($name, $width,$height);"; + } + if ($x or $y) + { + push @RES, " -> translate (\$previous, $x,$y);"; + } + + &attrs_implemented ( 'image', $name, [qw (transform x y width height id )], %attrs ); + &ddisplay (@RES, &transform('$previous', $attrs{transform})); +} # end of image + +sub image_ { + my ($parser, $elementname, %attrs) = @_; + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } +} + +sub line { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + my $res = "->add ('curve', $current_group, [$attrs{x1}, $attrs{y1}, $attrs{x2}, $attrs{y2}], -priority => 10"; + $res .= ", -tags => ['line'"; + $res .= ", $name" if ($natural or $attrs{transform}); + $res .= "]"; + $res .= &analyze_style (\%attrs); + $res .=");"; + &attrs_implemented ( 'line', $name, [qw (x1 y1 x2 y2 style id transform )], %attrs ); + &ddisplay ($res, + &transform('$previous', $attrs{transform}) ); +} # end of line + +sub line_ { + my ($parser, $elementname, %attrs) = @_; + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } +} + +sub Char { + my ($expat, $text) = @_; + return if !defined $text; + my $type = ($expat->context)[-1]; + return if !defined $type; + chomp $text; + return if (!$text && ($text ne "0")); # empty text! + if ($type eq 'tspan') + { + &nextText ($text); + } + elsif ($type eq 'style') + { + &nextStyle ($text); + } +} # end of char + +my $current_font_key = ''; +my %save_current_context = (); + +## this lexical block allows &text, &nextTetx, &tspan, and &text_ to share common variables +{ + my $res; + my @transforms; + my @texts; + my $text_x; + my $text_y; + sub text + { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + + my $prop; + %save_current_context = %current_context; + ($prop, %current_context) = &groupContext ("", %attrs); + + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + ($text_x, $text_y) = &sizesConvert( \%attrs , qw (x y)); + $res = "->add('text',$current_group, -composescale => 1, -composerotation => 1, -position => [0, 0], -tags => ['text'"; + $res .= ", $name" if ($natural or $attrs{transform}); + $res .= "], -anchor => 'nw'"; + $res .= &analyze_text_style (\%attrs); + @texts = (); + @transforms = &transform('$previous', $attrs{transform}); + &attrs_implemented ( 'text', $name, [qw (stroke-miterlimit x y id transform text-anchor font-family font-size)], %attrs ); + } + + sub nextText { + my $txt = shift; + push @texts,$txt; + } + + ## BUG: tags can be used to modiofy many graphics attributs of the part of the text + ## such as colors, fonte, size and position... + ## this is currently hard to implement as in Tk::Zinc a text item can only have one color, one size... + sub tspan { + my ($expat, $elementname, %attrs) = @_; + $res .= &analyze_text_style (\%attrs); + } + + sub text_ { + my ($parser, $elementname, %attrs) = @_; + if( !$includeFollowingItems ) + { + return; + } + for (my $i=0 ; $i <= $#texts ; $i++) + { + $texts[$i] =~ s/\'/\\'/g ; #' + } + my $theText = join ('', @texts); + $res .= ", -text => '$theText', -priority => 10);"; + my @ascent; + if ($text_x != 0 || $text_y != 0) + { + push (@ascent, "-> translate(\$previous, $text_x, $text_y);"); + } + push (@ascent, "my \$ascent = -> fontMetrics (\$fonts{\"$current_font_key\"}, -ascent);"); + push (@ascent, "-> translate(\$previous,0, -\$ascent);"); + + &ddisplay ($res, @ascent, @transforms); + + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } + %current_context = %save_current_context; + + } + +} ## end of text lexical block + +sub polyline { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + my $res = "->add('curve',$current_group,[" . &points(\%attrs); + $res .= "], -tags => ['polyline'"; + $res .= ", $name" if ($natural or $attrs{transform}); + $res .= "], -priority => 10"; + $res .= &analyze_style (\%attrs); + $res .=");"; + &attrs_implemented ( 'polyline', $name, [qw (points style transform id )], %attrs ); + &ddisplay ($res, + &transform('$previous', $attrs{transform}) ); +} + +sub polyline_ { + my ($parser, $elementname, %attrs) = @_; + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } +} + +my $add_stroke = 0; + +sub rect { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + my ($x,$y,$width,$height)=&sizesConvert( \%attrs , qw (x y width height)); + + my ($type, $path) = getRectData ($x, $y, $width, $height, $attrs {rx}, $attrs {ry}); + + $add_stroke = 0; + + my $res = "\$previous = -> add('$type',$current_group, [$path], -tags => ['rect'"; + $res .= ", $name" if ($natural or $attrs{transform}); + $res .= "], -priority => 10"; + + $res .= ", -filled => 1" unless defined $attrs{fill} and $attrs{fill} eq 'none'; + $add_stroke = 1 if defined $attrs{stroke}; + delete $attrs{'stroke-linejoin'}; ## BUG: due to TkZinc limitation: no -joinstyle for rectangle + $res .= &analyze_style (\%attrs); + $res .= ", -linewidth => 0" if !$add_stroke; + $res .=");"; + &attrs_implemented ( 'rect', $name, [qw (id x y width height style transform rx ry )], %attrs ); + &ddisplay ($res, + &transform('$previous', $attrs{transform}) ); +} + +sub getRectData { + my ($x, $y, $width, $height, $rx, $ry) = @_; + my $xf = $x + $width; + my $yf = $y + $height; + if (( !defined $rx ) && ( !defined $ry )) + { + return ('rectangle', "$x,$y, ".($x+$width).','.($y+$height)); + } + + $rx = (defined $rx) ? $rx : $ry; + $ry = (defined $ry) ? $ry : $rx; + $rx = 0 if ($rx < 0); + $ry = 0 if ($ry < 0); + $rx = ($rx > $width / 2) ? $width / 2 : $rx; + $ry = ($ry > $width / 2) ? $width / 2 : $ry; + + my $c = (sqrt (2) - 1) * 4/3; + my $retour = "[$x + $rx, $y], [$x + (1 - $c) * $rx, $y, 'c'],"; + $retour .= "[$x, $y + (1 - $c) * $ry, 'c'], [$x, $y + $ry],"; + $retour .= "[$x, $yf - $ry], [$x, $yf - (1 - $c) * $ry, 'c'],"; + $retour .= "[$x + (1 - $c) * $rx, $yf, 'c'], [$x + $rx, $yf],"; + $retour .= "[$xf - $rx, $yf], [$xf - (1 - $c) * $rx, $yf, 'c'],"; + $retour .= "[$xf, $yf - (1 - $c) * $ry, 'c'], [$xf, $yf - $ry],"; + $retour .= "[$xf, $y + $ry], [$xf, $y + (1 - $c) * $ry, 'c'],"; + $retour .= "[$xf - (1 - $c) * $rx, $y, 'c'], [$xf - $rx, $y],"; + $retour .= "[$x + $rx, $y]"; + + return ('curve', $retour); +} + +sub rect_ { + my ($parser, $elementname, %attrs) = @_; + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } +} + +sub ellipse { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + my ($cx,$cy,$rx,$ry)=&sizesConvert( \%attrs , qw (cx cy rx ry)); + my $res = "\$previous = ->add('arc', $current_group, [". ($cx-$rx) . ", ". ($cy-$ry) . + ", " . ($cx+$rx) . ", ". ($cy+$ry) . "], -tags => ['ellipse',"; + $res .= ", $name" if ($natural or $attrs{transform}); + $res .= "], -priority => 10"; + # by default, ellipses are filled + # from svg specifs). The value is set here, and can be overidden later + # in the &analyze_style + $res .= ", -filled => 1" unless defined $attrs{fill} and $attrs{fill} eq 'none'; + delete $attrs{'stroke-linejoin'}; ## BUG: due to TkZinc limitation: no -joinstyle for arc + $res .= &analyze_style (\%attrs); + $res .=");"; + &attrs_implemented ( 'ellipse', $name, [qw (cx cy rx ry style transform id )], %attrs ); + &ddisplay ($res, + &transform('$previous', $attrs{transform}) ); +} + +sub ellipse_ { + my ($parser, $elementname, %attrs) = @_; + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } +} + +sub circle { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + my ($cx,$cy,$r)=&sizesConvert( \%attrs , qw (cx cy r)); + my $res = "\$previous = -> add('arc',$current_group,[". ($cx-$r) . ", ". ($cy-$r) . + ", " . ($cx+$r) . ", ". ($cy+$r) . "], -tags => ['circle'"; + $res .= ", $name" if ($natural or $attrs{transform}); + $res .= "], -priority => 10"; + # by default, circles are filled + # from svg specifs). The value is set here, and can be overidden later + # in the &analyze_style + $res .= ", -filled => 1" unless defined $attrs{fill} and $attrs{fill} eq 'none'; + $res .= &analyze_style (\%attrs); + $res .=");"; + delete $attrs{'stroke-linejoin'}; ## BUG: due to TkZinc limitation: no -joinstyle for arc + &attrs_implemented ( 'circle', $name, [qw ( cx cy r transform id )], %attrs ); + &ddisplay ($res, + &transform('$previous', $attrs{transform}) ); +} + +sub circle_ { + my ($parser, $elementname, %attrs) = @_; + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } +} + +sub polygon { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + %attrs = &expandAttributes ($elementname,%attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + my $res = "\$previous = -> add('curve',$current_group,[" . &points(\%attrs); + $res .= "], -closed => 1, -tags => ['polygon'"; + $res .= ", $name" if ($natural or $attrs{transform}); + $res .= "], -priority => 10"; + # by default, polygones are filled + # from svg specifs). The value is set here, and can be overidden later + # in the &analyze_style + $res .= ", -filled => 1" unless defined $attrs{fill} and $attrs{fill} eq 'none'; + $res .= &analyze_style (\%attrs); + $res .= ");"; + &attrs_implemented ( 'polygone', $name, [qw ( points style transform id )], %attrs ); + &ddisplay ($res, + &transform('$previous', $attrs{transform}) ); +} + +sub polygon_ { + my ($parser, $elementname, %attrs) = @_; + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } +} + + +sub path { + my ($parser, $elementname, %attrs) = @_; + push (@nameStack, $attrs{id}); + if($attrs{id} eq $targetName) + { + $includeFollowingItems = 1; + } + if( !$includeFollowingItems ) + { + return; + } + $add_stroke = 0; + %attrs = &expandAttributes ($elementname, %attrs); + my ($name,$natural) = &name ($elementname, $attrs{id}); + my $res = ""; + my ($closed, @listOfListpoints) = &pathPoints (\%attrs); + my $refPoints = shift @listOfListpoints; + $res .= join (", ", @{$refPoints}); + $res .= "], -tags => [$name], -priority => 10"; + $res .= ", -filled => 1" unless defined $attrs {fill} and $attrs {fill} eq 'none'; + $add_stroke = 1 if defined $attrs {stroke}; + if ( defined $attrs{'fill-rule'} ) + { + $res .= ", -fillrule => 'nonzero'" unless $attrs{'fill-rule'} eq 'evenodd'; + delete $attrs{'fill-rule'}; + } + $res .= ", -closed => $closed"; + $res .= &analyze_style (\%attrs); + $res .= ", -linewidth => 0" if !$add_stroke; + $res .= ");"; + # and process other contours + my @contours = (); + foreach my $refPoints (@listOfListpoints) + { + my @points = @{$refPoints}; + my $contour = "-> contour($name, 'add', 0, ["; + $contour .= join (", ", @points); + $contour .= "]);"; + push @contours, $contour; + } + &attrs_implemented ( 'path', $name, [qw ( d style stroke-linejoin stroke-linecap transform id stroke-dasharray )], %attrs ); + $res = start_opacity_gp ($parser, $elementname)."\$previous = -> add('curve', $current_group, [".$res; + + &ddisplay ($res, @contours, &transform('$previous', $attrs{transform})); + $res = close_opacity_gp ($parser, $elementname); + &ddisplay ($res); + +} # end of path + + +sub path_ { + my ($parser, $elementname, %attrs) = @_; + $attrs{id} = pop (@nameStack); + if ((defined $attrs{id}) && ($attrs{id} eq $targetName)) + { + $includeFollowingItems = 0; + } +} + +sub expandAttributes { + my ($elementName, %rawAttrs) = @_; + my (%styleKeyValues, %classKeyValues, %elementKeyValues, %idKeyValues); + my $style = delete $rawAttrs{'style'}; + if (defined $style) { + %styleKeyValues = &expandStyle($style); + } + my $class = delete $rawAttrs{'class'}; + if (defined $class) { ## for the css + my $ref_styles = &getClass($class); + if (defined $ref_styles) { + %classKeyValues = %{$ref_styles}; + } else { + &myWarn ("class attribute refers an illegal style: '$class'\n"); + } + } + my $ref_styles = &getElementClass($elementName); + if (defined $ref_styles) { + %elementKeyValues = %{$ref_styles}; + } + my $id = $rawAttrs{id}; + if (defined $id) { + my $ref_style = &getIdClass($id); + if (defined $ref_style) { + %idKeyValues = %{$ref_styles}; + } + } + return (%rawAttrs, %elementKeyValues, %classKeyValues, %styleKeyValues, %idKeyValues); ## the order is important! +} + +### CM 19/1/03: This function could be really simplified (CM 09/09/3 why??? I do not remember!) +## analyze styles attached to an item (non text item) and on any of its groups +sub analyze_style { + my ($ref_attr) = @_; + my %ref_attr = %{$ref_attr}; + my %attrs = (%current_context , %ref_attr ); + my %directkeyvalues; + foreach my $attr (@STYLE_ATTRS) + { + my $value = $attrs {$attr}; + if (defined $value) + { + $directkeyvalues {$attr} = &removeComment ($value); + } + } + return &analyze_style_hash (\%directkeyvalues); +} + + +## analyze styles attached to a text item and on any of its groups +sub analyze_text_style { + my ($ref_attr) = @_; + my %attrs = ( %current_context , %{$ref_attr} ); + my $res = ""; + my $style = delete $attrs{'style'}; + if (defined $style) + { + my %keyvalues = &expandStyle($style); + $res = &analyze_text_style_hash (\%keyvalues); + } + my %directkeyvalues; + foreach my $attr (@STYLE_ATTRS) + { + my $value = $attrs{$attr}; + if (defined $value) + { + $directkeyvalues{$attr} = &removeComment($value); + } + } + $res .= &analyze_text_style_hash (\%directkeyvalues); + return $res; +} + + +## expanses the attribute = "prop:val;prop2:val2" in a hashtable like {prop => val, prop2 => val2, ...} +## and return this hash (BUG: may be it should return a reference!) +sub expandStyle { + my ($style) = @_; + return () unless defined $style; + my %keyvalues; + $style = &removeComment ($style); + foreach my $keyvalue ( split ( /\s*;\s*/ , $style) ) + { + my ($key, $value) = $keyvalue =~ /(.*)\s*:\s*(.*)/ ; + $keyvalues{$key} = $value; + } + return %keyvalues; +} + + +## Analyze attributes contained in the hashtable given as ref +## This hashtable {attribut =>value...} must contain all +## attributes to analyze +## returns a string containing the TkZinc attributes +sub analyze_style_hash { + my ($ref_keyvalues) = @_; + my %keyvalues = %{$ref_keyvalues}; + my $res = ""; + my $opacity = &convertOpacity (delete $keyvalues {'opacity'}); + my $stroke = delete $keyvalues {'stroke'}; + my $strokeOpacity = delete $keyvalues {'stroke-opacity'}; + $strokeOpacity = 1 if !defined $strokeOpacity; + $strokeOpacity = &float2int (&convertOpacity ($strokeOpacity) * $opacity * 100); + if (defined $stroke) + { + my ($color, $gd) = &colorConvert ($stroke); + if ($gd) + { + &applyGradient ($color, '-linecolor'); + } + elsif ($color eq "none") + { + $res .= ", -linewidth => 0"; + delete $keyvalues {'stroke-width'}; + } + elsif ($strokeOpacity != 100) + { + if (&existsGradient ($color)) + { + my $newColor = &addTransparencyToGradient ($color, $strokeOpacity); + $res .= ", -linecolor => \"$newColor\", -filled => 1"; + } + else + { + $res .= ", -linecolor => \"$color$colorSep$strokeOpacity\""; + } + } + else + { + $res .= ", -linecolor => \"$color\""; + } + $add_stroke = 1; + } + elsif ( $strokeOpacity != 1 ) + { + # no stroke color, but opacity + ## what should I do?! + } + + + my $fill = delete $keyvalues{'fill'}; + my $fillOpacity = delete $keyvalues{'fill-opacity'}; + $fillOpacity = 1 if !defined $fillOpacity; + $fillOpacity = &float2int(&convertOpacity($fillOpacity) * $opacity * 100); + delete $keyvalues{'fill-opacity'}; + if (defined $fill) + { + my ($color, $gd) = &colorConvert ($fill); + if ($gd) + { + if ($fillOpacity != 100) + { + print STDERR "Attention, gros hack\n"; + $start_opacity_group = 1; + $opacity_group = $fillOpacity; + } + &applyGradient ($color, '-fillcolor'); + } + elsif ($color eq "none") + { + $res .= ", -filled => 0"; + delete $keyvalues {'fill-opacity'}; + } + elsif ( $fillOpacity != 100 ) + { + if (&existsGradient ($color)) + { + my $newColor = &addTransparencyToGradient ($color, $fillOpacity); + $res .= ", -fillcolor => \"$newColor\", -filled => 1"; + $res .= ", -linecolor => \"$newColor\"," unless defined $stroke; + } + else + { + $res .= ", -fillcolor => \"$color$colorSep$fillOpacity\", -filled => 1"; + $res .= ", -linecolor => \"$color$colorSep$fillOpacity\"," unless defined $stroke; + } + } + else + { + $res .= ", -fillcolor => \"$color\", -filled =>1"; + $res .= ", -linecolor => \"$color\"" unless defined $stroke; + } + } + + foreach my $key (sort keys %keyvalues) + { + my $value = $keyvalues{$key}; + next if (!defined $value); + if ($key eq 'stroke-width') + { + if ( defined $keyvalues{stroke} and $keyvalues{stroke} eq 'none' ) + { + delete $keyvalues{stroke}; + next; + } + $value = &sizeConvert($value); + if ($value == 0 and $dtdVersion eq "1.0") + { + $value = 0.1; # BUG? a widht of 0 is the smallest possible width in SVG 1.0 [true or false?] + } + $res .= ", -linewidth => $value"; + } + elsif ($key eq 'stroke-dasharray') + { + $res .= ", -linestyle => \"dashed\""; + } + elsif ($key eq 'display') + { + if ($value eq 'none') + { + $res .= ", -visible => 0, -sensitive => 0"; + } + } + elsif ($key eq 'visibility') + { + ## BUG? if a "not-visible" group contains a visible graphic element + ## this element WILL NOT be visible in TkZinc , but should be visible in SVG!! + ## Cf specif svg p. 284 + if ($value eq 'hidden' or $value eq 'collapse') + { + $res .= ", -visible => 0"; + } + } + elsif ($key eq 'stroke-linecap') + { + if ($value eq 'butt' or $value eq 'round') + { + $res .= ", -capstyle => \"$value\""; + } + elsif ($value eq 'square') + { + $res .= ", -capstyle => \"projecting\""; + } + else + { + &myWarn ("!! bad value for $key style : $value\n"); + } + } + elsif ($key eq 'stroke-linejoin') + { + ($value) = $value =~ /(\w+)/ ; + $res .= ", -joinstyle => \"$value\""; + } + elsif ($key eq 'fill-rule') + { + ### this attributes is for shape only and is analyzed in &path + } + elsif ($key eq 'font-size') + { + ### this attributes is for text only and is analyzed in &analyze_text_style_hash + } + else + { + &myWarn ("Unknown Style (in analyze_style_hash): $key (value is $value)\n") if $warn; + } + } + return $res; +} + + +sub analyze_text_style_hash +{ + my ($ref_keyvalues) = @_; + my %keyvalues = %{$ref_keyvalues}; + + my $res = ""; + my $opacity = &convertOpacity($keyvalues{opacity}); + delete $keyvalues{'opacity'}; + + my $fontFamily=""; + my $fontSize =""; + my $fontWeight =""; + + foreach my $key (keys %keyvalues) + { + my $value = $keyvalues{$key}; + next if (!defined $value); # in this case, the SVG code is invalide (TBC) + if ($key eq 'text-anchor') + { + if ($value eq 'start') + { + $res .= ", -anchor => 'nw'"; + } + elsif ($value eq 'end') + { + $res .= ", -anchor => 'ne'"; + } + elsif ($value eq 'middle') + { + $res .= ", -anchor => 'n'" + } + } + elsif ($key eq 'display') + { + if ($value eq 'none') + { + $res .= ", -visible => 0, -sensitive => 0"; + } + } + elsif ($key eq 'visibility') + { + ## BUG? if a "not-visible" group contains a visible graphic element + ## this element WILL NOT be visible in TkZinc , but should be visible in SVG!! + ## Cf specif svg p. 284 + if ($value eq 'hidden' or $value eq 'collapse') + { + $res .= ", -visible => 0"; + } + ## We do not treat the other possible values for display as defined in CSS2?! + } + elsif ($key eq 'font-family') + { + $value =~ s/\'//g; # on removing quotes around the fonte name + $fontFamily = $value; + } + elsif ($key eq 'font-size') + { + $fontSize = $value; + } + elsif ($key eq 'font-weight') + { + $fontWeight = $value; + } + elsif ($key eq 'fill') + { + my $fillOpacity; + my ($color, $gd) = &colorConvert($value); + if ( $gd ) + { + &applyGradient ($color, '-color'); + } + elsif ($color eq 'none') + { + # $res .= ", -filled => 0"; # this is the default value in Tk::Zinc + } + elsif ( ($fillOpacity = $keyvalues{'fill-opacity'} or $opacity != 1) ) + { + $fillOpacity = &convertOpacity($fillOpacity) * $opacity; + delete $keyvalues{'fill-opacity'}; + if ( &existsGradient($color) ) + { + # so, apply a transparency to a Tk::Zinc named gradient + my $newColor = &addTransparencyToGradient($color,$fillOpacity); + $res .= ", -color => \"$newColor\""; + } + else + { + $fillOpacity = int ($fillOpacity * 100); + $res .= ", -color => \"$color$colorSep$fillOpacity\""; + } + } + else + { + $res .= ", -color => \"$color\""; + } + } + else + { + &myWarn ("Unknown Style of text: $key (value is $value)\n") if $warn; + } + } + if ($fontFamily or $fontSize or $fontWeight) + { + ## to be extended to all other fonts definition parameters + ## NB: fontWeight is not used yet! + my ($fontKey,$code) = &createNamedFont ($fontFamily, $fontSize, ""); + &display("\$fonts{\"$fontKey\"} = ") if $code; + &display($code) if $code; + $res .= ", -font => \"$fontKey\""; + $current_font_key = $fontKey; + } + return $res; +} + + + + +## print warnings for all used attributes unkonwn or not implemented +sub attrs_implemented { + my ($type, $name, $ref_attrs_implemented, %attrs) = @_; + my %attrs_implemented; + foreach my $attr (@{$ref_attrs_implemented}) { + $attrs_implemented{$attr}=1; + } + my %expandStyle = &expandStyle ($attrs{style}); + my %attributes = ( %expandStyle, %attrs); + foreach my $attr ( keys %attributes ) { +# print "attr: $attr $attributes{$attr}\n"; + if (!&isAnExtensionAttr($attr) and + !defined $STYLE_ATTRS{$attr} and + !defined $attrs_implemented{$attr}) { + if (defined $STYLE_ATTRS_NYI{$attr}) { + ¬_implemented_attr($attr); + } else { + &myWarn ("!!! Unimplemented attribute '$attr' (='$attributes{$attr}') in '$type' $name\n"); + } + } + } +} # end of attrs_implemented + +# These hashes contain the number of usage of not implemented attributes and +# the lines on svg source files where a not implemented attributes is used +# so that they can be displayed by the sub &print_warning_for_not_implemented_attr +my %not_implemented_attr; +my %not_implemented_attr_lines; +sub not_implemented_attr { + my ($attr) = @_; + $not_implemented_attr{$attr}++; + if (defined $not_implemented_attr_lines{$attr}) { + push @{$not_implemented_attr_lines{$attr}},¤t_line; + } else { + $not_implemented_attr_lines{$attr} = [¤t_line]; + } +} + +sub print_warning_for_not_implemented_attr { + foreach my $k (sort keys %not_implemented_attr) { + print "not implemented/implementable attribute '$k' was used $not_implemented_attr{$k} times in lines "; + my @lines; + if ($not_implemented_attr{$k} > 20) { + @lines = @{$not_implemented_attr_lines{$k}}[0..19]; + print join (", ",@lines) ,"...\n"; + } else { + @lines = @{$not_implemented_attr_lines{$k}}; + print join (", ",@lines) ,"...\n"; + } + } +} + + +# print a warning for the first use of an attribute of a non-implemented extension to SVG +# return : +# - true if the attribute belong to an extension of SVG +# - false if its supposed to be a standard SVG attribute (or a non-existing attribute) +sub isAnExtensionAttr { + my ($attr) = @_; + if ( $attr =~ /^(.+):.+/ ) { + my $prefix = $1; + if (defined $notImplementedExtensionPrefix{$prefix} and + $notImplementedExtensionPrefix{$prefix} == 0) { + &myWarn ("!! XML EXTENSION '$prefix' IS NOT IMPLEMENTED\n"); + # we set the value to 1 so that the next time we will not prnt another message + $notImplementedExtensionPrefix{$prefix} = 1; + } + return 1; + } else { + return 0; + } +} # end of isAnExtensionAttr + +{ + my $inMetadata=0; + sub metadata { + $inMetadata++; + } +sub _metadata { + $inMetadata--; +} + +sub inMetadata { + return $inMetadata; +} +} + +sub notYetImplemented { + my ($elementname) = @_; + &myWarn ("####### $elementname: Not Yet Implemented\n"); +} + +{ + my $expat; +sub Init { + $expat = shift; +} +sub Final { + undef $expat; +} + +## takes 1 arg : 'message' +sub myWarn { + my ($mess) = @_; + if (defined $expat) { + print STDOUT ("at ", $expat->current_line, ": $mess"); + } else { + print STDOUT $mess; + } +} + +sub current_line { + if (defined $expat) + { + return $expat->current_line; + } + else + { + return "_undef_"; + } +} +} + +sub applyGradient { + my (@res) = @_; + $backend -> applyGradient(@res); +} + +sub recordGradient { + my (@res) = @_; + $backend -> recordGradient(@res); +} + +sub getGradient { + my (@res) = @_; + return $backend -> getGradient(@res); +} + +sub display { + my (@res) = @_; + $backend -> treatLines(@res); +} + +sub ddisplay { + my (@res) = @_; + $backend -> dtreatLines(@res); +} + +sub findINC +{ + my $file = join('/',@_); + my $dir; + $file =~ s,::,/,g; + foreach $dir (@INC) + { + my $path; + return $path if (-e ($path = "$dir/$file")); + } + return undef; +} + + +################################################################### +### this a slightly different implementation of the subs style as defined in XML::Parser +### Differences are : +# - when an error occure in a callback, the error is handled and a warning is +# printed with the line number of the SVG source file +# - namespace can be used (this is usefull for example to treat the SVG included in dia data files) +# + +package XML::Parser::SVG2zinc; +$XML::Parser::Built_In_Styles{'SVG2zinc'} = 1; + + +sub Start { + no strict 'refs'; + my $expat = shift; + my $tag = shift; + my $ns = $expat->namespace($tag); + if (!defined $ns || $ns =~ /\/svg$/) + { + ## the tag is a SVG tag + ## BUG: we should also get some tags of XML standard used by + ## the SVG standard. Exemple: xlink:href + my $sub = $expat->{Pkg} . "::$tag"; + if (defined &$sub) + { + eval { &$sub($expat, $tag, @_) }; + if ($@) + { + $expat->xpcarp("An Error occured while evaluationg $tag {...} :\n$@"); + } + } + elsif (&SVG::SVG2zinc::inMetadata) + { + # we do othing, unless tags were treated before! + } + else + { + if ($tag eq 'a:midPointStop') {return;} + ## skipping the tag if it is part of not implemented extension + my ($extension) = $tag =~ /(\w+):.*/; + return if defined $extension && defined $notImplementedExtensionPrefix{$extension}; + warn "## Unimplemented SVG tag: $tag\n"; + } + } +} + +sub End { + no strict 'refs'; + my $expat = shift; + my $tag = shift; + my $ns = $expat->namespace($tag); + if (!defined $ns || $ns =~ /\/svg$/) { + my $sub = $expat->{Pkg} . "::${tag}_"; + ## the tag is a SVG tag + if (defined &$sub) { + eval { &$sub($expat, $tag) }; + if ($@) { + $expat->xpcarp("An Error occured while evaluationg ${tag}_ {...}) :\n$@"); + } + } else { + # the following error message is not usefull, as there were already + # an error message at the opening tag + # warn "## Unimplemented SVG tag: ${tag}_\n"; + } + } +} + + + +################################################################### + + +1; + +__END__ + +=head1 NAME + +SVG::SVG2zinc - a module to display or convert svg files in scripts, classes, images... + +=head1 SYNOPSIS + + use SVG::SVG2zinc; + + &SVG::SVG2zinc::parsefile('file.svg', 'Backend','file.svg', + -out => 'outfile', + -verbose => $verbose, + -namespace => 0|1, + -prefix => 'string', + ); + + # to generate a Perl script: + &SVG::SVG2zinc::parsefile('file.svg','PerlScript', + -out => 'file.pl'); + + # to generate a Perl Class: + &SVG::SVG2zinc::parsefile('file.svg','PerlClass', + -out => 'Class.pm'); + + # to display a svgfile: + &SVG::SVG2zinc::parsefile('file.svg', 'Display'); + + #To convert a svgfile in png/jpeg file: + &SVG::SVG2zinc::parsefile('file.svg', 'Image', + -out => 'file.jpg'); + + # to generate a Tcl script: + &SVG::SVG2zinc::parsefile('file.svg','TclScript', + -out => 'file.tcl'); + + +=head1 DESCRIPTION + +Depending on the used Backend, &SVG::SVG2zinc::parsefile either generates a Perl Class, +Perl script, Tcl Script, bitmap images or displays SVG files inside a Tk::Zinc widget. + +SVG::SVG2zinc could be extended to generate Python scripts and/or +classes, or other files, just by sub-classing SVG::SVG2zinc::Backend(3pm) + +==head1 HOW IT WORKS + +This converter creates some TkZinc items associated to most SVG tags. +For example, or tags are transformed in TkZinc groups. +are converted in TkZinc curves.... many more to come... + +==head2 TkZinc items tags + +Every TkZinc item created by the parser get one or more tags. If the +corresponding svg tag has an Id, this Id will be used as a tag, after +some cleaning due to TkZinc limitation on tag values (no dot, star, etc...). +If the corresponding svg tag has no Id, the parser add a tag of the +following form : ____. If the parser is provided +a B<-prefix> option, the prefix is prepended to the tag: +____ + +The TkZinc group associated to the top tag has the following tag 'svg_top', as well as 'width=integer' 'heigth=integer' tags if width and height are defined in the top tag. These tags can be used to find the group and to get its desired width and height. + +==head2 RunTime code + +There is currently on new Tk::Zinc method needed when executing perl code generated. +This perl Tk::Zinc::adaptViewport function should be translated and included or +imported in any script generated in an other scripting language (eg. Tcl or Python). + +=head1 BUGS and LIMITATIONS + +Some limitations are due to differences between Tk::Zinc and SVG graphic models : + +=over 2 + +=item B + +Drawing width are zoomed in SVG but are not in Tk::Zinc where it is constant whatever the zoom factor is. + +=item B + +Gradient Transformation is not possible in Tk::Zinc. May be it could be implemented by the converter? + +=item B + +Rectangles cannot have rounded corners in Tk::Zinc. Could be implemented, by producing curve item rather than rectangles in Tk::zinc. Should be implemented in a future release of Tk::Zinc + +=item B + +Text and tspan tags are very complex items in SVG, for example placement can be very precise and complex. Many such features are difficult +to implement in Tk::Zinc and are not currently implemented + +=item B + +Font management is still limited. It will be rotatable and zoomable in future release of Tk::Zinc. SVG fonts included in a document are not readed, currently. + +=item B + +No image filtering functions are (and will be) available with Tk::Zinc, except if YOU want to contribute? + +=item B + +The SVG ClipPath tag is a bit more powerfull than Tk::Zinc clipping (clipper is limited to one item). So currently this is not implemented at all in SVG::SVG2zinc + +=back + + +There are also some limitations due to the early stage of the converter: + +=over 2 + +=item B + +CSS in external url is not yet implemented + +=item B + +No animation is currently available, neither scripting in the SVG file. But Perl or Tcl are scripting languages, are not they? + +=item B + +The SVG switch tag is only partly implemented, but should work in most situations + +=item B + +href for images can only reference a file in the same directory than the SVG source file. + +=back + +It was said there is still one hidden bug... but please patch and/or report it to the author! Any (simple ?) + +SVG file not correctly rendered by this module (except for limitations +listed previously) could be send to the author with little comments +about the expected rendering and observed differences. + +=head1 SEE ALSO + +svg2zinc.pl(1) a sample script using and demonstrating SVG::SVG2zinc + +SVG::SVG2zinc::Backend(3pm) to defined new backends. + +Tk::Zinc(3) TkZinc is available at www.openatc.org/zinc/ + +=head1 AUTHORS + +Christophe Mertz + +many patches and extensions from Alexandre Lemort + +helps from Celine Schlienger and St?phane Chatty + +=head1 COPYRIGHT + +CENA (C) 2002-2004, IntuiLab (C) 2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut -- cgit v1.1