home *** CD-ROM | disk | FTP | other *** search
Text File | 1997-05-02 | 92.4 KB | 2,953 lines |
- #--------------------------------------------------------------------------
- #
- # (c) Cayenne Software Inc. 1997
- #
- # File: %W%
- # Author: <generated>
- #
- #--------------------------------------------------------------------------
-
- # File: @(#)vbgassocin.tcl /main/hindenburg/8
-
-
- Class VBGAssocInitializer : {Object OPAssocInitializer} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGAssocInitializer {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGAssocInitializer::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGAssocInitializer::generate {this ctor} {
- if {[[[$this assoc] ooplType] ooplClass] != ""} {
- if {[[[[$this assoc] ooplType] ooplClass] baseType] == "NodeControl" ||
- [[[[$this assoc] ooplType] ooplClass] baseType] == "LeafControl"} {
- return
- }
- }
- if {[[$this assoc] getMultiplicity] == "one"} {
- if {[[$this assoc] isMandatory] &&
- [[$this assoc] opposite] != ""} {
- if {[[[$this assoc] opposite] isQualified]} {
- [$ctor gencode] append "a_[$this getName].Add[cap [[[$this assoc] opposite] getName]] Me, CStr(a_[$this getName]_[[[[$this assoc] opposite] qualifier] getName])\n"
- } else {
- [$ctor gencode] append "Set [[$this assoc] getName] = a_[$this getName]\n"
- }
- } else {
- [$ctor gencode] append "Set [[$this assoc] getName] = a_[$this getName]\n"
- }
- } else {
- [$ctor gencode] append "Add[cap [[$this assoc] getName]] a_[$this getName]\n"
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPAssocInitializer {this} {
- VBGAssocInitializer promote $this
- }
-
- # File: @(#)vbgattribi.tcl /main/hindenburg/4
-
-
- Class VBGAttribInitializer : {Object OPAttribInitializer} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGAttribInitializer {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGAttribInitializer::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGAttribInitializer::generate {this ctor} {
- if {[[$this attrib] isClassFeature]} {
- m4_warning $W_NOKEYFEAT [[$this attrib] getName] [[[$this attrib] ooplClass] getName]
- } else {
- if {[[[$this attrib] ooplType] get_obj_type] == "class_type" ||
- [[[$this attrib] ooplType] getType3GL] == "Object"} {
- [$ctor gencode] append "Set "
- }
-
- [$ctor gencode] append [[$this attrib] getName]
- [$ctor gencode] append " = "
- [$ctor gencode] append [$this getName]
- [$ctor gencode] append "\n"
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPAttribInitializer {this} {
- VBGAttribInitializer promote $this
- }
-
- # File: @(#)vbgclass.tcl /main/hindenburg/20
-
-
- Class VBGClass : {Object} {
- constructor
- method destructor
- method guiLib
- method hasMain
- method hasExtras
- method baseClass
- method baseType
- method generate
- method generateContainer
- attribute bseClass
- attribute bseType
- attribute guiLb
- attribute done
- attribute loop
- attribute hsExtras
- }
-
- constructor VBGClass {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGClass::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGClass::guiLib {this} {
- if {[$this guiLb] == ""} {
- if {[$this baseType] != "Class"} {
- $this guiLb [[[lindex [$this genNodeSet] 0] superClass] getPropertyValue "gui_lib"]
- }
- }
- return [$this guiLb]
- }
-
- method VBGClass::hasMain {this} {
- switch [$this baseType] {
- "NodeControl" {
- return 0
- }
- "LeafControl" {
- return 0
- }
- default {
- return 1
- }
- }
- }
-
- method VBGClass::hasExtras {this} {
- if {[$this hsExtras] == ""} {
- switch [$this baseType] {
- "NodeControl" {
- $this hsExtras 0
- }
- "LeafControl" {
- $this hsExtras 0
- }
- default {
- $this hsExtras 0
-
- foreach feature [$this dataAttrSet] {
- if {[$feature isClassFeature]} {
- $this hsExtras 1
- break
- }
- }
-
- foreach feature [$this operationSet] {
- if {[$feature isClassFeature] && [$feature getName] != "create"} {
- $this hsExtras 1
- break
- }
- }
- }
- }
- }
- return [$this hsExtras]
- }
-
- method VBGClass::baseClass {this} {
- if {[$this bseClass] == ""} {
- if {[$this baseType] == "Class"} {
- $this bseClass "Class"
- } else {
- $this bseClass [[lindex [$this genNodeSet] 0] getSuperClassName]
- }
- }
- return [$this bseClass]
- }
-
- method VBGClass::baseType {this} {
- if {[$this bseType] == ""} {
- if {[$this loop] != 1} {
- $this loop 1
- if {[llength [$this genNodeSet]] > 0} {
- set name [[[lindex [$this genNodeSet] 0] superClass] baseType]
- } else {
- set name [$this getName]
- }
-
- switch $name {
- "Window" {
- $this bseType $name
- }
- "NodeControl" {
- $this bseType $name
- }
- "LeafControl" {
- $this bseType $name
- }
- default {
- $this bseType "Class"
- }
- }
- } else {
- m4_fatal $F_LOOP [$this getName]
- $this bseType "Class"
- }
- }
- return [$this bseType]
- }
-
- method VBGClass::generate {this tgt} {
- switch [$this baseClass] {
- "Form" {
- set unit [VBForm new]
- $tgt setForm [$this getName] $unit
- }
- "Class" {
- set unit [VBClassModule new]
- $tgt setClassmodule [$this getName] $unit
- foreach genNode [$this genNodeSet] {
- $genNode generate $unit
- }
- }
- "MDIForm" {
- set unit [VBForm new]
- $tgt mdiform $unit
- }
- default {
- return
- }
- }
-
- set terminate [VBSub new]
- $terminate name "Terminate"
- $terminate access "Private"
- $terminate userCodeFirst 1
- set gcode [TextSection new]
- $terminate gencode $gcode
-
- $unit terminate $terminate
- $unit name [$this getName]
-
- foreach feature [$this dataAttrSet] {
- $feature generate $unit
- }
- foreach feature [$this operationSet] {
- $feature generate $unit
- }
- if {[$this constructor] != ""} {
- [$this constructor] generate $unit
- }
- foreach feature [$this genAssocAttrSet] {
- $feature generate $unit
- }
- }
-
- method VBGClass::generateContainer {this roleName number tgt} {
- if {[$this done] == 1} {
- m4_fatal $F_CONTLOOP [$this getName]
- return
- }
- if {$number != ""} {
- set temp $number
- } else {
- set temp 1
- }
- for {set i $temp} {$i > 0} {incr i -1} {
- switch [$this baseType] {
- "NodeControl" {
- if {[$this baseClass] == "Menu"} {
- set control [VBMenu new]
- } else {
- set control [VBControl new]
- }
- $this done 1
- foreach assoc [$this genAssocAttrSet] {
- $assoc generate $control
- }
- $this done 0
- }
- "LeafControl" {
- set control [VBControl new]
- }
- default {
- m4_error $E_NOTACONT [$this getName]
- return
- }
- }
- $control name $roleName
- $control ofClass [$this getName]
- $control guiType [$this baseClass]
- if {[$this guiLib] != ""} {
- $control guiLib [$this guiLib]
- }
- if {$number != ""} {
- $control hasIndex 1
- }
- $tgt addContain $control
- }
-
- foreach event [$this operationSet] {
- $event generate $control
- }
-
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGClassD : {VBGClass OPClass} {
- }
-
- selfPromoter OPClass {this} {
- VBGClassD promote $this
- }
-
- # File: @(#)vbgfeature.tcl /main/hindenburg/5
-
-
- Class VBGFeature : {Object} {
- constructor
- method destructor
- }
-
- constructor VBGFeature {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGFeature::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGFeatureD : {VBGFeature OPFeature} {
- }
-
- selfPromoter OPFeature {this} {
- VBGFeatureD promote $this
- }
-
- # File: @(#)vbginhgrou.tcl /main/hindenburg/5
-
-
- Class VBGInhGroup : {Object OPInhGroup} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGInhGroup {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGInhGroup::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGInhGroup::generate {this cl} {
- set type [VBType new]
- $type name "New [[$this superClass] getName]"
-
- set variable [VBVariable new $type]
- $variable name "[[$this superClass] getName]"
-
- set access [$this inherAccess]
-
- if {$access == ""} {
- set access "Public"
- }
-
- $variable access $access
-
- $cl addInhervar $variable
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPInhGroup {this} {
- VBGInhGroup promote $this
- }
-
-
- # File: @(#)vbgparamet.tcl /main/hindenburg/4
-
-
- Class VBGParameter : {Object} {
- constructor
- method destructor
- }
-
- constructor VBGParameter {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGParameter::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGParameterD : {VBGParameter OPParameter} {
- }
-
- selfPromoter OPParameter {this} {
- VBGParameterD promote $this
- }
-
- # File: @(#)vbgqualini.tcl /main/hindenburg/6
-
-
- Class VBGQualInitializer : {Object OPQualInitializer} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGQualInitializer {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGQualInitializer::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGQualInitializer::generate {this ctor} {
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPQualInitializer {this} {
- VBGQualInitializer promote $this
- }
-
- # File: @(#)vbgsupercl.tcl /main/hindenburg/7
-
-
- Class VBGSuperClassInitializer : {Object OPSuperClassInitializer} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGSuperClassInitializer {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGSuperClassInitializer::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGSuperClassInitializer::generate {this ctor} {
- if {[[[$this constructor] ooplClass] baseClass] == "Class"} {
- [$ctor gencode] append "[[$this ooplClass] getName].[[$this ooplClass] getName]_Constructor"
- set first 1
- foreach param [$this parameterSet] {
- if {!$first} {
- [$ctor gencode] append ", "
- } else {
- [$ctor gencode] append " "
- set first 0
- }
- [$ctor gencode] append "[$param getName]"
- }
- [$ctor gencode] append "\n"
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPSuperClassInitializer {this} {
- VBGSuperClassInitializer promote $this
- }
-
- # File: @(#)vbgtype.tcl /main/hindenburg/6
-
-
- Class VBGType : {Object} {
- constructor
- method destructor
- }
-
- constructor VBGType {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGTypeD : {VBGType OPType} {
- }
-
- selfPromoter OPType {this} {
- VBGTypeD promote $this
- }
-
-
- # File: @(#)vbgassocge.tcl /main/hindenburg/8
-
-
- Class VBGAssocGen : {GCObject} {
- constructor
- method destructor
- method hasRead
- method hasWrite
- method hasGet
- method assocattr
- attribute _assocattr
- }
-
- constructor VBGAssocGen {class this assocattr} {
- set this [GCObject::constructor $class $this]
- $this _assocattr $assocattr
- $assocattr _generator $this
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGAssocGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGAssocGen::hasRead {this} {
- set accessList [split [[$this assocattr] getPropertyValue assoc_access] -]
- set accessStr [lindex $accessList 0]
- if {$accessStr == ""} {
- set accessStr "Public"
- }
- return $accessStr
- }
-
- method VBGAssocGen::hasWrite {this} {
- set accessList [split [[$this assocattr] getPropertyValue assoc_access] -]
- set accessStr [lindex $accessList 1]
- if {$accessStr == ""} {
- set accessStr "Public"
- }
- return $accessStr
- }
-
- method VBGAssocGen::hasGet {this self} {
- set rd [$this hasRead]
- if {$self} {
- if {$rd == "None"} {
- return 0
- }
- } else {
- if {$rd == "None" || $rd == "Private"} {
- return 0
- }
- }
- return 1
- }
-
- # Do not delete this line -- regeneration end marker
-
- method VBGAssocGen::assocattr {this args} {
- if {$args == ""} {
- return [$this _assocattr]
- }
- set ref [$this _assocattr]
- if {$ref != ""} {
- $ref _generator ""
- }
- set obj [lindex $args 0]
- if {$obj != ""} {
- $obj _generator $this
- }
- $this _assocattr $obj
- }
-
-
- # File: @(#)vbgclassen.tcl /main/hindenburg/5
-
-
- Class VBGClassEnum : {VBGClass} {
- constructor
- method destructor
- method baseClass
- method hasMain
- method hasExtras
- method generate
- }
-
- constructor VBGClassEnum {class this name} {
- set this [VBGClass::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGClassEnum::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGClassEnum::baseClass {this} {
- if {[$this bseClass] == ""} {
- $this bseClass "Enum"
- }
- return [$this bseClass]
- }
-
- method VBGClassEnum::hasMain {this} {
- return 0
- }
-
- method VBGClassEnum::hasExtras {this} {
- return 1
- }
-
- method VBGClassEnum::generate {this tgt} {
- set enummodule [VBEnumModule new]
- $enummodule name [$this getName]
-
- foreach enum [$this dataAttrSet] {
- $enum generate $enummodule
- }
- $tgt setModule [$this getName] $enummodule
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGClassEnumD : {VBGClassEnum OPClassEnum} {
- }
-
- selfPromoter OPClassEnum {this} {
- VBGClassEnumD promote $this
- }
-
- # File: @(#)vbgclassge.tcl /main/hindenburg/2
-
-
- Class VBGClassGenericTypeDef : {VBGClass} {
- constructor
- method destructor
- }
-
- constructor VBGClassGenericTypeDef {class this name} {
- set this [VBGClass::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGClassGenericTypeDef::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGClassGenericTypeDefD : {VBGClassGenericTypeDef OPClassGenericTypeDef} {
- }
-
- selfPromoter OPClassGenericTypeDef {this} {
- VBGClassGenericTypeDefD promote $this
- }
-
- # File: @(#)vbgclasstd.tcl /main/hindenburg/2
-
-
- Class VBGClassTDef : {VBGClass} {
- constructor
- method destructor
- }
-
- constructor VBGClassTDef {class this name} {
- set this [VBGClass::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGClassTDef::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGClassTDefD : {VBGClassTDef OPClassTDef} {
- }
-
- selfPromoter OPClassTDef {this} {
- VBGClassTDefD promote $this
- }
-
- # File: @(#)vbglinkcla.tcl /main/hindenburg/3
-
-
- Class VBGLinkClass : {VBGClass} {
- constructor
- method destructor
- }
-
- constructor VBGLinkClass {class this name} {
- set this [VBGClass::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGLinkClass::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGLinkClassD : {VBGLinkClass OPLinkClass} {
- }
-
- selfPromoter OPLinkClass {this} {
- VBGLinkClassD promote $this
- }
-
- # File: @(#)vbgattribu.tcl /main/hindenburg/4
-
-
- Class VBGAttribute : {VBGFeature} {
- constructor
- method destructor
- }
-
- constructor VBGAttribute {class this name} {
- set this [VBGFeature::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGAttribute::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGAttributeD : {VBGAttribute OPAttribute} {
- }
-
- selfPromoter OPAttribute {this} {
- VBGAttributeD promote $this
- }
-
- # File: @(#)vbgconstru.tcl /main/hindenburg/5
-
-
- Class VBGConstructor : {VBGFeature} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGConstructor {class this name} {
- set this [VBGFeature::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGConstructor::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGConstructor::generate {this cl} {
- set ctor [VBSub new]
- set comment [VBComment new]
- $ctor comment $comment
- $comment comment [$this getPropertyValue "freeText"]
-
- $ctor name "Constructor"
- $ctor access [$this getPropertyValue "method_access"]
- if {[$ctor access] == ""} {
- $ctor access "Public"
- }
-
- set gencode [TextSection new]
- $ctor gencode $gencode
-
- foreach attrib [[$this ooplClass] dataAttrSet] {
- $attrib generateSetDefault $ctor
- }
-
- foreach param [[$this ooplClass] creationParamSet] {
- $param generate $ctor
- }
-
- foreach initializer [$this initializerSet] {
- $initializer generate $ctor
- }
-
- $cl constructor $ctor
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGConstructorD : {VBGConstructor OPConstructor} {
- }
-
- selfPromoter OPConstructor {this} {
- VBGConstructorD promote $this
- }
-
- # File: @(#)vbgoperati.tcl /main/hindenburg/13
-
-
- Class VBGOperation : {VBGFeature} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGOperation {class this name} {
- set this [VBGFeature::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGOperation::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGOperation::generate {this cl} {
- switch [[$this ooplClass] baseType] {
- "NodeControl" {
- if {[$this getPropertyValue "is_event"] != 1} {
- m4_error $E_CANTCONTMETH [[$this ooplClass] getName]
- return
- } else {
- set oper [VBEvent new]
- $oper name [$this getName]
- if {[$cl getEvent [$oper name]] == ""} {
- $cl setEvent [$oper name] $oper
- $cl addSevent $oper
- } else {
- m4_warning $W_EVENTDBDEF [$oper name] [$cl name]
- }
- }
- }
- "LeafControl" {
- if {[$this getPropertyValue "is_event"] != 1} {
- m4_error $E_CANTCONTMETH [[$this ooplClass] getName]
- return
- } else {
- set oper [VBEvent new]
- $oper name [$this getName]
- if {[$cl getEvent [$oper name]] == ""} {
- $cl setEvent [$oper name] $oper
- $cl addSevent $oper
- } else {
- m4_warning $W_EVENTDBDEF [$oper name] [$cl name]
- }
- }
- }
- "Class" {
- if {[$this getPropertyValue "is_event"] == 1} {
- m4_error $E_CANTCONTEVENT [[$this ooplClass] getName]
- return
- } else {
- set returntype [[$this ooplType] generate]
- if {[$returntype name] != ""} {
- set oper [VBFunction new $returntype]
- $oper name [$this getName]
-
- if {[$this isClassFeature]} {
- if {[$cl getGlobproc [$oper name]] == ""} {
- $cl setGlobproc [$oper name] $oper
- $cl addGlobSproc $oper
- } else {
- m4_warning $W_EVENTDBMTH [$oper name] [$cl name]
- }
- } else {
- if {[$cl getUserproc [$oper name]] == ""} {
- $cl addUserSproc $oper
- $cl setUserproc [$oper name] $oper
- } else {
- m4_warning $W_EVENTDBMTH [$oper name] [$cl name]
- }
- }
- } else {
- set oper [VBSub new]
- $oper name [$this getName]
-
- if {[$this getName] == "create" && [$this isClassFeature]} {
- $oper name "Constructor"
- $cl constructor $oper
- } else {
- if {[$this isClassFeature]} {
- if {[$cl getGlobproc [$oper name]] == ""} {
- $cl setGlobproc [$oper name] $oper
- $cl addGlobSproc $oper
- } else {
- m4_warning $W_EVENTDBMTH [$oper name] [$cl name]
- }
- } else {
- if {[$cl getUserproc [$oper name]] == ""} {
- $cl addUserSproc $oper
- $cl setUserproc [$oper name] $oper
- } else {
- m4_warning $W_EVENTDBMTH [$oper name] [$cl name]
- }
- }
- }
- }
- }
- }
- "Window" {
- if {[$this getPropertyValue "is_event"] == 1} {
- set oper [VBEvent new]
- $oper name [$this getName]
- if {[$cl getEvent [$oper name]] == ""} {
- $cl setEvent [$oper name] $oper
- $cl addSevent $oper
- } else {
- m4_warning $W_EVENTDBDEF [$oper name] [$cl name]
- }
- } else {
- set returntype [[$this ooplType] generate]
- if {[$returntype name] != ""} {
- set oper [VBFunction new $returntype]
- $oper name [$this getName]
-
- if {[$this isClassFeature]} {
- if {[$cl getGlobproc [$oper name]] == ""} {
- $cl setGlobproc [$oper name] $oper
- $cl addGlobSproc $oper
- } else {
- m4_warning $W_EVENTDBMTH [$oper name] [$cl name]
- }
- } else {
- if {[$cl getUserproc [$oper name]] == ""} {
- $cl addUserSproc $oper
- $cl setUserproc [$oper name] $oper
- } else {
- m4_warning $W_EVENTDBMTH [$oper name] [$cl name]
- }
- }
- } else {
- set oper [VBSub new]
- $oper name [$this getName]
-
- if {[$this getName] == "create" && [$this isClassFeature]} {
- $oper name "Constructor"
- $cl constructor $oper
- } else {
- if {[$this isClassFeature]} {
- if {[$cl getGlobproc [$oper name]] == ""} {
- $cl setGlobproc [$oper name] $oper
- $cl addGlobSproc $oper
- }
- } else {
- if {[$cl getUserproc [$oper name]] == ""} {
- $cl addUserSproc $oper
- $cl setUserproc [$oper name] $oper
- }
- }
- }
- }
- }
- }
- }
-
- $oper access [$this getPropertyValue "method_access"]
- $oper hasUserSection 0
-
- if {[$oper access] == ""} {
- $oper access "Public"
- }
-
- set comment [VBComment new]
- $oper comment $comment
- $comment comment [$this getPropertyValue "freeText"]
-
- foreach param [$this parameterSet] {
- $param generate $oper
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGOperationD : {VBGOperation OPOperation} {
- }
-
- selfPromoter OPOperation {this} {
- VBGOperationD promote $this
- }
-
- # File: @(#)vbgctorpar.tcl /main/hindenburg/10
-
-
- Class VBGCtorParameter : {VBGParameter} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGCtorParameter {class this name} {
- set this [VBGParameter::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGCtorParameter::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGCtorParameter::generate {this method} {
- if {[$this attrib] != ""} {
- if {[[$this attrib] isClassFeature]} {
- return
- }
- }
- set param [VBArgument new [[$this ooplType] generate]]
- set param2 ""
-
- if {[$this initializer] != ""} {
- if {[[$this initializer] isA OPQualInitializer]} {
- return
- }
- if {[[$this initializer] isA OPAssocInitializer]} {
- if {[[[[$this initializer] assoc] ooplType] ooplClass] != ""} {
- if {[[[[[$this initializer] assoc] ooplType] ooplClass] baseType] == "NodeControl" ||
- [[[[[$this initializer] assoc] ooplType] ooplClass] baseType] == "LeafControl"} {
- return
- }
- }
- if {[[[$this initializer] assoc] opposite] != ""} {
- if {[[[$this initializer] assoc] isMandatory] &&
- [[[$this initializer] assoc] getMultiplicity] == "one" &&
- [[[[$this initializer] assoc] opposite] isQualified]} {
- set type [VBType new]
- $type name [[[[[[$this initializer] assoc] opposite] qualifier] ooplType] getType3GL]
- set param2 [VBArgument new $type]
- $param2 name "a_[$this getName]_[[[[[$this initializer] assoc] opposite] qualifier] getName]"
- }
- }
- $param name "a_[$this getName]"
- } else {
- $param name [$this getName]
- }
- } else {
- $param name [$this getName]
- }
-
- $param passedBy [$this getPropertyValue "pass_by"]
-
- if {[$this getPropertyValue "optional"] != ""} {
- $param optional [$this getPropertyValue "optional"]
- }
-
- $method addArg $param
-
- if {$param2 != ""} {
- $method addArg $param2
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGCtorParameterD : {VBGCtorParameter OPCtorParameter} {
- }
-
- selfPromoter OPCtorParameter {this} {
- VBGCtorParameterD promote $this
- }
-
- # File: @(#)vbgoperpar.tcl /main/hindenburg/5
-
-
- Class VBGOperParameter : {VBGParameter} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGOperParameter {class this name} {
- set this [VBGParameter::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGOperParameter::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGOperParameter::generate {this method} {
- set param [VBArgument new [[$this ooplType] generate]]
- $param name [$this getName]
- $param passedBy [$this getPropertyValue "pass_by"]
-
- if {[$this getPropertyValue "optional"] != ""} {
- $param optional [$this getPropertyValue "optional"]
- }
-
- $method addArg $param
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGOperParameterD : {VBGOperParameter OPOperParameter} {
- }
-
- selfPromoter OPOperParameter {this} {
- VBGOperParameterD promote $this
- }
-
- # File: @(#)vbgbasetyp.tcl /main/hindenburg/3
-
-
- Class VBGBaseType : {VBGType} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGBaseType {class this name} {
- set this [VBGType::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGBaseType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGBaseType::generate {this} {
- set type [VBType new]
- $type name [$this getType3GL]
- return $type
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGBaseTypeD : {VBGBaseType OPBaseType} {
- }
-
- selfPromoter OPBaseType {this} {
- VBGBaseTypeD promote $this
- }
-
- # File: @(#)vbgclassty.tcl /main/hindenburg/5
-
-
- Class VBGClassType : {VBGType} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGClassType {class this name} {
- set this [VBGType::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGClassType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGClassType::generate {this} {
- set type [VBType new]
- if {[$this ooplClass] != ""} {
- set name [[$this ooplClass] getName]
- } else {
- set name ""
- }
- $type name $name
- return $type
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGClassTypeD : {VBGClassType OPClassType} {
- }
-
- selfPromoter OPClassType {this} {
- VBGClassTypeD promote $this
- }
-
- # File: @(#)vbgenumtyp.tcl /main/hindenburg/6
-
-
- Class VBGEnumType : {VBGType} {
- constructor
- method destructor
- method generate
- }
-
- constructor VBGEnumType {class this name} {
- set this [VBGType::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGEnumType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGEnumType::generate {this} {
- set type [VBType new]
- if {[$this ooplClass] != ""} {
- set name [[$this ooplClass] getName]
- } else {
- set name ""
- }
- $type name $name
- return $type
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGEnumTypeD : {VBGEnumType OPEnumType} {
- }
-
- selfPromoter OPEnumType {this} {
- VBGEnumTypeD promote $this
- }
-
- # File: @(#)vbgassocma.tcl /main/hindenburg/15
-
-
- Class VBGAssocMany : {VBGAssocGen} {
- constructor
- method destructor
- method hasAdd
- method hasDtor
- method hasRemove
- method generate
- method generateGet
- method generateAdd
- method generateRemove
- method generateDtor
- }
-
- constructor VBGAssocMany {class this assocattr} {
- set this [VBGAssocGen::constructor $class $this $assocattr]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGAssocMany::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this VBGAssocGen::destructor
- }
-
- method VBGAssocMany::hasAdd {this self} {
- set wr [$this hasWrite]
- if {$self} {
- if {$wr == "None"} {
- return 0
- }
- } else {
- if {$wr == "None" || $wr == "Private"} {
- return 0
- }
- }
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] isQualified]} {
- m4_warning $W_NOSET [[$this assocattr] getName]
- return 0
- }
- }
- return 1
- }
-
- method VBGAssocMany::hasDtor {this self} {
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
- return 0
- }
- if {[[[$this assocattr] opposite] isQualified]} {
- m4_warning $W_NODTOR [[$this assocattr] getName]
- return 0
- }
- }
- return 1
- }
-
- method VBGAssocMany::hasRemove {this self} {
- set wr [$this hasWrite]
- if {$self} {
- if {$wr == "None"} {
- return 0
- }
- } else {
- if {$wr == "None" || $wr == "Private"} {
- return 0
- }
- }
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
- return 0
- }
- if {[[[$this assocattr] opposite] isQualified]} {
- m4_warning $W_NOREMOVE [[$this assocattr] getName]
- return 0
- }
- }
- return 1
- }
-
- method VBGAssocMany::generate {this cl} {
- set type [VBType new]
- $type name "New ClassSet"
- set vari [VBVariable new $type]
- $vari name "[[$this assocattr] getName]_"
- $cl addAssocvar $vari
- $vari access "Private"
- if {[[$this assocattr] opposite] != ""} {
- [[$this assocattr] opposite] setGenerator
- }
- $this generateGet $vari
- $this generateAdd $vari
- $this generateRemove $vari
- $this generateDtor $cl
- }
-
- method VBGAssocMany::generateGet {this vari} {
- if {![$this hasGet 0]} {
- $vari access "Public"
- }
- if {![$this hasGet 1]} {
- return
- }
- set type [VBType new]
- $type name "ClassSet"
- set getproc [VBGetProperty new $type]
- set getcode [TextSection new]
- $getproc gencode $getcode
- $getproc hasUserSection 0
- $getproc access [$this hasRead]
- $getproc name [[$this assocattr] getName]
- $getcode append "Set "
- $getcode append "[[$this assocattr] getName] = "
- $getcode append "[[$this assocattr] getName]_\n"
- $vari addProc $getproc
- }
-
- method VBGAssocMany::generateAdd {this vari} {
- if {![$this hasAdd 0]} {
- $vari access "Public"
- }
- if {![$this hasAdd 1]} {
- return
- }
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set arg [VBArgument new $type]
- $arg name "x"
- set addsub [VBSub new]
- $addsub addArg $arg
- set addcode [TextSection new]
-
- $addsub gencode $addcode
- $addsub hasUserSection 0
- $addsub access [$this hasWrite]
- $addsub name "Add[cap [[$this assocattr] getName]]"
-
- $addcode append "If Not([$vari name].Contains(x)) Then\n"
- $addcode indent +
- $addcode append "[$vari name].Add x\n"
-
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- if {[[[[$this assocattr] opposite] generator] hasAdd 0]} {
- $addcode append "x.Add[cap [[[$this assocattr] opposite] getName]] Me\n"
- } else {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.Add Me\n"
- }
- } else {
- if {[[[[$this assocattr] opposite] generator] hasSet 0]} {
- $addcode append "Set x.[[[$this assocattr] opposite] getName] = Me\n"
- } else {
- $addcode append "If Not(x.[[[$this assocattr] opposite] getName]_ Is Nothing) Then\n"
- $addcode indent +
- if {[$this hasRemove 1]} {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.Remove[cap [[$this assocattr] getName]] x\n"
- } else {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.[[$this assocattr] getName]_.Remove x\n"
- if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
- $addcode append "x.Remove[cap [[[$this assocattr] opposite] getName]]\n"
- } else {
- $addcode append "Set x.[[[$this assocattr] opposite] getName]_ = Nothing\n"
- }
- }
- $addcode indent -
- $addcode append "End If\n"
- $addcode append "Set x.[[[$this assocattr] opposite] getName]_ = Me\n"
- }
- }
- }
- $addcode indent -
- $addcode append "End If\n"
-
- $vari addProc $addsub
- }
-
- method VBGAssocMany::generateRemove {this vari} {
- if {![$this hasRemove 0]} {
- $vari access "Public"
- }
- if {![$this hasRemove 1]} {
- return
- }
- set removesub [VBSub new]
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set arg [VBArgument new $type]
- $arg name "x"
- $removesub addArg $arg
- set removecode [TextSection new]
- $removesub gencode $removecode
- $removesub hasUserSection 0
- $removesub access [$this hasWrite]
- $removesub name "Remove[cap [[$this assocattr] getName]]"
-
- if {[[$this assocattr] opposite] != ""} {
- $removecode append "If [$vari name].Contains(x) Then\n"
- $removecode indent +
- $removecode append "[$vari name].Remove x\n"
-
- if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
- $removecode append "x.Remove[cap [[[$this assocattr] opposite] getName]]"
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $removecode append " Me"
- }
- } else {
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $removecode append "x.[[[$this assocattr] opposite] getName]_.Remove Me"
- } else {
- $removecode append "Set x.[[[$this assocattr] opposite] getName]_ = Nothing"
- }
- }
-
- $removecode append "\n"
- $removecode indent -
- $removecode append "End If\n"
- } else {
- $removecode append "[$vari name].Remove x\n"
- }
- $vari addProc $removesub
- }
-
- method VBGAssocMany::generateDtor {this cl} {
- if {![$this hasDtor 1]} {
- return
- }
- if {[[$this assocattr] opposite] != ""} {
- [[$cl terminate] gencode] append "While [[$this assocattr] getName]_.Count > 0\n"
- [[$cl terminate] gencode] indent +
-
- if {[$this hasRemove 1]} {
- [[$cl terminate] gencode] append "Remove[cap [[$this assocattr] getName]] [[$this assocattr] getName]_.item(1)\n"
- } else {
- [[$cl terminate] gencode] append "Dim temp As [[[[$this assocattr] ooplType] ooplClass] getName]\n"
- [[$cl terminate] gencode] append "Set temp = [[$this assocattr] getName]_.item(1)\n"
- [[$cl terminate] gencode] append "[[$this assocattr] getName]_.Remove temp\n"
- if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
- [[$cl terminate] gencode] append "temp.Remove[cap [[[$this assocattr] opposite] getName]]"
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- [[$cl terminate] gencode] append " Me"
- }
- } else {
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- [[$cl terminate] gencode] append "temp.[[[$this assocattr] opposite] getName]_.Remove Me"
- } else {
- [[$cl terminate] gencode] append "Set temp.[[[$this assocattr] opposite] getName]_ = Nothing"
- }
- }
- [[$cl terminate] gencode] append "\n"
- }
- [[$cl terminate] gencode] indent -
- [[$cl terminate] gencode] append "Wend\n"
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)vbgassocon.tcl /main/hindenburg/14
-
-
- Class VBGAssocOne : {VBGAssocGen} {
- constructor
- method destructor
- method hasSet
- method hasDtor
- method hasRemove
- method generate
- method generateSet
- method generateGet
- method generateRemove
- method generateDtor
- }
-
- constructor VBGAssocOne {class this assocattr} {
- set this [VBGAssocGen::constructor $class $this $assocattr]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGAssocOne::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this VBGAssocGen::destructor
- }
-
- method VBGAssocOne::hasSet {this self} {
- set wr [$this hasWrite]
- if {$self} {
- if {$wr == "None"} {
- return 0
- }
- } else {
- if {$wr == "None" || $wr == "Private"} {
- return 0
- }
- }
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
- return 0
- }
- if {[[[$this assocattr] opposite] isQualified]} {
- m4_warning $W_NOADD [[$this assocattr] getName]
- return 0
- }
- }
- return 1
- }
-
- method VBGAssocOne::hasDtor {this self} {
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
- return 0
- }
- if {[[[$this assocattr] opposite] isQualified]} {
- m4_warning $W_NODTOR [[$this assocattr] getName]
- return 0
- }
- }
- return 1
- }
-
- method VBGAssocOne::hasRemove {this self} {
- set wr [$this hasWrite]
- if {$self} {
- if {$wr == "None"} {
- return 0
- }
- } else {
- if {$wr == "None" || $wr == "Private"} {
- return 0
- }
- }
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
- return 0
- }
- if {[[[$this assocattr] opposite] isQualified]} {
- m4_warning $W_NOREMOVE [[$this assocattr] getName]
- return 0
- }
- }
- if {[[$this assocattr] isMandatory]} {
- return 0
- }
- return 1
- }
-
- method VBGAssocOne::generate {this cl} {
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set vari [VBVariable new $type]
- $vari name "[[$this assocattr] getName]_"
- $cl addAssocvar $vari
- $vari access "Private"
- if {[[$this assocattr] opposite] != ""} {
- [[$this assocattr] opposite] setGenerator
- }
- $this generateGet $vari
- $this generateSet $vari
- $this generateRemove $vari
- $this generateDtor $cl
- }
-
- method VBGAssocOne::generateSet {this vari} {
- if {![$this hasSet 0]} {
- $vari access "Public"
- }
- if {![$this hasSet 1]} {
- return
- }
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set arg [VBArgument new $type]
- $arg name "x"
- set setproc [VBSetProperty new]
- $setproc addArg $arg
- set setcode [TextSection new]
-
- $setproc gencode $setcode
- $setproc hasUserSection 0
- $setproc access [$this hasWrite]
- $setproc name [[$this assocattr] getName]
- if {[[$this assocattr] opposite] != ""} {
- $setcode append "If Not(x Is Nothing) Then\n"
- $setcode indent +
-
- if {[[$this assocattr] isMandatory]} {
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- if {[[[[$this assocattr] opposite] generator] hasGet 0]} {
- $setcode append "If x.[[[$this assocattr] opposite] getName] Is Nothing Then\n"
- } else {
- $setcode append "If x.[[[$this assocattr] opposite] getName]_ Is Nothing Then\n"
- }
- $setcode indent +
- $setcode append "Set [$vari name].[[[$this assocattr] opposite] getName]_ = Nothing\n"
- } else {
- $setcode append "If Not(x Is [$vari name]) Then\n"
- $setcode indent +
- $setcode append "If Not([$vari name] Is Nothing) Then\n"
- $setcode indent +
- $setcode append "[$vari name].[[[$this assocattr] opposite] getName]_.Remove Me\n"
- $setcode indent -
- $setcode append "End If\n"
- }
- } else {
- $setcode append "If Not(x Is [$vari name]) Then\n"
- $setcode indent +
- $setcode append "If Not([$vari name] Is Nothing) Then\n"
- $setcode indent +
- if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
- $setcode append "[$vari name].Remove[cap [[[$this assocattr] opposite] getName]]"
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $setcode append " Me"
- }
- } else {
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $setcode append "[$vari name].[[[$this assocattr] opposite] getName]_.Remove Me"
- } else {
- $setcode append "Set [$vari name].[[[$this assocattr] opposite] getName]_ = Nothing"
- }
- }
- $setcode append "\n"
- $setcode indent -
- $setcode append "End If\n"
- }
-
- $setcode append "Set [$vari name] = x\n"
-
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- if {[[[[$this assocattr] opposite] generator] hasAdd 0]} {
- $setcode append "x.Add[cap [[[$this assocattr] opposite] getName]] Me\n"
- } else {
- $setcode append "x.[[[$this assocattr] opposite] getName]_.Add Me\n"
- }
- } else {
- if {[[[[$this assocattr] opposite] generator] hasSet 0]} {
- $setcode append "Set x.[[[$this assocattr] opposite] getName] = Me\n"
- } else {
- $setcode append "Set x.[[[$this assocattr] opposite] getName]_ = Me\n"
- }
- }
- $setcode indent -
- $setcode append "End If\n"
-
- if {[$this hasRemove 1]} {
- $setcode indent -
- $setcode append "Else\n"
- $setcode indent +
- $setcode append "Remove[cap [[$this assocattr] getName]]\n"
- }
- $setcode indent -
- $setcode append "End If\n"
- } else {
- if {[[$this assocattr] isMandatory]} {
- $setcode append "If Not(x Is Nothing) Then\n"
- $setcode indent +
- $setcode append "Set [$vari name] = x\n"
- $setcode indent -
- $setcode append "End If\n"
- } else {
- $setcode append "Set [$vari name] = x\n"
- }
- }
- $vari addProc $setproc
- }
-
- method VBGAssocOne::generateGet {this vari} {
- if {![$this hasGet 0]} {
- $vari access "Public"
- }
- if {![$this hasGet 1]} {
- return
- }
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set getproc [VBGetProperty new $type]
- set getcode [TextSection new]
- $getproc gencode $getcode
- $getproc hasUserSection 0
- $getproc access [$this hasRead]
- $getproc name [[$this assocattr] getName]
- $getcode append "Set "
- $getcode append "[[$this assocattr] getName] = "
- $getcode append "[[$this assocattr] getName]_\n"
- $vari addProc $getproc
- }
-
- method VBGAssocOne::generateRemove {this vari} {
- if {![$this hasRemove 0]} {
- $vari access "Public"
- }
- if {![$this hasRemove 1]} {
- return
- }
- set removesub [VBSub new]
- set removecode [TextSection new]
- $removesub gencode $removecode
- $removesub hasUserSection 0
- $removesub access [$this hasWrite]
- $removesub name "Remove[cap [[$this assocattr] getName]]"
- if {[[$this assocattr] opposite] != ""} {
- $removecode append "If Not([$vari name] Is Nothing) Then\n"
- $removecode indent +
- $removecode append "Dim temp As [[$vari type] name]\n"
- $removecode append "Set temp = [$vari name]\n"
- $removecode append "Set [$vari name] = Nothing\n"
- if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
- $removecode append "temp.Remove[cap [[[$this assocattr] opposite] getName]]"
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $removecode append " Me"
- }
- } else {
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $removecode append "temp.[[[$this assocattr] opposite] getName]_.Remove Me"
- } else {
- $removecode append "Set temp.[[[$this assocattr] opposite] getName]_ = Nothing"
- }
- }
- $removecode append "\n"
- $removecode indent -
- $removecode append "End If\n"
- } else {
- $removecode append "Set [$vari name] = Nothing\n"
- }
- $vari addProc $removesub
- }
-
- method VBGAssocOne::generateDtor {this cl} {
- if {![$this hasDtor 1]} {
- return
- }
- if {[[$this assocattr] opposite] != ""} {
- if {[$this hasRemove 1]} {
- [[$cl terminate] gencode] append "Remove[cap [[$this assocattr] getName]]\n"
- } else {
- [[$cl terminate] gencode] append "If Not([[$this assocattr] getName]_ Is Nothing) Then\n"
- [[$cl terminate] gencode] indent +
- if {[[[[$this assocattr] opposite] generator] hasRemove 0]} {
- [[$cl terminate] gencode] append "[[$this assocattr] getName]_.Remove[cap [[[$this assocattr] opposite] getName]]"
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- [[$cl terminate] gencode] append " Me"
- }
- } else {
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- [[$cl terminate] gencode] append "[[$this assocattr] getName]_.[[[$this assocattr] opposite] getName]_.Remove Me"
- } else {
- [[$cl terminate] gencode] append "Set [[$this assocattr] getName]_.[[[$this assocattr] opposite] getName]_ = Nothing"
- }
- }
- [[$cl terminate] gencode] append "\n"
- [[$cl terminate] gencode] indent -
- [[$cl terminate] gencode] append "End If\n"
- }
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)vbgqual.tcl /main/hindenburg/2
-
-
- Class VBGQual : {VBGAssocGen} {
- constructor
- method destructor
- method hasAdd
- method hasDtor
- method hasRemove
- }
-
- constructor VBGQual {class this assocattr} {
- set this [VBGAssocGen::constructor $class $this $assocattr]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGQual::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this VBGAssocGen::destructor
- }
-
- method VBGQual::hasAdd {this self} {
- set wr [$this hasWrite]
- if {$self} {
- if {$wr == "None"} {
- return 0
- }
- } else {
- if {$wr == "None" || $wr == "Private"} {
- return 0
- }
- }
- return 1
- }
-
- method VBGQual::hasDtor {this self} {
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
- return 0
- }
- }
- return 1
- }
-
- method VBGQual::hasRemove {this self} {
- set wr [$this hasWrite]
- if {$self} {
- } else {
- if {$wr == "None" || $wr == "Private"} {
- return 0
- }
- }
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] isMandatory] && [[[$this assocattr] opposite] getMultiplicity] == "one"} {
- return 0
- }
- }
- return 1
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)vbgdataatt.tcl /main/hindenburg/9
-
-
- Class VBGDataAttr : {VBGAttribute} {
- constructor
- method destructor
- method generateSetDefault
- method generateAccesProcs
- method generate
- }
-
- constructor VBGDataAttr {class this name} {
- set this [VBGAttribute::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGDataAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGDataAttr::generateSetDefault {this proc} {
- if {[$this getInitialValue] != ""} {
- if {[$this isClassFeature]} {
- m4_warning $W_NODEFAULT [$this getName] [[$this ooplClass] getName]
- } else {
- if {[[$this ooplType] get_obj_type] == "class_type" ||
- [[$this ooplType] getType3GL] == "Object"} {
- [$proc gencode] append "Set "
- }
-
- [$proc gencode] append [$this getName]
- [$proc gencode] append " = "
- [$proc gencode] append [$this getInitialValue]
- [$proc gencode] append "\n"
- }
- }
- }
-
- method VBGDataAttr::generateAccesProcs {this var} {
- set accessTxt [$this getPropertyValue "attrib_access"]
- set accessList [split $accessTxt -]
- set readAccess [lindex $accessList 0]
- if {$readAccess == ""} {
- set readAccess "Public"
- }
- set writeAccess [lindex $accessList 1]
- if {$writeAccess == ""} {
- set writeAccess "Public"
- }
-
- set getproc [VBGetProperty new [[$this ooplType] generate]]
- set getcode [TextSection new]
- $getproc gencode $getcode
- $getproc hasUserSection 0
- $getproc access $readAccess
- $getproc name [$this getName]
- $getproc refName [$var refName]
-
- set setcode [TextSection new]
-
- if {[[$this ooplType] get_obj_type] == "class_type" ||
- [[$this ooplType] getType3GL] == "Object"} {
- $setcode append "Set "
- $getcode append "Set "
- set setproc [VBSetProperty new]
- } else {
- set setproc [VBLetProperty new]
- }
-
- set arg [VBArgument new [[$this ooplType] generate]]
- $arg name "x"
- $setproc addArg $arg
- $setproc gencode $setcode
- $setproc hasUserSection 0
- $setproc access $writeAccess
- $setproc name [$this getName]
- $setproc refName [$var refName]
-
- if {[$setproc refName] != ""} {
- $setcode append "[$setproc refName]_"
- }
- $setcode append "[$var name] = x\n"
-
- if {[$getproc refName] != ""} {
- set addin "[$getproc refName]_[$this getName]"
- } else {
- set addin "[$this getName]"
- }
-
- $getcode append "$addin = "
- $getcode append "${addin}_\n"
-
- $var addProc $getproc
- $var addProc $setproc
- }
-
- method VBGDataAttr::generate {this cl} {
- if {[[$this ooplClass] baseType] == "NodeControl" || [[$this ooplClass] baseType] == "LeafControl"} {
- m4_error $E_CONTHASNOAT [[$this ooplClass] getName]
- return
- }
-
- if {[[$this ooplType] getType3GL] == "enum"} {
- if {![[$this ooplClass] isEnumClass]} {
- m4_error $E_NOENUM [[$this ooplClass] getName]
- return
- } else {
- set enum [VBEnumConstant new $cl]
- $enum name [$this getName]
-
- set comment [VBComment new]
- $enum comment $comment
- $comment comment [$this getPropertyValue "freeText"]
-
- if {[$this getPropertyValue "initial_value"] != ""} {
- $enum value [$this getPropertyValue "initial_value"]
- $enum hasValue 1
- }
- }
- } else {
- set variable [VBVariable new [[$this ooplType] generate]]
- $variable name "[$this getName]_"
-
- if {![$this isClassFeature]} {
- $variable defaultValue [$this getInitialValue]
- }
-
- set comment [VBComment new]
- $variable comment $comment
- $comment comment [$this getPropertyValue "freeText"]
-
- if {[$this isClassFeature]} {
- $variable access "Public"
- $variable refName [$cl name]
- $cl addGlobvar $variable
- } else {
- $variable access "Private"
- $cl addUservar $variable
- }
-
-
- $this generateAccesProcs $variable
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGDataAttrD : {VBGDataAttr OPDataAttr} {
- }
-
- selfPromoter OPDataAttr {this} {
- VBGDataAttrD promote $this
- }
-
- # File: @(#)vbggenasso.tcl /main/hindenburg/12
-
-
- Class VBGGenAssocAttr : {VBGAttribute} {
- constructor
- method destructor
- method getName
- method hasContainer
- method generateContainer
- method generator
- attribute _generator
- }
-
- constructor VBGGenAssocAttr {class this name} {
- set this [VBGAttribute::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGGenAssocAttr::destructor {this} {
- set ref [$this _generator]
- if {$ref != ""} {
- $ref _assocattr ""
- }
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGGenAssocAttr::getName {this} {
- if {[$this isLinkAttr]} {
- if {[$this opposite] != ""} {
- return "[uncap [[[$this opposite] ooplClass] getName]]of[$this OPGenAssocAttr::getName]"
- }
- }
- return [$this OPGenAssocAttr::getName]
- }
-
- method VBGGenAssocAttr::hasContainer {this} {
- set baseType [[[$this ooplType] ooplClass] baseType]
-
- if {$baseType == "NodeControl" || $baseType == "LeafControl"} {
- return 1
- } else {
- return 0
- }
- }
-
- method VBGGenAssocAttr::generateContainer {this cl} {
- if {[[$this ooplClass] baseType] == "Window" || [[$this ooplClass] baseType] == "NodeControl"} {
- set number [$this getConstraint]
- if {$number != ""} {
- if {![regexp {^[0123456789]*} $number]} {
- set number ""
- m4_warning $W_INCORCONTAR [$this getName] [[$this ooplClass] getName]
- }
- }
- [[$this ooplType] ooplClass] generateContainer [$this getName] $number $cl
- } else {
- m4_error $E_CANTCONTCONT [[$this ooplClass] getName]
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGGenAssocAttrD : {VBGGenAssocAttr OPGenAssocAttr} {
- }
-
- selfPromoter OPGenAssocAttr {this} {
- VBGGenAssocAttrD promote $this
- }
- method VBGGenAssocAttr::generator {this args} {
- if {$args == ""} {
- return [$this _generator]
- }
- set ref [$this _generator]
- if {$ref != ""} {
- $ref _assocattr ""
- }
- set obj [lindex $args 0]
- if {$obj != ""} {
- $obj _assocattr $this
- }
- $this _generator $obj
- }
-
-
- # File: @(#)vbgtypedef.tcl /main/hindenburg/4
-
-
- Class VBGTypeDefType : {VBGClassType} {
- constructor
- method destructor
- }
-
- constructor VBGTypeDefType {class this name} {
- set this [VBGClassType::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGTypeDefType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGTypeDefTypeD : {VBGTypeDefType OPTypeDefType} {
- }
-
- selfPromoter OPTypeDefType {this} {
- VBGTypeDefTypeD promote $this
- }
-
-
- # File: @(#)vbgmanyqua.tcl /main/hindenburg/15
-
-
- Class VBGManyQual : {VBGQual} {
- constructor
- method destructor
- method generate
- method generateAdd
- method generateGet
- method generateRemove
- method generateDtor
- }
-
- constructor VBGManyQual {class this assocattr} {
- set this [VBGQual::constructor $class $this $assocattr]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGManyQual::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this VBGQual::destructor
- }
-
- method VBGManyQual::generate {this cl} {
- set type [VBType new]
- $type name "New ClassSet"
- set vari [VBVariable new $type]
- $vari name "[[$this assocattr] getName]_"
- $cl addAssocvar $vari
- $vari access "Private"
- if {[[$this assocattr] opposite] != ""} {
- [[$this assocattr] opposite] setGenerator
- }
- $this generateGet $vari
- $this generateAdd $vari
- $this generateRemove $vari
- $this generateDtor $cl
- }
-
- method VBGManyQual::generateAdd {this vari} {
- if {![$this hasAdd 0]} {
- $vari access "Public"
- }
- if {![$this hasAdd 1]} {
- return
- }
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set arg [VBArgument new $type]
- $arg name "x"
- set addsub [VBSub new]
- $addsub addArg $arg
- set type [VBType new]
- $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
- set arg [VBArgument new $type]
- $arg name [[[$this assocattr] qualifier] getName]
- $addsub addArg $arg
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- set type [VBType new]
- $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
- set arg [VBArgument new $type]
- $arg name "old_[[[$this assocattr] qualifier] getName]"
- $arg optional 1
- $addsub addArg $arg
- }
- }
- set addcode [TextSection new]
-
- $addsub gencode $addcode
- $addsub hasUserSection 0
- $addsub access [$this hasWrite]
- $addsub name "Add[cap [[$this assocattr] getName]]"
-
- $addcode append "Dim tempSet As ClassSet\n"
-
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- $addcode append "If IsMissing(old_[[[$this assocattr] qualifier] getName]) Then\n"
- $addcode indent +
- $addcode append "If Not(x.[[[$this assocattr] opposite] getName]_ Is Nothing) Then\n"
- $addcode indent +
- if {[[[$this assocattr] opposite] isMandatory]} {
- $addcode append "Set tempSet = x.[[[$this assocattr] opposite] getName]_.[[$this assocattr] getName]_.Item(CStr([[[$this assocattr] qualifier] getName]))\n"
- } else {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.Remove[cap [[$this assocattr] getName]] [[[$this assocattr] qualifier] getName], x\n"
- }
- $addcode indent -
- $addcode append "End If\n"
- $addcode indent -
- $addcode append "Else\n"
- $addcode indent +
- $addcode append "If Not(x.[[[$this assocattr] opposite] getName]_ Is Nothing) Then\n"
- $addcode indent +
- if {[[[$this assocattr] opposite] isMandatory]} {
- $addcode append "Set tempSet = x.[[[$this assocattr] opposite] getName]_.[[$this assocattr] getName]_.Item(CStr(old_[[[$this assocattr] qualifier] getName]))\n"
- } else {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.Remove[cap [[$this assocattr] getName]] old_[[[$this assocattr] qualifier] getName], x\n"
- }
- $addcode indent -
- $addcode append "End If\n"
- $addcode indent -
- $addcode append "End If\n"
- if {[[[$this assocattr] opposite] isMandatory]} {
- $addcode append "tempSet.Remove x\n"
- }
- }
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.Add Me\n"
- } else {
- $addcode append "Set x.[[[$this assocattr] opposite] getName]_ = Me\n"
- }
- }
- $addcode append "If [$vari name].ContainsKey(CStr([[[$this assocattr] qualifier] getName])) Then\n"
- $addcode indent +
- $addcode append "Set tempSet = [$vari name].Item(CStr([[[$this assocattr] qualifier] getName]))\n"
- $addcode indent -
- $addcode append "Else\n"
- $addcode indent +
- $addcode append "Set tempSet = New ClassSet\n"
- $addcode append "[$vari name].Add tempSet, CStr([[[$this assocattr] qualifier] getName])\n"
- $addcode indent -
- $addcode append "End If\n"
- $addcode append "tempSet.Add x\n"
-
- $vari addProc $addsub
- }
-
- method VBGManyQual::generateGet {this vari} {
- if {![$this hasGet 0]} {
- $vari access "Public"
- }
- if {![$this hasGet 1]} {
- return
- }
- set type [VBType new]
- $type name "ClassSet"
- set getproc [VBGetProperty new $type]
- set getcode [TextSection new]
- $getproc gencode $getcode
- $getproc hasUserSection 0
- $getproc access [$this hasRead]
- $getproc name [[$this assocattr] getName]
- $getcode append "Set "
- $getcode append "[[$this assocattr] getName] = "
- $getcode append "[[$this assocattr] getName]_.Item(CStr([[[$this assocattr] qualifier] getName]))\n"
- set type [VBType new]
- $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
- set arg [VBArgument new $type]
- $arg name [[[$this assocattr] qualifier] getName]
- $getproc addArg $arg
- $vari addProc $getproc
- }
-
- method VBGManyQual::generateRemove {this vari} {
- if {![$this hasRemove 0]} {
- $vari access "Public"
- }
- if {![$this hasRemove 1]} {
- return
- }
- set removesub [VBSub new]
- set type [VBType new]
- $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
- set arg [VBArgument new $type]
- $arg name [[[$this assocattr] qualifier] getName]
- $removesub addArg $arg
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set arg [VBArgument new $type]
- $arg name "x"
- $arg optional 1
-
- $removesub addArg $arg
- set removecode [TextSection new]
- $removesub gencode $removecode
- $removesub hasUserSection 0
- $removesub name "Remove[cap [[$this assocattr] getName]]"
-
- if {[$this hasWrite] == "None"} {
- $removesub access "Private"
- m4_warning $W_CHANGEDREM [[$this assocattr] getName]
- } else {
- $removesub access [$this hasWrite]
- }
-
- $removecode append "Dim tempSet As ClassSet\n"
- $removecode append "Set tempSet = [$vari name].Item(CStr([[[$this assocattr] qualifier] getName]))\n"
-
- $removecode append "If IsMissing(x) Then\n"
- $removecode indent +
-
- $removecode append "Dim temp As [[[[$this assocattr] ooplType] ooplClass] getName]\n"
- $removecode append "While tempSet.Count > 0\n"
- $removecode indent +
- $removecode append "Set temp = tempSet.Item(1)\n"
-
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- $removecode append "Set "
- }
- $removecode append "temp.[[[$this assocattr] opposite] getName]_"
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $removecode append ".Remove Me"
- } else {
- $removecode append " = Nothing"
- }
- $removecode append "\n"
- }
-
- $removecode append "tempSet.Remove temp\n"
- $removecode indent -
- $removecode append "Wend\n"
- $removecode append "[$vari name].RemoveUsingKey(CStr([[[$this assocattr] qualifier] getName]))\n"
- $removecode indent -
- $removecode append "Else\n"
- $removecode indent +
-
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- $removecode append "Set "
- }
- $removecode append "temp.[[[$this assocattr] opposite] getName]_"
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $removecode append ".Remove Me"
- } else {
- $removecode append " = Nothing"
- }
- $removecode append "\n"
- }
-
- $removecode append "tempSet.Remove x\n"
-
- $removecode append "If tempSet.Count = 0 Then\n"
- $removecode indent +
- $removecode append "[$vari name].RemoveUsingKey(CStr([[[$this assocattr] qualifier] getName]))\n"
- $removecode indent -
- $removecode append "End If\n"
-
- $removecode indent -
- $removecode append "End If\n"
-
- $vari addProc $removesub
- }
-
- method VBGManyQual::generateDtor {this cl} {
- if {![$this hasDtor 1]} {
- return
- }
- if {[[$this assocattr] opposite] != ""} {
- [[$cl terminate] gencode] append "While [[$this assocattr] getName]_.Count > 0\n"
- [[$cl terminate] gencode] indent +
- [[$cl terminate] gencode] append "Remove[cap [[$this assocattr] getName]] [[$this assocattr] getName]_.key(1)\n"
- [[$cl terminate] gencode] indent -
- [[$cl terminate] gencode] append "Wend\n"
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)vbgonequal.tcl /main/hindenburg/14
-
-
- Class VBGOneQual : {VBGQual} {
- constructor
- method destructor
- method generate
- method generateAdd
- method generateGet
- method generateRemove
- method generateDtor
- }
-
- constructor VBGOneQual {class this assocattr} {
- set this [VBGQual::constructor $class $this $assocattr]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGOneQual::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this VBGQual::destructor
- }
-
- method VBGOneQual::generate {this cl} {
- set type [VBType new]
- $type name "New ClassSet"
- set vari [VBVariable new $type]
- $vari name "[[$this assocattr] getName]_"
- $cl addAssocvar $vari
- $vari access "Private"
- if {[[$this assocattr] opposite] != ""} {
- [[$this assocattr] opposite] setGenerator
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- $vari access "Public"
- }
- }
- $this generateGet $vari
- $this generateAdd $vari
- $this generateRemove $vari
- $this generateDtor $cl
- }
-
- method VBGOneQual::generateAdd {this vari} {
- if {![$this hasAdd 0]} {
- $vari access "Public"
- }
- if {![$this hasAdd 1]} {
- return
- }
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set arg [VBArgument new $type]
- $arg name "x"
- set addsub [VBSub new]
- $addsub addArg $arg
- set type [VBType new]
- $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
- set arg [VBArgument new $type]
- $arg name [[[$this assocattr] qualifier] getName]
- $addsub addArg $arg
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- set type [VBType new]
- $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
- set arg [VBArgument new $type]
- $arg name "old_[[[$this assocattr] qualifier] getName]"
- $arg optional 1
- $addsub addArg $arg
- }
- }
- set addcode [TextSection new]
-
- $addsub gencode $addcode
- $addsub hasUserSection 0
- $addsub access [$this hasWrite]
- $addsub name "Add[cap [[$this assocattr] getName]]"
-
- if {[[$this assocattr] isMandatory]} {
- $addcode append "If Not(x Is Nothing) Then\n"
- $addcode indent +
- }
- if {[[$this assocattr] opposite] != ""} {
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- $addcode append "If IsMissing(old_[[[$this assocattr] qualifier] getName]) Then\n"
- $addcode indent +
- $addcode append "If Not(x.[[[$this assocattr] opposite] getName]_ Is Nothing) Then\n"
- $addcode indent +
- if {[[[$this assocattr] opposite] isMandatory]} {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.[[$this assocattr] getName]_.RemoveUsingKey(CStr([[[$this assocattr] qualifier] getName]))\n"
- } else {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.Remove[cap [[$this assocattr] getName]]([[[$this assocattr] qualifier] getName])\n"
- }
- $addcode indent -
- $addcode append "End If\n"
- $addcode indent -
- $addcode append "Else\n"
- $addcode indent +
- $addcode append "If Not(x.[[[$this assocattr] opposite] getName]_ Is Nothing) Then\n"
- $addcode indent +
- if {[[[$this assocattr] opposite] isMandatory]} {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.[[$this assocattr] getName]_.RemoveUsingKey(CStr(old_[[[$this assocattr] qualifier] getName]))\n"
- } else {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.Remove[cap [[$this assocattr] getName]](old_[[[$this assocattr] qualifier] getName])\n"
- }
- $addcode indent -
- $addcode append "End If\n"
- $addcode indent -
- $addcode append "End If\n"
- }
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $addcode append "x.[[[$this assocattr] opposite] getName]_.Add Me\n"
- } else {
- $addcode append "Set x.[[[$this assocattr] opposite] getName]_ = Me\n"
- }
- }
- $addcode append "[$vari name].Add x, CStr([[[$this assocattr] qualifier] getName])\n"
-
- if {[[$this assocattr] isMandatory]} {
- $addcode indent -
- $addcode append "End If\n"
- }
- $vari addProc $addsub
- }
-
- method VBGOneQual::generateGet {this vari} {
- if {![$this hasGet 0]} {
- $vari access "Public"
- }
- if {![$this hasGet 1]} {
- return
- }
- set type [VBType new]
- $type name [[[[$this assocattr] ooplType] ooplClass] getName]
- set getproc [VBGetProperty new $type]
- set getcode [TextSection new]
- $getproc gencode $getcode
- $getproc hasUserSection 0
- $getproc access [$this hasRead]
- $getproc name [[$this assocattr] getName]
- $getcode append "Set "
- $getcode append "[[$this assocattr] getName] = "
- $getcode append "[[$this assocattr] getName]_.Item(CStr([[[$this assocattr] qualifier] getName]))\n"
- set type [VBType new]
- $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
- set arg [VBArgument new $type]
- $arg name [[[$this assocattr] qualifier] getName]
- $getproc addArg $arg
- $vari addProc $getproc
- }
-
- method VBGOneQual::generateRemove {this vari} {
- if {![$this hasRemove 0]} {
- $vari access "Public"
- }
- if {![$this hasRemove 1]} {
- return
- }
- set removesub [VBSub new]
- set type [VBType new]
- $type name [[[[$this assocattr] qualifier] ooplType] getType3GL]
- set arg [VBArgument new $type]
- $arg name [[[$this assocattr] qualifier] getName]
- $removesub addArg $arg
- set removecode [TextSection new]
- $removesub gencode $removecode
- $removesub hasUserSection 0
- $removesub name "Remove[cap [[$this assocattr] getName]]"
-
- if {[$this hasWrite] == "None"} {
- $removesub access "Private"
- m4_warning $W_CHANGEDREM [[$this assocattr] getName]
- } else {
- $removesub access [$this hasWrite]
- }
-
- $removecode append "Dim temp As [[[[$this assocattr] ooplType] ooplClass] getName]\n"
- $removecode append "Set temp = [$vari name].Item(CStr([[[$this assocattr] qualifier] getName]))\n"
-
- if {[[$this assocattr] opposite] != ""} {
- $removecode append "[$vari name].RemoveUsingKey(CStr([[[$this assocattr] qualifier] getName]))\n"
- if {[[[$this assocattr] opposite] getMultiplicity] == "one"} {
- $removecode append "Set "
- }
- $removecode append "temp.[[[$this assocattr] opposite] getName]_"
- if {[[[$this assocattr] opposite] getMultiplicity] != "one"} {
- $removecode append ".Remove Me"
- } else {
- $removecode append " = Nothing"
- }
- $removecode append "\n"
- } else {
- $removecode append "[$vari name].RemoveUsingKey(CStr([[[$this assocattr] qualifier] getName]))\n"
- }
-
- $vari addProc $removesub
- }
-
- method VBGOneQual::generateDtor {this cl} {
- if {![$this hasDtor 1]} {
- return
- }
- if {[[$this assocattr] opposite] != ""} {
- [[$cl terminate] gencode] append "While [[$this assocattr] getName]_.Count > 0\n"
- [[$cl terminate] gencode] indent +
- [[$cl terminate] gencode] append "Remove[cap [[$this assocattr] getName]] [[$this assocattr] getName]_.key(1)\n"
- [[$cl terminate] gencode] indent -
- [[$cl terminate] gencode] append "Wend\n"
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)vbgassocat.tcl /main/hindenburg/8
-
-
- Class VBGAssocAttr : {VBGGenAssocAttr} {
- constructor
- method destructor
- method setGenerator
- method generate
- }
-
- constructor VBGAssocAttr {class this name} {
- set this [VBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGAssocAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGAssocAttr::setGenerator {this} {
- if {[$this generator] == ""} {
- if {[$this getMultiplicity]=="one"} {
- $this generator [VBGAssocOne new $this]
- } else {
- $this generator [VBGAssocMany new $this]
- }
- }
- }
-
- method VBGAssocAttr::generate {this cl} {
- if {[[$this ooplType] isA OPBaseType]} {
- m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
- return
- }
-
- if {[$this hasContainer]} {
- $this generateContainer $cl
- } else {
- $this setGenerator
- [$this generator] generate $cl
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGAssocAttrD : {VBGAssocAttr OPAssocAttr} {
- }
-
- selfPromoter OPAssocAttr {this} {
- VBGAssocAttrD promote $this
- }
-
- # File: @(#)vbglinkatt.tcl /main/hindenburg/7
-
-
- Class VBGLinkAttr : {VBGGenAssocAttr} {
- constructor
- method destructor
- method setGenerator
- method generate
- }
-
- constructor VBGLinkAttr {class this name} {
- set this [VBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGLinkAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGLinkAttr::setGenerator {this} {
- if {[$this generator] == ""} {
- if {[$this getMultiplicity]=="one"} {
- $this generator [VBGAssocOne new $this]
- } else {
- $this generator [VBGAssocMany new $this]
- }
- }
- }
-
- method VBGLinkAttr::generate {this cl} {
- if {[[$this ooplType] isA OPBaseType]} {
- m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
- return
- }
-
- if {[$this hasContainer]} {
- $this generateContainer $cl
- } else {
- $this setGenerator
- [$this generator] generate $cl
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGLinkAttrD : {VBGLinkAttr OPLinkAttr} {
- }
-
- selfPromoter OPLinkAttr {this} {
- VBGLinkAttrD promote $this
- }
-
- # File: @(#)vbgqualass.tcl /main/hindenburg/9
-
-
- Class VBGQualAssocAttr : {VBGGenAssocAttr} {
- constructor
- method destructor
- method setGenerator
- method generate
- }
-
- constructor VBGQualAssocAttr {class this name} {
- set this [VBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGQualAssocAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGQualAssocAttr::setGenerator {this} {
- if {[$this generator] == ""} {
- if {[$this getMultiplicity]=="one"} {
- $this generator [VBGOneQual new $this]
- } else {
- $this generator [VBGManyQual new $this]
- }
- }
- }
-
- method VBGQualAssocAttr::generate {this cl} {
- if {[[$this ooplType] isA OPBaseType]} {
- m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
- return
- }
-
- if {![[[$this qualifier] ooplType] isA OPBaseType]} {
- m4_error $E_QUALTYPEWRONG [[$this qualifier] getName] [$this getName]
- return
- }
- if {[$this hasContainer]} {
- $this generateContainer $cl
- } else {
- $this setGenerator
- [$this generator] generate $cl
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGQualAssocAttrD : {VBGQualAssocAttr OPQualAssocAttr} {
- }
-
- selfPromoter OPQualAssocAttr {this} {
- VBGQualAssocAttrD promote $this
- }
-
- # File: @(#)vbgquallin.tcl /main/hindenburg/10
-
-
- Class VBGQualLinkAttr : {VBGGenAssocAttr} {
- constructor
- method destructor
- method setGenerator
- method generate
- }
-
- constructor VBGQualLinkAttr {class this name} {
- set this [VBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGQualLinkAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGQualLinkAttr::setGenerator {this} {
- if {[$this generator] == ""} {
- if {[$this getMultiplicity]=="one"} {
- $this generator [VBGOneQual new $this]
- } else {
- $this generator [VBGManyQual new $this]
- }
- }
- }
-
- method VBGQualLinkAttr::generate {this cl} {
- if {[[$this ooplType] isA OPBaseType]} {
- m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
- return
- }
-
- if {![[[$this qualifier] ooplType] isA OPBaseType]} {
- m4_error $E_QUALTYPEWRONG [[$this qualifier] getName] [$this getName]
- return
- }
- if {[$this hasContainer]} {
- $this generateContainer $cl
- } else {
- $this setGenerator
- [$this generator] generate $cl
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGQualLinkAttrD : {VBGQualLinkAttr OPQualLinkAttr} {
- }
-
- selfPromoter OPQualLinkAttr {this} {
- VBGQualLinkAttrD promote $this
- }
-
- # File: @(#)vbgreverse.tcl /main/hindenburg/7
-
-
- Class VBGReverseLinkAttr : {VBGGenAssocAttr} {
- constructor
- method destructor
- method setGenerator
- method generate
- }
-
- constructor VBGReverseLinkAttr {class this name} {
- set this [VBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method VBGReverseLinkAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method VBGReverseLinkAttr::setGenerator {this} {
- if {[$this generator] == ""} {
- if {[$this getMultiplicity]=="one"} {
- $this generator [VBGAssocOne new $this]
- } else {
- $this generator [VBGAssocOne new $this]
- }
- }
- }
-
- method VBGReverseLinkAttr::generate {this cl} {
- if {[[$this ooplType] isA OPBaseType]} {
- m4_warning $W_ASSOCTYPEERR [$this getName] [[$this ooplType] getName]
- return
- }
-
- if {[$this hasContainer]} {
- $this generateContainer $cl
- } else {
- $this setGenerator
- [$this generator] generate $cl
- }
-
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class VBGReverseLinkAttrD : {VBGReverseLinkAttr OPReverseLinkAttr} {
- }
-
- selfPromoter OPReverseLinkAttr {this} {
- VBGReverseLinkAttrD promote $this
- }
-