home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Lighthouse Design Suite
/
LIGHTHOUSE.mdf
/
TaskMaster_1.8
/
Application
/
FilterServicer.service
/
writedg.pl
< prev
next >
Wrap
Perl Script
|
1993-08-27
|
25KB
|
757 lines
#
# writedg.pl
#
# This package allows the user to easily create a Diagram file.
#
# Copyright (C) 1993 Lighthouse Design Ltd.
#
# You may freely copy, distribute, and reuse the code in
# this example provided this copyright legend and disclaimer
# are preserved in all copies and derivative work.
#
# Lighthouse Design disclaims any warranty of any kind,
# expressed or implied, as to this code's fitness
# for any particular use.
#
#
package writedg;
#
# defaults
#
$defViewHorizSize = 756.0;
$defViewVertSize = 576.0;
$defaultSymbolX = 10;
$defaultSymbolY = 10;
$defaultSymbolW = 10;
$defaultSymbolH = 10;
#
# initialization
#
$currentDocumentIndex = 1;
$legalSymbol{"Circle"}= 1;
$legalSymbol{"Cylinder"}= 1;
$legalSymbol{"Diamond"}= 1;
$legalSymbol{"Hexagon"}= 1;
$legalSymbol{"Horizontal Arrow"}= 1;
$legalSymbol{"Vertical Arrow"}= 1;
$legalSymbol{"Horizontal Triangle"}= 1;
$legalSymbol{"Vertical Triangle"}= 1;
$legalSymbol{"Rectangle"}= 1;
$legalSymbol{"Rounded Rectangle"}= 1;
$legalSymbol{"Parallelogram"}= 1;
$legalSymbol{"Parallel Lines"}= 1;
$legalHead{"arrow"} = 1;
$legalHead{"doubleArrow"} = 1;
$legalHead{"hollowArrow"} = 1;
$legalHead{"circle"} = 1;
$legalHead{"solidCircle"} = 1;
$legalPlacement{"top"} = 1;
$legalPlacement{"bottom"} = 1;
$legalPlacement{"centered"} = 1;
$debugging = 0;
sub main'setDebugging{ # onOff (0 = off, 1 = on)
$debugging = $_[0];
}
sub main'newDocument{ #nothing -> document identifier
local($newDocumentID) = $currentDocumentIndex;
print "New Document -> $newDocumentID\n" unless !$debugging;
$currentDocumentIndex++;
$documentExists{$newDocumentID} = 1;
$documentCurrentObjectID{$newDocumentID} = 1;
$documentSymbols{$newDocumentID} = "";
$documentLines{$newDocumentID} = "";
$documentVertexes{$newDocumentID} = "";
$documentGroups{$newDocumentID} = "";
return $newDocumentID;
}
sub main'setDocumentRuler{ # documentID rulerShowing (1 = yes, 0 = no)
local($documentID, $rulerShowing) = @_;
print "SetDocumentRuler -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$documentRuler{$documentID} = $rulerShowing;
$documentID;
}
sub main'setDocumentButtons{ # documentID buttonsShowing (1 = yes, 0 = no)
local($documentID, $buttonsShowing) = @_;
print "SetDocumentButtons -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$documentButtons{$documentID} = $buttonsShowing;
$documentID;
}
sub main'setDocumentDefaultFont{ # documentID fontName fontSize
local($documentID, $fontName, $fontSize) = @_;
print "SetDocumentDefaultFont -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$defaultFont{$documentID} = $fontName;
$defaultFontSize{$documentID} = $fontSize;
$documentID;
}
sub main'setDocumentCanvasSize{ # documentID canvasW canvasH
local($documentID, $canvasW, $canvasH) = @_;
print "SetDocumentCanvasSize -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$documentCanvasW{$documentID} = $canvasW;
$documentCanvasH{$documentID} = $canvasH;
$documentID;
}
sub main'setDocumentGridVisible{ # documentID gridVisible (1 = yes, 0 = no)
local($documentID, $gridShowing) = @_;
print "SetDocumentGridVis -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$documentGrid{$documentID} = $gridShowing;
$documentID;
}
sub main'setDocumentGridSize{ # documentID gridSpacing
local($documentID, $gridSpacing) = @_;
print "SetDocumentGridSpacing -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$documentGridSpacing{$docuementID} = $gridSpacing;
$documentID;
}
sub main'setDocumentSnapToGrid{ # documentID snapOn (1 = yes, 0 = no)
local($documentID, $snapOn) = @_;
print "SetDocumentSnapToGrid -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$documentSnap{$docuementID} = $snapOn;
$documentID;
}
sub main'setDocumentZoom{ # documentID zoomPercentage
local($documentID, $zoom) = @_;
print "SetDocumentZoom -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
$documentZoom{$documentID} = $zoom;
$documentID;
}
sub main'newSymbol{ # documentID type x y w h -> objectID
local($documentID, $objectType, $x, $y, $w, $h) = @_;
print "newSymbol -> @_\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
local($newObjectID) = &newObjectID($documentID);
print "New Symbol -> $newObjectID\n" unless !$debugging;
$documentSymbols{$documentID} .= "$newObjectID,";
$objectFlavor{$newObjectID} = "Symbol";
if($objectType){
&main'setObjectType($newObjectID, $objectType);
}
($objectX{$newObjectID} = $x)||($objectX{$newObjectID} = $defaultSymbolX);
($objectY{$newObjectID} = $y)||($objectY{$newObjectID} = $defaultSymbolY);
($objectW{$newObjectID} = $w)||($objectW{$newObjectID} = $defaultSymbolW);
($objectH{$newObjectID} = $h)||($objectH{$newObjectID} = $defaultSymbolH);
&main'setObjectFramed($newObjectID, 1);
$newObjectID;
}
sub main'newLine{ # documentID fromObject toObject -> objectID
local($documentID, $fromObject, $toObject) = @_;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
local($newLineID) = &newObjectID($documentID);
print "New Line -> $newLineID\n" unless !$debugging;
$documentLines{$documentID} .= "$newLineID,";
$objectFlavor{$newLineID} = "Line";
local($vertex1) = &main'newVertex($documentID);
local($vertex2) = &main'newVertex($documentID);
$lineVertexList{$newLineID} = "$vertex1,$vertex2";
($fromObject && $toObject) || &error("Must specify both from and to");
$objectFlavor{$fromObject} || &error("Invalid fromObject -> $fromObject");
$lineFrom{$newLineID} = $fromObject;
$objectFlavor{$toObject} || &error("Invalid toObject -> $toObject");
$lineTo{$newLineID} = $toObject;
$newLineID;
}
sub main'newVertex{ # documentID x y
local($documentID, $x, $y) = @_;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
local($newVertexID) = &newObjectID($documentID);
print "New Vertext -> $newVertexID\n" unless !$debugging;
$documentVertexes{$documentID} .= "$newVertexID,";
$objectFlavor{$newVertexID} = "Vertex";
$objectX{$newVertexID} = $x;
$objectY{$newVertexID} = $y;
$newVertexID;
}
sub main'newGroup{ # documentID groupedObjectID groupedObjectID2 etc
local($documentID, @objectList) = @_;
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
local($newGroupID) = &newObjectID($documentID);
print "New Group -> $newGroupID\n" unless !$debugging;
$documentGroups{$documentID} .= "$newGroupID,";
$objectFlavor{$newGroupID} = "Group";
$groupObjectList{$newGroupID} = "";
foreach $thing (@objectList){
$objectFlavor{$thing}|| &error("Invalid Object ID in Group -> $thing");
$objectFlavor{$thing} && do {
$groupObjectList{$newGroupID} .= "$thing,";
$objectInGroup{$thing} = 1;
};
}
$newGroupID;
}
sub main'vertexesForLine{ # objectID
local($objectID) = @_;
print "vertexesForLine (@_)\n" unless !$debugging;
$objectFlavor{$objectID} eq "Line" || &error("Object not a line -> $objectID");
split(/,/,$lineVertexList{$objectID});
}
sub main'setVertexesForLine{ # objectID vertex1, vertex2, ...
local($objectID, @vertexList) = @_;
print "setVertexesForLine (@_)\n" unless !$debugging;
$objectFlavor{$objectID} eq "Line" || &error("Object not a line -> $objectID");
$ok = 0;
foreach $thing (@vertexList){
$objectFlavor{$objectID} eq "Vertex" || &error("Object not a vertex -> $thing");
if(!$ok){
$lineVertexList{$objectID} = "$thing,";
$ok = 1;
}else{
$lineVertexList{$objectID} .= "$thing,";
}
}
$objectID;
}
sub main'setObjectType{ # objectID type
local($objectID, $type) = @_;
print "setObjectType (@_)\n" unless !$debugging;
$objectFlavor{$objectID} eq "Symbol" || &error("Object not a symbol -> $objectID");
($legalSymbol{$type}) || &error("Invalid symbol type -> $type");
$objectType{$objectID} = $type;
$objectID;
}
sub main'setObjectLocation{ # objectID x y
local($objectID, $x, $y) = @_;
print "setObjectLocation (@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Vertex" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectLocation -> $objectID");
$objectX{$objectID} = $x;
$objectY{$objectID} = $y;
$objectID;
}
sub main'setObjectSize{ # documentID objectID w h
local($objectID, $w, $h) = @_;
print "setObjectSize (@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectSize -> $objectID");
$objectW{$objectID} = $w;
$objectH{$objectID} = $h;
$objectID;
}
sub main'setObjectX{ # documentID objectID x
local($objectID, $x) = @_;
print "setObjectX (@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Vertex" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectX -> $objectID");
$objectX{$objectID} = $x;
$objectID;
}
sub main'setObjectY{ # documentID objectID y
local($objectID, $y) = @_;
print "setObjectY (@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Vertex" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectY -> $objectID");
$objectY{$objectID} = $y;
$objectID;
}
sub main'setObjectWidth{ # documentID objectID width
local($objectID, $w) = @_;
print "setObjectWidth (@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectWidth -> $objectID");
$objectW{$objectID} = $w;
$objectID;
}
sub main'setObjectHeight{ # documentID objectID height
local($objectID, $h) = @_;
print "setObjectHeight (@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectHeight -> $objectID");
$objectH{$objectID} = $h;
$objectID;
}
sub main'setObjectLocked{ # objectID locked (1 = yes, 0 = no)
local($objectID, $locked) = @_;
print "setObjectLocked (@_)\n" unless !$debugging;
$objectFlavor{$objectID} || &error("Object not valid for setObjectLocked -> $objectID");
$objectLocked{$objectID} = $locked;
$objectID;
}
sub main'setObjectRotationAngle{ # objectID rotationAngle
local($objectID, $rot) = @_;
print "setObjectRotationAngle (@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectRotationAngle -> $objectID");
$objectRotationAngle{$objectID} = $rot;
$objectID;
}
sub main'setObjectShadowed{ # documentID objectID shadowed (1 = yes, 0 = no)
local($objectID, $flag) = @_;
print "setObjectShadowed (@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol") || &error("Object not valid for setObjectShadowed -> $objectID");
$objectShadowed{$objectID} = $flag;
$objectID;
}
sub main'setObjectShadowColor{ # documentID objectID r g b
local($objectID, $r, $g, $b) = @_;
print "setObjectShadowColor(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol") || &error("Object not valid for setObjectShadowColor -> $objectID");
$objectShadowColor{$objectID} = "rgbColor $r $g $b";
$objectID;
}
sub main'setObjectShadowGray{ # objectID gray
local($objectID, $gray) = @_;
print "setObjectShadowGray(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol") || &error("Object not valid for setObjectShadowGray -> $objectID");
$objectShadowColor{$objectID} = sprintf("gray %f", $gray);
$objectID;
}
sub main'setObjectFilled{ # objectID filled (1 = yes, 0 = no)
local($objectID, $filled) = @_;
print "setObjectFilled(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectShadowGray -> $objectID");
$objectFilled{$objectID} = $filled;
$objectID;
}
sub main'setObjectFillColor{ # documentID objectID r g b
local($objectID, $r, $g, $b) = @_;
print "setObjectFillColor(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectFillColor -> $objectID");
$objectFillColor{$objectID} = "rgbColor $r $g $b";
$objectID;
}
sub main'setObjectFillGray{ # documentID objectID gray
local($objectID, $gray) = @_;
print "setObjectFillGray(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectFillGray -> $objectID");
$objectFillColor{$objectID} = "gray $gray";
$objectID;
}
sub main'setObjectFramed{ # documentID objectID framed (1 = yes, 0 = no)
local($objectID, $framed) = @_;
print "setObjectFramed(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol") || &error("Object not valid for setObjectFramed -> $objectID");
$objectFramed{$objectID} = $framed;
$objectID;
}
sub main'setObjectFrameColor{ # documentID objectID r g b
local($objectID, $r, $g, $b) = @_;
print "setObjectFrameColor(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectFrameColor -> $objectID");
$objectFrameColor{$objectID} = "rgbColor $r $g $b";
$objectID;
}
sub main'setObjectFrameGray{ # documentID objectID gray
local($objectID, $gray) = @_;
print "setObjectFrameGray(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectFrameGray -> $objectID");
$objectFrameColor{$objectID} = "gray $gray";
$objectID;
}
sub main'setObjectLineWidth{ # documentID objectID gray
local($objectID, $width) = @_;
print "setObjectLineWidth(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectLineWidth -> $objectID");
$objectLineWidth{$objectID} = $width;
$objectID;
}
sub main'setObjectLineType{ # objectID type (0 = solid, 1 = dot, 2 = dash, 3 = dotDash
local($objectID, $type) = @_;
print "setObjectLineType(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectLineWidth -> $objectID");
if($type == 0){
$objectLineType{$objectID} = "solid";
}elsif($type == 1){
$objectLineType{$objectID} = "dot";
}elsif($type == 2){
$objectLineType{$objectID} = "dash";
}elsif($type == 3){
$objectLineType{$objectID} = "dotDash";
}else{
&error("Invalid type in setObjectLineType -> $type");
}
$objectID;
}
sub main'setObjectRtfText{ # objectID textString
local($objectID, $rtf) = @_;
print "setObjectRtfText(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectRtfText -> $objectID");
$objectRtfText{$objectID} = $rtf;
$objectID;
}
sub main'setObjectText{ # objectID text
local($objectID, $text) = @_;
print "setObjectText(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectText -> $objectID");
$objectText{$objectID} = $text;
$objectID;
}
sub main'setObjectTextPlacement{ # objectID textPlacement
local($objectID, $placement) = @_;
print "setObjectTextPlacement(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Symbol" ) || &error("Object not valid for setObjectTextPlacement -> $objectID");
$legalPlacement{$placement} || &error("Illegal placement parameter -> $placement");
$objectTextPlacement{$objectID} = $placement;
$objectID;
}
sub main'setObjectLayer{ # objectID level
local($objectID, $layer) = @_;
print "setObjectLayer(@_)\n" unless !$debugging;
($objectFlavor{$objectID}) || &error("Object not valid for setObjectText -> $objectID");
$objectLayer{$objectID} = $layer;
$objectID;
}
sub main'setLineTailType{ # lineID text
local($objectID, $type) = @_;
print "setLineTailType(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineTailType -> $objectID");
$legalHead{$type} || &error("Type not valid for line end -> $type");
$lineTailType{$objectID} = $type;
$objectID;
}
sub main'setLineHeadType{
local($objectID, $type) = @_;
print "setLineHeadType(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineTailType -> $objectID");
$legalHead{$type} || &error("Type not valid for line end -> $type");
$lineHeadType{$objectID} = $type;
$objectID;
}
sub main'setLineTo{ #objectID toObjectID
local($objectID, $toObject) = @_;
print "setLineTo(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineTo -> $objectID");
($objectFlavor{$toObject}) || &error("Argument not valid for setLineTo -> $toObject");
$lineTo{$objectID} = $toObject;
$objectID;
}
sub main'setLineFrom{ #objectID toObjectID
local($objectID, $fromObject) = @_;
print "setLineFrom(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineFrom -> $objectID");
($objectFlavor{$fromObject}) || &error("Argument not valid for setLineFrom -> $fromObject");
$lineFrom{$objectID} = $fromObject;
$objectID;
}
sub main'setLineCurved{ #objectID curved(1=yes, 0=no)
local($objectID, $curved) = @_;
print "setLineCurved(@_)\n" unless !$debugging;
($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineCurved -> $objectID");
$lineCurved{$objectID} = $curved;
$objectID;
}
sub main'writeDocument{ # documentID filename
local($documentID, $filename) = @_;
print "writeDocument(@_)\n" unless !$debugging;
$documentExists{$documentID} || &error("Invalid document argument -> $documentID");
local($dtFilename) = "$filename/DiagramText";
if((-f "$dtFilename")){
print "$filename exists, overwriting\n";
}elsif((!mkdir($filename, 0775))){
die "Couldn't create $filename - exiting.";
}
if(!open(DIAG, ">$dtFilename")){
die "Couln't open $dtFilename";
}
select((select(DIAG), $| = 1)[0]);
#
# Document Stuff
#
print DIAG "#!DG_TEXT\n";
print DIAG "# generated by writedg.pl library v. 1.0 ";
print DIAG "\n";
if($documentCanvasW{$documentID} && $documentCanvasH{$documentID}){
print DIAG "canvasSize $documentCanvasW{$documentID} $documentCanvasH{$documentID}\n";
}else{
print DIAG "canvasSize 1 1\n";
}
if($documentRuler{$documentID}){
print DIAG "showRulers\n";
}
if($documentButtons{$documentID}){
print DIAG "showTools\n";
}
if($documentGrid{$documentID}){
print DIAG "gridVisible\n";
}
if($documentGridSpacing{$documentID}){
print DIAG "gridSpacing $documentGridSpacing\n";
}
if($documentSnap{$documentID}){
print DIAG "snapToGrid\n";
}
print DIAG "viewSize $defViewHorizSize $defViewVertSize\n";
if($documentZoom{$documentID}){
print DIAG "zoom $documentZoom{$documentID}\n";
}
if($defaultFont{$documentID}){
print DIAG "defaultFont \"$defaultFont{$documentID}\"\n";
}
if($defaultFontSize{$documentID}){
print DIAG "defaultFontSize $defaultFontSize{$documentID}\n";
}
print DIAG "\n";
#
# Symbols
#
local(@symbolList) = split(/,/,$documentSymbols{$documentID});
foreach $thing (@symbolList){
$objectNum = &objectNumber($thing);
print DIAG "symbol $objectNum\n";
if(!$objectType{$thing}){
$objectType{$thing} = 9;
}
print DIAG "\tshape \"$objectType{$thing}\"\n";
if($objectInGroup{$thing}){
print DIAG "\tlayer -1\n";
}elsif($objectLayer{$thing}){
print DIAG "\tlayer $objectLayer{$thing}\n";
}
if($objectFramed{$thing}){
print DIAG "\tframed\n";
}
if($objectFrameColor{$thing}){
print DIAG "\tframeColor $objectFrameColor{$thing}\n";
}
if($objectLineWidth{$thing}){
print DIAG "\tlineWidth $objectLineWidth{$thing}\n";
}
if($objectLineType{$thing}){
print DIAG "\tlineType $objectLineType{$thing}\n";
}
if($objectFilled{$thing}){
print DIAG "\tfilled\n";
}
if($objectFillColor{$thing}){
print DIAG "\tfillColor $objectFillColor{$thing}\n";
}
if($objectShadowed{$thing}){
print DIAG "\tshadowed\n";
}
if($objectShadowColor{$thing}){
print DIAG "\tshadowColor $objectShadowColor{$thing}\n";
}
if($objectLocked{$thing}){
print DIAG "\tlocked\n";
}
if($objectTextPlacement{$thing}){
print DIAG "\ttextPlacement $objectTextPlacement{$thing}\n";
}
if($objectRtfText{$thing}){
print DIAG "\trtfText $objectRtfText{$thing}\n";
}elsif($objectText{$thing}){
print DIAG "\ttext \"$objectText{$thing}\"\n";
}
print DIAG "\tlocation $objectX{$thing} $objectY{$thing}\n";
print DIAG "\tsize $objectW{$thing} $objectH{$thing}\n";
print DIAG "end\n\n";
}
#
# Vertices
#
local(@vertexList) = split(/,/,$documentVertexes{$documentID});
foreach $thing (@vertexList){
$objectNum = &objectNumber($thing);
print DIAG "vertex $objectNum\n";
if($objectInGroup{$thing}){
print DIAG "\tlayer -1";
}elsif($objectLayer{$thing}){
print DIAG "\tlayer $objectLayer{$thing}\n";
}
if($objectX{$thing} && $objectY{$thing}){
print DIAG "\tlocation $objectX{$thing} $objectY{$thing}\n";
}
print DIAG "end\n\n";
}
#
# Lines
#
local(@lineList) = split(/,/,$documentLines{$documentID});
foreach $thing (@lineList){
$objectNum = &objectNumber($thing);
print DIAG "line $objectNum\n";
$num = &objectNumber($lineFrom{$thing});
print DIAG "\tfrom $num\n";
$num = &objectNumber($lineTo{$thing});
print DIAG "\tto $num\n";
foreach $vert (split(/,/,$lineVertexList{$thing})){
$vertNum = &objectNumber($vert);
print DIAG "\t$vertNum\n";
}
if($objectInGroup{$thing}){
print DIAG "\tlayer -1\n";
}elsif($objectLayer{$thing}){
print DIAG "\tlayer $objectLayer{$thing}\n";
}
if($objectLineWidth{$thing}){
print DIAG "\tlineWidth $objectLineWidth{$thing}\n";
}
if($objectFilled{$thing}){
print DIAG "\tfilled\n";
}
if($objectFillColor{$thing}){
print DIAG "\tfillColor $objectFillColor{$thing}\n";
}
if($objectFramed{$thing}){
print DIAG "\tframed\n";
}
if($objectFrameColor{$thing}){
print DIAG "\tframeColor $objectFrameColor{$thing}\n";
}
if($lineHeadType{$thing}){
print DIAG "\theadType $lineHeadType{$thing}\n";
}
if($lineTailType{$thing}){
print DIAG "\ttailType $lineTailType{$thing}\n";
}
if($lineCurved{$thing}){
print DIAG "\tcurved\n";
}
print DIAG "end\n\n";
}
#
# Groups
#
local(@groupList) = split(/,/,$documentGroups{$documentID});
foreach $thing (@groupList){
$objectNum = &objectNumber($thing);
print DIAG "group $objectNum\n";
print DIAG "\t";
foreach $littlething (split(/,/,$groupObjectList{$thing})){
$num = &objectNumber($littlething);
print DIAG "$num ";
}
print DIAG "\n";
if($objectInGroup{$thing}){
print DIAG "\tlayer -1\n";
}elsif($objectLayer{$thing}){
print DIAG "\tlayer $objectLayer{$thing}\n";
}
if($objectX{$thing} && $objectY{$thing}){
print DIAG "\tlocation $objectX{$thing} $objectY{$thing}\n";
}
if($objectW{$thing} && $objectH{$thing}){
print DIAG "\tsize $objectW{$thing} $objectH{$thing}\n";
}
if($objectLocked{$thing}){
print DIAG "\tlocked\n";
}
print DIAG "end\n\n";
}
}
#
# local subroutines
#
sub newObjectID { # documentID
$documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
local($return) = "$documentID:$documentCurrentObjectID{$documentID}";
$documentCurrentObjectID{$documentID}++;
return $return;
}
sub error{ # error string
print STDERR ($_[0], "\n\n");
sleep 1;
exit 1;
}
sub objectNumber{ # objectID
local($objectID) = @_;
$objectID =~ /[^:]+:(\d+)/ || &error("Couldn't extract number from $objectID");
return $1;
}
1;
# Place Emacs into Perl-mode
# Local Variables:
# mode: perl
# End: