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