home *** CD-ROM | disk | FTP | other *** search
/ Lighthouse Design Suite / LIGHTHOUSE.mdf / Quantrix_1.2 / Application / FilterServicer.service / writedg.pl < prev    next >
Perl Script  |  1993-08-27  |  25KB  |  757 lines
  1. #
  2. #  writedg.pl
  3. #
  4. #  This package allows the user to easily create a Diagram file.
  5. #
  6. #  Copyright (C) 1993 Lighthouse Design Ltd.
  7. #
  8. #  You may freely copy, distribute, and reuse the code in
  9. #  this example provided this copyright legend and disclaimer
  10. #  are preserved in all copies and derivative work.
  11. #
  12. #  Lighthouse Design disclaims any warranty of any kind,
  13. #  expressed or implied, as to this code's fitness
  14. #  for any particular use.
  15. #
  16. #
  17.  
  18. package writedg;
  19. #
  20. # defaults
  21. #
  22. $defViewHorizSize = 756.0;
  23. $defViewVertSize = 576.0;
  24. $defaultSymbolX = 10;
  25. $defaultSymbolY = 10;
  26. $defaultSymbolW = 10;
  27. $defaultSymbolH = 10;
  28.  
  29. #
  30. # initialization
  31. #
  32. $currentDocumentIndex = 1;
  33.  
  34. $legalSymbol{"Circle"}= 1;
  35. $legalSymbol{"Cylinder"}= 1;
  36. $legalSymbol{"Diamond"}= 1;
  37. $legalSymbol{"Hexagon"}= 1;
  38. $legalSymbol{"Horizontal Arrow"}= 1;
  39. $legalSymbol{"Vertical Arrow"}= 1;
  40. $legalSymbol{"Horizontal Triangle"}= 1;
  41. $legalSymbol{"Vertical Triangle"}= 1;
  42. $legalSymbol{"Rectangle"}= 1;
  43. $legalSymbol{"Rounded Rectangle"}= 1;
  44. $legalSymbol{"Parallelogram"}= 1;
  45. $legalSymbol{"Parallel Lines"}= 1;
  46.  
  47. $legalHead{"arrow"} = 1;
  48. $legalHead{"doubleArrow"} = 1;
  49. $legalHead{"hollowArrow"} = 1;
  50. $legalHead{"circle"} = 1;
  51. $legalHead{"solidCircle"} = 1;
  52.  
  53. $legalPlacement{"top"} = 1;
  54. $legalPlacement{"bottom"} = 1;
  55. $legalPlacement{"centered"} = 1;
  56.  
  57. $debugging = 0;
  58.  
  59. sub main'setDebugging{ # onOff (0 = off, 1 = on)
  60.     $debugging = $_[0];
  61. }
  62.  
  63. sub main'newDocument{ #nothing -> document identifier
  64.     local($newDocumentID) = $currentDocumentIndex;
  65.     print "New Document -> $newDocumentID\n" unless !$debugging;
  66.     $currentDocumentIndex++;
  67.     $documentExists{$newDocumentID} = 1;
  68.     $documentCurrentObjectID{$newDocumentID} = 1;
  69.     $documentSymbols{$newDocumentID} = "";
  70.     $documentLines{$newDocumentID} = "";
  71.     $documentVertexes{$newDocumentID} = "";
  72.     $documentGroups{$newDocumentID} = "";
  73.     return $newDocumentID;
  74. }
  75.  
  76. sub main'setDocumentRuler{ # documentID rulerShowing (1 = yes, 0 = no)
  77.     local($documentID, $rulerShowing) = @_;
  78.     print "SetDocumentRuler -> @_\n" unless !$debugging;
  79.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  80.     $documentRuler{$documentID} = $rulerShowing;
  81.     $documentID;
  82. }
  83.  
  84. sub main'setDocumentButtons{ # documentID buttonsShowing (1 = yes, 0 = no)
  85.     local($documentID, $buttonsShowing) = @_;
  86.     print "SetDocumentButtons -> @_\n" unless !$debugging;
  87.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  88.     $documentButtons{$documentID} = $buttonsShowing;
  89.     $documentID;
  90. }
  91.  
  92. sub main'setDocumentDefaultFont{ # documentID fontName fontSize
  93.     local($documentID, $fontName, $fontSize) = @_;
  94.     print "SetDocumentDefaultFont -> @_\n" unless !$debugging;
  95.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  96.     $defaultFont{$documentID} = $fontName;
  97.     $defaultFontSize{$documentID} = $fontSize;
  98.     $documentID;
  99. }
  100.  
  101. sub main'setDocumentCanvasSize{ # documentID canvasW canvasH
  102.     local($documentID, $canvasW, $canvasH) = @_;
  103.     print "SetDocumentCanvasSize -> @_\n" unless !$debugging;
  104.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  105.     $documentCanvasW{$documentID} = $canvasW;
  106.     $documentCanvasH{$documentID} = $canvasH;
  107.     $documentID;
  108. }
  109.  
  110. sub main'setDocumentGridVisible{ # documentID gridVisible (1 = yes, 0 = no)
  111.     local($documentID, $gridShowing) = @_;
  112.     print "SetDocumentGridVis -> @_\n" unless !$debugging;
  113.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  114.     $documentGrid{$documentID} = $gridShowing;
  115.     $documentID;
  116.  
  117. }
  118.  
  119. sub main'setDocumentGridSize{ # documentID gridSpacing
  120.     local($documentID, $gridSpacing) = @_;
  121.     print "SetDocumentGridSpacing -> @_\n" unless !$debugging;
  122.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  123.     $documentGridSpacing{$docuementID} = $gridSpacing;
  124.     $documentID;
  125. }
  126.  
  127. sub main'setDocumentSnapToGrid{ # documentID snapOn (1 = yes, 0 = no)
  128.     local($documentID, $snapOn) = @_;
  129.     print "SetDocumentSnapToGrid -> @_\n" unless !$debugging;
  130.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  131.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  132.     $documentSnap{$docuementID} = $snapOn;
  133.     $documentID;
  134.     
  135. }
  136.  
  137. sub main'setDocumentZoom{ # documentID zoomPercentage
  138.     local($documentID, $zoom) = @_;
  139.     print "SetDocumentZoom -> @_\n" unless !$debugging;
  140.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  141.     $documentZoom{$documentID} = $zoom;
  142.     $documentID;
  143. }
  144.  
  145. sub main'newSymbol{ # documentID type x y w h -> objectID
  146.     local($documentID, $objectType, $x, $y, $w, $h) = @_;
  147.     print "newSymbol -> @_\n" unless !$debugging;
  148.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  149.     
  150.     local($newObjectID) = &newObjectID($documentID);
  151.     print "New Symbol -> $newObjectID\n" unless !$debugging;
  152.     $documentSymbols{$documentID} .= "$newObjectID,";
  153.     $objectFlavor{$newObjectID} = "Symbol";
  154.     if($objectType){
  155.     &main'setObjectType($newObjectID, $objectType);
  156.     }
  157.     ($objectX{$newObjectID} = $x)||($objectX{$newObjectID} = $defaultSymbolX);
  158.     ($objectY{$newObjectID} = $y)||($objectY{$newObjectID} = $defaultSymbolY);
  159.     ($objectW{$newObjectID} = $w)||($objectW{$newObjectID} = $defaultSymbolW);
  160.     ($objectH{$newObjectID} = $h)||($objectH{$newObjectID} = $defaultSymbolH);
  161.     &main'setObjectFramed($newObjectID, 1);
  162.  
  163.     $newObjectID;
  164. }
  165.  
  166. sub main'newLine{ # documentID fromObject toObject -> objectID
  167.     local($documentID, $fromObject, $toObject) = @_;
  168.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  169.     local($newLineID) = &newObjectID($documentID);
  170.     print "New Line -> $newLineID\n" unless !$debugging;
  171.     $documentLines{$documentID} .= "$newLineID,";
  172.     $objectFlavor{$newLineID} = "Line";
  173.     local($vertex1) = &main'newVertex($documentID);
  174.     local($vertex2) = &main'newVertex($documentID);
  175.     $lineVertexList{$newLineID} = "$vertex1,$vertex2";
  176.     ($fromObject && $toObject) || &error("Must specify both from and to");
  177.     $objectFlavor{$fromObject} || &error("Invalid fromObject -> $fromObject");
  178.     $lineFrom{$newLineID} = $fromObject;
  179.     $objectFlavor{$toObject} || &error("Invalid toObject -> $toObject");
  180.     $lineTo{$newLineID} = $toObject;
  181.     
  182.     $newLineID;
  183. }
  184.  
  185. sub main'newVertex{ # documentID x y
  186.     local($documentID, $x, $y) = @_;
  187.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  188.     local($newVertexID) = &newObjectID($documentID);
  189.     print "New Vertext -> $newVertexID\n" unless !$debugging;
  190.     $documentVertexes{$documentID} .= "$newVertexID,";
  191.     $objectFlavor{$newVertexID} = "Vertex";
  192.     $objectX{$newVertexID} = $x;
  193.     $objectY{$newVertexID} = $y;
  194.  
  195.     $newVertexID;
  196. }
  197.  
  198. sub main'newGroup{ # documentID groupedObjectID groupedObjectID2 etc
  199.     local($documentID, @objectList) = @_;
  200.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  201.     local($newGroupID) = &newObjectID($documentID);
  202.     print "New Group -> $newGroupID\n" unless !$debugging;
  203.     $documentGroups{$documentID} .= "$newGroupID,";
  204.     $objectFlavor{$newGroupID} = "Group";
  205.     $groupObjectList{$newGroupID} = "";
  206.     foreach $thing (@objectList){
  207.     $objectFlavor{$thing}|| &error("Invalid Object ID in Group -> $thing");
  208.     $objectFlavor{$thing} && do {
  209.         $groupObjectList{$newGroupID} .= "$thing,";
  210.         $objectInGroup{$thing} = 1;
  211.     };
  212.     }
  213.  
  214.     $newGroupID;
  215. }
  216.  
  217. sub main'vertexesForLine{ # objectID
  218.     local($objectID) = @_;
  219.     print "vertexesForLine (@_)\n" unless !$debugging;
  220.     $objectFlavor{$objectID} eq "Line" || &error("Object not a line -> $objectID");
  221.     split(/,/,$lineVertexList{$objectID});
  222. }
  223.  
  224. sub main'setVertexesForLine{ # objectID vertex1, vertex2, ...
  225.     local($objectID, @vertexList) = @_;
  226.     print "setVertexesForLine (@_)\n" unless !$debugging;
  227.     $objectFlavor{$objectID} eq "Line" || &error("Object not a line -> $objectID");
  228.     $ok = 0;
  229.     foreach $thing (@vertexList){
  230.     $objectFlavor{$objectID} eq "Vertex" || &error("Object not a vertex -> $thing");
  231.     if(!$ok){
  232.         $lineVertexList{$objectID} = "$thing,";
  233.         $ok = 1;
  234.     }else{
  235.         $lineVertexList{$objectID} .= "$thing,";
  236.     }
  237.     }
  238.     $objectID;
  239. }
  240.  
  241. sub main'setObjectType{ # objectID type 
  242.     local($objectID, $type) = @_;
  243.     print "setObjectType (@_)\n" unless !$debugging;
  244.     $objectFlavor{$objectID} eq "Symbol" || &error("Object not a symbol -> $objectID");
  245.     ($legalSymbol{$type}) || &error("Invalid symbol type -> $type");
  246.     $objectType{$objectID} = $type;
  247.     $objectID;
  248. }
  249.  
  250. sub main'setObjectLocation{ # objectID x y
  251.     local($objectID, $x, $y) = @_;
  252.     print "setObjectLocation (@_)\n" unless !$debugging;
  253.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Vertex" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectLocation -> $objectID");
  254.     $objectX{$objectID} = $x;
  255.     $objectY{$objectID} = $y;
  256.  
  257.     $objectID;
  258. }
  259.  
  260. sub main'setObjectSize{ # documentID objectID w h
  261.     local($objectID, $w, $h) = @_;
  262.     print "setObjectSize (@_)\n" unless !$debugging;
  263.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectSize -> $objectID");
  264.     $objectW{$objectID} = $w;
  265.     $objectH{$objectID} = $h;
  266.  
  267.     $objectID;
  268. }
  269.  
  270. sub main'setObjectX{ # documentID objectID x 
  271.     local($objectID, $x) = @_;
  272.     print "setObjectX (@_)\n" unless !$debugging;
  273.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Vertex" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectX -> $objectID");
  274.     $objectX{$objectID} = $x;
  275.  
  276.     $objectID;
  277. }
  278.  
  279. sub main'setObjectY{ # documentID objectID y
  280.     local($objectID, $y) = @_;
  281.     print "setObjectY (@_)\n" unless !$debugging;
  282.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Vertex" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectY -> $objectID");
  283.     $objectY{$objectID} = $y;
  284.     
  285.     $objectID;
  286. }
  287.  
  288. sub main'setObjectWidth{ # documentID objectID width
  289.     local($objectID, $w) = @_;
  290.     print "setObjectWidth (@_)\n" unless !$debugging;
  291.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectWidth -> $objectID");
  292.     $objectW{$objectID} = $w;
  293.     
  294.     $objectID;
  295. }
  296.  
  297. sub main'setObjectHeight{ # documentID objectID height
  298.     local($objectID, $h) = @_;
  299.     print "setObjectHeight (@_)\n" unless !$debugging;
  300.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectHeight -> $objectID");
  301.     $objectH{$objectID} = $h;
  302.     
  303.     $objectID;
  304. }
  305.  
  306. sub main'setObjectLocked{ # objectID locked (1 = yes, 0 = no)
  307.     local($objectID, $locked) = @_;
  308.     print "setObjectLocked (@_)\n" unless !$debugging;
  309.     $objectFlavor{$objectID} || &error("Object not valid for setObjectLocked -> $objectID");
  310.     $objectLocked{$objectID} = $locked;
  311.  
  312.     $objectID;
  313. }
  314.  
  315. sub main'setObjectRotationAngle{ # objectID rotationAngle
  316.     local($objectID, $rot) = @_;
  317.     print "setObjectRotationAngle (@_)\n" unless !$debugging;
  318.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Group") || &error("Object not valid for setObjectRotationAngle -> $objectID");
  319.     $objectRotationAngle{$objectID} = $rot;
  320.     
  321.     $objectID;
  322. }
  323.  
  324. sub main'setObjectShadowed{ # documentID objectID shadowed (1 = yes, 0 = no)
  325.     local($objectID, $flag) = @_;
  326.     print "setObjectShadowed (@_)\n" unless !$debugging;
  327.     ($objectFlavor{$objectID} eq "Symbol") || &error("Object not valid for setObjectShadowed -> $objectID");
  328.     $objectShadowed{$objectID} = $flag;
  329.     
  330.     $objectID;
  331. }
  332.  
  333. sub main'setObjectShadowColor{ # documentID objectID r g b
  334.     local($objectID, $r, $g, $b) = @_;
  335.     print "setObjectShadowColor(@_)\n" unless !$debugging;
  336.     ($objectFlavor{$objectID} eq "Symbol") || &error("Object not valid for setObjectShadowColor -> $objectID");
  337.     $objectShadowColor{$objectID} = "rgbColor $r $g $b";
  338.     
  339.     $objectID;
  340. }
  341.  
  342. sub main'setObjectShadowGray{ # objectID gray
  343.     local($objectID, $gray) = @_;
  344.     print "setObjectShadowGray(@_)\n" unless !$debugging;
  345.     ($objectFlavor{$objectID} eq "Symbol") || &error("Object not valid for setObjectShadowGray -> $objectID");
  346.     $objectShadowColor{$objectID} = sprintf("gray %f", $gray);
  347.     
  348.     $objectID;
  349. }
  350.  
  351. sub main'setObjectFilled{ # objectID filled (1 = yes, 0 = no)
  352.     local($objectID, $filled) = @_;
  353.     print "setObjectFilled(@_)\n" unless !$debugging;
  354.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectShadowGray -> $objectID");
  355.     $objectFilled{$objectID} = $filled;
  356.     
  357.     $objectID;
  358. }
  359.  
  360. sub main'setObjectFillColor{ # documentID objectID r g b
  361.     local($objectID, $r, $g, $b) = @_;
  362.     print "setObjectFillColor(@_)\n" unless !$debugging;
  363.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectFillColor -> $objectID");
  364.     $objectFillColor{$objectID} = "rgbColor $r $g $b";
  365.     
  366.     $objectID;
  367. }
  368.  
  369. sub main'setObjectFillGray{ # documentID objectID gray
  370.     local($objectID, $gray) = @_;
  371.     print "setObjectFillGray(@_)\n" unless !$debugging;
  372.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectFillGray -> $objectID");
  373.     $objectFillColor{$objectID} = "gray $gray";
  374.     
  375.     $objectID;
  376. }
  377.  
  378. sub main'setObjectFramed{ # documentID objectID framed (1 = yes, 0 = no)
  379.     local($objectID, $framed) = @_;
  380.     print "setObjectFramed(@_)\n" unless !$debugging;
  381.     ($objectFlavor{$objectID} eq "Symbol") || &error("Object not valid for setObjectFramed -> $objectID");
  382.     $objectFramed{$objectID} = $framed;
  383.     
  384.     $objectID;
  385. }
  386.  
  387. sub main'setObjectFrameColor{ # documentID objectID r g b
  388.     local($objectID, $r, $g, $b) = @_;
  389.     print "setObjectFrameColor(@_)\n" unless !$debugging;
  390.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectFrameColor -> $objectID");
  391.     $objectFrameColor{$objectID} = "rgbColor $r $g $b";
  392.     
  393.     $objectID;
  394. }
  395.  
  396. sub main'setObjectFrameGray{ # documentID objectID gray
  397.     local($objectID, $gray) = @_;
  398.     print "setObjectFrameGray(@_)\n" unless !$debugging;
  399.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectFrameGray -> $objectID");
  400.     $objectFrameColor{$objectID} = "gray $gray";
  401.     
  402.     $objectID;
  403. }
  404.  
  405. sub main'setObjectLineWidth{ # documentID objectID gray
  406.     local($objectID, $width) = @_;
  407.     print "setObjectLineWidth(@_)\n" unless !$debugging;
  408.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectLineWidth -> $objectID");
  409.     $objectLineWidth{$objectID} = $width;
  410.     
  411.     $objectID;
  412. }
  413.  
  414. sub main'setObjectLineType{ # objectID type (0 = solid, 1 = dot, 2 = dash, 3 = dotDash
  415.     local($objectID, $type) = @_;
  416.     print "setObjectLineType(@_)\n" unless !$debugging;
  417.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectLineWidth -> $objectID");
  418.     if($type == 0){
  419.     $objectLineType{$objectID} = "solid";
  420.     }elsif($type == 1){
  421.     $objectLineType{$objectID} = "dot";
  422.     }elsif($type == 2){
  423.     $objectLineType{$objectID} = "dash";
  424.     }elsif($type == 3){
  425.     $objectLineType{$objectID} = "dotDash";
  426.     }else{
  427.     &error("Invalid type in setObjectLineType -> $type");
  428.     }
  429.     
  430.     $objectID;
  431. }
  432.  
  433. sub main'setObjectRtfText{ # objectID textString
  434.     local($objectID, $rtf) = @_;
  435.     print "setObjectRtfText(@_)\n" unless !$debugging;
  436.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectRtfText -> $objectID");
  437.     $objectRtfText{$objectID} = $rtf;
  438.  
  439.     $objectID;
  440. }
  441.  
  442. sub main'setObjectText{ # objectID text
  443.     local($objectID, $text) = @_;
  444.     print "setObjectText(@_)\n" unless !$debugging;
  445.     ($objectFlavor{$objectID} eq "Symbol" || $objectFlavor{$objectID} eq "Line") || &error("Object not valid for setObjectText -> $objectID");
  446.     $objectText{$objectID} = $text;
  447.  
  448.     $objectID;
  449. }
  450.  
  451. sub main'setObjectTextPlacement{ # objectID textPlacement
  452.     local($objectID, $placement) = @_;
  453.     print "setObjectTextPlacement(@_)\n" unless !$debugging;
  454.     ($objectFlavor{$objectID} eq "Symbol" ) || &error("Object not valid for setObjectTextPlacement -> $objectID");
  455.     $legalPlacement{$placement} || &error("Illegal placement parameter -> $placement");
  456.     $objectTextPlacement{$objectID} = $placement;
  457.  
  458.     $objectID;
  459. }
  460.  
  461. sub main'setObjectLayer{ # objectID level
  462.     local($objectID, $layer) = @_;
  463.     print "setObjectLayer(@_)\n" unless !$debugging;
  464.     ($objectFlavor{$objectID}) || &error("Object not valid for setObjectText -> $objectID");
  465.     $objectLayer{$objectID} = $layer;
  466.  
  467.     $objectID;
  468. }
  469.  
  470. sub main'setLineTailType{ # lineID text
  471.     local($objectID, $type) = @_;
  472.     print "setLineTailType(@_)\n" unless !$debugging;
  473.     ($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineTailType -> $objectID");
  474.     $legalHead{$type} || &error("Type not valid for line end -> $type");
  475.     $lineTailType{$objectID} = $type;
  476.  
  477.     $objectID;
  478. }
  479.  
  480. sub main'setLineHeadType{
  481.     local($objectID, $type) = @_;
  482.     print "setLineHeadType(@_)\n" unless !$debugging;
  483.     ($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineTailType -> $objectID");
  484.     $legalHead{$type} || &error("Type not valid for line end -> $type");
  485.     $lineHeadType{$objectID} = $type;
  486.     
  487.     $objectID;
  488. }
  489.  
  490. sub main'setLineTo{ #objectID toObjectID
  491.     local($objectID, $toObject) = @_;
  492.     print "setLineTo(@_)\n" unless !$debugging;
  493.     ($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineTo -> $objectID");
  494.     ($objectFlavor{$toObject}) || &error("Argument not valid for setLineTo -> $toObject");
  495.     $lineTo{$objectID} = $toObject;
  496.  
  497.     $objectID;
  498. }
  499.  
  500. sub main'setLineFrom{ #objectID toObjectID
  501.     local($objectID, $fromObject) = @_;
  502.     print "setLineFrom(@_)\n" unless !$debugging;
  503.     ($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineFrom -> $objectID");
  504.     ($objectFlavor{$fromObject}) || &error("Argument not valid for setLineFrom -> $fromObject");
  505.     $lineFrom{$objectID} = $fromObject;
  506.  
  507.     $objectID;
  508. }
  509.  
  510. sub main'setLineCurved{ #objectID curved(1=yes, 0=no)
  511.     local($objectID, $curved) = @_;
  512.     print "setLineCurved(@_)\n" unless !$debugging;
  513.     ($objectFlavor{$objectID} eq "Line") || &error("Object not valid for setLineCurved -> $objectID");
  514.     $lineCurved{$objectID} = $curved;
  515.  
  516.     $objectID;
  517.  
  518. }
  519.  
  520. sub main'writeDocument{ # documentID filename
  521.     local($documentID, $filename) = @_;
  522.     print "writeDocument(@_)\n" unless !$debugging;
  523.     $documentExists{$documentID} || &error("Invalid document argument -> $documentID");
  524.  
  525.     local($dtFilename) = "$filename/DiagramText";
  526.     if((-f "$dtFilename")){
  527.     print "$filename exists, overwriting\n";
  528.     }elsif((!mkdir($filename, 0775))){
  529.     die "Couldn't create $filename - exiting.";
  530.     }
  531.     if(!open(DIAG, ">$dtFilename")){
  532.     die "Couln't open $dtFilename";
  533.     }
  534.     select((select(DIAG), $| = 1)[0]);
  535.  
  536.     #
  537.     # Document Stuff
  538.     #
  539.     print DIAG "#!DG_TEXT\n";
  540.     print DIAG "# generated by writedg.pl library v. 1.0 ";
  541.     print DIAG "\n";
  542.     if($documentCanvasW{$documentID} &&  $documentCanvasH{$documentID}){
  543.     print DIAG "canvasSize $documentCanvasW{$documentID} $documentCanvasH{$documentID}\n";
  544.     }else{
  545.     print DIAG "canvasSize 1 1\n";
  546.     }
  547.     if($documentRuler{$documentID}){
  548.     print DIAG "showRulers\n";
  549.     }
  550.     if($documentButtons{$documentID}){
  551.     print DIAG "showTools\n";
  552.     }
  553.     if($documentGrid{$documentID}){
  554.     print DIAG "gridVisible\n";
  555.     }
  556.     if($documentGridSpacing{$documentID}){
  557.     print DIAG "gridSpacing $documentGridSpacing\n";
  558.     }
  559.     if($documentSnap{$documentID}){
  560.     print DIAG "snapToGrid\n";
  561.     }
  562.     print DIAG "viewSize $defViewHorizSize $defViewVertSize\n";
  563.     if($documentZoom{$documentID}){
  564.     print DIAG "zoom $documentZoom{$documentID}\n";
  565.     }
  566.     if($defaultFont{$documentID}){
  567.     print DIAG "defaultFont \"$defaultFont{$documentID}\"\n";
  568.     }
  569.     if($defaultFontSize{$documentID}){
  570.     print DIAG "defaultFontSize $defaultFontSize{$documentID}\n";
  571.     }
  572.     print DIAG "\n";
  573.     
  574.     #
  575.     # Symbols
  576.     #
  577.     local(@symbolList) = split(/,/,$documentSymbols{$documentID});
  578.     foreach $thing (@symbolList){
  579.     $objectNum = &objectNumber($thing);
  580.     print DIAG "symbol $objectNum\n";
  581.     if(!$objectType{$thing}){
  582.         $objectType{$thing} = 9;
  583.     }
  584.     print DIAG "\tshape \"$objectType{$thing}\"\n";
  585.     if($objectInGroup{$thing}){
  586.         print DIAG "\tlayer -1\n";
  587.     }elsif($objectLayer{$thing}){
  588.         print DIAG "\tlayer $objectLayer{$thing}\n";
  589.     }
  590.     if($objectFramed{$thing}){
  591.         print DIAG "\tframed\n";
  592.     }
  593.     if($objectFrameColor{$thing}){
  594.         print DIAG "\tframeColor $objectFrameColor{$thing}\n";
  595.     }
  596.     if($objectLineWidth{$thing}){
  597.         print DIAG "\tlineWidth $objectLineWidth{$thing}\n";
  598.     }
  599.     if($objectLineType{$thing}){
  600.         print DIAG "\tlineType $objectLineType{$thing}\n";
  601.     }
  602.     if($objectFilled{$thing}){
  603.         print DIAG "\tfilled\n";
  604.     }
  605.     if($objectFillColor{$thing}){
  606.         print DIAG "\tfillColor $objectFillColor{$thing}\n";
  607.     }
  608.     if($objectShadowed{$thing}){
  609.         print DIAG "\tshadowed\n";
  610.     }
  611.     if($objectShadowColor{$thing}){
  612.         print DIAG "\tshadowColor $objectShadowColor{$thing}\n";
  613.     }
  614.     if($objectLocked{$thing}){
  615.         print DIAG "\tlocked\n";
  616.     }
  617.     if($objectTextPlacement{$thing}){
  618.         print DIAG "\ttextPlacement $objectTextPlacement{$thing}\n";
  619.     }
  620.     if($objectRtfText{$thing}){
  621.         print DIAG "\trtfText $objectRtfText{$thing}\n";
  622.     }elsif($objectText{$thing}){
  623.         print DIAG "\ttext \"$objectText{$thing}\"\n";
  624.     }
  625.     print DIAG "\tlocation $objectX{$thing} $objectY{$thing}\n";
  626.     print DIAG "\tsize $objectW{$thing} $objectH{$thing}\n";
  627.     print DIAG "end\n\n";
  628.     }
  629.     #
  630.     # Vertices
  631.     #
  632.     local(@vertexList) = split(/,/,$documentVertexes{$documentID});
  633.     foreach $thing (@vertexList){
  634.     $objectNum = &objectNumber($thing);
  635.     print DIAG "vertex $objectNum\n";
  636.     if($objectInGroup{$thing}){
  637.         print DIAG "\tlayer -1";
  638.     }elsif($objectLayer{$thing}){
  639.         print DIAG "\tlayer $objectLayer{$thing}\n";
  640.     }
  641.     if($objectX{$thing} && $objectY{$thing}){
  642.         print DIAG "\tlocation $objectX{$thing} $objectY{$thing}\n";
  643.     }
  644.     print DIAG "end\n\n";
  645.     }
  646.  
  647.     #
  648.     # Lines
  649.     #
  650.     local(@lineList) = split(/,/,$documentLines{$documentID});
  651.     foreach $thing (@lineList){
  652.     $objectNum = &objectNumber($thing);
  653.     print DIAG "line $objectNum\n";
  654.     $num = &objectNumber($lineFrom{$thing});
  655.     print DIAG "\tfrom $num\n";
  656.     $num = &objectNumber($lineTo{$thing});
  657.     print DIAG "\tto $num\n";
  658.     foreach $vert (split(/,/,$lineVertexList{$thing})){
  659.         $vertNum = &objectNumber($vert);
  660.         print DIAG "\t$vertNum\n";
  661.     }
  662.     if($objectInGroup{$thing}){
  663.         print DIAG "\tlayer -1\n";
  664.     }elsif($objectLayer{$thing}){
  665.         print DIAG "\tlayer $objectLayer{$thing}\n";
  666.     }
  667.     if($objectLineWidth{$thing}){
  668.         print DIAG "\tlineWidth $objectLineWidth{$thing}\n";
  669.     }
  670.     if($objectFilled{$thing}){
  671.         print DIAG "\tfilled\n";
  672.     }
  673.     if($objectFillColor{$thing}){
  674.         print DIAG "\tfillColor $objectFillColor{$thing}\n";
  675.     }
  676.     if($objectFramed{$thing}){
  677.         print DIAG "\tframed\n";
  678.     }
  679.     if($objectFrameColor{$thing}){
  680.         print DIAG "\tframeColor $objectFrameColor{$thing}\n";
  681.     }
  682.     if($lineHeadType{$thing}){
  683.         print DIAG "\theadType $lineHeadType{$thing}\n";
  684.     }
  685.     if($lineTailType{$thing}){
  686.         print DIAG "\ttailType $lineTailType{$thing}\n";
  687.     }
  688.     if($lineCurved{$thing}){
  689.         print DIAG "\tcurved\n";
  690.     }
  691.     
  692.     print DIAG "end\n\n";
  693.     }
  694.  
  695.     #
  696.     # Groups
  697.     #
  698.     local(@groupList) = split(/,/,$documentGroups{$documentID});
  699.     foreach $thing (@groupList){
  700.     $objectNum = &objectNumber($thing);
  701.     print DIAG "group $objectNum\n";
  702.     print DIAG "\t";
  703.     foreach $littlething (split(/,/,$groupObjectList{$thing})){
  704.         $num = &objectNumber($littlething);
  705.         print DIAG "$num ";
  706.     }
  707.     print DIAG "\n";
  708.     if($objectInGroup{$thing}){
  709.         print DIAG "\tlayer -1\n";
  710.     }elsif($objectLayer{$thing}){
  711.         print DIAG "\tlayer $objectLayer{$thing}\n";
  712.     }
  713.     if($objectX{$thing} && $objectY{$thing}){
  714.         print DIAG "\tlocation $objectX{$thing} $objectY{$thing}\n";
  715.     }
  716.     if($objectW{$thing} && $objectH{$thing}){
  717.         print DIAG "\tsize $objectW{$thing} $objectH{$thing}\n";
  718.     }
  719.     if($objectLocked{$thing}){
  720.         print DIAG "\tlocked\n";
  721.     }
  722.     print DIAG "end\n\n";
  723.     }
  724.  
  725. }
  726.  
  727. #
  728. # local subroutines
  729. #
  730. sub newObjectID { # documentID
  731.     $documentExists{$documentID} || &error("Invalid Document ID -> $documentID");
  732.     local($return) =  "$documentID:$documentCurrentObjectID{$documentID}";
  733.     $documentCurrentObjectID{$documentID}++;
  734.     return $return;
  735. }
  736.  
  737. sub error{ # error string
  738.  
  739.     print STDERR ($_[0], "\n\n");
  740.     sleep 1;
  741.     exit 1;
  742. }
  743.  
  744. sub objectNumber{ # objectID
  745.     local($objectID) = @_;
  746.     $objectID =~ /[^:]+:(\d+)/ || &error("Couldn't extract number from $objectID");
  747.     return $1;
  748. }
  749.  
  750. 1;
  751.  
  752. # Place Emacs into Perl-mode
  753. # Local Variables:
  754. # mode: perl
  755. # End:
  756.  
  757.