home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / roundtrip.tcl < prev    next >
Encoding:
Text File  |  1997-12-01  |  66.7 KB  |  2,662 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #      (c)     Cadre Technologies Inc.    1996
  4. #
  5. #      File:           @(#)header.tcl    /main/titanic/3
  6. #      Description:
  7. #---------------------------------------------------------------------------
  8. # SccsId = @(#)header.tcl    /main/titanic/3   23 Jun 1997 Copyright 1996 Cadre Technologies Inc.
  9.  
  10. require "wmt_util.tcl"
  11. require "fstorage.tcl"
  12. require "rt_getset.tcl"
  13. require "propknowle.tcl"
  14. require "config.tcl"
  15. require "platform.tcl"
  16. require "procs.tcl"
  17.  
  18. OTShRegister::importToolEdExt
  19.  
  20. #---------------------------------------------------------------------------
  21. #
  22. # Copyright (c) 1997 by Cayenne Software, Inc.
  23. #
  24. # This software is furnished under a license and may be used only in
  25. # accordance with the terms of such license and with the inclusion of
  26. # the above copyright notice. This software or any other copies thereof
  27. # may not be provided or otherwise made available to any other person.
  28. # No title to and ownership of the software is hereby transferred.
  29. #
  30. # The information in this software is subject to change without notice
  31. # and should not be construed as a commitment by Cayenne Software, Inc.
  32. #
  33. #---------------------------------------------------------------------------
  34. #
  35. #       File            : tmp
  36. #       Author          : 
  37. #       Original date   : November 1997
  38. #       Description     : Classes for code generation
  39. #
  40. #---------------------------------------------------------------------------
  41.  
  42.  
  43. #      File:           @(#)rtcomp.tcl    /main/titanic/5
  44. # End user added include file section
  45.  
  46.  
  47. Class RTComp : {GCObject} {
  48.     constructor
  49.     method destructor
  50.     method getUniqueName
  51.     method setLabel
  52.     method setProp
  53.     method findLabel
  54.     method findProp
  55.     method getLabel
  56.     method getProp
  57.     method REGenerateSub
  58.     method rtDiagram
  59.     method rtLabelSet
  60.     method addRtLabel
  61.     method removeRtLabel
  62.     method rtPropertySet
  63.     method addRtProperty
  64.     method removeRtProperty
  65.     attribute objId
  66.     attribute _rtDiagram
  67.     attribute _rtLabelSet
  68.     attribute _rtPropertySet
  69. }
  70.  
  71. global RTComp::objects
  72. set RTComp::objects 0
  73.  
  74.  
  75. constructor RTComp {class this rtDiagram} {
  76.     set this [GCObject::constructor $class $this]
  77.     $this _rtDiagram $rtDiagram
  78.     [$rtDiagram _rtCompSet] append $this
  79.     $this _rtLabelSet [List new]
  80.     $this _rtPropertySet [List new]
  81.     # Start constructor user section
  82.     global RTComp::objects
  83.     $this objId ${RTComp::objects}
  84.     incr RTComp::objects
  85.     # End constructor user section
  86.     return $this
  87. }
  88.  
  89. method RTComp::destructor {this} {
  90.     # Start destructor user section
  91.     # End destructor user section
  92. }
  93.  
  94. method RTComp::getUniqueName {this} {
  95.     return "obj[$this objId]"
  96. }
  97.  
  98. method RTComp::setLabel {this name value} {
  99.     set lbl [$this findLabel $name]
  100.     if {$lbl == ""} {
  101.         set lbl [RTLabel new [$this rtDiagram]]
  102.         $lbl name $name
  103.         $this addRtLabel $lbl
  104.     }
  105.     $lbl value $value
  106. }
  107.  
  108. method RTComp::setProp {this name value {item "comp"}} {
  109.     switch $item {
  110.         de {set item "name"}
  111.         pe {set item "name"}
  112.         cl {set item "type"}
  113.     }
  114.     set prop [$this findProp $name $item]
  115.     if { $prop == "" } {
  116.         set prop [RTProperty new]
  117.         $prop name $name
  118.         $prop item $item
  119.         $this addRtProperty $prop
  120.     }
  121.     $prop value $value
  122. }
  123.  
  124. method RTComp::findLabel {this name} {
  125.     [$this rtLabelSet] foreach lbl {
  126.         if { [$lbl name] == $name } {
  127.             return $lbl
  128.         }
  129.     }
  130.     return ""
  131. }
  132.  
  133. method RTComp::findProp {this name {item "comp"}} {
  134.     switch $item {
  135.         de {set item "name"}
  136.         pe {set item "name"}
  137.         cl {set item "type"}
  138.     }
  139.     [$this rtPropertySet] foreach prop {
  140.         if { ( [$prop name] == $name ) &&
  141.              ( [$prop item] == $item ) } {
  142.             return $prop
  143.         }
  144.     }
  145.     return ""
  146. }
  147.  
  148. method RTComp::getLabel {this name} {
  149.     set lbl [$this findLabel $name]
  150.     if {$lbl != ""} {
  151.         return [$lbl value]
  152.     } else {
  153.         return ""
  154.     }
  155. }
  156.  
  157. method RTComp::getProp {this name {item "comp"}} {
  158.     set prop [$this findProp $name $item]
  159.     if {$prop != ""} {
  160.         return [$prop value]
  161.     } else {
  162.         return ""
  163.     }
  164. }
  165.  
  166. method RTComp::REGenerateSub {this RTFd} {
  167.         [$this rtPropertySet] foreach prop {
  168.                 $prop REGenerate $RTFd
  169.         }
  170.  
  171.         [$this rtLabelSet] foreach lbl {
  172.                 $lbl REGenerate $RTFd
  173.         }
  174. }
  175.  
  176. # Do not delete this line -- regeneration end marker
  177.  
  178. method RTComp::rtDiagram {this args} {
  179.     if {$args == ""} {
  180.         return [$this _rtDiagram]
  181.     }
  182.     set ref [$this _rtDiagram]
  183.     if {$ref != ""} {
  184.         [$ref _rtCompSet] removeValue $this
  185.     }
  186.     set obj [lindex $args 0]
  187.     if {$obj != ""} {
  188.         [$obj _rtCompSet] append $this
  189.     }
  190.     $this _rtDiagram $obj
  191. }
  192.  
  193. method RTComp::rtLabelSet {this} {
  194.     return [$this _rtLabelSet]
  195. }
  196.  
  197. method RTComp::addRtLabel {this newRtLabel} {
  198.     [$this _rtLabelSet] append $newRtLabel
  199.     $newRtLabel _rtComp $this
  200. }
  201.  
  202. method RTComp::removeRtLabel {this oldRtLabel} {
  203.     $oldRtLabel _rtComp ""
  204.     [$this _rtLabelSet] removeValue $oldRtLabel
  205. }
  206.  
  207. method RTComp::rtPropertySet {this} {
  208.     return [$this _rtPropertySet]
  209. }
  210.  
  211. method RTComp::addRtProperty {this newRtProperty} {
  212.     [$this _rtPropertySet] append $newRtProperty
  213.     $newRtProperty _rtComp $this
  214. }
  215.  
  216. method RTComp::removeRtProperty {this oldRtProperty} {
  217.     $oldRtProperty _rtComp ""
  218.     [$this _rtPropertySet] removeValue $oldRtProperty
  219. }
  220.  
  221.  
  222.  
  223. #---------------------------------------------------------------------------
  224. #      File:           @(#)rtdiagram.tcl    /main/titanic/15
  225. # End user added include file section
  226.  
  227.  
  228. Class RTDiagram : {GCObject} {
  229.     method destructor
  230.     method startREFile
  231.     method EndREFile
  232.     method DoRE
  233.     constructor
  234.     method addClass
  235.     method addNode
  236.     method findClass
  237.     method addConn
  238.     method update
  239.     method checkAccess
  240.     method save
  241.     method rtCompSet
  242.     method addRtComp
  243.     method removeRtComp
  244.     attribute fileName
  245.     attribute systemName
  246.     attribute phaseName
  247.     attribute phaseType
  248.     attribute configName
  249.     attribute configVersion
  250.     attribute projectName
  251.     attribute hasScopePhase
  252.     attribute overwriteDiagram
  253.     attribute RTFd
  254.     attribute RTFName
  255.     attribute REFName
  256.     attribute _rtCompSet
  257. }
  258.  
  259. method RTDiagram::destructor {this} {
  260.     # Start destructor user section
  261.     # End destructor user section
  262. }
  263.  
  264. method RTDiagram::startREFile {this} {
  265.     if {[$this RTFd] == ""} {
  266.         # zet er nu gewoon wat in maar moet file discript zijn
  267.         $this RTFName [BasicFS::tmpFile]
  268.         $this RTFd [open [$this RTFName] w]
  269.               puts [$this RTFd] "# generated by roundtrip"
  270.         puts [$this RTFd] " "
  271.                 puts [$this RTFd] "# generated for reverse engineering"
  272.         puts [$this RTFd] " "
  273.  
  274.         if {[$this fileName] == ""} {
  275.             $this fileName "NewRT"
  276.         }
  277.  
  278.             puts [$this RTFd] "set diag \[REDiagram new \"[$this fileName]\" \"[$this systemName]\" \"[$this phaseName]\" \"[$this phaseType]\" \"[$this configName]\" \"[$this configVersion]\" \"[$this projectName]\" \"[$this hasScopePhase]\"\ [$this overwriteDiagram] \]"
  279.         puts [$this RTFd] " "
  280.     }
  281. }
  282.  
  283. method RTDiagram::EndREFile {this} {
  284.     if {[$this RTFd] != ""} {
  285.         puts [$this RTFd] " "
  286.         $this REFName [BasicFS::tmpFile]
  287.         puts [$this RTFd] "\$diag save \{[$this REFName]\}"
  288.         close [$this RTFd]
  289.         $this RTFd "" 
  290.     }
  291. }
  292.  
  293. method RTDiagram::DoRE {this} {
  294.     if {[$this RTFName] != ""} {
  295.         global EXE_EXT
  296.         set otprint [quoteIf [m4_path_name bin otprint$EXE_EXT]]
  297.         system "$otprint [$this RTFName]"
  298.         puts ""
  299.         source [$this REFName]
  300.         BasicFS::removeFile [$this RTFName]
  301.         BasicFS::removeFile [$this REFName]
  302.     }
  303. }
  304.  
  305. constructor RTDiagram {class this {fin ""} {syn ""} {phn ""} {pht ""} {con ""} {cov ""} {prn ""} {hsp ""} {overwrite ""}} {
  306.     set this [GCObject::constructor $class $this]
  307.     $this _rtCompSet [List new]
  308.  
  309.     $this fileName $fin
  310.     $this systemName $syn
  311.     $this phaseName $phn
  312.     $this phaseType $pht
  313.     $this configName $con
  314.     $this configVersion $cov
  315.     $this projectName $prn
  316.     $this hasScopePhase $hsp
  317.     $this overwriteDiagram $overwrite
  318.  
  319.     return $this
  320. }
  321.  
  322. method RTDiagram::addClass {this {name ""} {section ""}} {
  323.     set clss [RTClass new $this]
  324.     $clss section $section
  325.     if { $name != "" } {
  326.         $clss setLabel "name" $name
  327.     }
  328.     return $clss
  329. }
  330.  
  331. method RTDiagram::addNode {this type} {
  332.     if {$type=="cad_class"} {
  333.         return [$this addClass]
  334.     }
  335.     return ""
  336. }
  337.  
  338. method RTDiagram::findClass {this name} {
  339.     [$this rtCompSet] foreach comp {
  340.         if [ $comp isA RTClass ] {
  341.             if { [[$comp findLabel "name"] value] == $name } {
  342.                 return $comp
  343.             }
  344.         }
  345.     }
  346.     return ""
  347. }
  348.  
  349. method RTDiagram::addConn {this type st end} {
  350.     return [RTConn new $this $type $st $end]
  351. }
  352.  
  353. method RTDiagram::update {this} {
  354.     [$this rtCompSet] foreach comp {
  355.         if [$comp isA RTClass] {
  356.             $comp update
  357.         }
  358.     }
  359. }
  360.  
  361. method RTDiagram::checkAccess {this} {
  362.     [$this rtCompSet] foreach comp {
  363.         if [ $comp isA RTAttrib ] {
  364.             $comp checkAccess
  365.         }
  366.     }
  367. }
  368.  
  369. method RTDiagram::save {this {filename ""}} {
  370.     set status [catch {
  371.         $this update
  372.         $this checkAccess
  373.     
  374.         set rtitui [RTITUserInterface new]
  375.     
  376.         # combine models
  377.         [$this rtCompSet] foreach comp {
  378.             if [$comp isA RTClass] {
  379.                 # Temporary save current levelpath
  380.                 set cc [ClientContext::global]
  381.                 set path [$cc currentLevelString]
  382.     
  383.                 set rtitClass [RTITClass new $comp $rtitui]
  384.     
  385.                 if {[$rtitClass go] == 0} {
  386.                     $rtitClass deleteUnUsed
  387.                     $rtitClass update
  388.                     $rtitClass save
  389.                 }
  390.     
  391.                 $cc setLevelPath $path
  392.             }
  393.         }
  394.         $this EndREFile
  395.         $this DoRE
  396.     } msg]
  397.     if {$status} {
  398.         puts stderr $msg
  399.         if [info exists debug] {
  400.             puts stderr $errorInfo
  401.         }
  402.     }
  403. }
  404.  
  405. # Do not delete this line -- regeneration end marker
  406.  
  407. method RTDiagram::rtCompSet {this} {
  408.     return [$this _rtCompSet]
  409. }
  410.  
  411. method RTDiagram::addRtComp {this newRtComp} {
  412.     [$this _rtCompSet] append $newRtComp
  413.     $newRtComp _rtDiagram $this
  414. }
  415.  
  416. method RTDiagram::removeRtComp {this oldRtComp} {
  417.     $oldRtComp _rtDiagram ""
  418.     [$this _rtCompSet] removeValue $oldRtComp
  419. }
  420.  
  421.  
  422.  
  423. #---------------------------------------------------------------------------
  424. #      File:           @(#)rtitattrib.tcl    /main/titanic/14
  425. # End user added include file section
  426.  
  427.  
  428. Class RTITAttrib : {GCObject} {
  429.     constructor
  430.     method destructor
  431.     method go
  432.     method update
  433.     method setBestMatch
  434.     method setPosition
  435.     method prev
  436.     method next
  437.     method clss
  438.     attribute rtAttrib
  439.     attribute _clss
  440.     attribute edAttrib
  441. }
  442.  
  443. constructor RTITAttrib {class this rtAttrib clss} {
  444.     set this [GCObject::constructor $class $this]
  445.     $this rtAttrib $rtAttrib
  446.     $this _clss $clss
  447.     [$clss _attrSet] append $this
  448.     # Start constructor user section
  449.     # End constructor user section
  450.     return $this
  451. }
  452.  
  453. method RTITAttrib::destructor {this} {
  454.     # Start destructor user section
  455.     # End destructor user section
  456. }
  457.  
  458. method RTITAttrib::go {this} {
  459.     $this setBestMatch
  460.     $this setPosition
  461. }
  462.  
  463. method RTITAttrib::update {this} {
  464.     # Check pre-conditions
  465.     if {[$this edAttrib] == "" } return
  466.  
  467.     # Special key attribute handling
  468.     if [[$this rtAttrib] keyAttrib] {
  469.         if {[[$this edAttrib] getProp "nullable" name_type de] == "no"} {
  470.             [$this rtAttrib] setProp "nullable" "no" "name"
  471.         } else {
  472.             if {[[$this rtAttrib] getProp "key"] != 1} {
  473.                 [$this rtAttrib] setProp "key" 1
  474.                 [$this rtAttrib] setLabel name_type \
  475.                     "*[[$this rtAttrib] getLabel name_type]"
  476.             }
  477.         }
  478.     }
  479.  
  480.     # check the label
  481.     # compare the items name and type and check the properties which
  482.     # change the label
  483.     set attribName [[$this edAttrib] getItem name_type de]
  484.  
  485.     set standTypeDiag [[$this edAttrib] getItem name_type cl]
  486.     set langTypeDiag $standTypeDiag
  487.     set type [${RTITClass::langTypeTable} getTypeByStdTypeName $standTypeDiag]
  488.     if {$type != ""} {
  489.         set langTypeDiag [$type name]
  490.     }
  491.  
  492.     if { ([[$this rtAttrib] name] != $attribName) ||
  493.          (([[$this rtAttrib] type] != $standTypeDiag) &&
  494.           ([[$this rtAttrib] type] != $langTypeDiag)) ||
  495.          ([[$this rtAttrib] getProp "is_class_feature"] !=
  496.           [[$this edAttrib] getProp "is_class_feature"]) ||
  497.          ([[$this rtAttrib] getProp "is_derived"] !=
  498.           [[$this edAttrib] getProp "is_derived"]) ||
  499.          ([[$this rtAttrib] getProp "key"] !=
  500.           [[$this edAttrib] getProp "key"]) ||
  501.          ([[$this rtAttrib] getProp "initial_value"] !=
  502.           [[$this edAttrib] getProp "initial_value"]) } {
  503.  
  504.         set typeStr ""
  505.         if {[[$this rtAttrib] type] == $langTypeDiag} {
  506.             set typeStr $standTypeDiag
  507.         } else {
  508.             set type [${RTITClass::langTypeTable} getTypeByStdTypeName [[$this rtAttrib] type]]
  509.             if {$type == ""} {
  510.                 set type [${RTITClass::langTypeTable} getType [[$this rtAttrib] type]]
  511.                 if {$type != ""} {
  512.                     set typeStr [$type stdTypeName]
  513.                 }
  514.             }
  515.         }
  516.         if {$typeStr != ""} {
  517.             if [regsub "(.*:.*)[[$this rtAttrib] type](.*)" \
  518.                 "[[$this rtAttrib] getLabel name_type]" \
  519.                 "\\1$typeStr\\2" newLabel] {
  520.                 [$this rtAttrib] setLabel name_type $newLabel
  521.             }
  522.         }
  523.  
  524.         set clssName [[[$this clss] rtClass] name]
  525.         set attrNLbl [[$this rtAttrib] getLabel name_type]
  526.         regsub -all "\n" [[$this edAttrib] getLabel name_type] "" attrOLbl
  527.         set answer [[[$this clss] ui] askQuestion \
  528.             "In class \"$clssName\": \
  529.             \n    change attribute \"$attrOLbl\" into \"$attrNLbl\"" \
  530.             "Change this attribute?" \
  531.             "attribute-change_label" \
  532.             [$this clss]]
  533.  
  534.         if {$answer == "yes"} {
  535.             [$this edAttrib] setLabel name_type \
  536.                 "[[$this rtAttrib] getLabel name_type]"
  537.         }
  538.     }
  539.     # check all known properties
  540.     # known properties are properties which have been defined by the
  541.     # parser which gave us our input
  542.     [[$this rtAttrib] rtPropertySet] foreach prop {
  543.         set name [$prop name]
  544.         switch $name {
  545.             "is_class_feature"    continue
  546.             "is_derived"         continue
  547.             "key"            continue
  548.             "initial_value"        continue
  549.         }
  550.         set item [$prop item]
  551.         switch $item {
  552.             "name"    { set itlbl "name_type" ; set ititem "de" }
  553.             "type"    { set itlbl "name_type" ; set ititem "cl" }
  554.             "comp"    { set itlbl "" ; set ititem "" }
  555.         }
  556.         set value [$prop value]
  557.         set itvalue [[$this edAttrib] getProp $name $itlbl $ititem]
  558.         set defaultValue [PropKnowledge::getDefaultValue $name]
  559.         if [info exists debug] {
  560.             puts stderr "value: '$value' itvalue: '$itvalue' defaultValue: '$defaultValue'"
  561.         }
  562.         if { $itvalue == "" } {
  563.             set itvalue $defaultValue
  564.         }
  565.         if { $value == "" } {
  566.             set value $defaultValue
  567.         }
  568.         if { $itvalue != $value } {
  569.             set clssName [[[$this clss] rtClass] name]
  570.             set fullPropName [PropKnowledge::getLongName $name]
  571.             set answer [[[$this clss] ui] askQuestion \
  572.                 "In class \"$clssName\": \
  573.                 \n    change property \"$fullPropName\" of attribute \"$attribName\" \
  574.                 \n        from \"$itvalue\" into \"$value\"" \
  575.                 "Change this attribute property?" \
  576.                 "attribute-change_property" \
  577.                 [$this clss]]
  578.             if {$answer == "yes"} {
  579.                 if { $value == $defaultValue } {
  580.                     set value ""
  581.                 }
  582.                 [$this edAttrib] setProp $name $value $itlbl $ititem
  583.             }
  584.         }
  585.     }
  586. }
  587.  
  588. method RTITAttrib::setBestMatch {this} {
  589.     [[$this clss] unUsedAttribSet] foreach attr {
  590.         if { [$attr getItem name_type de] == [[$this rtAttrib] name] } {
  591.             # found an attribute with the same name.
  592.             # only one attribute with a specific name can 
  593.             # exists at one time, so this is the one.
  594.             $this edAttrib $attr
  595.             [[$this clss] unUsedAttribSet] removeValue $attr
  596.             return
  597.         }
  598.     }
  599.     # attribute was not found
  600.     # create a new attribute
  601.     set clssName [[[$this clss] rtClass] name]
  602.     set attribName [[$this rtAttrib] name]
  603.     set answer [[[$this clss] ui] askQuestion \
  604.         "In class \"$clssName\": add attribute \"$attribName\"" \
  605.         "Add attribute?" \
  606.         "attribute-add" \
  607.         [$this clss]]
  608.     if {$answer == "yes"} {
  609.         set newAttr [[[$this clss] edMatrix] addRow "attribute"]
  610.         $this edAttrib $newAttr
  611.  
  612.         set type [${RTITClass::langTypeTable} getTypeByStdTypeName [[$this rtAttrib] type]]
  613.         if {$type == ""} {
  614.             set type [${RTITClass::langTypeTable} getType [[$this rtAttrib] type]]
  615.             if {$type != ""} {
  616.                 set typeStr [$type stdTypeName]
  617.                 if [regsub "(.*:.*)[[$this rtAttrib] type](.*)" \
  618.                     "[[$this rtAttrib] getLabel name_type]" \
  619.                     "\\1$typeStr\\2" newLabel] {
  620.                     [$this rtAttrib] setLabel name_type $newLabel
  621.                 }
  622.             }
  623.         }
  624.  
  625.         $newAttr setLabel name_type [[$this rtAttrib] getLabel name_type]
  626.         [[$this rtAttrib] rtPropertySet] foreach prop {
  627.             set name [$prop name]
  628.             switch $name {
  629.                 "is_class_feature"    continue
  630.                 "is_derived"         continue
  631.                 "key"            continue
  632.                 "initial_value"        continue
  633.             }
  634.             set item [$prop item]
  635.             switch $item {
  636.                 "name"    { set itlbl "name_type" ; set ititem "de" }
  637.                 "type"    { set itlbl "name_type" ; set ititem "cl" }
  638.                 "comp"    { set itlbl "" ; set ititem "" }
  639.             }
  640.             set value [$prop value]
  641.             $newAttr setProp $name $value $itlbl $ititem
  642.         }
  643.     } else {
  644.         $this edAttrib ""
  645.     }
  646. }
  647.  
  648. method RTITAttrib::setPosition {this} {
  649.     if {[$this edAttrib] == ""} return
  650.     set prev [$this prev]
  651.     if { $prev != "" } {
  652.         # not the first one, so move
  653.         if { [$prev edAttrib] != "" } {
  654.             [$this edAttrib] moveBehind [$prev edAttrib]
  655.         }
  656.     }
  657. }
  658.  
  659. method RTITAttrib::prev {this} {
  660.     # Look for myself and sub one to the index
  661.     set idx [[[$this clss] attrSet] search -exact $this]
  662.     if { $idx == -1 } {
  663.         return ""
  664.     } else {
  665.         set previdx [expr $idx - 1]
  666.         if { $previdx != -1 } {
  667.             return [[[$this clss] attrSet] index $previdx]
  668.         } else {
  669.             return ""
  670.         }
  671.     }
  672. }
  673.  
  674. method RTITAttrib::next {this} {
  675.     # Look for myself and add one to the index
  676.     set idx [[[$this clss] attrSet] search -exact $this]
  677.     if { $idx == -1 } {
  678.         return ""
  679.     } else {
  680.         set nextidx [expr $idx + 1]
  681.         if { $nextidx < [[[$this clss] attrSet] length] } {
  682.             return [[[$this clss] attrSet] index $nextidx]
  683.         } else {
  684.             return ""
  685.         }
  686.     }
  687. }
  688.  
  689. # Do not delete this line -- regeneration end marker
  690.  
  691. method RTITAttrib::clss {this args} {
  692.     if {$args == ""} {
  693.         return [$this _clss]
  694.     }
  695.     set ref [$this _clss]
  696.     if {$ref != ""} {
  697.         [$ref _attrSet] removeValue $this
  698.     }
  699.     set obj [lindex $args 0]
  700.     if {$obj != ""} {
  701.         [$obj _attrSet] append $this
  702.     }
  703.     $this _clss $obj
  704. }
  705.  
  706.  
  707.  
  708. #---------------------------------------------------------------------------
  709. #      File:           @(#)rtitclass.tcl    /main/titanic/14
  710. # End user added include file section
  711.  
  712.  
  713. Class RTITClass : {GCObject} {
  714.     constructor
  715.     method destructor
  716.     method go
  717.     method update
  718.     method deleteUnUsed
  719.     method save
  720.     method createLists
  721.     method addUnUsedAttrib
  722.     method removeUnUsedAttrib
  723.     method attrSet
  724.     method addAttr
  725.     method removeAttr
  726.     method mthdSet
  727.     method addMthd
  728.     method removeMthd
  729.     method addUnUsedMethod
  730.     method removeUnUsedMethod
  731.     attribute rtClass
  732.     attribute unUsedAttribSet
  733.     attribute _attrSet
  734.     attribute _mthdSet
  735.     attribute ui
  736.     attribute edMatrix
  737.     attribute unUsedMethodSet
  738. }
  739.  
  740. global RTITClass::langTypeTable
  741. set RTITClass::langTypeTable ""
  742.  
  743.  
  744. constructor RTITClass {class this rtClass ui} {
  745.     set this [GCObject::constructor $class $this]
  746.     $this rtClass $rtClass
  747.     $this ui $ui
  748.     $this unUsedAttribSet [List new]
  749.     $this _attrSet [List new]
  750.     $this _mthdSet [List new]
  751.     $this unUsedMethodSet [List new]
  752.     # Start constructor user section
  753.  
  754.     if {${RTITClass::langTypeTable} == ""} {
  755.         global RTITClass::langTypeTable
  756.         set RTITClass::langTypeTable [LangTypeTable::createTable]
  757.     }
  758.  
  759.     [[$this rtClass] rtAttribSet] foreach attr {
  760.         if { [$attr section] == "user-defined-attribute" } {
  761.             RTITAttrib new $attr $this
  762.         }
  763.     }
  764.  
  765.     [[$this rtClass] rtMethodSet] foreach mthd {
  766.         if { [$mthd section] == "user-defined-method" } {
  767.             RTITMethod new $this $mthd
  768.         }
  769.     }
  770.  
  771.     # End constructor user section
  772.     return $this
  773. }
  774.  
  775. method RTITClass::destructor {this} {
  776.     # Start destructor user section
  777.     # End destructor user section
  778. }
  779.  
  780. method RTITClass::go {this} {
  781.  
  782.     # find out CDM name with some help of fstorage
  783.     # (if we still know the file name)
  784.     set CDMname ""
  785.     set fileName [[$this rtClass] getProp include_list type] 
  786.     if {$fileName != "" } {
  787.         set CDMname [fstorage::get_imp_from $fileName]
  788.     }
  789.     if { $CDMname == "" } {
  790.         # Last resort
  791.         set CDMname [[$this rtClass] name]
  792.     }
  793.  
  794.     # Check if this class has a CDM
  795.     # if no CDM exists, we should not try to roundtrip this file
  796.     set cc [ClientContext::global]
  797.     set levelPath "/[[$cc currentCorporate] name]"
  798.     set diag [[$this rtClass] rtDiagram]
  799.     if {[$diag projectName] != ""} {
  800.         set levelPath "${levelPath}/[$diag projectName]"
  801.     } else {
  802.         set levelPath "${levelPath}/[[$cc currentProject] name]"
  803.     }
  804.     if {[$diag configName] != ""} {
  805.         set levelPath "${levelPath}/[$diag configName]"
  806.     } else {
  807.         set levelPath "${levelPath}/[[[$cc currentConfig] config] name]"
  808.     }
  809.     if {[$diag configVersion] != ""} {
  810.         set levelPath "${levelPath}:[$diag configVersion]"
  811.     } else {
  812.         set levelPath "${levelPath}:[[$cc currentConfig] versionNumber]"
  813.     }
  814.     if {[$diag phaseName] != ""} {
  815.         set levelPath "${levelPath}/[$diag phaseName]"
  816.     } else {
  817.         set levelPath "${levelPath}/[[[$cc currentPhase] phase] name]"
  818.     }
  819.     if {[$diag phaseType] != ""} {
  820.         set levelPath "${levelPath}.[$diag phaseType]"
  821.     } else {
  822.         set levelPath "${levelPath}.[[[$cc currentPhase] phase] type]"
  823.     }
  824.     if {[$diag systemName] != ""} {
  825.         set levelPath "${levelPath}/[$diag systemName].system"
  826.     } else {
  827.         set levelPath "${levelPath}/[[[$cc currentSystem] system] name].system"
  828.     }
  829.  
  830.     set prop [[$this rtClass] getProp "is_folded" comp]
  831.     if {$prop != ""} {
  832.         if { $prop == "1" } {
  833.             $this edMatrix ""
  834.             return 1
  835.         }
  836.     }
  837.  
  838.     $cc setLevelPath $levelPath
  839.     set sysV [$cc currentSystem]
  840.     set item [[$cc currentProject] findItem $CDMname cl]
  841.     if {$item != "" && ![$item isNil]} {
  842.         $sysV getDecompositions $item [$cc currentConfig] decompFiles \
  843.             {cdm} resultSystems resultFiles
  844.         if {[lempty $resultFiles]} {
  845.             puts "Warning: CDM ($CDMname) not found, roundtrip skipped..."
  846.             return 1
  847.         }
  848.     } else {
  849.         if {[[$this rtClass] section] != "new-control"} {
  850.             puts "Warning: CDM ($CDMname) not found, roundtrip skipped..."
  851.             return 1
  852.         } else {
  853.             set clssName [[$this rtClass] name]
  854.             set answer [[$this ui] askQuestion \
  855.                 "Add new control \"$clssName\"" \
  856.                 "Add control?" \
  857.                 "control-add" \
  858.                 $this]
  859.             if {$answer == "yes"} {
  860.                 [$this rtClass] REGenerate
  861.             }
  862.             return 1
  863.         }
  864.     }
  865.  
  866.     set diag [[$this rtClass] rtDiagram]
  867.     set newEdCDM [EdCDM new $CDMname \
  868.         "[$diag systemName]" "[$diag phaseName]" \
  869.         "[$diag phaseType]" "[$diag configName]" \
  870.         "[$diag configVersion]" "[$diag projectName]" \
  871.         "[$diag hasScopePhase]" "[$diag overwriteDiagram]"]
  872.  
  873.     $this edMatrix $newEdCDM
  874.  
  875.     $this createLists
  876.     [$this attrSet] foreach attr {
  877.         $attr go
  878.     }
  879.     [$this mthdSet] foreach mthd {
  880.         $mthd go
  881.     }
  882.     return 0
  883. }
  884.  
  885. method RTITClass::update {this} {
  886.     if {[$this edMatrix] == ""} return
  887.     [$this attrSet] foreach attr {
  888.         $attr update
  889.     }
  890.     [$this mthdSet] foreach mthd {
  891.         $mthd update
  892.     }
  893.     [$this edMatrix] formatLayout
  894. }
  895.  
  896. method RTITClass::deleteUnUsed {this} {
  897.     if {[$this edMatrix] == ""} return
  898.     set clssName [[$this rtClass] name]
  899.     [$this unUsedAttribSet] foreach attr {
  900.         set attribName [$attr getItem name_type de]
  901.         set answer [[$this ui] askQuestion \
  902.             "In class \"$clssName\": delete attribute \"$attribName\"" \
  903.             "Delete attribute?" \
  904.             "attribute-delete" \
  905.             $this]
  906.         if {$answer == "yes"} {
  907.             [$this edMatrix] deleteRow $attr
  908.         }
  909.     }
  910.     [$this unUsedMethodSet] foreach mthd {
  911.         # Check if this is the default ctor
  912.         # if so, don't remove it
  913.         if {[$mthd getItem name_type pe] != "create" ||
  914.             [$mthd getProp is_class_feature] != "1" ||
  915.             [llength [$mthd getCells]] != 0} {
  916.             set methodName [$mthd getItem name_type pe]
  917.             set answer [[$this ui] askQuestion \
  918.                 "In class \"$clssName\": delete method \"$methodName\"" \
  919.                 "Delete method?" \
  920.                 "method-delete" \
  921.                 $this]
  922.             if {$answer == "yes"} {
  923.                 [$this edMatrix] deleteRow $mthd
  924.             }
  925.         }
  926.     }
  927.     [$this mthdSet] foreach mthd {
  928.         $mthd deleteUnUsed
  929.     }
  930. }
  931.  
  932. method RTITClass::save {this} {
  933.     if {[$this edMatrix] == ""} return
  934.     if {[[$this ui] changes] <= 0} {
  935.         puts "No changes..."
  936.         [$this edMatrix] quit
  937.         return
  938.     }
  939.     set clssName [[$this rtClass] name]
  940.     set answer [[$this ui] askQuestion \
  941.         "Save class \"$clssName\" and accept all changes" \
  942.         "Save changes?" \
  943.         "class-save" \
  944.         $this]
  945.  
  946.     if { $answer == "yes"} {    
  947.         [$this edMatrix] save
  948.     } else {
  949.         puts "Abandoning all changes..."
  950.         [$this edMatrix] quit
  951.     }
  952. }
  953.  
  954. method RTITClass::createLists {this} {
  955.     if {[$this edMatrix] == ""} return
  956.     foreach row [[$this edMatrix] getRows] {
  957.         switch [$row getType] {
  958.             "attribute"    { $this addUnUsedAttrib $row }
  959.             "method"    { $this addUnUsedMethod $row }
  960.         }
  961.     }
  962. }
  963.  
  964. # Do not delete this line -- regeneration end marker
  965.  
  966. method RTITClass::addUnUsedAttrib {this newUnUsedAttrib} {
  967.     [$this unUsedAttribSet] append $newUnUsedAttrib
  968.  
  969. }
  970.  
  971. method RTITClass::removeUnUsedAttrib {this oldUnUsedAttrib} {
  972.     [$this unUsedAttribSet] removeValue $oldUnUsedAttrib
  973. }
  974.  
  975. method RTITClass::attrSet {this} {
  976.     return [$this _attrSet]
  977. }
  978.  
  979. method RTITClass::addAttr {this newAttr} {
  980.     [$this _attrSet] append $newAttr
  981.     $newAttr _clss $this
  982. }
  983.  
  984. method RTITClass::removeAttr {this oldAttr} {
  985.     $oldAttr _clss ""
  986.     [$this _attrSet] removeValue $oldAttr
  987. }
  988.  
  989. method RTITClass::mthdSet {this} {
  990.     return [$this _mthdSet]
  991. }
  992.  
  993. method RTITClass::addMthd {this newMthd} {
  994.     [$this _mthdSet] append $newMthd
  995.     $newMthd _clss $this
  996. }
  997.  
  998. method RTITClass::removeMthd {this oldMthd} {
  999.     $oldMthd _clss ""
  1000.     [$this _mthdSet] removeValue $oldMthd
  1001. }
  1002.  
  1003. method RTITClass::addUnUsedMethod {this newUnUsedMethod} {
  1004.     [$this unUsedMethodSet] append $newUnUsedMethod
  1005.  
  1006. }
  1007.  
  1008. method RTITClass::removeUnUsedMethod {this oldUnUsedMethod} {
  1009.     [$this unUsedMethodSet] removeValue $oldUnUsedMethod
  1010. }
  1011.  
  1012.  
  1013.  
  1014. #---------------------------------------------------------------------------
  1015. #      File:           @(#)rtitmethod.tcl    /main/titanic/13
  1016. # End user added include file section
  1017.  
  1018.  
  1019. Class RTITMethod : {GCObject} {
  1020.     constructor
  1021.     method destructor
  1022.     method go
  1023.     method update
  1024.     method deleteUnUsed
  1025.     method createList
  1026.     method setBestMatch
  1027.     method setPosition
  1028.     method prev
  1029.     method next
  1030.     method clss
  1031.     method paramSet
  1032.     method addParam
  1033.     method removeParam
  1034.     method addUnUsedParam
  1035.     method removeUnUsedParam
  1036.     attribute _clss
  1037.     attribute rtMethod
  1038.     attribute _paramSet
  1039.     attribute edMethod
  1040.     attribute unUsedParamSet
  1041. }
  1042.  
  1043. constructor RTITMethod {class this clss rtMethod} {
  1044.     set this [GCObject::constructor $class $this]
  1045.     $this _clss $clss
  1046.     [$clss _mthdSet] append $this
  1047.     $this rtMethod $rtMethod
  1048.     $this _paramSet [List new]
  1049.     $this unUsedParamSet [List new]
  1050.     # Start constructor user section
  1051.  
  1052.     [[$this rtMethod] rtParamSet] foreach param {
  1053.         RTITParam new $this $param
  1054.     }
  1055.  
  1056.     # End constructor user section
  1057.     return $this
  1058. }
  1059.  
  1060. method RTITMethod::destructor {this} {
  1061.     # Start destructor user section
  1062.     # End destructor user section
  1063. }
  1064.  
  1065. method RTITMethod::go {this} {
  1066.     $this setBestMatch
  1067.     $this setPosition
  1068.  
  1069.     $this createList
  1070.     [$this paramSet] foreach param {
  1071.         $param go
  1072.     }
  1073. }
  1074.  
  1075. method RTITMethod::update {this} {
  1076.     if {[$this edMethod] == ""} return
  1077.     # check the name_type label
  1078.     # compare the items and all properties which change the label
  1079.  
  1080.     set methodName [[$this edMethod] getItem name_type pe]
  1081.     set standTypeDiag [[$this edMethod] getItem name_type cl]
  1082.     set langTypeDiag $standTypeDiag
  1083.     set type [${RTITClass::langTypeTable} getTypeByStdTypeName $standTypeDiag]
  1084.     if {$type != ""} {
  1085.         set langTypeDiag [$type name]
  1086.     }
  1087.  
  1088.     if { ([[$this rtMethod] name] != $methodName) ||
  1089.          (([[$this rtMethod] type] != $standTypeDiag) &&
  1090.           ([[$this rtMethod] type] != $langTypeDiag)) ||
  1091.          ([[$this rtMethod] getProp "is_class_feature"] !=
  1092.           [[$this edMethod] getProp "is_class_feature"]) ||
  1093.          ([[$this rtMethod] getProp "is_abstract"] !=
  1094.           [[$this edMethod] getProp "is_abstract"])} {
  1095.  
  1096.         set typeStr ""
  1097.         if {[[$this rtMethod] type] == $langTypeDiag} {
  1098.             set typeStr $standTypeDiag
  1099.         } else {
  1100.             set type [${RTITClass::langTypeTable} getTypeByStdTypeName [[$this rtMethod] type]]
  1101.             if {$type == ""} {
  1102.                 set type [${RTITClass::langTypeTable} getType [[$this rtMethod] type]]
  1103.                 if {$type != ""} {
  1104.                     set typeStr [$type stdTypeName]
  1105.                 }
  1106.             }
  1107.         }
  1108.  
  1109.         if {$typeStr != ""} {
  1110.             if [regsub "(.*:.*)[[$this rtMethod] type](.*)" \
  1111.                 "[[$this rtMethod] getLabel name_type]" \
  1112.                 "\\1$typeStr\\2" newLabel] {
  1113.                 [$this rtMethod] setLabel name_type $newLabel
  1114.             }
  1115.         }
  1116.  
  1117.         set mthdNLbl [[$this rtMethod] getLabel name_type]
  1118.         regsub -all "\n" [[$this edMethod] getLabel name_type] "" mthdOLbl
  1119.         set clssName [[[$this clss] rtClass] name]
  1120.         set answer [[[$this clss] ui] askQuestion \
  1121.             "In class \"$clssName\": \
  1122.             \n    change method \"$mthdOLbl\" into \"$mthdNLbl\"" \
  1123.             "Change method?" \
  1124.             "method-change_label" \
  1125.             [$this clss]]
  1126.         if {$answer == "yes"} {
  1127.             [$this edMethod] setLabel name_type \
  1128.                 [[$this rtMethod] getLabel name_type]
  1129.         }
  1130.     }
  1131.     # check all known properties
  1132.     # known properties are properties which have been defined by the
  1133.     # parser which gave us our input
  1134.     [[$this rtMethod] rtPropertySet] foreach prop {
  1135.         set name [$prop name]
  1136.         switch $name {
  1137.             "is_class_feature"    continue
  1138.             "is_abstract"        continue
  1139.         }
  1140.  
  1141.         set item [$prop item]
  1142.         switch $item {
  1143.             "name"  { set itlbl "name_type" ; set ititem "pe" }
  1144.             "type"  { set itlbl "name_type" ; set ititem "cl" }
  1145.             "comp"  { set itlbl "" ; set ititem "" }
  1146.         }
  1147.         set value [$prop value]
  1148.         set itvalue [[$this edMethod] getProp $name $itlbl $ititem]
  1149.         set defaultValue [PropKnowledge::getDefaultValue $name]
  1150.         if [info exists debug] {
  1151.             puts stderr "value: '$value' itvalue: '$itvalue' defaultValue: '$defaultValue'"
  1152.         }
  1153.         if { $itvalue == "" } {
  1154.             set itvalue $defaultValue
  1155.         }
  1156.         if { $value == "" } {
  1157.             set value $defaultValue
  1158.         }
  1159.         if { $itvalue != $value } {
  1160.             set clssName [[[$this clss] rtClass] name]
  1161.             set fullPropName [PropKnowledge::getLongName $name]
  1162.             set answer [[[$this clss] ui] askQuestion \
  1163.                 "In class \"$clssName\": \
  1164.                 \n    change property \"$fullPropName\" of method \"$methodName\" \
  1165.                 \n        from \"$itvalue\" into \"$value\"" \
  1166.                 "Change method property?" \
  1167.                 "method-change_property" \
  1168.                 [$this clss]]
  1169.  
  1170.             if {$answer == "yes"} {
  1171.                 if { $value == $defaultValue } {
  1172.                     set value ""
  1173.                 }
  1174.                 [$this edMethod] setProp $name $value $itlbl $ititem
  1175.             }
  1176.         }
  1177.     }
  1178.  
  1179.     [$this paramSet] foreach param {
  1180.         $param update
  1181.     }
  1182.  
  1183.     [$this edMethod] formatLayout
  1184.  
  1185. }
  1186.  
  1187. method RTITMethod::deleteUnUsed {this} {
  1188.     if {[$this edMethod] == ""} return
  1189.     [$this unUsedParamSet] foreach param {
  1190.         set clssName [[[$this clss] rtClass] name]
  1191.         set paramName [$param getItem name_type de]
  1192.         set methodName [[$this rtMethod] name]
  1193.         set answer [[[$this clss] ui] askQuestion \
  1194.             "In class \"$clssName\", method \"$methodName\":\
  1195.             \n    delete parameter \"$paramName\"" \
  1196.             "Delete parameter?" \
  1197.             "parameter-delete" \
  1198.             [$this clss]]
  1199.  
  1200.         if {$answer == "yes"} {
  1201.             [$this edMethod] deleteCell $param
  1202.         }
  1203.     }
  1204. }
  1205.  
  1206. method RTITMethod::createList {this} {
  1207.     if {[$this edMethod] == ""} return
  1208.     foreach cell [[$this edMethod] getCells] {
  1209.         $this addUnUsedParam $cell
  1210.     }
  1211. }
  1212.  
  1213. method RTITMethod::setBestMatch {this} {
  1214.     # this is the most tricky method.
  1215.     # methods are the same if the signature is the same, this
  1216.     # means that we should determine the signature of the
  1217.     # methods from the it and rt models, compare these and
  1218.     # it they match use that one. if they don't match use
  1219.     # the first method with the same name (warning: this makes
  1220.     # re-ordering of methods dangerous)
  1221.  
  1222.     # a signature consists of the name, type and parameters 
  1223.     # (with their names, types and ordering).
  1224.  
  1225.     # calc signature of RT method
  1226.     set signatureRt "[[$this rtMethod] name]:[[$this rtMethod] type]"
  1227.     [[$this rtMethod] rtParamSet] foreach param {
  1228.         set signatureRt "$signatureRt:[$param name]:[$param type]"
  1229.     }
  1230.  
  1231.     [[$this clss] unUsedMethodSet] foreach mthd {
  1232.         # make sure it is not the default ctor "$create"
  1233.         if [regexp {^.*$create[^(]*$} [$mthd getLabel name_type]] {
  1234.             puts "Default ctor found"
  1235.             [[$this clss] unUsedMethodSet] removeValue $mthd
  1236.             continue
  1237.         }
  1238.         # calc signature of IT method
  1239.         set signatureEd "[$mthd getItem name_type pe]"
  1240.         set signatureEd "$signatureEd:[$mthd getItem name_type cl]"
  1241.         foreach cell [$mthd getCells] {
  1242.             set signatureEd "$signatureEd:[$cell getItem name_type de]"
  1243.             set signatureEd "$signatureEd:[$cell getItem name_type cl]"
  1244.         }
  1245.  
  1246.         if { $signatureRt == $signatureEd } {
  1247.             # found a matching signature
  1248.             $this edMethod $mthd
  1249.             [[$this clss] unUsedMethodSet] removeValue $mthd
  1250.             return
  1251.         }
  1252.     }
  1253.  
  1254.     # no matching signature found, so try to find a method with the same name
  1255.     [[$this clss] unUsedMethodSet] foreach mthd {
  1256.         if { [$mthd getItem "name_type" "pe"] == [[$this rtMethod] name] } {
  1257.             # found a matching name (signatures don't match)
  1258.             $this edMethod $mthd
  1259.             [[$this clss] unUsedMethodSet] removeValue $mthd
  1260.             return
  1261.         }
  1262.     }
  1263.  
  1264.     # no matching name found either, so create a new method
  1265.     set clssName [[[$this clss] rtClass] name]
  1266.     set mthdName [[$this rtMethod] name]
  1267.     set answer [[[$this clss] ui] askQuestion \
  1268.         "In class \"$clssName\": add method \"$mthdName\"" \
  1269.         "Add method?" \
  1270.         "method-add" \
  1271.         [$this clss]]
  1272.  
  1273.     if {$answer == "yes"} {
  1274.         set newMethod [[[$this clss] edMatrix] addRow "method"]
  1275.         $this edMethod $newMethod
  1276.         set type [${RTITClass::langTypeTable} getTypeByStdTypeName [[$this rtMethod] type]]
  1277.         if {$type == ""} {
  1278.             set type [${RTITClass::langTypeTable} getType [[$this rtMethod] type]]
  1279.             if {$type != ""} {
  1280.                 set typeStr [$type stdTypeName]
  1281.                 if [regsub "(.*:.*)[[$this rtMethod] type](.*)" \
  1282.                     "[[$this rtMethod] getLabel name_type]" \
  1283.                     "\\1$typeStr\\2" newLabel] {
  1284.                     [$this rtMethod] setLabel name_type $newLabel
  1285.                 }
  1286.             }
  1287.         }
  1288.         $newMethod setLabel name_type [[$this rtMethod] getLabel name_type]
  1289.         [[$this rtMethod] rtPropertySet] foreach prop {
  1290.             set name [$prop name]
  1291.             switch $name {
  1292.                 "is_class_feature"    continue
  1293.                 "is_abstract"        continue
  1294.             }
  1295.  
  1296.             set item [$prop item]
  1297.             switch $item {
  1298.                 "name"  { set itlbl "name_type" ; set ititem "pe" }
  1299.                 "type"  { set itlbl "name_type" ; set ititem "cl" }
  1300.                 "comp"  { set itlbl "name_type" ; set ititem "" }
  1301.             }
  1302.             set value [$prop value]
  1303.             $newMethod setProp $name $value $itlbl $ititem
  1304.         }
  1305.     } else {
  1306.         $this edMethod ""
  1307.     }
  1308. }
  1309.  
  1310. method RTITMethod::setPosition {this} {
  1311.     if {[$this edMethod] == ""} return
  1312.     set prev [$this prev]
  1313.     if { $prev != "" } {
  1314.         # not the first one, so move
  1315.         if { [$prev edMethod] != ""} {
  1316.             [$this edMethod] moveBehind [$prev edMethod]
  1317.         }
  1318.     }
  1319. }
  1320.  
  1321. method RTITMethod::prev {this} {
  1322.     # Look for myself and sub one to the index
  1323.     set idx [[[$this clss] mthdSet] search -exact $this]
  1324.     if { $idx == -1 } {
  1325.         return ""
  1326.     } else {
  1327.         set previdx [expr $idx - 1]
  1328.         if { $previdx != -1 } {
  1329.             return [[[$this clss] mthdSet] index $previdx]
  1330.         } else {
  1331.             return ""
  1332.         }
  1333.     }
  1334. }
  1335.  
  1336. method RTITMethod::next {this} {
  1337.     # Look for myself and add one to the index
  1338.     set idx [[[$this clss] mthdSet] search -exact $this]
  1339.     if { $idx == -1 } {
  1340.         return ""
  1341.     } else {
  1342.         set nextidx [expr $idx + 1]
  1343.         if { $nextidx < [[[$this clss] mthdSet] length] } {
  1344.             return [[[$this clss] mthdSet] index $nextidx]
  1345.         } else {
  1346.             return ""
  1347.         }
  1348.     }
  1349. }
  1350.  
  1351. # Do not delete this line -- regeneration end marker
  1352.  
  1353. method RTITMethod::clss {this args} {
  1354.     if {$args == ""} {
  1355.         return [$this _clss]
  1356.     }
  1357.     set ref [$this _clss]
  1358.     if {$ref != ""} {
  1359.         [$ref _mthdSet] removeValue $this
  1360.     }
  1361.     set obj [lindex $args 0]
  1362.     if {$obj != ""} {
  1363.         [$obj _mthdSet] append $this
  1364.     }
  1365.     $this _clss $obj
  1366. }
  1367.  
  1368. method RTITMethod::paramSet {this} {
  1369.     return [$this _paramSet]
  1370. }
  1371.  
  1372. method RTITMethod::addParam {this newParam} {
  1373.     [$this _paramSet] append $newParam
  1374.     $newParam _mthd $this
  1375. }
  1376.  
  1377. method RTITMethod::removeParam {this oldParam} {
  1378.     $oldParam _mthd ""
  1379.     [$this _paramSet] removeValue $oldParam
  1380. }
  1381.  
  1382. method RTITMethod::addUnUsedParam {this newUnUsedParam} {
  1383.     [$this unUsedParamSet] append $newUnUsedParam
  1384.  
  1385. }
  1386.  
  1387. method RTITMethod::removeUnUsedParam {this oldUnUsedParam} {
  1388.     [$this unUsedParamSet] removeValue $oldUnUsedParam
  1389. }
  1390.  
  1391.  
  1392.  
  1393. #---------------------------------------------------------------------------
  1394. #      File:           @(#)rtitparam.tcl    /main/titanic/13
  1395. # End user added include file section
  1396.  
  1397.  
  1398. Class RTITParam : {GCObject} {
  1399.     constructor
  1400.     method destructor
  1401.     method go
  1402.     method update
  1403.     method setBestMatch
  1404.     method setPosition
  1405.     method prev
  1406.     method next
  1407.     method mthd
  1408.     attribute _mthd
  1409.     attribute rtParam
  1410.     attribute edParam
  1411. }
  1412.  
  1413. constructor RTITParam {class this mthd rtParam} {
  1414.     set this [GCObject::constructor $class $this]
  1415.     $this _mthd $mthd
  1416.     [$mthd _paramSet] append $this
  1417.     $this rtParam $rtParam
  1418.     # Start constructor user section
  1419.     # End constructor user section
  1420.     return $this
  1421. }
  1422.  
  1423. method RTITParam::destructor {this} {
  1424.     # Start destructor user section
  1425.     # End destructor user section
  1426. }
  1427.  
  1428. method RTITParam::go {this} {
  1429.     $this setBestMatch
  1430.     $this setPosition
  1431. }
  1432.  
  1433. method RTITParam::update {this} {
  1434.     if {[$this edParam] == ""} return
  1435.     if {[$this mthd] == ""} return
  1436.     if {[[$this mthd] clss] == ""} return
  1437.  
  1438.     # compare the name and type item of each parameter
  1439.     set paramName [[$this edParam] getItem name_type de]
  1440.  
  1441.     set standTypeDiag [[$this edParam] getItem name_type cl]
  1442.     set langTypeDiag $standTypeDiag
  1443.     set type [${RTITClass::langTypeTable} getTypeByStdTypeName $standTypeDiag]
  1444.     if {$type != ""} {
  1445.         set langTypeDiag [$type name]
  1446.     }
  1447.  
  1448.     if { ([[$this rtParam] name] != $paramName) ||
  1449.          (([[$this rtParam] type] != $standTypeDiag) &&
  1450.           ([[$this rtParam] type] != $langTypeDiag))} {
  1451.  
  1452.         set typeStr ""
  1453.         if {[[$this rtParam] type] == $langTypeDiag} {
  1454.             set typeStr $standTypeDiag
  1455.         } else {
  1456.             set type [${RTITClass::langTypeTable} getTypeByStdTypeName [[$this rtParam] type]]
  1457.             if {$type == ""} {
  1458.                 set type [${RTITClass::langTypeTable} getType [[$this rtParam] type]]
  1459.                 if {$type != ""} {
  1460.                     set typeStr [$type stdTypeName]
  1461.                 }
  1462.             }
  1463.         }
  1464.  
  1465.         if {$typeStr != ""} {
  1466.             if [regsub "(.*:.*)[[$this rtParam] type](.*)" \
  1467.                 [[$this rtParam] getLabel name_type] \
  1468.                 "\\1$typeStr\\2" newLabel] {
  1469.                 [$this rtParam] setLabel name_type $newLabel
  1470.             }
  1471.         }
  1472.  
  1473.         set clssName [[[[$this mthd] clss] rtClass] name]
  1474.         set methodName [[[$this mthd] rtMethod] name]
  1475.         set paramNLbl [[$this rtParam] getLabel name_type]
  1476.         regsub -all "\[\t\n, \]" [[$this edParam] getLabel name_type] "" paramOLbl
  1477.         set answer [[[[$this mthd] clss] ui] askQuestion \
  1478.             "In class \"$clssName\":\
  1479.             \n    change parameter of method \"$methodName\"\
  1480.             \n        from \"$paramOLbl\" into \"$paramNLbl\"" \
  1481.             "Change parameter?" \
  1482.             "parameter-change_label" \
  1483.             [[$this mthd] clss]]
  1484.         if {$answer == "yes"} {
  1485.             [$this edParam] setLabel name_type $paramNLbl
  1486.         }
  1487.     }
  1488.     # check all known properties
  1489.     # known properties are properties which have been defined by the
  1490.     # parser which gave us our input
  1491.     [[$this rtParam] rtPropertySet] foreach prop {
  1492.         set item [$prop item]
  1493.         switch $item {
  1494.             "name"  { set itlbl "name_type" ; set ititem "de" }
  1495.             "type"  { set itlbl "name_type" ; set ititem "cl" }
  1496.             "comp"  { set itlbl "" ; set ititem "" }
  1497.         }
  1498.         set name [$prop name]
  1499.         set value [$prop value]
  1500.         set itvalue [[$this edParam] getProp $name $itlbl $ititem]
  1501.         set defaultValue [PropKnowledge::getDefaultValue $name]
  1502.         if [info exists debug] {
  1503.             puts stderr "value: '$value' itvalue: '$itvalue' defaultValue: '$defaultValue'"
  1504.         }
  1505.         if { $itvalue == "" } {
  1506.             set itvalue $defaultValue
  1507.         }
  1508.         if { $value == "" } {
  1509.             set value $defaultValue
  1510.         }
  1511.         if { $itvalue != $value } {
  1512.             set clssName [[[[$this mthd] clss] rtClass] name]
  1513.             set methodName [[[$this mthd] rtMethod] name]
  1514.             set fullPropName [PropKnowledge::getLongName $name]
  1515.             set answer [[[[$this mthd] clss] ui] askQuestion \
  1516.                 "In class \"$clssName\", method \"$methodName\"\
  1517.                 \n    change property \"$fullPropName\" of parameter \"$paramName\"\
  1518.                 \n        from \"$itvalue\" into \"$value\"" \
  1519.                 "Change parameter property?" \
  1520.                 "parameter-change_property" \
  1521.                 [[$this mthd] clss]]
  1522.             if {$answer == "yes"} {
  1523.                 if { $value == $defaultValue } {
  1524.                     set value ""
  1525.                 }
  1526.                 [$this edParam] setProp $name $value $itlbl $ititem
  1527.             }
  1528.         }
  1529.     }
  1530. }
  1531.  
  1532. method RTITParam::setBestMatch {this} {
  1533.     if {[$this rtParam] == ""} return
  1534.     if {[$this mthd] == ""} return
  1535.     if {[[$this mthd] clss] == ""} return
  1536.     if {[[$this mthd] edMethod] == ""} return
  1537.     
  1538.     [[$this mthd] unUsedParamSet] foreach param {
  1539.         if { [$param getItem name_type de] == [[$this rtParam] name] } {
  1540.             # found a parameter with the same name.
  1541.             # most languages don't support multiple parameters
  1542.             # with the same name, but if there is a language,
  1543.             # we will simply take the first one found.
  1544.             $this edParam $param
  1545.             [[$this mthd] unUsedParamSet] removeValue $param
  1546.             return
  1547.         }
  1548.     }
  1549.     # attribute was not found
  1550.     # create a new attribute
  1551.     set clssName [[[[$this mthd] clss] rtClass] name]
  1552.     set methodName [[[$this mthd] rtMethod] name]
  1553.     set paramName [[$this rtParam] name]
  1554.     set answer [[[[$this mthd] clss] ui] askQuestion \
  1555.         "In class \"$clssName\", method \"$methodName\":\
  1556.         \n    add parameter \"$paramName\"" \
  1557.         "Add parameter?" \
  1558.         "parameter-add" \
  1559.         [[$this mthd] clss]]
  1560.     if {$answer == "yes"} {
  1561.         set newParam [[[$this mthd] edMethod] addCell "parameter"]
  1562.         $this edParam $newParam
  1563.         set type [${RTITClass::langTypeTable} getTypeByStdTypeName [[$this rtParam] type]]
  1564.         if {$type == ""} {
  1565.             set type [${RTITClass::langTypeTable} getType [[$this rtParam] type]]
  1566.             if {$type != ""} {
  1567.                 set typeStr [$type stdTypeName]
  1568.                 if [regsub "(.*:.*)[[$this rtParam] type](.*)" \
  1569.                     "[[$this rtParam] getLabel name_type]" \
  1570.                     "\\1$typeStr\\2" newLabel] {
  1571.                     [$this rtParam] setLabel name_type $newLabel
  1572.                 }
  1573.             }
  1574.         }
  1575.  
  1576.         $newParam setLabel name_type [[$this rtParam] getLabel name_type]
  1577.         [[$this rtParam] rtPropertySet] foreach prop {
  1578.             set item [$prop item]
  1579.             switch $item {
  1580.                 "name"  { set itlbl "name_type" ; set ititem "de" }
  1581.                 "type"  { set itlbl "name_type" ; set ititem "cl" }
  1582.                 "comp"  { set itlbl "" ; set ititem "" }
  1583.             }
  1584.             set name [$prop name]
  1585.             set value [$prop value]
  1586.             set itvalue [[$this edParam] getProp $name $itlbl $ititem]
  1587.             $newParam setProp $name $value $itlbl $ititem
  1588.         }
  1589.     } else {
  1590.         $this edParam ""
  1591.     }
  1592. }
  1593.  
  1594. method RTITParam::setPosition {this} {
  1595.     if {[$this edParam] == ""} return
  1596.     set prev [$this prev]
  1597.     if { $prev != "" } {
  1598.         # not the first one, so move
  1599.         if { [$prev edParam] != "" } {
  1600.             [$this edParam] moveBehind [$prev edParam]
  1601.         }
  1602.     }
  1603. }
  1604.  
  1605. method RTITParam::prev {this} {
  1606.     # Look for myself and sub one to the index
  1607.     set idx [[[$this mthd] paramSet] search -exact $this]
  1608.     if { $idx == -1 } {
  1609.         return ""
  1610.     } else {
  1611.         set previdx [expr $idx - 1]
  1612.         if { $previdx != -1 } {
  1613.             return [[[$this mthd] paramSet] index $previdx]
  1614.         } else {
  1615.             return ""
  1616.         }
  1617.     }
  1618. }
  1619.  
  1620. method RTITParam::next {this} {
  1621.     # Look for myself and add one to the index
  1622.     set idx [[[$this mthd] paramSet] search -exact $this]
  1623.     if { $idx == -1 } {
  1624.         return ""
  1625.     } else {
  1626.         set nextidx [expr $idx + 1]
  1627.         if { $nextidx < [[[$this mthd] paramSet] length] } {
  1628.             return [[[$this mthd] paramSet] index $nextidx]
  1629.         } else {
  1630.             return ""
  1631.         }
  1632.     }
  1633. }
  1634.  
  1635. # Do not delete this line -- regeneration end marker
  1636.  
  1637. method RTITParam::mthd {this args} {
  1638.     if {$args == ""} {
  1639.         return [$this _mthd]
  1640.     }
  1641.     set ref [$this _mthd]
  1642.     if {$ref != ""} {
  1643.         [$ref _paramSet] removeValue $this
  1644.     }
  1645.     set obj [lindex $args 0]
  1646.     if {$obj != ""} {
  1647.         [$obj _paramSet] append $this
  1648.     }
  1649.     $this _mthd $obj
  1650. }
  1651.  
  1652.  
  1653.  
  1654. #---------------------------------------------------------------------------
  1655. #      File:           @(#)rtituserin.tcl    /main/titanic/17
  1656. # End user added include file section
  1657.  
  1658.  
  1659. Class RTITUserInterface : {GCObject} {
  1660.     constructor
  1661.     method destructor
  1662.     method askQuestion
  1663.     attribute configuration
  1664.     attribute changes
  1665. }
  1666.  
  1667. constructor RTITUserInterface {class this} {
  1668.     set this [GCObject::constructor $class $this]
  1669.     # Start constructor user section
  1670.  
  1671.     $this configuration [Dictionary new]
  1672.     $this changes 0
  1673.  
  1674.     set clientContext [ClientContext::global]
  1675.     set config [path_name concat \
  1676.         [location [M4Login::getHomeDir] icase] roundtrip roundtrip]
  1677.  
  1678.     if [file exists $config] {
  1679.         set configList [readConfigurationFile $config]
  1680.     } else {
  1681.         set config [args_file {}]
  1682.         $clientContext downLoadCustomFile roundtrip roundtrip etc $config
  1683.         set configList [readConfigurationFile $config]
  1684.         unlink $config
  1685.     }
  1686.  
  1687.     foreach configLine $configList {
  1688.         set key "[lindex $configLine 0]-[lindex $configLine 1]"
  1689.         set value "[lindex $configLine 2] [lindex $configLine 3]"
  1690.         [$this configuration] set $key $value
  1691.     }
  1692.     # End constructor user section
  1693.     return $this
  1694. }
  1695.  
  1696. method RTITUserInterface::destructor {this} {
  1697.     # Start destructor user section
  1698.     # End destructor user section
  1699. }
  1700.  
  1701. method RTITUserInterface::askQuestion {this question shortQuestion qtype {clss ""}} {
  1702.     set action ""
  1703.     set defaultAnswer ""
  1704.     set conf [[$this configuration] set $qtype]
  1705.     if {$conf != ""} {
  1706.         set action [lindex $conf 0]
  1707.         set defaultAnswer [string tolower [lindex $conf 1]]
  1708.     }
  1709.  
  1710.     if { ($action != "ask") && ($action != "display") && ($action != "none") } {
  1711.         set action "ask"
  1712.     }
  1713.  
  1714.     if { ($defaultAnswer != "yes") && ($defaultAnswer != "no") } {
  1715.         set defaultAnswer "no"
  1716.     }
  1717.     
  1718.     if { ($action == "ask") || ($action == "display") } {
  1719.         puts "\n$question"
  1720.     }
  1721.  
  1722.     if { ($action == "display") || ($action == "none") } {
  1723.         if { $defaultAnswer != "yes" } {
  1724.             puts "Skipped..."
  1725.         } else {
  1726.             $this changes [expr [$this changes] + 1]
  1727.         }
  1728.         return $defaultAnswer
  1729.     }
  1730.  
  1731.     puts -nonewline \
  1732.         "QUESTION $defaultAnswer $shortQuestion"
  1733.  
  1734.     flush stdout
  1735.  
  1736.     set answer [gets stdin]
  1737.  
  1738.     set retval $defaultAnswer
  1739.  
  1740.     if {[string toupper [string index $answer 0]] == "N"} {
  1741.         return "no"
  1742.     }
  1743.  
  1744.     if {[string toupper [string index $answer 0]] == "Y"} {
  1745.         $this changes [expr [$this changes] + 1]
  1746.         return "yes"
  1747.     }
  1748.  
  1749.     if {[string toupper [string index $answer 0]] == "S"} {
  1750.         if {$clss != ""} {
  1751.             set matrix [$clss edMatrix]
  1752.             if {$matrix != ""} {
  1753.                 $matrix quit
  1754.                 exit
  1755.             }
  1756.         } else {
  1757.             $this changes -10000
  1758.             return "no"
  1759.         }
  1760.     }
  1761.  
  1762.     if { $defaultAnswer == "yes" } {
  1763.         $this changes [expr [$this changes] + 1]
  1764.     }
  1765.     return $defaultAnswer
  1766. }
  1767.  
  1768. # Do not delete this line -- regeneration end marker
  1769.  
  1770.  
  1771.  
  1772. #---------------------------------------------------------------------------
  1773. #      File:           @(#)rtproperty.tcl    /main/titanic/2
  1774.  
  1775.  
  1776. Class RTProperty : {GCObject} {
  1777.     constructor
  1778.     method destructor
  1779.     method REGenerate
  1780.     method rtComp
  1781.     attribute name
  1782.     attribute value
  1783.     attribute item
  1784.     attribute _rtComp
  1785. }
  1786.  
  1787. constructor RTProperty {class this} {
  1788.     set this [GCObject::constructor $class $this]
  1789.     # Start constructor user section
  1790.     # End constructor user section
  1791.     return $this
  1792. }
  1793.  
  1794. method RTProperty::destructor {this} {
  1795.     # Start destructor user section
  1796.     # End destructor user section
  1797. }
  1798.  
  1799. method RTProperty::REGenerate {this RTFd} {
  1800.     puts $RTFd "\$[[$this rtComp] getUniqueName] setProp \{[$this name]\} \{[$this value]\} [$this item]"
  1801. }
  1802.  
  1803. # Do not delete this line -- regeneration end marker
  1804.  
  1805. method RTProperty::rtComp {this args} {
  1806.     if {$args == ""} {
  1807.         return [$this _rtComp]
  1808.     }
  1809.     set ref [$this _rtComp]
  1810.     if {$ref != ""} {
  1811.         [$ref _rtPropertySet] removeValue $this
  1812.     }
  1813.     set obj [lindex $args 0]
  1814.     if {$obj != ""} {
  1815.         [$obj _rtPropertySet] append $this
  1816.     }
  1817.     $this _rtComp $obj
  1818. }
  1819.  
  1820.  
  1821.  
  1822. #---------------------------------------------------------------------------
  1823. #      File:           @(#)rtattrib.tcl    /main/titanic/6
  1824.  
  1825.  
  1826. Class RTAttrib : {RTComp} {
  1827.     constructor
  1828.     method destructor
  1829.     method update
  1830.     method checkAccess
  1831.     method REGenerate
  1832.     method rtClass
  1833.     attribute section
  1834.     attribute mods
  1835.     attribute name
  1836.     attribute type
  1837.     attribute initValue
  1838.     attribute keyAttrib
  1839.     attribute _rtClass
  1840. }
  1841.  
  1842. constructor RTAttrib {class this rtDiagram} {
  1843.     set this [RTComp::constructor $class $this $rtDiagram]
  1844.     # Start constructor user section
  1845.     $this keyAttrib 0
  1846.     # End constructor user section
  1847.     return $this
  1848. }
  1849.  
  1850. method RTAttrib::destructor {this} {
  1851.     # Start destructor user section
  1852.     # End destructor user section
  1853.     $this RTComp::destructor
  1854. }
  1855.  
  1856. method RTAttrib::update {this} {
  1857.     if {[$this name] != ""} {
  1858.         # WARNING: key attributes update should be called after all ctors 
  1859.         # are available!
  1860.         return
  1861.     }
  1862.     set lbl [$this findLabel "name_type"]
  1863.     if {$lbl != ""} {
  1864.         if [regexp \
  1865.             "(\[ \t\]*)(\[\\\$/*\]*)(\[ \t\]*)(\[^:= \t\]+)(\[: \t\]*)(\[^= \t\]+)?(\[ \t\]*)(=.*)?\$" \
  1866.             [$lbl value] discard ws0 mods ws1 name point type ws2 initval] {
  1867.             $this mods $mods
  1868.             $this name $name
  1869.             $this type $type
  1870.  
  1871.             if [regexp "(\[ \t=\]*)(.*)" $initval discard assign val] {
  1872.                 $this initValue $val
  1873.             } else {
  1874.                 $this initValue $initval
  1875.             }
  1876.  
  1877.             $this setProp "initial_value" [$this initValue]
  1878.  
  1879.             if [regexp {\$} $mods] {
  1880.                 $this setProp "is_class_feature" "1" 
  1881.             }
  1882.             if [regexp {/} $mods] {
  1883.                 $this setProp "is_derived" "1"
  1884.             }
  1885.             if [regexp {[*]} $mods] {
  1886.                 $this setProp "key" "1"
  1887.             } else {
  1888.                 # Look for a default constructor with this attrib as param
  1889.                 [[$this rtClass] rtMethodSet] foreach mthd {
  1890.                     if { [$mthd section] == "default-constructor-destructor"  &&
  1891.                          [$mthd name] == "create" } {
  1892.                         # Found the constructor we were looking for
  1893.                         # Check it parameters (try to match this attributes name)
  1894.                         set paramName "i_[$this name]"
  1895.                         [$mthd rtParamSet] foreach param {
  1896.                             if {$paramName == [$param name]} {
  1897.                                 # Found the parameter
  1898.                                 $this keyAttrib 1
  1899.                                 break
  1900.                             }
  1901.                         }
  1902.                         break
  1903.                     }
  1904.                 }
  1905.             }
  1906.         } 
  1907.     }
  1908. }
  1909.  
  1910. method RTAttrib::checkAccess {this} {
  1911.     if {[$this section] != "user-defined-attribute"} {
  1912.         # skip all non user-defined attributes
  1913.         return
  1914.     }
  1915.  
  1916.     if {![info exists hasGetSetMethod]} {
  1917.         return
  1918.     }
  1919.  
  1920.     if {!$hasGetSetMethod} {
  1921.         return
  1922.     }
  1923.  
  1924.     set raccess "None"
  1925.     set waccess "None"
  1926.  
  1927.     global methodAccessPropName
  1928.  
  1929.     [[$this rtClass] rtMethodSet] foreach mthd {
  1930.         if { [$mthd section] == "attribute-accessor-method" } {
  1931.             set prop [$mthd findProp $methodAccessPropName "comp"]
  1932.             if {$prop != ""} {
  1933.                 set access [$prop value]
  1934.             } else {
  1935.                 set access [PropKnowledge::getDefaultValue method_access]
  1936.             }
  1937.             if [isGetMethod $mthd $this] {
  1938.                 set raccess $access
  1939.             }
  1940.             if [isSetMethod $mthd $this] {
  1941.                 set waccess $access
  1942.             }
  1943.         }
  1944.     }
  1945.     global attribAccessPropName
  1946.     $this setProp $attribAccessPropName "${raccess}-${waccess}" "name"
  1947. }
  1948.  
  1949. method RTAttrib::REGenerate {this RTFd} {
  1950.         puts $RTFd "set [$this getUniqueName] \[\$[[$this rtClass] getUniqueName] addAttrib \"\" \{[$this section]\}\]"
  1951.         $this REGenerateSub $RTFd
  1952. }
  1953.  
  1954. # Do not delete this line -- regeneration end marker
  1955.  
  1956. method RTAttrib::rtClass {this args} {
  1957.     if {$args == ""} {
  1958.         return [$this _rtClass]
  1959.     }
  1960.     set ref [$this _rtClass]
  1961.     if {$ref != ""} {
  1962.         [$ref _rtAttribSet] removeValue $this
  1963.     }
  1964.     set obj [lindex $args 0]
  1965.     if {$obj != ""} {
  1966.         [$obj _rtAttribSet] append $this
  1967.     }
  1968.     $this _rtClass $obj
  1969. }
  1970.  
  1971.  
  1972.  
  1973. #---------------------------------------------------------------------------
  1974. #      File:           @(#)rtclass.tcl    /main/titanic/8
  1975. # End user added include file section
  1976.  
  1977.  
  1978. Class RTClass : {RTComp} {
  1979.     constructor
  1980.     method destructor
  1981.     method addMethod
  1982.     method addAttrib
  1983.     method addGeneralization
  1984.     method update
  1985.     method REGenerate
  1986.     method accessible
  1987.     method assocStartSet
  1988.     method addAssocStart
  1989.     method removeAssocStart
  1990.     method superGenSet
  1991.     method addSuperGen
  1992.     method removeSuperGen
  1993.     method assocEndSet
  1994.     method addAssocEnd
  1995.     method removeAssocEnd
  1996.     method rtAttribSet
  1997.     method addRtAttrib
  1998.     method removeRtAttrib
  1999.     method rtMethodSet
  2000.     method addRtMethod
  2001.     method removeRtMethod
  2002.     method genSet
  2003.     method addGen
  2004.     method removeGen
  2005.     attribute section
  2006.     attribute derived
  2007.     attribute name
  2008.     attribute doneNN
  2009.     attribute _assocStartSet
  2010.     attribute _superGenSet
  2011.     attribute _assocEndSet
  2012.     attribute _rtAttribSet
  2013.     attribute _rtMethodSet
  2014.     attribute _genSet
  2015. }
  2016.  
  2017. constructor RTClass {class this rtDiagram} {
  2018.     set this [RTComp::constructor $class $this $rtDiagram]
  2019.     $this doneNN 0
  2020.     $this _assocStartSet [List new]
  2021.     $this _superGenSet [List new]
  2022.     $this _assocEndSet [List new]
  2023.     $this _rtAttribSet [List new]
  2024.     $this _rtMethodSet [List new]
  2025.     $this _genSet [List new]
  2026.     # Start constructor user section
  2027.     # End constructor user section
  2028.     return $this
  2029. }
  2030.  
  2031. method RTClass::destructor {this} {
  2032.     # Start destructor user section
  2033.     # End destructor user section
  2034.     $this RTComp::destructor
  2035. }
  2036.  
  2037. method RTClass::addMethod {this {nameType ""} {section "user-defined-method"}} {
  2038.     set mthd [RTMethod new [$this rtDiagram]]
  2039.     $mthd section $section
  2040.     if {$nameType != ""} {
  2041.         $mthd setLabel "name_type" $nameType
  2042.     }
  2043.     $this addRtMethod $mthd
  2044.     return $mthd
  2045. }
  2046.  
  2047. method RTClass::addAttrib {this {nameType ""} {section "user-defined-attribute"}} {
  2048.     set attr [RTAttrib new [$this rtDiagram]]
  2049.     $attr section $section
  2050.     if {$nameType != ""} {
  2051.         $attr setLabel "name_type" $nameType
  2052.     }
  2053.     $this addRtAttrib $attr
  2054.     return $attr
  2055. }
  2056.  
  2057. method RTClass::addGeneralization {this super {overlap 0}} {
  2058.     [$super genSet] foreach gen {
  2059.         if { [$gen overlap] == $overlap } {
  2060.             $gen addDerived $this
  2061.             return $gen
  2062.         }
  2063.     }
  2064.     # No generalization created yet, create one
  2065.     set ng [RTGen new [$this rtDiagram]]
  2066.     $ng overlap $overlap
  2067.     $ng super $super
  2068.     $ng addDerived $this
  2069.     return $ng
  2070. }
  2071.  
  2072. method RTClass::update {this} {
  2073.     [$this rtMethodSet] foreach mthd {
  2074.         $mthd update
  2075.     }
  2076.     [$this rtAttribSet] foreach attr {
  2077.         $attr update
  2078.     }
  2079.     if {[$this name] != ""} {
  2080.         return
  2081.     }
  2082.     set lbl [$this findLabel "name"]
  2083.     if {$lbl != ""} {
  2084.         regsub -all "\[ \t\n\]" [$lbl value] "" value
  2085.         if [regexp {(/*)(.*)} $value discard derived name] {
  2086.             $this derived $derived
  2087.             $this name $name
  2088.         }
  2089.     }
  2090.     set prop [$this getProp "is_folded"] 
  2091.     if {$prop != ""} {
  2092.         if {$prop == "1"} {
  2093.             return
  2094.         }
  2095.     }
  2096. }
  2097.  
  2098. method RTClass::REGenerate {this} {
  2099.      $this doneNN 1
  2100.      [$this rtDiagram] startREFile
  2101.          puts [[$this rtDiagram] RTFd] "set [$this getUniqueName] \[\$diag findClass \"[$this name]\"]"
  2102.          puts [[$this rtDiagram] RTFd] "if {\$[$this getUniqueName] == \"\"} {"
  2103.      puts [[$this rtDiagram] RTFd] "   set [$this getUniqueName] \[\$diag addClass \"[$this name]\"\]"
  2104.      puts [[$this rtDiagram] RTFd] "   \$[$this getUniqueName] setProp {rt_control} {1} name"
  2105.          puts [[$this rtDiagram] RTFd] "}"
  2106.  
  2107.     $this REGenerateSub [[$this rtDiagram] RTFd] 
  2108.  
  2109.      [$this rtMethodSet] foreach mthd {
  2110.         $mthd REGenerate [[$this rtDiagram] RTFd] 
  2111.     }
  2112.     [$this rtAttribSet] foreach attr {
  2113.         $attr REGenerate [[$this rtDiagram] RTFd] 
  2114.     }
  2115.     [$this genSet] foreach gen {
  2116.         $gen REGenerateSubC [[$this rtDiagram] RTFd] 
  2117.     }
  2118.     [$this superGenSet] foreach gen {
  2119.         $gen REGenerateSuper [[$this rtDiagram] RTFd] $this
  2120.     }
  2121.     [$this assocStartSet] foreach con {
  2122.         $con REGenerate [[$this rtDiagram] RTFd]
  2123.     }
  2124.     [$this assocEndSet] foreach con {
  2125.         $con REGenerate [[$this rtDiagram] RTFd]
  2126.     }
  2127. }
  2128.  
  2129. method RTClass::accessible {this} {
  2130.     if {[$this doneNN] == 1} {
  2131.         return 1
  2132.     }
  2133.  
  2134.     if {[$this section] != "new-control"} {
  2135.              puts [[$this rtDiagram] RTFd] "set [$this getUniqueName] \[\$diag findClass \"[$this name]\"]"
  2136.              puts [[$this rtDiagram] RTFd] "if {\$[$this getUniqueName] == \"\"} {"
  2137.          puts [[$this rtDiagram] RTFd] "   set [$this getUniqueName] \[\$diag addClass \"[$this name]\"\]"
  2138.              puts [[$this rtDiagram] RTFd] "}"
  2139.          puts [[$this rtDiagram] RTFd] "\$[$this getUniqueName] setProp {is_folded} {1} comp"
  2140.  
  2141.         return 1
  2142.     }
  2143.  
  2144.     return 0
  2145. }
  2146.  
  2147. # Do not delete this line -- regeneration end marker
  2148.  
  2149. method RTClass::assocStartSet {this} {
  2150.     return [$this _assocStartSet]
  2151. }
  2152.  
  2153. method RTClass::addAssocStart {this newAssocStart} {
  2154.     [$this _assocStartSet] append $newAssocStart
  2155.     $newAssocStart _start $this
  2156. }
  2157.  
  2158. method RTClass::removeAssocStart {this oldAssocStart} {
  2159.     $oldAssocStart _start ""
  2160.     [$this _assocStartSet] removeValue $oldAssocStart
  2161. }
  2162.  
  2163. method RTClass::superGenSet {this} {
  2164.     return [$this _superGenSet]
  2165. }
  2166.  
  2167. method RTClass::addSuperGen {this newSuperGen} {
  2168.     [$this _superGenSet] append $newSuperGen
  2169.     [$newSuperGen _derivedSet] append $this
  2170. }
  2171.  
  2172. method RTClass::removeSuperGen {this oldSuperGen} {
  2173.     [$oldSuperGen _derivedSet] removeValue $this
  2174.     [$this _superGenSet] removeValue $oldSuperGen
  2175. }
  2176.  
  2177. method RTClass::assocEndSet {this} {
  2178.     return [$this _assocEndSet]
  2179. }
  2180.  
  2181. method RTClass::addAssocEnd {this newAssocEnd} {
  2182.     [$this _assocEndSet] append $newAssocEnd
  2183.     $newAssocEnd _end $this
  2184. }
  2185.  
  2186. method RTClass::removeAssocEnd {this oldAssocEnd} {
  2187.     $oldAssocEnd _end ""
  2188.     [$this _assocEndSet] removeValue $oldAssocEnd
  2189. }
  2190.  
  2191. method RTClass::rtAttribSet {this} {
  2192.     return [$this _rtAttribSet]
  2193. }
  2194.  
  2195. method RTClass::addRtAttrib {this newRtAttrib} {
  2196.     [$this _rtAttribSet] append $newRtAttrib
  2197.     $newRtAttrib _rtClass $this
  2198. }
  2199.  
  2200. method RTClass::removeRtAttrib {this oldRtAttrib} {
  2201.     $oldRtAttrib _rtClass ""
  2202.     [$this _rtAttribSet] removeValue $oldRtAttrib
  2203. }
  2204.  
  2205. method RTClass::rtMethodSet {this} {
  2206.     return [$this _rtMethodSet]
  2207. }
  2208.  
  2209. method RTClass::addRtMethod {this newRtMethod} {
  2210.     [$this _rtMethodSet] append $newRtMethod
  2211.     $newRtMethod _rtClass $this
  2212. }
  2213.  
  2214. method RTClass::removeRtMethod {this oldRtMethod} {
  2215.     $oldRtMethod _rtClass ""
  2216.     [$this _rtMethodSet] removeValue $oldRtMethod
  2217. }
  2218.  
  2219. method RTClass::genSet {this} {
  2220.     return [$this _genSet]
  2221. }
  2222.  
  2223. method RTClass::addGen {this newGen} {
  2224.     [$this _genSet] append $newGen
  2225.     $newGen _super $this
  2226. }
  2227.  
  2228. method RTClass::removeGen {this oldGen} {
  2229.     $oldGen _super ""
  2230.     [$this _genSet] removeValue $oldGen
  2231. }
  2232.  
  2233.  
  2234.  
  2235. #---------------------------------------------------------------------------
  2236. #      File:           @(#)rtconn.tcl    /main/titanic/1
  2237.  
  2238.  
  2239. Class RTConn : {RTComp} {
  2240.     constructor
  2241.     method destructor
  2242.     method REGenerate
  2243.     method start
  2244.     method end
  2245.     attribute connType
  2246.     attribute done
  2247.     attribute _start
  2248.     attribute _end
  2249. }
  2250.  
  2251. constructor RTConn {class this rtDiagram i_connType start end} {
  2252.     set this [RTComp::constructor $class $this $rtDiagram]
  2253.     $this done 0
  2254.     $this connType $i_connType
  2255.     $this _start $start
  2256.     [$start _assocStartSet] append $this
  2257.     $this _end $end
  2258.     [$end _assocEndSet] append $this
  2259.     # Start constructor user section
  2260.     # End constructor user section
  2261.     return $this
  2262. }
  2263.  
  2264. method RTConn::destructor {this} {
  2265.     # Start destructor user section
  2266.     # End destructor user section
  2267.     $this RTComp::destructor
  2268. }
  2269.  
  2270. method RTConn::REGenerate {this RTFd} {
  2271.     if {[$this done] != 1} {
  2272.         if {[[$this start] accessible] == 1} {
  2273.             if {[[$this end] accessible] == 1} {
  2274.                 $this done 1
  2275.                 puts $RTFd "set [$this getUniqueName] \[ \$diag addConn \{[$this connType]\} \$[[$this start] getUniqueName] \$[[$this end] getUniqueName]\]"                
  2276.                 $this REGenerateSub $RTFd
  2277.             }
  2278.         }
  2279.     }
  2280. }
  2281.  
  2282. # Do not delete this line -- regeneration end marker
  2283.  
  2284. method RTConn::start {this args} {
  2285.     if {$args == ""} {
  2286.         return [$this _start]
  2287.     }
  2288.     set ref [$this _start]
  2289.     if {$ref != ""} {
  2290.         [$ref _assocStartSet] removeValue $this
  2291.     }
  2292.     set obj [lindex $args 0]
  2293.     if {$obj != ""} {
  2294.         [$obj _assocStartSet] append $this
  2295.     }
  2296.     $this _start $obj
  2297. }
  2298.  
  2299. method RTConn::end {this args} {
  2300.     if {$args == ""} {
  2301.         return [$this _end]
  2302.     }
  2303.     set ref [$this _end]
  2304.     if {$ref != ""} {
  2305.         [$ref _assocEndSet] removeValue $this
  2306.     }
  2307.     set obj [lindex $args 0]
  2308.     if {$obj != ""} {
  2309.         [$obj _assocEndSet] append $this
  2310.     }
  2311.     $this _end $obj
  2312. }
  2313.  
  2314.  
  2315.  
  2316. #---------------------------------------------------------------------------
  2317. #      File:           @(#)rtgen.tcl    /main/titanic/2
  2318.  
  2319.  
  2320. Class RTGen : {RTComp} {
  2321.     constructor
  2322.     method destructor
  2323.     method ifDone
  2324.     method REGenerateSubC
  2325.     method REGenerateSuper
  2326.     method super
  2327.     method addDone
  2328.     method removeDone
  2329.     method derivedSet
  2330.     method addDerived
  2331.     method removeDerived
  2332.     attribute overlap
  2333.     attribute _super
  2334.     attribute doneSet
  2335.     attribute _derivedSet
  2336. }
  2337.  
  2338. constructor RTGen {class this rtDiagram} {
  2339.     set this [RTComp::constructor $class $this $rtDiagram]
  2340.     $this doneSet [List new]
  2341.     $this _derivedSet [List new]
  2342.     # Start constructor user section
  2343.     # End constructor user section
  2344.     return $this
  2345. }
  2346.  
  2347. method RTGen::destructor {this} {
  2348.     # Start destructor user section
  2349.     # End destructor user section
  2350.     $this RTComp::destructor
  2351. }
  2352.  
  2353. method RTGen::ifDone {this cls} {
  2354.     [$this doneSet] foreach don {
  2355.         if {$cls == $don} {
  2356.             return 1
  2357.         }
  2358.     }
  2359.     return 0
  2360. }
  2361.  
  2362. method RTGen::REGenerateSubC {this RTFd} {
  2363.          if {[[$this super] accessible] == 1} {
  2364.         [$this derivedSet] foreach sub {
  2365.             if {[$this ifDone $sub] != 1} {
  2366.                 if {[$sub accessible] == 1} {
  2367.                     puts $RTFd "set [$this getUniqueName] \[\$[$sub getUniqueName] addGeneralization \$[[$this super] getUniqueName] \{[$this overlap]\}\]"
  2368.                     $this REGenerateSub $RTFd
  2369.                     $this addDone $sub
  2370.                 }
  2371.             }
  2372.         }
  2373.          }
  2374. }
  2375.  
  2376. method RTGen::REGenerateSuper {this RTFd sub} {
  2377.          if {[[$this super] accessible] == 1} {
  2378.         if {[$this ifDone $sub] != 1} {
  2379.             if {[$sub accessible] == 1} {
  2380.                 puts $RTFd "set [$this getUniqueName] \[\$[$sub getUniqueName] addGeneralization \$[[$this super] getUniqueName] \{[$this overlap]\}\]"
  2381.                 $this REGenerateSub $RTFd
  2382.                 $this addDone $sub
  2383.             }
  2384.         }
  2385.     }
  2386. }
  2387.  
  2388. # Do not delete this line -- regeneration end marker
  2389.  
  2390. method RTGen::super {this args} {
  2391.     if {$args == ""} {
  2392.         return [$this _super]
  2393.     }
  2394.     set ref [$this _super]
  2395.     if {$ref != ""} {
  2396.         [$ref _genSet] removeValue $this
  2397.     }
  2398.     set obj [lindex $args 0]
  2399.     if {$obj != ""} {
  2400.         [$obj _genSet] append $this
  2401.     }
  2402.     $this _super $obj
  2403. }
  2404.  
  2405. method RTGen::addDone {this newDone} {
  2406.     [$this doneSet] append $newDone
  2407.  
  2408. }
  2409.  
  2410. method RTGen::removeDone {this oldDone} {
  2411.     [$this doneSet] removeValue $oldDone
  2412. }
  2413.  
  2414. method RTGen::derivedSet {this} {
  2415.     return [$this _derivedSet]
  2416. }
  2417.  
  2418. method RTGen::addDerived {this newDerived} {
  2419.     [$this _derivedSet] append $newDerived
  2420.     [$newDerived _superGenSet] append $this
  2421. }
  2422.  
  2423. method RTGen::removeDerived {this oldDerived} {
  2424.     [$oldDerived _superGenSet] removeValue $this
  2425.     [$this _derivedSet] removeValue $oldDerived
  2426. }
  2427.  
  2428.  
  2429.  
  2430. #---------------------------------------------------------------------------
  2431. #      File:           @(#)rtlabel.tcl    /main/titanic/2
  2432.  
  2433.  
  2434. Class RTLabel : {RTComp} {
  2435.     constructor
  2436.     method destructor
  2437.     method REGenerate
  2438.     method rtComp
  2439.     attribute name
  2440.     attribute value
  2441.     attribute _rtComp
  2442. }
  2443.  
  2444. constructor RTLabel {class this rtDiagram} {
  2445.     set this [RTComp::constructor $class $this $rtDiagram]
  2446.     # Start constructor user section
  2447.     # End constructor user section
  2448.     return $this
  2449. }
  2450.  
  2451. method RTLabel::destructor {this} {
  2452.     # Start destructor user section
  2453.     # End destructor user section
  2454.     $this RTComp::destructor
  2455. }
  2456.  
  2457. method RTLabel::REGenerate {this RTFd} {
  2458.         puts $RTFd "set [$this getUniqueName] \[\$[[$this rtComp] getUniqueName] setLabel \{[$this name]\} \{[$this value]\}\]"
  2459.     $this REGenerateSub $RTFd
  2460. }
  2461.  
  2462. # Do not delete this line -- regeneration end marker
  2463.  
  2464. method RTLabel::rtComp {this args} {
  2465.     if {$args == ""} {
  2466.         return [$this _rtComp]
  2467.     }
  2468.     set ref [$this _rtComp]
  2469.     if {$ref != ""} {
  2470.         [$ref _rtLabelSet] removeValue $this
  2471.     }
  2472.     set obj [lindex $args 0]
  2473.     if {$obj != ""} {
  2474.         [$obj _rtLabelSet] append $this
  2475.     }
  2476.     $this _rtComp $obj
  2477. }
  2478.  
  2479.  
  2480.  
  2481. #---------------------------------------------------------------------------
  2482. #      File:           @(#)rtmethod.tcl    /main/titanic/3
  2483.  
  2484.  
  2485. Class RTMethod : {RTComp} {
  2486.     constructor
  2487.     method destructor
  2488.     method addParam
  2489.     method update
  2490.     method REGenerate
  2491.     method rtClass
  2492.     method rtParamSet
  2493.     method addRtParam
  2494.     method removeRtParam
  2495.     attribute section
  2496.     attribute mods
  2497.     attribute name
  2498.     attribute type
  2499.     attribute constraint
  2500.     attribute _rtClass
  2501.     attribute _rtParamSet
  2502. }
  2503.  
  2504. constructor RTMethod {class this rtDiagram} {
  2505.     set this [RTComp::constructor $class $this $rtDiagram]
  2506.     $this _rtParamSet [List new]
  2507.     # Start constructor user section
  2508.     # End constructor user section
  2509.     return $this
  2510. }
  2511.  
  2512. method RTMethod::destructor {this} {
  2513.     # Start destructor user section
  2514.     # End destructor user section
  2515.     $this RTComp::destructor
  2516. }
  2517.  
  2518. method RTMethod::addParam {this {nameType ""}} {
  2519.     set prm [RTParam new [$this rtDiagram]]
  2520.     $this addRtParam $prm
  2521.     if { $nameType != "" } {
  2522.         $prm setLabel "name_type" $nameType
  2523.     }
  2524.     return $prm
  2525. }
  2526.  
  2527. method RTMethod::update {this} {
  2528.     [$this rtParamSet] foreach prm {
  2529.         $prm update
  2530.     }
  2531.     if {[$this name] != ""} {
  2532.         return
  2533.     }
  2534.     set lbl [$this findLabel "name_type"]
  2535.     if {$lbl != ""} {
  2536.         regsub -all "\[ \t\n\]" [$lbl value] "" value
  2537.         if [regexp {(\$)?([^(:\{]+)([()]*)(:[^\{]+)?(\{abstract\})?$}\
  2538.             $value discard mods name braces type constraint] {
  2539.             $this mods $mods
  2540.             $this name $name
  2541.             if [regexp {(:)?(.*)} $type discard point typeName] {
  2542.                 $this type $typeName
  2543.             } else {
  2544.                 $this type $type
  2545.             }
  2546.             $this constraint $constraint
  2547.             if { $constraint == "{abstract}" } {
  2548.                 $this setProp "is_abstract" "1"
  2549.             }
  2550.             if { $mods == "\$" } {
  2551.                 $this setProp "is_class_feature" "1"
  2552.             }
  2553.         }
  2554.     }
  2555. }
  2556.  
  2557. method RTMethod::REGenerate {this RTFd} {
  2558.         puts $RTFd "set [$this getUniqueName] \[\$[[$this rtClass] getUniqueName] addMethod \"\" \{[$this section]\}\]"
  2559.         [$this rtParamSet] foreach para {
  2560.                 $para REGenerate $RTFd
  2561.         }
  2562.         $this REGenerateSub $RTFd
  2563. }
  2564.  
  2565. # Do not delete this line -- regeneration end marker
  2566.  
  2567. method RTMethod::rtClass {this args} {
  2568.     if {$args == ""} {
  2569.         return [$this _rtClass]
  2570.     }
  2571.     set ref [$this _rtClass]
  2572.     if {$ref != ""} {
  2573.         [$ref _rtMethodSet] removeValue $this
  2574.     }
  2575.     set obj [lindex $args 0]
  2576.     if {$obj != ""} {
  2577.         [$obj _rtMethodSet] append $this
  2578.     }
  2579.     $this _rtClass $obj
  2580. }
  2581.  
  2582. method RTMethod::rtParamSet {this} {
  2583.     return [$this _rtParamSet]
  2584. }
  2585.  
  2586. method RTMethod::addRtParam {this newRtParam} {
  2587.     [$this _rtParamSet] append $newRtParam
  2588.     $newRtParam _rtMethod $this
  2589. }
  2590.  
  2591. method RTMethod::removeRtParam {this oldRtParam} {
  2592.     $oldRtParam _rtMethod ""
  2593.     [$this _rtParamSet] removeValue $oldRtParam
  2594. }
  2595.  
  2596.  
  2597.  
  2598. #---------------------------------------------------------------------------
  2599. #      File:           @(#)rtparam.tcl    /main/titanic/3
  2600.  
  2601.  
  2602. Class RTParam : {RTComp} {
  2603.     constructor
  2604.     method destructor
  2605.     method update
  2606.     method REGenerate
  2607.     method rtMethod
  2608.     attribute name
  2609.     attribute type
  2610.     attribute _rtMethod
  2611. }
  2612.  
  2613. constructor RTParam {class this rtDiagram} {
  2614.     set this [RTComp::constructor $class $this $rtDiagram]
  2615.     # Start constructor user section
  2616.     # End constructor user section
  2617.     return $this
  2618. }
  2619.  
  2620. method RTParam::destructor {this} {
  2621.     # Start destructor user section
  2622.     # End destructor user section
  2623.     $this RTComp::destructor
  2624. }
  2625.  
  2626. method RTParam::update {this} {
  2627.     if {[$this name] != ""} {
  2628.         return
  2629.     }
  2630.     set lbl [$this findLabel "name_type"]
  2631.     if {$lbl != ""} {
  2632.         regsub -all "\[ \t\n\]" [$lbl value] "" value
  2633.         if [regexp {([^:]+)(:)(.*)} $value discard name point type] {
  2634.             $this name $name
  2635.             $this type $type
  2636.         }
  2637.     }
  2638. }
  2639.  
  2640. method RTParam::REGenerate {this RTFd} {
  2641.         puts $RTFd "set [$this getUniqueName] \[\$[[$this rtMethod] getUniqueName] addParam \"\"\]"
  2642.         $this REGenerateSub $RTFd
  2643. }
  2644.  
  2645. # Do not delete this line -- regeneration end marker
  2646.  
  2647. method RTParam::rtMethod {this args} {
  2648.     if {$args == ""} {
  2649.         return [$this _rtMethod]
  2650.     }
  2651.     set ref [$this _rtMethod]
  2652.     if {$ref != ""} {
  2653.         [$ref _rtParamSet] removeValue $this
  2654.     }
  2655.     set obj [lindex $args 0]
  2656.     if {$obj != ""} {
  2657.         [$obj _rtParamSet] append $this
  2658.     }
  2659.     $this _rtMethod $obj
  2660. }
  2661.  
  2662.