diff options
Diffstat (limited to 'src/SVG')
| -rw-r--r-- | src/SVG/SVG2zinc.pm | 2245 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Backend.pm | 293 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Backend/Display.pm.k | 257 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Backend/Image.pm.k | 201 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Backend/PerlClass.pm | 203 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Backend/PerlScript.pm.k | 275 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Backend/Print.pm.k | 61 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Backend/Tcl.pm.k | 96 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Backend/TclScript.pm.k | 275 | ||||
| -rw-r--r-- | src/SVG/SVG2zinc/Conversions.pm | 909 |
10 files changed, 4815 insertions, 0 deletions
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 <mertz at intuilab dot com> +# previously <mertz at cena dot fr> +# with many helps from +# Alexandre Lemort <lemort at intuilab dot com> +# Celine Schlienger <celine at intuilab dot com> +# St?phane Chatty <chatty at intuilab dot com> +# +# $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 '__<elementtype>__<$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 <use> 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 <symbols> is defined inside a <defs> 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 <defs> will generate the creation of an invisible group in Tk::Zinc + ## to be cloned latter in a <use> 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 <linearGradient> or <radialGradiant>\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 <stop>\n"); + } elsif (!defined $offset) { + &myWarn ("!! Undefined offset in a <stop>\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: <tspan> 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" <g> 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" <g> 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, <SVG> or <G> tags are transformed in TkZinc groups. <PATH> +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 : __<itemtype>__<integer>. If the parser is provided +a B<-prefix> option, the prefix is prepended to the tag: +<prefix>__<itemtype>__<integer> + +The TkZinc group associated to the top <SVG> tag has the following tag 'svg_top', as well as 'width=integer' 'heigth=integer' tags if width and height are defined in the top <SVG> 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> + +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> + +Gradient Transformation is not possible in Tk::Zinc. May be it could be implemented by the converter? + +=item B<Rounded Rectangles> + +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> + +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> + +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<SVG image filtering> + +No image filtering functions are (and will be) available with Tk::Zinc, except if YOU want to contribute? + +=item B<ClipPath tag> + +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> + +CSS in external url is not yet implemented + +=item B<SVG animation and scripting> + +No animation is currently available, neither scripting in the SVG file. But Perl or Tcl are scripting languages, are not they? + +=item B<switch tag> + +The SVG switch tag is only partly implemented, but should work in most situations + +=item B<href for images> + +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 <mertz at intuilab dot com> + +many patches and extensions from Alexandre Lemort <lemort at intuilab dot com> + +helps from Celine Schlienger <celine at intuilab dot com> and St?phane Chatty <chatty at intuilab dot com> + +=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 diff --git a/src/SVG/SVG2zinc/Backend.pm b/src/SVG/SVG2zinc/Backend.pm new file mode 100644 index 0000000..badee67 --- /dev/null +++ b/src/SVG/SVG2zinc/Backend.pm @@ -0,0 +1,293 @@ +package SVG::SVG2zinc::Backend; +# 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 +# +################################################################## + +# Backend for SVG2zinc +# +# Copyright 2003-2004 +# Centre d'?tudes de la Navigation A?rienne +# +# Author: Christophe Mertz <mertz at intuilab dot com> +# +# An abstract class for code generation +# Concrete sub-classes can generate code for perl (script / module), tcl, +# printing, or direct execution +# +# $Id: Backend.pm,v 1.1.1.2 2006-11-16 14:51:45 merlin Exp $ +############################################################################# + +use strict; +use Carp; +use FileHandle; + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.2 $ =~ /(\d+)\.(\d+)/); + +sub new { + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + $self->_initialize(%passed_options); + return $self; +} + +my %new_options = ( + -render => 1, + -out => 1, + -in => 1, + -verbose => 1, +); + +sub _initialize { + my ($self, %passed_options) = @_; + foreach my $opt (keys (%passed_options)) + { + if (defined ($new_options{$opt})) + { + $self->{$opt} = $passed_options{$opt}; + } + else + { + carp ("Warning: option $opt unknown for a ".ref($self)."\n"); + } + } + $self -> {-render} = 1 unless defined $self -> {-render}; + croak("undefined mandatory -in options") unless defined $self -> {-in}; + if (defined $self -> {-out} and $self -> {-out}) + { + my $out = $self->{-out}; + if (ref($out) eq 'GLOB') + { + ## nothing to do, the $out is supposed to be open!? + } + else + { + my @reps = split ('::', $out); + my $file = $reps [0]; + for (my $i = 0; $i < @reps - 1; $i++) + { + if(not -d $file) + { + if(!mkdir ($file)) + { + print STDERR "##### Error creating directory: $file\n"; + } + } + $file .= '/'.$reps [$i + 1]; + } + print STDERR "writing $file...\n"; + my $fh = FileHandle -> new("> " . $file); + if ($fh) + { + $self->{-filehandle} = $fh; + } + else + { + carp ("unable to open " . $out); + } + } + } + return $self; +} + +# used by SVG2zinc to know the zinc group in which the svg topgroup +# by default: 1 +# currently default need be overriden by PerlClass only, as far as I now!? +sub _topgroup { + my ($self) = @_; + if ($self->{-topgroup}) { + return $self->{-topgroup}; + } else { + return 1; + } +} + +# returns true if code is put in a file +sub inFile { + my ($self) = @_; + return (defined $self->{-filehandle}); +} + +sub printLines { + my ($self, @lines) = @_; + if ($self->inFile) { + my $fh = $self->{-filehandle}; + foreach my $l (@lines) { + print $fh "$l\n"; + } + } else { + carp "printLines cannot print if no outfile has been given\n"; + } +} + +sub treatLines { + my ($self, @lines) = @_; + if ($self->inFile) { + $self->printLines(@lines); + } +} + + +## in case of file generation, should print a comment +## the default is to print comment starting with # +sub comment { + my ($self, @lines) = @_; + if ($self->inFile) { + foreach my $l (@lines) { + $self->printLines("## $l"); + } + } +} + +sub close { + my ($self) = @_; + if ($self->inFile) { + $self->{-filehandle}->close; + } +} + +sub fileHeader { + my ($self) = @_; + $self->comment ("", "default Header of SVG::SVG2zinc::Backend", ""); +} + + +sub fileTail { + my ($self) = @_; + $self->comment ("", "default Tail of SVG::SVG2zinc::Backend", ""); + $self->close; +} + + + +1; + + +__END__ + +=head1 NAME + +SVG::SVG2zinc::Backend - a virtual class SVG::SVG2zinc svg reader. Sub-class are specialized for different type of generation + +=head1 SYNOPSIS + +package SVG::SVG2zinc::Backend::SubClass + +use SVG::SVG2zinc::Backend; + +## some methods definition + +.... + + ## when using a specialized backend: + + use SVG::SVG2zinc::Backend::SubClass; + + $backend = SVG::SVG2zinc::Backend::SubClass->new( + -out => filename_or_handle, + -in => svgfilename, + -verbose => 0|1, + [otheroptions], + ); + + $backend->fileHeader(); + + $backend->treatLines("lineOfCode1", "lineOfCode2",...); + + $backend->comment("comment1", "comment2", ...); + + $backend->printLines("comment1", "comment2", ...); + + $backend->fileTail(); + +=head1 DESCRIPTION + +SVG::SVG2zinc::Backend is a perl virtual class which should be specialized in sub-classes. It defines +a common interface ot classes which can for example generate perl code with Tk::Zinc, display +SVG file in a Tk::Zinc widget, convert svg file in image files (e.g. png) or generate tcl code +to be used with TkZinc etc... + +A backend should provide the following methods: + +=over + +=item B<new> + +This creation class method should accept pairs of (-option => value) as well as the following arguments: + +=over + +=item B<-out> + +A filename or a filehandle ready for writing the output. In same rare cases +(e.g. the Display backend which only displays the SVG file on the screen, +this option will not be used) + +=item B<-in> + +The svg filename. It should be used in comments only in the generated file + +=item B<-verbose> + +It will be used for letting the backend being verbose + +=back + +=item B<fileHeader> + +Generates the header in the out file, if needed. This method should be called just after creating a backend and prior any treatLines or comment method call. + +=item B<treatLines> + +Processes the given arguments as lines of code. The arguments are very close to Tk::Zinc perl code. When creating a new backend, using the B<Print> backend can help understanding what are exactly these arguments. + +=item B<comment> + +Processes the given arguments as comments. Depending on the backend, this method must be redefined so that arguments are treated as comments, or just skipped. + +=item B<printLines> + +Print in an outfile the given arguments as lines of text. This method should not be re-defined, but used by any Backend which generates code. + +=item B<fileTail> + +Generate the tail in the out file if needed and closes the out file. This must be the last call. + +=back + +A backend can use the printLines method to print lines in the generated file. + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend::Display(3pm), SVG::SVG2zinc::Backend::PerlScript(3pm), +SVG::SVG2zinc::Backend::TclScript(3pm), SVG::SVG2zinc::Backend::PerlClass(3pm) code +as examples of SVG::SVG2zinc::Backend subclasses. + +SVG::SVG2zinc(3pm) + +=head1 AUTHORS + +Christophe Mertz <mertz at intuilab dot com> with some help from Daniel Etienne <etienne at cena dot fr> + +=head1 COPYRIGHT + +CENA (C) 2003-2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + diff --git a/src/SVG/SVG2zinc/Backend/Display.pm.k b/src/SVG/SVG2zinc/Backend/Display.pm.k new file mode 100644 index 0000000..8da4b9b --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/Display.pm.k @@ -0,0 +1,257 @@ +package SVG::SVG2zinc::Backend::Display; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc to display a svg file in a Tk::Zinc canvas +# +# Copyright 2003 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz <mertz at intuilab dot com> +# +# $Id: Display.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use SVG::SVG2zinc::Backend; + +@ISA = qw( SVG::SVG2zinc::Backend ); + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +use strict; +use Carp; +use Tk::Zinc::SVGExtension; + +eval (require Tk::Zinc); +if ($@) { + die "$@\nSVG::SVG2zinc::Backend requires Tk::Zinc to be installed\n"; +} elsif (eval ('$Tk::Zinc::VERSION !~ /^\d\.\d+$/ or $Tk::Zinc::VERSION < 3.295') ) { + die "Tk::Zinc must be at least 3.295"; +} + + +sub new { + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + $self->_initialize(%passed_options); + return $self; +} + +my $zinc; +my ($WIDTH, $HEIGHT); +my $top_group; +sub _initialize { + my ($self, %passed_options) = @_; + $WIDTH = delete $passed_options{-width}; + $WIDTH = 600 unless defined $WIDTH; + $HEIGHT = delete $passed_options{-height}; + $HEIGHT = 600 unless defined $HEIGHT; + + $self->SUPER::_initialize(%passed_options); + + require Tk::Zinc::Debug; # usefull for browsing items herarchy + my $mw = MainWindow->new(); + my $svgfile = $self->{-in}; + $mw->title($svgfile); + $zinc = $mw->Zinc(-width => $WIDTH, -height => $HEIGHT, + -borderwidth => 0, + -render => $self->{-render}, + -backcolor => "white", ## why white? + )->pack(qw/-expand yes -fill both/); + + if (Tk::Zinc::Debug->can('init')) { + # for TkZinc >= 3.2.96 + &Tk::Zinc::Debug::init($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row"); + } else { + # for TkZinc <= 3.2.95 + &Tk::Zinc::Debug::finditems($zinc); + &Tk::Zinc::Debug::tree($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row"); + } +} + + +sub treatLines { + my ($self,@lines) = @_; + my $verbose = $self->{-verbose}; + foreach my $l (@lines) { + my $expr = $l; + $expr =~ s/->/\$zinc->/g; + my $unused = $zinc; ## due to a perl bug, this is needed so that $zinc will be known in $expr + my $r = eval ($expr); + if ($@) { +# &myWarn ("While evaluationg:\n$expr\nAn Error occured: $@\n"); + print ("While evaluationg:\n$expr\nAn Error occured: $@\n"); + } elsif ($verbose) { + if ($l =~ /^->add/) { + print "$r == $expr\n" if $verbose; + } else { + print "$expr\n" if $verbose; + } + } + } +} + + +sub fileHeader { +# my ($self) = @_; +} + + +my $zoom; +sub fileTail { + # resizing to make them all visible + $top_group = $zinc->find ('withtag', ".1"); + my @bbox = $zinc->bbox($top_group); + $zinc->translate($top_group, -$bbox[0], -$bbox[1]) if defined $bbox[0] and $bbox[1]; + @bbox = $zinc->bbox($top_group); + my $ratio = 1; + $ratio = $WIDTH / $bbox[2] if ($bbox[2] and $bbox[2] > $WIDTH); + $ratio = $HEIGHT/ $bbox[3] if ($bbox[3] and $HEIGHT/$bbox[3] lt $ratio); + + $zoom=1; + $zinc->scale($top_group, $ratio, $ratio); + + # adding some usefull callbacks + $zinc->Tk::bind('<ButtonPress-1>', [\&press, \&motion]); + $zinc->Tk::bind('<ButtonRelease-1>', [\&release]); + + $zinc->Tk::bind('<ButtonPress-2>', [\&press, \&zoom]); + $zinc->Tk::bind('<ButtonRelease-2>', [\&release]); + + $zinc->Tk::bind('<Control-ButtonPress-1>', [\&press, \&mouseRotate]); + $zinc->Tk::bind('<Control-ButtonRelease-1>', [\&release]); + $zinc->bind('all', '<Enter>', + [ sub { my ($z)=@_; my $i=$z->find('withtag', 'current'); + my @tags = $z->gettags($i); + pop @tags; # to remove the tag 'current' + print "$i (", $z->type($i), ") [@tags]\n";}] ); + + Tk::MainLoop; +} + +##### bindings for moving, rotating, scaling the displayed items +my ($cur_x, $cur_y, $cur_angle); +sub press { + my ($zinc, $action) = @_; + my $ev = $zinc->XEvent(); + $cur_x = $ev->x; + $cur_y = $ev->y; + $cur_angle = atan2($cur_y, $cur_x); + $zinc->Tk::bind('<Motion>', [$action]); +} + +sub motion { + my ($zinc) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + + my @res = $zinc->transform($top_group, [$lx, $ly, $cur_x, $cur_y]); + $zinc->translate($top_group, ($res[0] - $res[2])*$zoom, ($res[1] - $res[3])*$zoom); + $cur_x = $lx; + $cur_y = $ly; +} + +sub zoom { + my ($zinc, $self) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + my ($maxx, $maxy); + + if ($lx > $cur_x) { + $maxx = $lx; + } else { + $maxx = $cur_x; + } + if ($ly > $cur_y) { + $maxy = $ly + } else { + $maxy = $cur_y; + } + return if ($maxx == 0 || $maxy == 0); + my $sx = 1.0 + ($lx - $cur_x)/$maxx; + my $sy = 1.0 + ($ly - $cur_y)/$maxy; + $cur_x = $lx; + $cur_y = $ly; + $zoom = $zoom * $sx; + $zinc->scale($top_group, $sx, $sx); #$sy); +} + +sub mouseRotate { + my ($zinc) = @_; + my $ev = $zinc->XEvent(); + my $langle = atan2($ev->y, $ev->x); + $zinc->rotate($top_group, -($langle - $cur_angle), $cur_x, $cur_y); + $cur_angle = $langle; +} + +sub release { + my ($zinc) = @_; + $zinc->Tk::bind('<Motion>', ''); +} + + +sub displayVersion { + print $0, " : Version $VERSION\n\tSVG::SVG2zinc.pm Version : $SVG::SVG2zinc::VERSION\n"; + exit; +} + + +1; + + +__END__ + +=head1 NAME + +SVG:SVG2zinc::Backend::Display - a backend class for displaying SVG file + +=head1 DESCRIPTION + +SVG:SVG2zinc::Backend::Display is a class for displaying SVG files. + +For more information, you should look at SVG:SVG2zinc::Backend(3pm). + +The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters: + +=over + +=item B<-render> + +The render value of the Tk::Zinc widget. 0 means no openGL, 1 or 2 for openGL. Defaults to 1. + +=back + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm) + +=head1 AUTHORS + +Christophe Mertz <mertz at intuilab dot com> + +=head1 COPYRIGHT + +CENA (C) 2003-2004 IntuiLab 2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + diff --git a/src/SVG/SVG2zinc/Backend/Image.pm.k b/src/SVG/SVG2zinc/Backend/Image.pm.k new file mode 100644 index 0000000..bfd7851 --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/Image.pm.k @@ -0,0 +1,201 @@ +package SVG::SVG2zinc::Backend::Image; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc to generate image files +# +# Copyright 2003 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz <mertz at intuilab dot com> +# +# $Id: Image.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use SVG::SVG2zinc::Backend; + +@ISA = qw( SVG::SVG2zinc::Backend ); + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +use strict; +use Carp; +use Tk::Zinc::SVGExtension; + +eval (require Tk::Zinc); +if ($@) { + print "$@\nSVG::SVG2zinc::Backend requires Tk::Zinc to be installed\n"; +} + +sub new { + # testing that 'import' is available + # is this test portable? + my $ret = `which import`; + croak ("## You need the 'import' command from 'imagemagic' package to use the Image backend.\n") + if !$ret; + + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + $self->_initialize(%passed_options); + return $self; +} + +my $zinc; +sub _initialize { + my ($self, %passed_options) = @_; + if (defined $passed_options{-ratio}) { + if ($passed_options{-ratio} !~ /^\d+%$/) { + croak ("## -ratio should look like nn%"); + } else { + $self->{-ratio} = delete $passed_options{-ratio}; + } + } + if (defined $passed_options{-width}) { + $self->{-width} = delete $passed_options{-width}; + } + if (defined $passed_options{-height}) { + $self->{-height} = delete $passed_options{-height}; + } + + $self->SUPER::_initialize(%passed_options); + + my $mw = MainWindow->new(); + my $svgfile = $self->{-in}; + $mw->title($svgfile); + my $render = (defined $self->{-render}) ? $self->{-render} : 1; + $zinc = $mw->Zinc(-borderwidth => 0, + -render => $render, + -backcolor => "white", ## why white? + )->pack(qw/-expand yes -fill both/); +} + + +sub treatLines { + my ($self,@lines) = @_; + my $verbose = $self->{-verbose}; + foreach my $l (@lines) { + my $expr = $l; + $expr =~ s/->/\$zinc->/g; + my $unused = $zinc; ## due to a perl bug, this is needed so that $zinc will be known in $expr + my $r = eval ($expr); + if ($@) { +# &myWarn ("While evaluationg:\n$expr\nAn Error occured: $@\n"); + print ("While evaluationg:\n$expr\nAn Error occured: $@\n"); + } elsif ($verbose) { + if ($l =~ /^->add/) { + print "$r == $expr\n" if $verbose; + } else { + print "$expr\n" if $verbose; + } + } + } +} + + +sub fileHeader { +# my ($self) = @_; +} + + +sub fileTail { + my ($self) = @_; + my $outfile = $self->{-out}; + + # to find the top group containing width and height + my $svgGroup = $zinc->find('withtag', 'svg_top') ; + + my $tags = join " ", $zinc->gettags($svgGroup); +# print "svgGroup=$svgGroup => $tags\n"; + my ($width) = $tags =~ /width=(\d+)/ ; + my ($height) = $tags =~ /height=(\d+)/ ; +# print "height => $height width => $width\n"; + + $zinc->configure (-width => $width, -height => $height); + $zinc->update; + + my $requiredWidth = $self->{-width}; + my $requiredHeigth = $self->{-height}; + my $importParams=""; + if (defined $requiredWidth and defined $requiredHeigth) { + $importParams=" -resize $requiredWidth"."x$requiredHeigth"; + } elsif (defined $self->{-ratio}) { + $importParams=" -resize ".$self->{-ratio}; + } +# print "importParams=$importParams\n"; + + ## following are for comments: + my ($svg2zincPackage) = caller; + my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" ); + my $svgfile = $self->{-in}; + + my $command = "import -window " . $zinc->id . $importParams ." -comment 'created with SVG::SVG2zinc from $svgfile v$VERSION (c) CENA 2003 C.Mertz.' $outfile"; +# print "command=$command\n"; + my $return = system ($command); + + if ($return) { + ## -1 when import is not available + print "## To use the Image Backend you need the 'import' command\n"; + print "## from the 'imagemagick' package on your system\n"; + } +} + + +1; + + +__END__ + +=head1 NAME + +SVG:SVG2zinc::Backend::Image - a backend class for generating image file from SVG file + +=head1 DESCRIPTION + +SVG:SVG2zinc::Backend::Image is a backend class for generating image file from SVG files. It uses the 'import' command included in the ImageMagick package. + +For more information, you should look at SVG:SVG2zinc::Backend(3pm). + +The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters: + +=over + +=item B<none> + +=back + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm) + +=head1 BUGS and LIMITATIONS + +This backend generates images files from the content of a displayed Tk::Zinc window. The size (in pixels) of the generated image is thus limited to the maximal size of a window on your system. + +=head1 AUTHORS + +Christophe Mertz <mertz at intuilab dot com> + +=head1 COPYRIGHT + +CENA (C) 2003-2004 IntuiLab 2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + diff --git a/src/SVG/SVG2zinc/Backend/PerlClass.pm b/src/SVG/SVG2zinc/Backend/PerlClass.pm new file mode 100644 index 0000000..9b47ee7 --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/PerlClass.pm @@ -0,0 +1,203 @@ +package SVG::SVG2zinc::Backend::PerlClass; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003-2004 +# Centre d'?tudes de la Navigation A?rienne +# +# Author: Christophe Mertz <mertz at intuilab dot com> +# +# An concrete class for code generation for Perl Class +# +# $Id: PerlClass.pm,v 1.4 2007-03-12 10:25:18 merlin Exp $ +############################################################################# + +use SVG::SVG2zinc::Backend; +use File::Basename; + +use Tk::Zinc; + +@ISA = qw( SVG::SVG2zinc::Backend ); + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); + +use strict; +use Carp; + +our $current_package_name = ''; + +sub _initialize { + my ($self, %passed_options) = @_; + $self->{-topgroup} = '$self->{-topgroup}'; # this code is used by SVG2zinc + $self->SUPER::_initialize(%passed_options); + $self -> {delayed_lines} = (); + $self -> {gradient} = {}; + $self -> {gradient_id} = 0; + return $self; +} + +sub recordGradient { + my ($self, $name, $def) = @_; + $self -> {gradient} -> {$name} = $def; +} + +sub getGradient { + my ($self, $name) = @_; + return $self -> {gradient} -> {$name} -> {stops}; +} + +sub applyGradient { + my ($self, $name, $prop) = @_; + my $grad = $self -> {gradient} -> {$name}; + my $id = $self -> {gradient_id} ++; + my %hash = %{$grad}; + my @lignes = 'my ($x1, $y1, $x2, $y2) = $_zinc -> bbox ($previous);'; +# push (@lignes, 'my ($parent) = $_zinc -> find(\'ancestors\', $previous);'); + push (@lignes, '($x1, $y1, $x2, $y2) = $_zinc -> transform(\'device\', $parent, [$x1+1, $y1+1, $x2-2, $y2-2]);'); + push (@lignes, "my \$grad = getGradient ("); + push (@lignes, "\t'$current_package_name',"); + push (@lignes, "\t'$id',"); + push (@lignes, "\t'".$hash {type}."',"); + push (@lignes, "\t'".$hash {gradientUnits}."',"); + push (@lignes, "\t".join (',' , @{$hash{coords}}).","); + push (@lignes, "\t'".join ('|' , @{$hash{stops}})."',"); + push (@lignes, "\t".join (',' , @{$hash{transform}}).","); + push (@lignes, "\t\$x1, \$y1, \$x2, \$y2"); + push (@lignes, ");"); + push (@lignes, "mconfigure (\$previous, $prop => \$grad);"); + + $self -> {current_gradient} = \@lignes; +} + +sub treatLines { + my ($self,@lines) = @_; + foreach my $l (@lines) + { + $l =~ s/^(\s*)->/$1\$_zinc->/g; + $l =~ s/(\W)->/$1\$_zinc->/g; + $self -> printLines($l); + } +} + +sub dtreatLines { + my ($self, @lines) = @_; + foreach my $l (@lines) + { + $l =~ s/^(\s*)->add/$1\$previous = \$_zinc-> add/g; + $l =~ s/(\W)->add/$1\$previous = \$_zinc-> add/g; + + $l =~ s/^(\s*)->/$1\$_zinc-> /g; + $l =~ s/(\W)->/$1\$_zinc-> /g; + + } + if (defined @lines) + { + my $rule = shift (@lines); + push (@{$self -> {delayed_lines}}, $rule); + } + if (defined $self -> {current_gradient}) + { + my @grad = @{$self -> {current_gradient}}; + foreach my $l (@grad) + { + push (@{$self -> {delayed_lines}}, $l); + } + $self -> {current_gradient} = undef; + } + foreach my $l (@lines) + { + push (@{$self -> {delayed_lines}}, $l); + } +} + +sub fileHeader { + my ($self) = @_; + my $file = $self -> {-in}; # print "file=$file\n"; + my ($svg2zincPackage) = caller; + my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" ); + my ($package_name) = $self -> {-out} =~ /(.*)\.pm$/ ; + $current_package_name = $package_name; + $self -> printLines("package $package_name; + +####### This file has been generated from $file by SVG::SVG2zinc.pm Version: $VERSION + +"); + $self->printLines( +<<'HEADER' + +use strict; +use MTools; +use MTools::MGroup; +use vars qw /@ISA @EXPORT @EXPORT_OK/; +use Tk::PNG; + +BEGIN +{ + @ISA = qw /MTools::MGroup/; +} + + +sub new { + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + + my $_zinc = $passed_options {-zinc}; + croak ("-zinc option is mandatory at instanciation") unless defined $_zinc; + + if (defined $passed_options {-topgroup}) + { + $self -> {-topgroup} = $passed_options {-topgroup}; + } + else + { + $self -> {-topgroup} = 1; + } + + my $parent = $self -> {-topgroup}; + my @parents = (); + my $previous = (); + push (@parents, $parent); + +# on now items creation! +HEADER +); +} + + +sub fileTail { + my ($self) = @_; + $self->comment ("", "Tail of SVG2zinc::Backend::PerlScript", ""); + unshift (@{$self -> {delayed_lines}}, '$self -> {instance} = $previous = '); + $self -> printLines(@{$self -> {delayed_lines}}); + $self -> printLines( +<<'TAIL' +return $self; +} + +1; +TAIL +); + $self->close; +} + + +1; + diff --git a/src/SVG/SVG2zinc/Backend/PerlScript.pm.k b/src/SVG/SVG2zinc/Backend/PerlScript.pm.k new file mode 100644 index 0000000..b3b453c --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/PerlScript.pm.k @@ -0,0 +1,275 @@ +package SVG::SVG2zinc::Backend::PerlScript; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003-2004 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz <mertz at intuilab dot com> +# +# A concrete class for code generation for Perl Scripts +# +# $Id: PerlScript.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use strict; +use Carp; + +use SVG::SVG2zinc::Backend; +use File::Basename; + +use vars qw( $VERSION @ISA ); +@ISA = qw( SVG::SVG2zinc::Backend ); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + + +sub treatLines { + my ($self,@lines) = @_; + foreach my $l (@lines) { + $l =~ s/->/\$_zinc->/g; + $self->printLines($l); + } +} + +sub fileHeader { + my ($self) = @_; + my $svgfile = $self->{-in}; + my ($svg2zincPackage) = caller; + my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" ); + $self->printLines("#!/usr/bin/perl -w + +####### This file has been generated from $svgfile by SVG::SVG2zinc.pm Version: $VERSION +"); + + + $self->printLines( +<<'HEADER' +use Tk::Zinc 3.295; +use Tk::Zinc::Debug; +use Tk::PNG; # only usefull if loading png file +use Tk::JPEG; # only usefull if loading png file + +use Tk::Zinc::SVGExtension; + +my $mw = MainWindow->new(); +HEADER + ); + my $svgfilename = basename($svgfile); + $self->printLines(" +\$mw->title('$svgfile'); +my (\$WIDTH, \$HEIGHT) = (800, 600); +" ); + my $render = $self->{-render}; + $self->printLines(" +my \$zinc = \$mw->Zinc(-width => \$WIDTH, -height => \$HEIGHT, + -borderwidth => 0, + -backcolor => 'white', # why white? + -render => $render, + )->pack(qw/-expand yes -fill both/);; +"); + + $self->printLines( +<<'HEADER' +if (Tk::Zinc::Debug->can('init')) { + # for TkZinc >= 3.2.96 + &Tk::Zinc::Debug::init($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row"); +} else { + # for TkZinc <= 3.2.95 + &Tk::Zinc::Debug::finditems($zinc); + &Tk::Zinc::Debug::tree($zinc, -optionsToDisplay => "-tags", -optionsFormat => "row"); +} + +my $top_group = 1; ###$zinc->add('group', 1); + +my $_zinc=$zinc; + +{ ### + +HEADER + ); +} + + +sub fileTail { + my ($self) = @_; + $self->printLines( +<<'TAIL' + } + +### on va retailler et translater les objets créés! + +my @bbox = $_zinc->bbox($top_group); +$_zinc->translate($top_group, -$bbox[0], -$bbox[1]); +@bbox = $_zinc->bbox($top_group); +my $ratio = 1; +$ratio = $WIDTH / $bbox[2] if ($bbox[2] > $WIDTH); +$ratio = $HEIGHT/$bbox[3] if ($HEIGHT/$bbox[3] lt $ratio); +$zinc->scale($top_group, $ratio, $ratio); + +### on ajoute quelques binding bien pratiques pour la mise au point + +$_zinc->Tk::bind('<ButtonPress-1>', [\&press, \&motion]); +$_zinc->Tk::bind('<ButtonRelease-1>', [\&release]); +$_zinc->Tk::bind('<ButtonPress-2>', [\&press, \&zoom]); +$_zinc->Tk::bind('<ButtonRelease-2>', [\&release]); + +# $_zinc->Tk::bind('<ButtonPress-3>', [\&press, \&mouseRotate]); +# $_zinc->Tk::bind('<ButtonRelease-3>', [\&release]); +$_zinc->bind('all', '<Enter>', + [ sub { my ($z)=@_; my $i=$z->find('withtag', 'current'); + my @tags = $z->gettags($i); + pop @tags; # pour enlever 'current' + print "$i (", $z->type($i), ") [@tags]\n";}] ); + +&Tk::MainLoop; + + +##### bindings for moving, rotating, scaling the items +my ($cur_x, $cur_y, $cur_angle); +sub press { + my ($zinc, $action) = @_; + my $ev = $zinc->XEvent(); + $cur_x = $ev->x; + $cur_y = $ev->y; + $cur_angle = atan2($cur_y, $cur_x); + $zinc->Tk::bind('<Motion>', [$action]); +} + +sub motion { + my ($zinc) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + my @res = $zinc->transform($top_group, [$lx, $ly, $cur_x, $cur_y]); + $zinc->translate($top_group, $res[0] - $res[2], $res[1] - $res[3]); + $cur_x = $lx; + $cur_y = $ly; +} + +sub zoom { + my ($zinc, $self) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + my $maxx; + my $maxy; + my $sx; + my $sy; + + if ($lx > $cur_x) { + $maxx = $lx; + } else { + $maxx = $cur_x; + } + if ($ly > $cur_y) { + $maxy = $ly + } else { + $maxy = $cur_y; + } + return if ($maxx == 0 || $maxy == 0); + $sx = 1.0 + ($lx - $cur_x)/$maxx; + $sy = 1.0 + ($ly - $cur_y)/$maxy; + $cur_x = $lx; + $cur_y = $ly; + $zinc->scale($top_group, $sx, $sx); #$sy); +} + +sub mouseRotate { + my ($zinc) = @_; + my $ev = $zinc->XEvent(); + my $lx = $ev->x; + my $ly = $ev->y; + my $langle = atan2($ly, $lx); + $zinc->rotate($top_group, -($langle - $cur_angle)); + $cur_angle = $langle; +} + +sub release { + my ($zinc) = @_; + $zinc->Tk::bind('<Motion>', ''); +} +TAIL +); + $self->close; +} + + +1; + +__END__ + +=head1 NAME + +SVG:SVG2zinc::Backend::PerlScript - a backend class generating Perl script displaying the content of a SVG file + +=head1 SYNOPSIS + + use SVG:SVG2zinc::Backend::PerlScript; + + $backend = SVG:SVG2zinc::Backend::PerlScript->new( + -out => filename_or_handle, + -in => svgfilename, + -verbose => 0|1, + -render => 0|1|2, + ); + + $backend->fileHeader(); + + $backend->treatLines("lineOfCode1", "lineOfCode2",...); + + $backend->comment("comment1", "comment2", ...); + + $backend->printLines("comment1", "comment2", ...); + + $backend->fileTail(); + +=head1 DESCRIPTION + +SVG:SVG2zinc::Backend::PerlScript is a class for generating perl script which displays the content of a SVG file. The generated script requires Tk::Zinc. + +For more information, you should look at SVG::SVG2zinc::Backend(3pm). + +The generated perl script uses the Tk::Zinc::Debug tool, so it is easy to inspect items created in Tk::Zinc. Use the <ESC> key to get some help when the cursor is in the Tk::Zinc window. + +The B<new> method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameter: + +=over + +=item B<-render> + +The render option of the Tk::Zinc widget. A value of 0 means no openGL, 1 or 2 for openGL. Defaults to 1. + +=back + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend(3pm) and SVG::SVG2zinc(3pm) + +=head1 AUTHORS + +Christophe Mertz <mertz at intuilab dot com> + +=head1 COPYRIGHT + +CENA (C) 2003-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 + diff --git a/src/SVG/SVG2zinc/Backend/Print.pm.k b/src/SVG/SVG2zinc/Backend/Print.pm.k new file mode 100644 index 0000000..8e533ac --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/Print.pm.k @@ -0,0 +1,61 @@ +package SVG::SVG2zinc::Backend::Print; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz <mertz at intuilab dot com> +# +# An concrete class for code printing for Perl Scripts/Modules +# This Backend is for svg2zinc debug purpose mainly +# +# $Id: Print.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use SVG::SVG2zinc::Backend; + +@ISA = qw( SVG::SVG2zinc::Backend ); + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +use strict; +use Carp; + +sub treatLines { + my ($self,@lines) = @_; + foreach my $l (@lines) { + print "$l\n"; + } +} + + +sub fileHeader { +# my ($self) = @_; +} + + +sub fileTail { +# my ($self) = @_; +} + + +1; + diff --git a/src/SVG/SVG2zinc/Backend/Tcl.pm.k b/src/SVG/SVG2zinc/Backend/Tcl.pm.k new file mode 100644 index 0000000..3149ef6 --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/Tcl.pm.k @@ -0,0 +1,96 @@ +package SVG::SVG2zinc::Backend::Tcl; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003-2004 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz <mertz at intuilab dot com> +# +# A module for code translation from perl to tcl generation +# +# $Id: Tcl.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + + +use vars qw( $VERSION); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +@ISA = qw( Exporter ); +@EXPORT = qw( perl2tcl ); + +use strict; +use Carp; + + +sub perl2tcl { + my (@lines) = @_; + my @res; + foreach my $l (@lines) { + + $l =~ s/->(\w*)\((.*)\)/\$w\.zinc $1 $2/g; # ->add(....) => $w.zinc add ... + + $l =~ s/\s*,\s*/ /g; # replacing commas by spaces + $l =~ s/\s*=>\s*/ /g; # replacing => by spaces + + $l =~ s/\s*\'([^\s;]+)\'\s*/ $1 /g ; # removing single-quotes around string without spaces + $l =~ s/\s*\"([^\s;]+)\"\s*/ $1 /g ; # removing double-quotes around string without spaces + $l =~ s/([\"\s])\#/$1\\\#/g ; # prefixing # by a slash + + $l =~ s/\[/\{/g; # replacing [ by } + $l =~ s/\]/\}/g; # replacing ] by } + $l =~ s/\{\s+/\{/g; # removing spaces after { + $l =~ s/\s+\}/\}/g; # removing spaces before } + + $l =~ s/-tags \{(\S+)\}/-tags $1/g; # -tags {toto} ==>> -tags toto + $l =~ s/\'/\"/g; # replacing all single quotes by double quotes + + $l = &hack($l); + + $l =~ s/\s+/ /g; # dangerous: removing multiple occurences of blanks + + $l =~ s/^\s+//; # removing blanks at the beginning + $l =~ s/\s+$//; # removing trailing blanks + $l =~ s/\s*;$//; # removing trailing ; + push @res, $l; + } + return (@res); +} + + +# this routine is used to do some special code transformation, +# due to soem discrepancies between tcl/tk and perl/tk +# the following code is more or less dependant from the generated +# code by SVG2zinc.pm +# +# We assume is code has already been tcl-ised +sub hack { + my ($l) = @_; + + if ($l =~ /^\$w\.zinc fontCreate/) { + # this works because I know how fontCreate is used in SVG2zinc + $l =~ s/\$w\.zinc fontCreate/font create/; + $l =~ s/-weight medium/-weight normal/; + } + + return $l; +} + +1; + diff --git a/src/SVG/SVG2zinc/Backend/TclScript.pm.k b/src/SVG/SVG2zinc/Backend/TclScript.pm.k new file mode 100644 index 0000000..90ecf4b --- /dev/null +++ b/src/SVG/SVG2zinc/Backend/TclScript.pm.k @@ -0,0 +1,275 @@ +package SVG::SVG2zinc::Backend::TclScript; +# 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 +# +################################################################## + +# Backend Class for SVG2zinc +# +# Copyright 2003 +# Centre d'Études de la Navigation Aérienne +# +# Author: Christophe Mertz <mertz at intuilab dot com> +# +# A concrete class for code generation for Tcl Scripts +# +# $Id: TclScript.pm.k,v 1.1.1.1 2006-10-20 13:34:31 merlin Exp $ +############################################################################# + +use strict; +use Carp; + +use SVG::SVG2zinc::Backend; +use SVG::SVG2zinc::Backend::Tcl; +use File::Basename; + +use vars qw( $VERSION @ISA ); +@ISA = qw( SVG::SVG2zinc::Backend ); +($VERSION) = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +sub new { + my ($class, %passed_options) = @_; + my $self = {}; + bless $self, $class; + $self->{-render} = defined $passed_options{-render} ? delete $passed_options{-render} : 1; + $self->_initialize(%passed_options); + return $self; +} + + +sub treatLines { + my ($self,@lines) = @_; + foreach my $l (@lines) { + $self->printLines( &perl2tcl($l) ); + } +} + +sub fileHeader { + my ($self) = @_; + my $svgfile = $self->{-in}; + my $svgfilename = basename($svgfile); + $svgfilename =~ s/\./_/g; + my ($svg2zincPackage) = caller; + my $VERSION = eval ( "\$".$svg2zincPackage."::VERSION" ); + $self->printLines('#!/bin/sh +# the next line restarts using wish \ + exec wish "$0" "$@" +'); + + $self->printLines(" + +####### This Tcl script file has been generated +####### from $svgfile +####### by SVG::SVG2zinc.pm Version: $VERSION + +"); + + $self->printLines(' +# +# Locate the zinc top level directory. +# +set zincRoot [file join [file dirname [info script]] ..] + +# +# And adjust the paths accordingly. +# +lappend auto_path $zincRoot +set zinc_library $zincRoot + +package require Tkzinc 3.2 + +## here we should import img for reading jpeg, png, gif files + +'); + + my $render = $self->{-render}; + $self->printLines( +<<HEADER +set w .$svgfilename +## catch {destroy \$w} +toplevel \$w +wm title \$w $svgfilename +wm iconname \$w $svgfilename + +########################################### +# Zinc +########################################## +zinc \$w.zinc -width 600 -height 600 -font 9x15 -borderwidth 0 -backcolor grey90 -render $render + +pack \$w.zinc + +set topGroup [\$w.zinc add group 1] + + +HEADER + ); +} + + +sub fileTail { + my ($self) = @_; + $self->printLines( +<<'TAIL' +### translating ojects for making them all visibles + +#set bbox [$w.zinc bbox $topGroup] + +$w.zinc translate $topGroup 200 150 + + +##### bindings for moving rotating scaling the items + +bind $w.zinc <ButtonPress-1> "press motion %x %y" +bind $w.zinc <ButtonRelease-1> release +bind $w.zinc <ButtonPress-2> "press zoom %x %y" +bind $w.zinc <ButtonRelease-2> release +bind $w.zinc <ButtonPress-3> "press mouseRotate %x %y" +bind $w.zinc <ButtonRelease-3> release + + +set curX 0 +set curY 0 +set curAngle 0 + +proc press {action x y} { + global w curAngle curX curY + + set curX $x + set curY $y + set curAngle [expr atan2($y, $x)] + bind $w.zinc <Motion> "$action %x %y" +} + +proc motion {x y} { + global w topGroup curX curY + + foreach {x1 y1 x2 y2} [$w.zinc transform $topGroup \ + [list $x $y $curX $curY]] break + $w.zinc translate $topGroup [expr $x1 - $x2] [expr $y1 - $y2] + set curX $x + set curY $y +} + +proc zoom {x y} { + global w curX curY + + if {$x > $curX} { + set maxX $x + } else { + set maxX $curX + } + if {$y > $curY} { + set maxY $y + } else { + set maxY $curY + } + if {($maxX == 0) || ($maxY == 0)} { + return; + } + set sx [expr 1.0 + (double($x - $curX) / $maxX)] + set sy [expr 1.0 + (double($y - $curY) / $maxY)] + $w.zinc scale __svg__1 $sx $sx + set curX $x + set curY $y +} + +proc mouseRotate {x y} { + global w curAngle + + set lAngle [expr atan2($y, $x)] + $w.zinc rotate __svg__1 [expr $lAngle - $curAngle] + set curAngle $lAngle +} + +proc release {} { + global w + + bind $w.zinc <Motion> {} +} +TAIL +); + + $self->close; +} + + +1; + + +__END__ + +=head1 NAME + +SVG:SVG2zinc::Backend::TclScript - a backend class for generating Tcl script + +=head1 SYNOPSIS + + use SVG:SVG2zinc::Backend::TclScript; + + $backend = SVG:SVG2zinc::Backend::TclScript->new( + -out => filename_or_handle, + -in => svgfilename, + -verbose => 0|1, + -render => 0|1|2, + ); + + $backend->fileHeader(); + + $backend->treatLines("lineOfCode1", "lineOfCode2",...); + + $backend->comment("comment1", "comment2", ...); + + $backend->printLines("comment1", "comment2", ...); + + $backend->fileTail(); + +=head1 DESCRIPTION + +SVG:SVG2zinc::Backend::TclScript is a class for generating Tcl script to display SVG files. The generated script is based on TkZinc. + +For more information, you should look at SVG:SVG2zinc::Backend(3pm). + +The new method accepts parameters described in the SVG:SVG2zinc::Backend class and the following additionnal parameters: + +=over + +=item B<-render> + +The render value of the TkZinc widget. 0 means no openGL, 1 or 2 for openGL. Defaults to 1. + +=back + +=head1 SEE ALSO + +SVG::SVG2zinc::Backend and SVG::SVG2zinc(3pm) + +=head1 BUGS and LIMITATIONS + +This is higly experimental. Only few tests... The author is not a Tcl coder! + +The Tk::Zinc::SVGExtension perl module provided with SVG::SVG2zinc should be converted in Tcl and imported by (or included in) the generated Tcl script. + +=head1 AUTHORS + +Christophe Mertz <mertz at intuilab dot com> + +=head1 COPYRIGHT + +CENA (C) 2003-2004 + +This program is free software; you can redistribute it and/or modify it under the term of the LGPL licence. + +=cut + diff --git a/src/SVG/SVG2zinc/Conversions.pm b/src/SVG/SVG2zinc/Conversions.pm new file mode 100644 index 0000000..9a8ccb9 --- /dev/null +++ b/src/SVG/SVG2zinc/Conversions.pm @@ -0,0 +1,909 @@ +package SVG::SVG2zinc::Conversions; +# 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 +# +################################################################## + +use Math::Trig; +use Math::Bezier::Convert; +use strict; +use Carp; + +use vars qw( $VERSION @ISA @EXPORT ); + +($VERSION) = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/); + +@ISA = qw( Exporter ); + +@EXPORT = qw( InitConv + removeComment convertOpacity + createNamedFont + defineNamedGradient namedGradient namedGradientDef existsGradient + extractGradientTypeAndStops addTransparencyToGradient + colorConvert + pathPoints points + cleanName + float2int sizesConvert sizeConvert + transform + ); + +# some variables to be initialized at the beginning + +my ($warnProc, $lineNumProc); # two proc +my %fonts; # a hashtable to identify all used fonts +my %gradients; + +sub InitConv { + ($warnProc, $lineNumProc) = @_; + %fonts = (); + %gradients = (); + return 1; +} + +sub myWarn{ + &{$warnProc}(@_); +} + +### remove SVG comments in the form /* */ in $str +### returns the string without these comments +sub removeComment { + my ($str) = @_; +# my $strOrig = $str; + return "" unless defined $str; + + while ($str =~ s|(.*)(/\*.*\*/){1}?|$1|) { +# print "begin='$str'\n"; + } +# print "'$strOrig' => '$str'\n"; + $str =~ s/^\s*// ; + return $str; +} + +## returns an opacity value between 0 and 1 +## returns 1 if the argument is undefined +sub convertOpacity { + my ($opacity) = @_; + $opacity = 1 unless defined $opacity; + $opacity = 0 if $opacity<0; + $opacity = 1 if $opacity>1; + return $opacity; +} + + +###################################################################################### +# fontes management +###################################################################################### + +# the following hashtable is used to maps SVG font names to X font names +# BUG: obvioulsy this hashtable should be defined in the system or at +# least as a configuration file or in the SVG2zinc parser parameters + +my %fontsMapping = ( + 'comicsansms' => "comic sans ms", + 'arialmt' => "arial", + 'arial black' => "arial-bold", + 'bleriottextmono-roman' => 'bleriot-radar', + 'bleriottext-roman' => 'bleriot', + 'cityd' => 'city d', + 'cityd-medi' => 'city d', +); + +my $last_key = "verdana"; + +sub createNamedFont { + my ($fullFamily, $size, $weight) = @_; + if ($fullFamily eq "") + { + $fullFamily = $last_key if $fullFamily eq ""; + } + else + { + $last_key = $fullFamily; + } + my $family = lc($fullFamily); + + $weight = "normal" unless $weight; + if ( $size =~ /(.*)pt/ ) + { + $size = -$1; + } + elsif ( $size =~ /(.*)px/ ) + { + $size = -$1; + } + elsif ( $size =~ /(\d*(.\d*)?)\s*$/ ) + { + $size = -$1; + } +# $size = &float2int($size); # I round the font size, at least until we have vectorial font in Tk::Zinc + + $family = $fontsMapping{$family} if defined $fontsMapping{$family}; + if ( $family =~ /(\w*)-bold/ ) + { + $family = $1; + $weight = "bold"; + } + else + { + $weight = "medium"; + } + + my $fontKey = join "_", ($family, $size, $weight); + if (!defined $fonts{$fontKey}) + { + $fonts{$fontKey} = $fontKey; + return ($fontKey, "->fontCreate('$fontKey', -family => \"$family\", -size => $size, -weight => \"$weight\") if ! \$fonts {\"$fontKey\"};"); + } + else + { + return ($fontKey,""); + } + +} # end of createNamedFont + +###################################################################################### +# gradients management +###################################################################################### +# my %gradients; + +## Check if the new gradient does not already exists (with another name) +## In this case, the hash is extended with an "auto-reference" +## $gradients{newName} = "oldName" +## and the function returns 0 +## Otherwise, add an entry in the hastable +## $gradients{newName} = "newDefinition" +## and returns 1 +sub defineNamedGradient { + my ($newGname, $newGradDef) = @_; + my $prevEqGrad; + $newGradDef =~ s/^\s*(.*\S)\s*$/$1/ ; # removing trailing/leading blank + $newGradDef =~ s/\s*\|\s*/ \| /g ; # inserting blanks around the | + $newGradDef =~ s/\s\s+/ /g; # removing multiple occurence of blanks +# print "CLEANED grad='$newGradDef'\n"; + foreach my $gname (keys %gradients) { + if ($gradients{$gname} eq $newGradDef) { + ## such a gradient already exist with another name + $gradients{$newGname} = $gname; +# print "GRADIENT: $newGname == $gname\n"; + +# $res .= "\n###### $newGname => $gname"; ### + + return 0; + } + } + ## there is no identical gradient with another name + ## we add the definition in the hashtable + $gradients{$newGname} = $newGradDef; + return $newGradDef; +} + +## returns the name of a gradient, by following if necessary +## "auto-references" in the hashtable +sub namedGradient { + my ($gname) = @_; + my $def = $gradients{$gname}; + return $gname unless defined $def; + ## to avoid looping if the hashtable is buggy: + return $gname if !defined $gradients{$def} or $def eq $gradients{$def}; + return &namedGradient($gradients{$gname}); +} + +## returns the definition associated to a named gradient, following if necessary +## "auto-references" in the hashtable +sub namedGradientDef { + my ($gname) = @_; + my $def = $gradients{$gname}; + return "" unless defined $def; + ## to avoid looping if the hashtable is buggy: + return $def if !defined $gradients{$def} or $def eq $gradients{$def}; + return $gradients{&namedGradient($gradients{$gname})}; +} + +# returns 1 if the named has an associated gradient +sub existsGradient { + my ($gname) = @_; + if (defined $gradients{$gname}) {return 1} else {return 0}; +} + +## this function returns both the radial type with its parameters AND +## a list of stops characteristics as defined in TkZinc +## usage: ($radialType, @stops) = &extractGradientTypeAndStops(<namedGradient>); +## this func assumes that <namedGradient> DOES exist +sub extractGradientTypeAndStops { + my ($namedGradient) = @_; + my $gradDef = &namedGradientDef($namedGradient); + my @defElements = split (/\s*\|\s*/ , $gradDef); + my $gradientType; + $gradientType = shift @defElements; + return ($gradientType, @defElements); +} + +## combines the opacity to every parts of a named gradient +## if some parts of the gradients are themselves partly transparent, they are combined +## if $opacity is 1, returns directly $gname +## else returns a new definition of a gradient +sub addTransparencyToGradient { + my ($gname,$opacity) = @_; + return $gname if $opacity == 100; + &myWarn ("ATTG: ERROR $gname\n"), return $gname if !&namedGradientDef($gname); ## this cas is certainly an error in the SVG source file! + my ($gradientType, @stops) = &extractGradientTypeAndStops($gname); + + my @newStops; + foreach my $stop (@stops) { + my $newStop=""; + if ($stop =~ /^([^\s;]+)\s*;\s*(\d+)\s*(\d*)\s*$/ # red;45 50 or red;45 + ) { + my ($color,$trans,$pos) = ($1,$2,$3); +# print "$stop => '$color','$trans','$pos'\n"; + my $newtransp = &float2int($trans*$opacity/100); + if ($pos) { + $newStop="$color;$newtransp $pos"; + } else { + $newStop="$color;$newtransp"; + } + } elsif ($stop =~ /^(\S+)\s+(\d+)$/) { # red 50 + my ($color,$pos) = ($1,$2); +# print "$stop => '$color','$pos'\n"; + my $newtransp = &float2int($opacity); + $newStop="$color;$newtransp $pos"; + } elsif ($stop =~ /^(\S+)$/) { + my ($color) = ($1); +# print "$stop => '$color'\n"; + my $newtransp = &float2int($opacity); + $newStop="$color;$newtransp"; + } else { + &myWarn ("In addTransparencyToGradient: bad gradient Elements: '$stop'\n"); + } + push @newStops, $newStop; + } + return ( $gradientType . " | " . join (" | ", @newStops)); +} # end of addTransparencyToGradient + + +###################################################################################### +# color conversion +###################################################################################### +# a hash table to define non-X SVG colors +# THX to Lemort for bug report and correction! +my %color2color = ('lime' => 'green', + 'Lime' => 'green', + 'crimson' => '#DC143C', + 'Crimson' => '#DC143C', + 'aqua' => '#00ffff', + 'Aqua' => '#00ffff', + 'fuschia' => '#ff00ff', + 'Fuschia' => '#ff00ff', + 'fuchsia' => '#ff00ff', + 'Fuchsia' => '#ff00ff', + 'indigo' => '#4b0082', + 'Indigo' => '#4b0082', + 'olive' => '#808000', + 'Olive' => '#808000', + 'silver' => '#c0c0c0', + 'Silver' => '#c0c0c0', + 'teal' => '#008080', + 'Teal' => '#008080', + 'green' => '#008000', + 'Green' => '#008000', + 'grey' => '#808080', + 'Grey' => '#808080', + 'gray' => '#808080', + 'Gray' => '#808080', + 'maroon' => '#800000', + 'Maroon' => '#800000', + 'purple' => '#800080', + 'Purple' => '#800080', + ); + +#### BUG: this is certainly only a partial implementation!! +sub colorConvert { + my ($color) = @_; + + if ($color =~ /^\s*none/m) + { + return ('none', 0); + } + elsif ($color =~ /rgb\(\s*(.+)\s*\)/ ) + { + ## color like "rgb(...)" + my $rgbs = $1; + if ($rgbs =~ /([\d.]*)%\s*,\s*([\d.]*)%\s*,\s*([\d.]*)%/ ) + { + ## color like "rgb(1.2% , 45%,67.%)" + my ($r,$g,$b) = ($1,$2,$3); + $color = sprintf ("#%02x%02x%02x", + sprintf ("%.0f",2.55*$r), + sprintf ("%.0f",2.55*$g), + sprintf ("%.0f",2.55*$b)); + return ($color, 0); + } + elsif ($rgbs =~ /(\d*)\s*,\s*(\d*)\s*,\s*(\d*)/ ) + { + ## color like "rgb(255, 45,67)" + my ($r,$g,$b) = ($1,$2,$3); + $color = sprintf "#%02x%02x%02x", $r,$g,$b; + return ($color, 0); + } + else + { + &myWarn ("Unknown rgb color coding: $color\n"); + } + } + elsif ($color =~ /^url\(\#(.+)\)/ ) + { + ## color like "url(#monGradient)" +# $color = $1; +# my $res = &namedGradient($color); + return ($1, 1); #&namedGradient($1); + } + elsif ( $color =~ /\#([0-9a-fA-F]{3}?)$/ ) + { + ## color like #fc1 => #ffcc11 + $color =~ s/([0-9a-fA-F])/$1$1/g ; + # on doubling the digiys, because Tk does not do it properly + return ($color, 0); + } + elsif ( $color =~ /\#([0-9a-fA-F]{6}?)$/ ) + { + return ($color, 0); + } + else + { + ## named colors! + ## except those in the %color2color, all other should be defined in the + ## standard rgb.txt file +# my $converted = $color2color{lc($color)}; # THX to Lemort for bug report! +# if (defined $converted) { +# return $converted; +# } else { + return ($color, 0); +# } + } +} # end of colorConvert + +###################################################################################### +# path points commands conversion +###################################################################################### + + +# &pathPoints (\%attrs) +# returns a boolean and a list of table references +# - the boolean is true is the path has more than one contour or if it must be closed +# - every table referecne pints to a table of strings, each string describing coordinates +# possible BUG: in Tk::Zinc when a curve has more than one contour, they are all closed +# how is it in SVG? +sub pathPoints { + my ($ref_attrs) = @_; + my $str = $ref_attrs->{d}; +# print "#### In PathPoints : $str\n"; + my ($x,$y) = (0,0); # current values + my $closed = 1; + my $atLeastOneZ=0; # true if at least one z/Z command. The curve must then be closed + my @fullRes; + my @res ; + my ($firstX, $firstY); # for memorizing the first point for a 'm' command after a 'z'! + my ($prevContrlx,$prevContrly); # useful for the s/S commande + + # I use now a repetitive search on the same string, without allocating + # a $last string for the string end; with very long list of points, such + # as iceland.svg, we can gain 30% in this function and about 3s over 30s + while ( $str =~ m/\s*([aAmMzZvVhHlLcCsSqQtT])\s*([^aAmMzZvVhHlLcCsSqQtT]*)\s*/g ) { + my ($command, $args)=($1,$2); + &myWarn ("!!!! Ill-formed path command: '", substr($str,pos($str), 40), "...'\n") unless defined $command ; +# print "Command=$command args=$args x=$x y=$y\n"; + if ($command eq "M") { ## moveto absolute + if (!$closed) { + ## creating a new contour + push @fullRes, [ @res ]; + $atLeastOneZ = 1; + @res = (); + } + my @points = &splitPoints($args); + ($prevContrlx,$prevContrly) = (undef,undef); + $firstX = $points[0]; + $firstY = $points[1]; + while (@points) { + $x = shift @points; + $y = shift @points; + push @res , "[$x, $y]"; + } + next; + } elsif ($command eq "m") { ## moveto relative + if (!$closed) { + ## creating a new contour + push @fullRes, [ @res ]; + $atLeastOneZ = 1; + @res = (); + } + my @dxy = &splitPoints($args); + $firstX = $x+$dxy[0]; + $firstY = $y+$dxy[1]; +# print "m command: $args => @dxy ,$x,$y\n"; + while (@dxy) { + ## trying to minimize the number of operation + ## to speed a bit this loop + $x += shift @dxy; + $y += shift @dxy; + push @res, "[$x, $y]"; + } + next; + } elsif ($command eq 'z' or $command eq 'Z') { + push @fullRes, [ @res ]; + $closed = 1; + $atLeastOneZ = 1; + @res = (); + $x=$firstX; + $y=$firstY; + next; + } + # as a command will/should follow, the curve is no more closed + $closed = 0; + if ($command eq "V") { ## vertival lineto absolute + ($y) = $args =~ /(\S+)/m ; ## XXXX what about multiple y !? + push @res , "[$x, $y]"; + } elsif ($command eq "v") { ## vertical lineto relative + my ($dy) = $args =~ /(\S+)/m ; ## XXXX what about multiple dy !? + $y += $dy; + push @res , "[$x, $y]"; + } elsif ($command eq "H") { ## horizontal lineto absolute + ($x) = $args =~ /(\S+)/m ; ## XXXX what about multiple x !? + push @res , "[$x, $y]"; + } elsif ($command eq "h") { ## horizontal lineto relative + my ($dx) = $args =~ /(\S+)/m ; ## XXXX what about multiple dx !? + $x += $dx; + push @res , "[$x, $y]"; + } elsif ($command eq "L") { ## lineto absolute + my @points = &splitPoints($args); + while (@points) { + $x = shift @points; + $y = shift @points; + push @res , "[$x, $y]"; + } + } elsif ($command eq "l") { ## lineto relative + ### thioscommand can have more than one point as arguments + my @points = &splitPoints($args); + # for (my $i = 0; $i < $#points; $i+=2) + # is not quicker than the following while + while (@points) { + ## trying to minimize the number of operation + ## to speed a bit this loop + $x += shift @points; + $y += shift @points; + push @res , "[$x, $y]"; + } + } elsif ($command eq "C" or $command eq "c") { ## cubic bezier + &myWarn ("$command command in a path must not be the first one") ,last + if (scalar @res < 1); + my @points = &splitPoints($args); + while (@points) { + &myWarn ("$command command must have 6 coordinates x N times") ,last + if (scalar @points < 6); + my $x1 = shift @points; + my $y1 = shift @points; + $prevContrlx = shift @points; + $prevContrly = shift @points; + my $xf = shift @points; + my $yf = shift @points; + if ($command eq "c") { $x1+=$x; $y1+=$y; $prevContrlx+=$x; $prevContrly+=$y; $xf+=$x; $yf+=$y} + push @res, ( "[$x1, $y1, 'c'], [$prevContrlx, $prevContrly, 'c'], [$xf, $yf]"); + $x=$xf; + $y=$yf; + } + } elsif ($command eq "S" or $command eq "s") { ## cubic bezier with opposite last control point + &myWarn ("$command command in a path must not be the first one") ,last + if (scalar @res < 1); +# print "$command command : $args\n"; + my @points = &splitPoints($args); + if ($command eq "s") { + for (my $i=0; $i <= $#points; $i += 2) { + $points[$i] += $x; + } + for (my $i=1; $i <= $#points; $i += 2) { + $points[$i] += $y; + } + } + while (@points) { + &myWarn ("$command command must have 4 coordinates x N times; skipping @points") ,last + if (scalar @points < 4); + my $x1 = (defined $prevContrlx) ? $prevContrlx : $x; + $x1 = 2*$x-$x1; + my $y1 = (defined $prevContrly) ? $prevContrly : $y; + $y1 = 2*$y-$y1; + $prevContrlx = shift @points; + $prevContrly = shift @points; + $x = shift @points; + $y = shift @points; + push @res, ( "[$x1, $y1, 'c'], [$prevContrlx, $prevContrly, 'c'], [$x, $y]"); + } + + + } elsif ($command eq "Q" or $command eq "q") { ## quadratic bezier + &myWarn ("$command command in a path must not be the first one") ,last + if (scalar @res < 1); + my @points = &splitPoints($args); + if ($command eq "q") { + for (my $i=0; $i <= $#points; $i += 2) { + $points[$i] += $x; + } + for (my $i=1; $i <= $#points; $i += 2) { + $points[$i] += $y; + } + } + while (@points) { + &myWarn ("$command command must have 4 coordinates x N times") ,last + if (scalar @points < 4); + $prevContrlx = shift @points; + $prevContrly = shift @points; + + my $last_x = $x; + my $last_y = $y; + + $x = shift @points; + $y = shift @points; + + # the following code has been provided by Lemort@intuilab.com + my @coordsToConvert = ($last_x,$last_y, $prevContrlx, $prevContrly,$x,$y); + my @convertCoords = Math::Bezier::Convert::quadratic_to_cubic(@coordsToConvert); + # removing the first point, already present + splice(@convertCoords, 0, 2); + + while (@convertCoords) { + my ($ctrl1_x, $ctrl1_y) = splice(@convertCoords, 0, 2); + my ($ctrl2_x, $ctrl2_y) = splice(@convertCoords, 0, 2); + my ($pt_x, $pt_y) = splice(@convertCoords, 0, 2); + + push @res, ("[$ctrl1_x, $ctrl1_y, 'c'], [$ctrl2_x, $ctrl2_y, 'c'], [$pt_x, $pt_y]"); + } + + } + + } elsif ($command eq "T" or $command eq "t") { ## quadratic bezier with opposite last control point?! + &myWarn ("$command command in a path must not be the first one") ,last + if (scalar @res < 1); + my @points = &splitPoints($args); + + if ($command eq "t") { + for (my $i=0; $i <= $#points; $i += 2) { + $points[$i] += $x; + } + for (my $i=1; $i <= $#points; $i += 2) { + $points[$i] += $y; + } + } + while (@points) { + &myWarn ("$command command must have 2 coordinates x N times") ,last + if (scalar @points < 2); + my $x1 = (defined $prevContrlx) ? $prevContrlx : $x; + $prevContrlx = 2*$x-$x1; + my $y1 = (defined $prevContrly) ? $prevContrly : $y; + $prevContrly = 2*$y-$y1; + + my $last_x = $x; + my $last_y = $y; + + $x = shift @points; + $y = shift @points; + + # the following code has been provided by Lemort@intuilab.com + my @coordsToConvert = ($last_x,$last_y, $prevContrlx, $prevContrly,$x,$y); + my @convertCoords = Math::Bezier::Convert::quadratic_to_cubic(@coordsToConvert); + # removing the first point, already present + splice(@convertCoords, 0, 2); + + while (@convertCoords) { + my ($ctrl1_x, $ctrl1_y) = splice(@convertCoords, 0, 2); + my ($ctrl2_x, $ctrl2_y) = splice(@convertCoords, 0, 2); + my ($pt_x, $pt_y) = splice(@convertCoords, 0, 2); + + push @res, ("[$ctrl1_x, $ctrl1_y, 'c'], [$ctrl2_x, $ctrl2_y, 'c'], [$pt_x, $pt_y]"); + } + + } + } elsif ($command eq 'a' or $command eq 'A') { + my @points = &splitPoints($args); + while (@points) { + &myWarn ("bad $command command parameters: @points\n") if (scalar @points < 7); +# print "($x,$y) $command command: @points\n"; + if ($command eq 'a') { + $points[5] += $x; + $points[6] += $y; + } +# print "($x,$y) $command command: @points\n"; + my @coords = &arcPathCommand ( $x,$y, @points[0..6] ); + push @res, @coords; + $x = $points[5]; + $y = $points[6]; + last if (scalar @points == 7); + @points = @points[7..$#points]; ### XXX ? tester! + } + } else { + &myWarn ("!!! bad path command: $command\n"); + } + } + if (@res) { + return ( $atLeastOneZ, [@res], @fullRes); + } else { return ( $atLeastOneZ, @fullRes) } +} # end of pathPoints + + + + +# this function can be called many many times; so it has been "optimized" +# even if a bit less readable +sub splitPoints { + $_ = shift; + ### adding a space before every dash (-) when the dash preceeds by a digit + s/(\d)-/$1 -/g; + ### adding a space before ? dot (.) when more than one real are not separated; + ### e.g.: '2.3.45.6.' becomes '2.3 .45 .5' + while ( scalar s/\.(\d+)\.(\d+)/\.$1 \.$2/) { + } + return split ( /[\s,]+/ ); +} + + + +sub arcPathCommand { + my ($x1,$y1, $rx,$ry, $x_rot, $large_arc_flag,$sweep_flag, $x2,$y2) = @_; + return ($x2,$y2) if ($rx == 0 and $ry == 0); + $rx = -$rx if $rx < 0; + $ry = -$ry if $ry < 0; + + # computing the center + my $phi = deg2rad($x_rot); + + # compute x1' and y1' (formula F.6.5.1) + my $deltaX = ($x1-$x2)/2; + my $deltaY = ($y1-$y2)/2; + my $xp1 = cos($phi)*$deltaX + sin($phi)*$deltaY; + my $yp1 = -sin($phi)*$deltaX + cos($phi)*$deltaY; +# print "xp1,yp1= $xp1 , $yp1\n"; + + # the radius_check has been suggested by lemort@intuilab.com + # checking that radius are correct + my $radius_check = ($xp1/$rx)**2 + ($yp1/$ry)**2; + + if ($radius_check > 1) { + $rx *= sqrt($radius_check); + $ry *= sqrt($radius_check); + } + + # compute the sign: (formula F.6.5.2) + my $sign = 1; + $sign = -1 if $large_arc_flag eq $sweep_flag; + # compute the big square root (formula F.6.5.2) +# print "denominator: ", ( ($rx*$ry)**2 - ($rx*$yp1)**2 - ($ry*$xp1)**2 ),"\n"; + my $bigsqroot = ( + abs( ($rx*$ry)**2 - ($rx*$yp1)**2 - ($ry*$xp1)**2 ) ### ABS ?!?! + / + ( ($rx*$yp1)**2 + ($ry*$xp1)**2 ) + ); + # computing c'x and c'y (formula F.6.5.2) + $bigsqroot = $sign * sqrt ($bigsqroot); + my $cpx = $bigsqroot * ($rx*$yp1/$ry); + my $cpy = $bigsqroot * (- $ry*$xp1/$rx); + + # compute cx and cy (formula F.6.5.3) + my $middleX = ($x1+$x2)/2; + my $middleY = ($y1+$y2)/2; + my $cx = cos($phi)*$cpx - sin($phi)*$cpy + $middleX; + my $cy = sin($phi)*$cpx + cos($phi)*$cpy + $middleY; + + # computing theta1 (formula F.6.5.5) + my $XX = ($xp1-$cpx)/$rx; + my $YY = ($yp1-$cpy)/$ry; + my $theta1 = rad2deg (&vectorProduct ( 1,0, $XX,$YY)); + # computing dTheta (formula F.6.5.6) + my $dTheta = rad2deg (&vectorProduct ( $XX,$YY, (-$xp1-$cpx)/$rx,(-$yp1-$cpy)/$ry )); + + if (!$sweep_flag and $dTheta>0) { + $dTheta-=360; + } + if ($sweep_flag and $dTheta<0) { + $dTheta+=360; + } + return join (",", &computeArcPoints($cx,$cy,$rx,$ry, + $phi,deg2rad($theta1),deg2rad($dTheta))), "\n"; +} + +sub computeArcPoints { + my ($cx,$cy,$rx,$ry,$phi,$theta1,$dTheta) = @_; + my $Nrad = 3.14/18; + my $N = &float2int(abs($dTheta/$Nrad)); + my $cosPhi = cos($phi); + my $sinPhi = sin($phi); + my $dd = $dTheta/$N; + my @res; + for (my $i=0; $i<=$N; $i++) + { + my $a = $theta1 + $dd*$i; + my $xp = $rx*cos($a); + my $yp = $ry*sin($a); + my $x1 = $cosPhi*$xp - $sinPhi*$yp + $cx; + my $y1 = $sinPhi*$xp + $cosPhi*$yp + $cy; + push @res, "[$x1, $y1]"; + } + return @res; +} + +## vectorial product +sub vectorProduct { + my ($x1,$y1, $x2,$y2) = @_; + my $sign = 1; + $sign = -1 if ($x1*$y2 - $y1*$x2) < 0; + + return $sign * acos ( ($x1*$x2 + $y1*$y2) + / + sqrt ( ($x1**2 + $y1**2) * ($x2**2 + $y2**2) ) + ); +} + +###################################################################################### +# points conversions for polygone / polyline +###################################################################################### + +# &points (\%attrs) +# converts the string, value of an attribute points +# to a string of coordinate list for Tk::Zinc +sub points { + my ($ref_attrs) = @_; + my $str = $ref_attrs->{points}; + # suppressing leading and trailing blanks: + ($str) = $str =~ /^\s* # leading blanks + (.*\S) # + \s*$ # trailing blanks + /x; + + $str =~ s/([^,])[\s]+([^,])/$1,$2/g ; # replacing blanks separators by a comma + return $str; +} + +###################################################################################### +# cleaning an id to make it usable as a TkZinc Tag +###################################################################################### + +## the following function cleans an id, ie modifies it so that it +## follows the TkZinc tag conventions. +## BUG: the cleanning is far from being complete +sub cleanName { + my $id = shift; + # to avoid numeric ids + if ($id =~ /^\d+$/) { +# &myWarn ("id: $id start with digits\n"); + $id = "id_".$id; + } + # to avoid any dots in a tag + if ($id =~ /\./) { +# &myWarn ("id: $id contains dots\n"); + $id =~ s/\./_/g ; + } + return $id; +} + +################################################################################ +# size conversions +################################################################################ + +## get a list of "size" attributes as listed in @attrs (e.g.: x y width height...) +## - convert all in pixel +## - return 0 for attributes listed in @attrs and not available in %{$ref_attrs} +sub sizesConvert { + my ($ref_attrs,@attrs) = @_; + my %attrs = %{$ref_attrs}; + my @res; + foreach my $attr (@attrs) + { + my $value; + if (!defined ($value = $attrs{$attr}) ) + { + if ($attr eq 'x2') + { + push (@res, 1); + } + else + { + push (@res, 0); + } + } + else + { + push @res,&sizeConvert ($value); + } + } + return @res; +} # end of sizesConvert + +# currently, to simplify this code, I suppose the screen is 100dpi! +# at least the generated code is currently independant from the host +# where is is supposed to run +# maybe this should be enhanced +sub sizeConvert { + my ($value) = @_; + if ($value =~ /(.*)cm/) { + return $1 * 40; ## approximative pixel / cm + } elsif ($value =~ /(.*)mm/) { + return $1 * 4; ## approximative pixel / mm + } elsif ($value =~ /(.*)px/) { + return $1; ## exact! pixel / pixel + } elsif ($value =~ /(.*)in/) { + return &float2int($1 * 100); ## approximative pixel / inch + } elsif ($value =~ /(.*)pt/) { + return &float2int($1 * 100 / 72); ## approximative pixel / pt (a pt = 1in/72) + } elsif ($value =~ /(.*)pc/) { + return &float2int($1 * 100 / 6); ## (a pica = 1in/6) + } elsif ($value =~ /(.*)%/) { + return $1/100; ## useful for coordinates using % + ## in lienar gradient (x1,x2,y2,y2) + } elsif ($value =~ /(.*)em/) { # not yet implemented + &myWarn ("em unit not yet implemented in sizes"); + return $value; + } elsif ($value =~ /(.*)ex/) { # not yet implemented + &myWarn ("ex unit not yet implemented in sizes"); + return $value; + } else { + return $value; + } +} # end of sizeConvert + + +sub float2int { + return sprintf ("%.0f",$_[0]); +} + + +# process a string describing transformations +# returns a list of string describing transformations +# to be applied to Tk::Zinc item Id +sub transform { + my ($id, $str) = @_; + return () if !defined $str; + &myWarn ("!!! Need an Id for applying a transformation\n"), return () if !defined $id; + my @fullTrans; + while ($str =~ m/\s*(\w+)\s*\(([^\)]*)\)\s*/g) { + my ($trans, $params) = ($1,$2); + my @params = split (/[\s,]+/, $params); + if ($trans eq 'translate') { + $params[1] = 0 if scalar @params == 1; ## the 2nd paramter defaults to 0 + my $translation = "-> translate ($id," . join (",",@params) . ");" ; + push @fullTrans, $translation; + } elsif ($trans eq 'rotate') { + $params[0] = deg2rad($params[0]); + my $rotation = "-> rotate ($id," . join (",",@params) . ");"; + push @fullTrans, $rotation; + } elsif ($trans eq 'scale') { + $params[1] = $params[0] if scalar @params == 1; ## the 2nd scale parameter defaults to the 1st + my $scale = "-> scale ($id," . join (",",@params) . ");"; + push @fullTrans,$scale; + } elsif ($trans eq 'matrix') { + my $matrixParams = join ',',@params; + my $matrix = "-> tset ($id, $matrixParams);"; + push @fullTrans, $matrix; + } elsif ($trans eq 'skewX'){ + my $skewX = "-> skew ($id, " . deg2rad($params[0]) . ",0);"; +# print "skewX=$skewX\n"; + push @fullTrans, $skewX; + } elsif ($trans eq 'skewY'){ + my $skewY = "-> skew ($id, 0," . deg2rad($params[0]) . ");"; +# print "skewY=$skewY\n"; + push @fullTrans, $skewY; + } else { + &myWarn ("!!! Unknown transformation '$trans'\n"); + } +# $str = $rest; + } + return reverse @fullTrans; +} # end of transform + +1; |