home *** CD-ROM | disk | FTP | other *** search
Text File | 1997-05-30 | 81.1 KB | 3,083 lines |
- #--------------------------------------------------------------------------
- #
- # (c) Cayenne Software Inc. 1997
- #
- # File: %W%
- # Author: <generated>
- #
- #--------------------------------------------------------------------------
-
- # File: @(#)pbgassocin.tcl /main/hindenburg/1
-
-
- Class PBGAssocInitializer : {Object OPAssocInitializer} {
- constructor
- method destructor
- }
-
- constructor PBGAssocInitializer {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGAssocInitializer::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPAssocInitializer {this} {
- PBGAssocInitializer promote $this
- }
-
- # File: @(#)pbgattribi.tcl /main/hindenburg/1
-
-
- Class PBGAttribInitializer : {Object OPAttribInitializer} {
- constructor
- method destructor
- }
-
- constructor PBGAttribInitializer {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGAttribInitializer::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPAttribInitializer {this} {
- PBGAttribInitializer promote $this
- }
-
- # File: @(#)pbgclass.tcl /main/hindenburg/5
-
-
- Class PBGClass : {Object} {
- constructor
- method destructor
- method promoter
- method generate
- method generateAsContainedClass
- method getPBClassKind
- method getSuperClass
- method getBuiltinSuperClass
- method getBuiltinSuperClassName
- method hasEvent
- method isGlobalType
- method isAutoInstantiate
- method getWindowType
- method isBuiltin
- method addContainedTypeName
- method removeContainedTypeName
- attribute pbClassKind
- attribute superClass
- attribute builtinSuperClass
- attribute inhLoopDetect
- attribute containLoopDetect
- attribute containedTypeNameSet
- }
-
- constructor PBGClass {class this name} {
- set this [Object::constructor $class $this $name]
- $this pbClassKind ""
- $this superClass "_uninitialized_"
- $this builtinSuperClass "_uninitialized_"
- $this inhLoopDetect 0
- $this containLoopDetect 0
- $this containedTypeNameSet [List new]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGClass::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGClass::promoter {this} {
- $this pbClassKind ""
- $this superClass "_uninitialized_"
- $this builtinSuperClass "_uninitialized_"
- $this inhLoopDetect 0
- $this containLoopDetect 0
- $this containedTypeNameSet [List new]
- }
-
- method PBGClass::generate {this model} {
- set kind [$this getPBClassKind]
-
- if {$kind == ${PBClassKind::NotSupported}} {
- return ""
- }
-
- set name [$this getName]
- set superNm [[$this getSuperClass] getName]
-
- set pbDefGen [PB${kind}Gen new $name $this \
- -superNm $superNm \
- -isGlobalType 1 \
- -globalOoplClass $this \
- -container "" \
- -model $model]
-
- return [$pbDefGen generate]
- }
-
- method PBGClass::generateAsContainedClass {this name globalOoplClass fromOoplClass container} {
- set kind [$this getPBClassKind]
- if {$kind == ${PBClassKind::NotSupported}} {
- return ""
- }
- if [$this containLoopDetect] {
- m4_error $E_GRCONTLOOP [$this getName]
- return ""
- }
-
- if {[$this isBuiltin] || [$this isGlobalType]} {
- set superNm [$this getName]
- } else {
- set superNm [[$this getSuperClass] getName]
- }
-
- if {$name == $superNm} {
- m4_error $E_INVALIDLOCTYPE $name [$fromOoplClass getName] \
- [$this getName] [$globalOoplClass getName]
- }
- set typeNames [$globalOoplClass containedTypeNameSet]
- if {[$typeNames search $name] != -1 ||
- $name == [$globalOoplClass getName]} {
- m4_error $E_MULTDEFLOCTYPES $name [$fromOoplClass getName] \
- [$this getName] [$globalOoplClass getName]
- } else {
- $typeNames append $name
- }
-
- set pbDefGen [PB${kind}Gen new $name $this \
- -superNm $superNm \
- -isGlobalType 0 \
- -globalOoplClass $globalOoplClass \
- -container $container \
- -model ""]
-
- $this containLoopDetect 1
- set def [$pbDefGen generate]
- $this containLoopDetect 0
-
- return $def
- }
-
- method PBGClass::getPBClassKind {this} {
- if {[$this pbClassKind] != ""} {
- return [$this pbClassKind]
- }
-
- if {[$this getBuiltinSuperClass] == ""} {
- $this pbClassKind ${PBClassKind::NotSupported}
- return [$this pbClassKind]
- }
-
- set superClass [$this getSuperClass]
- if {![$superClass isBuiltin] && ![$superClass isGlobalType]} {
- m4_error $E_NONGLOBALSUPER [$this getName] [$superClass getName]
- $this pbClassKind ${PBClassKind::NotSupported}
- return [$this pbClassKind]
- }
-
- set builtinSuperNm [$this getBuiltinSuperClassName]
- set classInfo [[PBBuiltinInfo::global] getBuiltinClass $builtinSuperNm]
- if {$classInfo == ""} {
- m4_error $E_INVALBUILTINSUPER [$this getName] $builtinSuperNm
- $this pbClassKind ${PBClassKind::NotSupported}
- } else {
- $this pbClassKind [$classInfo kind]
- }
- return [$this pbClassKind]
- }
-
- method PBGClass::getSuperClass {this} {
- if {[$this superClass] != "_uninitialized_"} {
- return [$this superClass]
- }
-
- if {[string tolower [$this getName]] == "powerobject"} {
- # this is THE root class
- $this superClass ""
- return ""
- }
- set genNodeSet [$this genNodeSet]
- if {[llength $genNodeSet] == 0} {
- m4_warning $W_NOSUPERCLASS [$this getName]
- set superClass [[$this ooplModel] classByName "nonvisualobject"]
- $this superClass $superClass
- return $superClass
- }
- if {[llength $genNodeSet] > 1} {
- m4_error $E_NOMULTINH [$this getName]
- }
- $this superClass [[lindex $genNodeSet 0] superClass]
- return [$this superClass]
- }
-
- method PBGClass::getBuiltinSuperClass {this} {
- if {[$this builtinSuperClass] != "_uninitialized_"} {
- return [$this builtinSuperClass]
- }
-
- if [$this inhLoopDetect] {
- # error is already given by ooplModel ...
- #m4_error $E_INHLOOP [$this getName]
- $this builtinSuperClass ""
- return ""
- }
- $this inhLoopDetect 1
- if [$this isBuiltin] {
- $this builtinSuperClass $this
- return $this
- }
-
- set superClass [$this getSuperClass]
- if {$superClass != ""} {
- set builtinSuperClass [$superClass getBuiltinSuperClass]
- $this builtinSuperClass $builtinSuperClass
- return $builtinSuperClass
- }
- $this builtinSuperClass ""
- return ""
- }
-
- method PBGClass::getBuiltinSuperClassName {this} {
- set class [$this getBuiltinSuperClass]
- if {$class == ""} {
- return ""
- }
- return [$class getName]
- }
-
- method PBGClass::hasEvent {this name} {
- set name [string tolower $name]
-
- foreach oper [$this operationSet] {
- if {[$oper isEvent] &&
- [string tolower [$oper getName]] == $name} {
- return 1
- }
- }
- return 0
- }
-
- method PBGClass::isGlobalType {this} {
- if {[$this getPropertyValue is_global_type] == "No"} {
- return 0
- }
- if [$this isBuiltin] {
- # The 'is_global_type' property does not apply to builtin
- # classes, so they do not have the property set to 'No'.
- # They must not be interpreted as global types however.
- return 0
- }
- return 1
- }
-
- method PBGClass::isAutoInstantiate {this} {
- if {[$this getPropertyValue is_autoinstantiate] == "1"} {
- return 1
- }
- return 0
- }
-
- method PBGClass::getWindowType {this} {
- set windowType [$this getPropertyValue window_type]
- if {$windowType == ""} {
- set windowType "Main"
- }
- return $windowType
- }
-
- method PBGClass::isBuiltin {this} {
- if {[$this getPropertyValue is_builtin] == "1"} {
- return 1
- }
- return 0
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGClassD : {PBGClass OPClass} {
- }
-
- selfPromoter OPClass {this} {
- PBGClassD promote $this
- }
- method PBGClass::addContainedTypeName {this newContainedTypeName} {
- [$this containedTypeNameSet] append $newContainedTypeName
-
- }
-
- method PBGClass::removeContainedTypeName {this oldContainedTypeName} {
- [$this containedTypeNameSet] removeValue $oldContainedTypeName
- }
-
-
- # File: @(#)pbgfeature.tcl /main/hindenburg/1
-
-
- Class PBGFeature : {Object} {
- constructor
- method destructor
- }
-
- constructor PBGFeature {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGFeature::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGFeatureD : {PBGFeature OPFeature} {
- }
-
- selfPromoter OPFeature {this} {
- PBGFeatureD promote $this
- }
-
- # File: @(#)pbgparamet.tcl /main/hindenburg/1
-
-
- Class PBGParameter : {Object} {
- constructor
- method destructor
- }
-
- constructor PBGParameter {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGParameter::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGParameterD : {PBGParameter OPParameter} {
- }
-
- selfPromoter OPParameter {this} {
- PBGParameterD promote $this
- }
-
- # File: @(#)pbgqualini.tcl /main/hindenburg/1
-
-
- Class PBGQualInitializer : {Object OPQualInitializer} {
- constructor
- method destructor
- }
-
- constructor PBGQualInitializer {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGQualInitializer::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPQualInitializer {this} {
- PBGQualInitializer promote $this
- }
-
- # File: @(#)pbgsupercl.tcl /main/hindenburg/1
-
-
- Class PBGSuperClassInitializer : {Object OPSuperClassInitializer} {
- constructor
- method destructor
- }
-
- constructor PBGSuperClassInitializer {class this name} {
- set this [Object::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGSuperClassInitializer::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- selfPromoter OPSuperClassInitializer {this} {
- PBGSuperClassInitializer promote $this
- }
-
- # File: @(#)pbgtype.tcl /main/hindenburg/2
-
-
- Class PBGType : {Object} {
- constructor
- method destructor
- attribute arrayDesc
- }
-
- constructor PBGType {class this name} {
- set this [Object::constructor $class $this $name]
- $this arrayDesc ""
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGTypeD : {PBGType OPType} {
- }
-
- selfPromoter OPType {this} {
- PBGTypeD promote $this
- }
-
- # File: @(#)pbbuiltinc.tcl /main/hindenburg/4
-
-
- Class PBBuiltinClass : {GCObject} {
- constructor
- method destructor
- method getMandatoryProp
- method setMandatoryProp
- method removeMandatoryProp
- attribute name
- attribute kind
- attribute isControl
- attribute isGrContainer
- attribute hasCtorDtor
- attribute initialOnCreateResidue
- attribute initialOnDestroyResidue
- attribute mandatoryProp
- }
-
- constructor PBBuiltinClass {class this i_name} {
- set this [GCObject::constructor $class $this]
- $this isControl 0
- $this isGrContainer 0
- $this hasCtorDtor 0
- $this name $i_name
- $this mandatoryProp [Dictionary new]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBBuiltinClass::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- method PBBuiltinClass::getMandatoryProp {this name} {
- return [[$this mandatoryProp] set $name]
- }
-
- method PBBuiltinClass::setMandatoryProp {this name newMandatoryProp} {
- [$this mandatoryProp] set $name $newMandatoryProp
- }
-
- method PBBuiltinClass::removeMandatoryProp {this name} {
- [$this mandatoryProp] unset $name
- }
-
-
- # File: @(#)pbbuiltini.tcl /main/hindenburg/5
- # End user added include file section
-
-
- Class PBBuiltinInfo : {GCObject} {
- constructor
- method destructor
- method getBuiltinClass
- method setBuiltinClass
- method removeBuiltinClass
- attribute builtinClass
- }
-
- global PBBuiltinInfo::instance
- set PBBuiltinInfo::instance ""
-
-
- constructor PBBuiltinInfo {class this} {
- set this [GCObject::constructor $class $this]
- $this builtinClass [Dictionary new]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBBuiltinInfo::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- proc PBBuiltinInfo::global {} {
- if {${PBBuiltinInfo::instance} != ""} {
- return ${PBBuiltinInfo::instance}
- }
-
- set instance [PBBuiltinInfo new]
- set PBBuiltinInfo::instance $instance
-
- # Fill it ...
- #
- set class [PBBuiltinClass new checkbox \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass checkbox $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 77]
- $class setMandatoryProp Text [ \
- PBBuiltinProperty new Text string \"none\"]
-
- set class [PBBuiltinClass new commandbutton \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass commandbutton $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 109]
- $class setMandatoryProp Text [ \
- PBBuiltinProperty new Text string \"none\"]
-
- set class [PBBuiltinClass new connection \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass connection $class
-
- set class [PBBuiltinClass new datastore \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass datastore $class
-
- set class [PBBuiltinClass new datawindow \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass datawindow $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new dropdownlistbox \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass dropdownlistbox $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 229]
-
- set class [PBBuiltinClass new dropdownpicturelistbox \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass dropdownpicturelistbox $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 229]
-
- set class [PBBuiltinClass new dynamicdescriptionarea \
- -kind ${PBClassKind::VSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass dynamicdescriptionarea $class
-
- set class [PBBuiltinClass new dynamicstagingarea \
- -kind ${PBClassKind::VSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass dynamicstagingarea $class
-
- set class [PBBuiltinClass new editmask \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass editmask $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 101]
-
- set class [PBBuiltinClass new error \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass error $class
-
- set class [PBBuiltinClass new graph \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass graph $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 988]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 721]
- $class setMandatoryProp Title [ \
- PBBuiltinProperty new Title string \"(None)\"]
- $class setMandatoryProp GraphType [ \
- PBBuiltinProperty new GraphType grGraphType ColGraph!]
- set sect [TextSection new]
- $class initialOnCreateResidue $sect
- expand_text $sect {
- TitleDispAttr = create grDispAttr
- LegendDispAttr = create grDispAttr
- PieDispAttr = create grDispAttr
- Series = create grAxis
- Series.DispAttr = create grDispAttr
- Series.LabelDispAttr = create grDispAttr
- Category = create grAxis
- Category.DispAttr = create grDispAttr
- Category.LabelDispAttr = create grDispAttr
- Values = create grAxis
- Values.DispAttr = create grDispAttr
- Values.LabelDispAttr = create grDispAttr
- TitleDispAttr.Weight=700
- TitleDispAttr.FaceName="Arial"
- TitleDispAttr.FontFamily=Swiss!
- TitleDispAttr.FontPitch=Variable!
- TitleDispAttr.Alignment=Center!
- TitleDispAttr.BackColor=536870912
- TitleDispAttr.Format="[General]"
- TitleDispAttr.DisplayExpression="title"
- TitleDispAttr.AutoSize=true
- Category.Label="(None)"
- Category.AutoScale=true
- Category.ShadeBackEdge=true
- Category.SecondaryLine=transparent!
- Category.MajorGridLine=transparent!
- Category.MinorGridLine=transparent!
- Category.DropLines=transparent!
- Category.OriginLine=transparent!
- Category.MajorTic=Outside!
- Category.DataType=adtText!
- Category.DispAttr.Weight=400
- Category.DispAttr.FaceName="Arial"
- Category.DispAttr.FontFamily=Swiss!
- Category.DispAttr.FontPitch=Variable!
- Category.DispAttr.Alignment=Center!
- Category.DispAttr.BackColor=536870912
- Category.DispAttr.Format="[General]"
- Category.DispAttr.DisplayExpression="category"
- Category.DispAttr.AutoSize=true
- Category.LabelDispAttr.Weight=400
- Category.LabelDispAttr.FaceName="Arial"
- Category.LabelDispAttr.FontFamily=Swiss!
- Category.LabelDispAttr.FontPitch=Variable!
- Category.LabelDispAttr.Alignment=Center!
- Category.LabelDispAttr.BackColor=536870912
- Category.LabelDispAttr.Format="[General]"
- Category.LabelDispAttr.DisplayExpression="categoryaxislabel"
- Category.LabelDispAttr.AutoSize=true
- Values.Label="(None)"
- Values.AutoScale=true
- Values.SecondaryLine=transparent!
- Values.MajorGridLine=transparent!
- Values.MinorGridLine=transparent!
- Values.DropLines=transparent!
- Values.MajorTic=Outside!
- Values.DataType=adtDouble!
- Values.DispAttr.Weight=400
- Values.DispAttr.FaceName="Arial"
- Values.DispAttr.FontFamily=Swiss!
- Values.DispAttr.FontPitch=Variable!
- Values.DispAttr.Alignment=Right!
- Values.DispAttr.BackColor=536870912
- Values.DispAttr.Format="[General]"
- Values.DispAttr.DisplayExpression="value"
- Values.DispAttr.AutoSize=true
- Values.LabelDispAttr.Weight=400
- Values.LabelDispAttr.FaceName="Arial"
- Values.LabelDispAttr.FontFamily=Swiss!
- Values.LabelDispAttr.FontPitch=Variable!
- Values.LabelDispAttr.Alignment=Center!
- Values.LabelDispAttr.BackColor=536870912
- Values.LabelDispAttr.Format="[General]"
- Values.LabelDispAttr.DisplayExpression="valuesaxislabel"
- Values.LabelDispAttr.AutoSize=true
- Values.LabelDispAttr.Escapement=900
- Series.Label="(None)"
- Series.AutoScale=true
- Series.SecondaryLine=transparent!
- Series.MajorGridLine=transparent!
- Series.MinorGridLine=transparent!
- Series.DropLines=transparent!
- Series.OriginLine=transparent!
- Series.MajorTic=Outside!
- Series.DataType=adtText!
- Series.DispAttr.Weight=400
- Series.DispAttr.FaceName="Arial"
- Series.DispAttr.FontFamily=Swiss!
- Series.DispAttr.FontPitch=Variable!
- Series.DispAttr.BackColor=536870912
- Series.DispAttr.Format="[General]"
- Series.DispAttr.DisplayExpression="series"
- Series.DispAttr.AutoSize=true
- Series.LabelDispAttr.Weight=400
- Series.LabelDispAttr.FaceName="Arial"
- Series.LabelDispAttr.FontFamily=Swiss!
- Series.LabelDispAttr.FontPitch=Variable!
- Series.LabelDispAttr.Alignment=Center!
- Series.LabelDispAttr.BackColor=536870912
- Series.LabelDispAttr.Format="[General]"
- Series.LabelDispAttr.DisplayExpression="seriesaxislabel"
- Series.LabelDispAttr.AutoSize=true
- LegendDispAttr.Weight=400
- LegendDispAttr.FaceName="Arial"
- LegendDispAttr.FontFamily=Swiss!
- LegendDispAttr.FontPitch=Variable!
- LegendDispAttr.BackColor=536870912
- LegendDispAttr.Format="[General]"
- LegendDispAttr.DisplayExpression="series"
- LegendDispAttr.AutoSize=true
- PieDispAttr.Weight=400
- PieDispAttr.FaceName="Arial"
- PieDispAttr.FontFamily=Swiss!
- PieDispAttr.FontPitch=Variable!
- PieDispAttr.BackColor=536870912
- PieDispAttr.Format="[General]"
- PieDispAttr.DisplayExpression="if(seriescount > 1,\
- series,string(percentofseries,\~"0.00%\~"))"
- PieDispAttr.AutoSize=true
- }
- set sect [TextSection new]
- $class initialOnDestroyResidue $sect
- expand_text $sect {
- destroy TitleDispAttr
- destroy LegendDispAttr
- destroy PieDispAttr
- destroy Series.DispAttr
- destroy Series.LabelDispAttr
- destroy Series
- destroy Category.DispAttr
- destroy Category.LabelDispAttr
- destroy Category
- destroy Values.DispAttr
- destroy Values.LabelDispAttr
- destroy Values
- }
-
- set class [PBBuiltinClass new groupbox \
- -kind ${PBClassKind::VSUserObject} -isControl 1]
- $instance setBuiltinClass groupbox $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
- $class setMandatoryProp Text [ \
- PBBuiltinProperty new Text string \"none\"]
-
- set class [PBBuiltinClass new hscrollbar \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass hscrollbar $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 293]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 65]
-
- set class [PBBuiltinClass new line \
- -kind ${PBClassKind::VSUserObject} -isControl 1]
- $instance setBuiltinClass line $class
- $class setMandatoryProp Width [\
- PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [\
- PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new listbox \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass listbox $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new listview \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass listview $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new mailsession \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass mailsession $class
-
- set class [PBBuiltinClass new menu \
- -kind ${PBClassKind::Menu} -isGrContainer 1]
- $instance setBuiltinClass menu $class
- # mandatory prop 'Text' is set in class PBMenuGen
-
- set class [PBBuiltinClass new menucascade \
- -kind ${PBClassKind::Menu} -isGrContainer 1]
- $instance setBuiltinClass menucascade $class
- # mandatory prop 'Text' is set in class PBMenuGen
-
- set class [PBBuiltinClass new message \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass message $class
-
- set class [PBBuiltinClass new multilineedit \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass multilineedit $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new nonvisualobject \
- -kind ${PBClassKind::CCUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass nonvisualobject $class
-
- set class [PBBuiltinClass new olecontrol \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass olecontrol $class
- # mandatory props 'Width' & 'Height' set to 'a' default value
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new oleobject \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass oleobject $class
-
- set class [PBBuiltinClass new olestorage \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass olestorage $class
-
- set class [PBBuiltinClass new olestream \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass olestream $class
-
- set class [PBBuiltinClass new oval \
- -kind ${PBClassKind::VSUserObject} -isControl 1]
- $instance setBuiltinClass oval $class
- $class setMandatoryProp Width [\
- PBBuiltinProperty new Width int 165]
- $class setMandatoryProp Height [\
- PBBuiltinProperty new Height int 145]
-
- set class [PBBuiltinClass new picture \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass picture $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 165]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 145]
-
- set class [PBBuiltinClass new picturebutton \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass picturebutton $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 145]
- $class setMandatoryProp Text [ \
- PBBuiltinProperty new Text string \"none\"]
-
- set class [PBBuiltinClass new picturelistbox \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass picturelistbox $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new pipeline \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass pipeline $class
-
- set class [PBBuiltinClass new radiobutton \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass radiobutton $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 77]
- $class setMandatoryProp Text [ \
- PBBuiltinProperty new Text string \"none\"]
-
- set class [PBBuiltinClass new rectangle \
- -kind ${PBClassKind::VSUserObject} -isControl 1]
- $instance setBuiltinClass rectangle $class
- $class setMandatoryProp Width [\
- PBBuiltinProperty new Width int 165]
- $class setMandatoryProp Height [\
- PBBuiltinProperty new Height int 145]
-
- set class [PBBuiltinClass new richtextedit \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass richtextedit $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new roundrectangle \
- -kind ${PBClassKind::VSUserObject} -isControl 1]
- $instance setBuiltinClass roundrectangle $class
- $class setMandatoryProp Width [\
- PBBuiltinProperty new Width int 165]
- $class setMandatoryProp Height [\
- PBBuiltinProperty new Height int 145]
-
- set class [PBBuiltinClass new singlelineedit \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass singlelineedit $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 93]
-
- set class [PBBuiltinClass new statictext \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass statictext $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 247]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 77]
- $class setMandatoryProp Text [ \
- PBBuiltinProperty new Text string \"none\"]
-
- set class [PBBuiltinClass new structure \
- -kind ${PBClassKind::Structure}]
- $instance setBuiltinClass structure $class
-
- set class [PBBuiltinClass new tab \
- -kind ${PBClassKind::VSUserObject} -isControl 1 \
- -isGrContainer 1 -hasCtorDtor 1]
- $instance setBuiltinClass tab $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 1153]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 865]
-
- set class [PBBuiltinClass new transaction \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass transaction $class
-
- set class [PBBuiltinClass new transport \
- -kind ${PBClassKind::CSUserObject} -hasCtorDtor 1]
- $instance setBuiltinClass transport $class
-
- set class [PBBuiltinClass new treeview \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass treeview $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 494]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 361]
-
- set class [PBBuiltinClass new userobject \
- -kind ${PBClassKind::VCUserObject} -isControl 1 \
- -isGrContainer 1 -hasCtorDtor 1]
- $instance setBuiltinClass userobject $class
- $class setMandatoryProp Width [\
- PBBuiltinProperty new Width int 2533]
- $class setMandatoryProp Height [\
- PBBuiltinProperty new Height int 1517]
-
- set class [PBBuiltinClass new vscrollbar \
- -kind ${PBClassKind::VSUserObject} -isControl 1 -hasCtorDtor 1]
- $instance setBuiltinClass vscrollbar $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 74]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 257]
-
- set class [PBBuiltinClass new window \
- -kind ${PBClassKind::Window} -isGrContainer 1]
- $instance setBuiltinClass window $class
- $class setMandatoryProp Width [PBBuiltinProperty new Width int 2533]
- $class setMandatoryProp Height [PBBuiltinProperty new Height int 1517]
-
- return ${PBBuiltinInfo::instance}
- }
-
- # Do not delete this line -- regeneration end marker
-
- method PBBuiltinInfo::getBuiltinClass {this name} {
- return [[$this builtinClass] set $name]
- }
-
- method PBBuiltinInfo::setBuiltinClass {this name newBuiltinClass} {
- [$this builtinClass] set $name $newBuiltinClass
- }
-
- method PBBuiltinInfo::removeBuiltinClass {this name} {
- [$this builtinClass] unset $name
- }
-
-
- # File: @(#)pbdefiniti.tcl /main/hindenburg/5
-
-
- Class PBDefinitionGen : {GCObject} {
- constructor
- method destructor
- method generate
- method createPBDefinition
- method genFeatures
- method genDataAttrs
- method genOperations
- method genAssocAttrs
- attribute name
- attribute superNm
- attribute builtinSuperNm
- attribute isGlobalType
- attribute container
- attribute model
- attribute ooplClass
- attribute globalOoplClass
- }
-
- constructor PBDefinitionGen {class this i_name ooplClass} {
- set this [GCObject::constructor $class $this]
- $this name $i_name
- $this ooplClass $ooplClass
- # Start constructor user section
-
- $this builtinSuperNm [[$this ooplClass] getBuiltinSuperClassName]
-
- # End constructor user section
- return $this
- }
-
- method PBDefinitionGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBDefinitionGen::generate {this} {
- set def [$this createPBDefinition]
- $this genFeatures $def
- return $def
- }
-
- method PBDefinitionGen::createPBDefinition {this} {
- set type [$this objType]
- set kind [string range $type 0 [expr {[string length $type] - 4}]]
- set def [$kind new [$this name] [$this ooplClass] \
- [$this superNm] [$this builtinSuperNm] \
- -isGlobalType [$this isGlobalType]]
-
- if [$this isGlobalType] {
- PBLibraryEntry new [$this model] $def
- } else {
- [$this container] addContainedClass $def
- }
-
- return $def
- }
-
- method PBDefinitionGen::genFeatures {this def} {
- if {[[$this ooplClass] isBuiltin] ||
- (![$this isGlobalType] && [[$this ooplClass] isGlobalType])} {
- # Only a type definition (a local one) is generated, without
- # variables, functions, user events and even scripts!
- return
- }
- $this genDataAttrs $def
- $this genOperations $def
- $this genAssocAttrs $def
- }
-
- method PBDefinitionGen::genDataAttrs {this def} {
- foreach attr [[$this ooplClass] dataAttrSet] {
- $attr generate $def
- }
- }
-
- method PBDefinitionGen::genOperations {this def} {
- foreach oper [[$this ooplClass] operationSet] {
- $oper generate $def
- }
- if {[[$this ooplClass] constructor] != ""} {
- [[$this ooplClass] constructor] generate $def
- }
- }
-
- method PBDefinitionGen::genAssocAttrs {this def} {
- foreach assoc [[$this ooplClass] genAssocAttrSet] {
- $assoc generate [$this globalOoplClass] $def
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)pbgclassen.tcl /main/hindenburg/1
-
-
- Class PBGClassEnum : {PBGClass} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGClassEnum {class this name} {
- set this [PBGClass::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGClassEnum::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGClassEnum::generate {this model} {
- m4_error $E_NOENUMS
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGClassEnumD : {PBGClassEnum OPClassEnum} {
- }
-
- selfPromoter OPClassEnum {this} {
- PBGClassEnumD promote $this
- }
-
- # File: @(#)pbgclassge.tcl /main/hindenburg/1
-
-
- Class PBGClassGenericTypeDef : {PBGClass} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGClassGenericTypeDef {class this name} {
- set this [PBGClass::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGClassGenericTypeDef::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGClassGenericTypeDef::generate {this model} {
- $this PBGClass::generate $model
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGClassGenericTypeDefD : {PBGClassGenericTypeDef OPClassGenericTypeDef} {
- }
-
- selfPromoter OPClassGenericTypeDef {this} {
- PBGClassGenericTypeDefD promote $this
- }
-
- # File: @(#)pbgclasstd.tcl /main/hindenburg/1
-
-
- Class PBGClassTDef : {PBGClass} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGClassTDef {class this name} {
- set this [PBGClass::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGClassTDef::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGClassTDef::generate {this model} {
- $this PBGClass::generate $model
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGClassTDefD : {PBGClassTDef OPClassTDef} {
- }
-
- selfPromoter OPClassTDef {this} {
- PBGClassTDefD promote $this
- }
-
- # File: @(#)pbglinkcla.tcl /main/hindenburg/1
-
-
- Class PBGLinkClass : {PBGClass} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGLinkClass {class this name} {
- set this [PBGClass::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGLinkClass::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGLinkClass::generate {this model} {
- $this PBGClass::generate $model
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGLinkClassD : {PBGLinkClass OPLinkClass} {
- }
-
- selfPromoter OPLinkClass {this} {
- PBGLinkClassD promote $this
- }
-
- # File: @(#)pbgattribu.tcl /main/hindenburg/1
-
-
- Class PBGAttribute : {PBGFeature} {
- constructor
- method destructor
- }
-
- constructor PBGAttribute {class this name} {
- set this [PBGFeature::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGAttribute::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGAttributeD : {PBGAttribute OPAttribute} {
- }
-
- selfPromoter OPAttribute {this} {
- PBGAttributeD promote $this
- }
-
- # File: @(#)pbgconstru.tcl /main/hindenburg/1
-
-
- Class PBGConstructor : {PBGFeature} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGConstructor {class this name} {
- set this [PBGFeature::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGConstructor::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGConstructor::generate {this class} {
- return ""
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGConstructorD : {PBGConstructor OPConstructor} {
- }
-
- selfPromoter OPConstructor {this} {
- PBGConstructorD promote $this
- }
-
- # File: @(#)pbgoperati.tcl /main/hindenburg/4
-
-
- Class PBGOperation : {PBGFeature} {
- constructor
- method destructor
- method generate
- method generateFunction
- method generateAccess
- method generateEvent
- method isEvent
- method isUserEvent
- }
-
- constructor PBGOperation {class this name} {
- set this [PBGFeature::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGOperation::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGOperation::generate {this class} {
- if [$this isEvent] {
- set oper [$this generateEvent $class]
- } else {
- set oper [$this generateFunction $class]
- }
-
- return $oper
- }
-
- method PBGOperation::generateFunction {this class} {
- set type [[$this ooplType] generate]
- set access [$this generateAccess]
- set func [PBFunction new [$this getName] $type $access]
-
- foreach param [$this parameterSet] {
- $param generate $func
- }
-
- $class addObjectFunction $func
-
- return $func
- }
-
- method PBGOperation::generateAccess {this} {
- set access [string tolower [$this getPropertyValue "method_access"]]
- if {$access == "" } {
- set access "public"
- }
- return [PBAccess new $access]
- }
-
- method PBGOperation::generateEvent {this class} {
- set type [[$this ooplType] generate]
- set name [$this getName]
- if {$name == "constructor"} {
- set event [PBConstructor new $name $type]
- } elseif {$name == "destructor"} {
- set event [PBDestructor new $name $type]
- } else {
- set event [PBEvent new $name $type]
- }
-
- set firstParam 1
- foreach param [$this parameterSet] {
- # special case when type of first parameter is "eventid";
- # in this case, prevent mapping of standard type "eventid"
- # onto language type "string"
- if $firstParam {
- set firstParam 0
- set pbParam [$param generate $event]
- if {[[$param ooplType] getName] == "eventid"} {
- [$pbParam type] name "eventid"
- break
- }
- } else {
- $param generate $event
- }
- }
-
- if {[$this isUserEvent]} {
- $class addUserEvent $event
- } else {
- $class addScript $event
- }
-
- return $event
- }
-
- method PBGOperation::isEvent {this} {
- if {[$this getPropertyValue is_event] == "1"} {
- return 1
- }
- return 0
- }
-
- method PBGOperation::isUserEvent {this} {
- set superClass [[$this ooplClass] getSuperClass]
- while {$superClass != ""} {
- if [$superClass hasEvent [$this getName]] {
- return 0
- }
- set superClass [$superClass getSuperClass]
- }
- return 1
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGOperationD : {PBGOperation OPOperation} {
- }
-
- selfPromoter OPOperation {this} {
- PBGOperationD promote $this
- }
-
- # File: @(#)pbgctorpar.tcl /main/hindenburg/1
-
-
- Class PBGCtorParameter : {PBGParameter} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGCtorParameter {class this name} {
- set this [PBGParameter::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGCtorParameter::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGCtorParameter::generate {this oper} {
- # !! Implement this function !!
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGCtorParameterD : {PBGCtorParameter OPCtorParameter} {
- }
-
- selfPromoter OPCtorParameter {this} {
- PBGCtorParameterD promote $this
- }
-
- # File: @(#)pbgoperpar.tcl /main/hindenburg/2
-
-
- Class PBGOperParameter : {PBGParameter} {
- constructor
- method destructor
- method generate
- method generateModifier
- }
-
- constructor PBGOperParameter {class this name} {
- set this [PBGParameter::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGOperParameter::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGOperParameter::generate {this oper} {
- set type [[$this ooplType] generate]
- set modifier [$this generateModifier]
- set param [PBParameter new [$this getName] $type $modifier \
- -arrayDesc [[$this ooplType] arrayDesc]]
- $oper addParameter $param
- return $param
- }
-
- method PBGOperParameter::generateModifier {this} {
- set modifier [$this getPropertyValue "pass_by"]
- if {$modifier == "Reference"} {
- set modifier "ref"
- } elseif {$modifier == "ReadOnly"} {
- set modifier "readonly"
- } else {
- set modifier ""
- }
- return [PBModifier new $modifier]
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGOperParameterD : {PBGOperParameter OPOperParameter} {
- }
-
- selfPromoter OPOperParameter {this} {
- PBGOperParameterD promote $this
- }
-
- # File: @(#)pbgbasetyp.tcl /main/hindenburg/2
-
-
- Class PBGBaseType : {PBGType} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGBaseType {class this name} {
- set this [PBGType::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGBaseType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGBaseType::generate {this} {
- set type [$this getType3GL]
-
- set arrayDesc ""
- regexp {\[.*\]$} $type arrayDesc
- $this arrayDesc $arrayDesc
-
- regsub {\[.*\]$} $type "" type
- return [PBType new $type]
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGBaseTypeD : {PBGBaseType OPBaseType} {
- }
-
- selfPromoter OPBaseType {this} {
- PBGBaseTypeD promote $this
- }
-
- # File: @(#)pbgclassty.tcl /main/hindenburg/1
-
-
- Class PBGClassType : {PBGType} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGClassType {class this name} {
- set this [PBGType::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGClassType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGClassType::generate {this} {
- return [PBType new [$this getName]]
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGClassTypeD : {PBGClassType OPClassType} {
- }
-
- selfPromoter OPClassType {this} {
- PBGClassTypeD promote $this
- }
-
- # File: @(#)pbgenumtyp.tcl /main/hindenburg/1
-
-
- Class PBGEnumType : {PBGType} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGEnumType {class this name} {
- set this [PBGType::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGEnumType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGEnumType::generate {this} {
- return [PBType new [$this getName]]
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGEnumTypeD : {PBGEnumType OPEnumType} {
- }
-
- selfPromoter OPEnumType {this} {
- PBGEnumTypeD promote $this
- }
-
- # File: @(#)pbgtypedef.tcl /main/hindenburg/1
-
-
- Class PBGTypeDefType : {PBGType} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGTypeDefType {class this name} {
- set this [PBGType::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGTypeDefType::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGTypeDefType::generate {this} {
- return [PBType new [$this getName]]
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGTypeDefTypeD : {PBGTypeDefType OPTypeDefType} {
- }
-
- selfPromoter OPTypeDefType {this} {
- PBGTypeDefTypeD promote $this
- }
-
- # File: @(#)pbclasscus.tcl /main/hindenburg/1
-
-
- Class PBClassCustomUserObjectGen : {PBDefinitionGen} {
- constructor
- method destructor
- method createPBDefinition
- }
-
- constructor PBClassCustomUserObjectGen {class this i_name ooplClass} {
- set this [PBDefinitionGen::constructor $class $this $i_name $ooplClass]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBClassCustomUserObjectGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this PBDefinitionGen::destructor
- }
-
- method PBClassCustomUserObjectGen::createPBDefinition {this} {
- set def [$this PBDefinitionGen::createPBDefinition]
- $def isAutoInstantiate [[$this ooplClass] isAutoInstantiate]
- return $def
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)pbclasssta.tcl /main/hindenburg/1
-
-
- Class PBClassStandardUserObjectGen : {PBDefinitionGen} {
- constructor
- method destructor
- }
-
- constructor PBClassStandardUserObjectGen {class this i_name ooplClass} {
- set this [PBDefinitionGen::constructor $class $this $i_name $ooplClass]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBClassStandardUserObjectGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this PBDefinitionGen::destructor
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)pbmenugen.tcl /main/hindenburg/5
-
-
- Class PBMenuGen : {PBDefinitionGen} {
- constructor
- method destructor
- method createPBDefinition
- method genAssocAttrs
- }
-
- constructor PBMenuGen {class this i_name ooplClass} {
- set this [PBDefinitionGen::constructor $class $this $i_name $ooplClass]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBMenuGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this PBDefinitionGen::destructor
- }
-
- method PBMenuGen::createPBDefinition {this} {
- set def [$this PBDefinitionGen::createPBDefinition]
-
- # set default for (mandatory) builtin property 'Text'
- $def setBuiltinProperty Text [PBBuiltinProperty new Text string \
- \"[$this name]\" -where ${PBBuiltinProperty::InOnCreate}]
-
- return $def
- }
-
- method PBMenuGen::genAssocAttrs {this def} {
- foreach assoc [[$this ooplClass] genAssocAttrSet] {
- set oppClass [$assoc getOppositeClass]
- if {$oppClass == ""} {
- # error is already given
- continue
- }
- if {[$oppClass getPBClassKind] == ${PBClassKind::Window}} {
- m4_warning $W_IGNMENUWINAGGR [$assoc getName] \
- [$this name] [$oppClass getName]
- continue
- }
- $assoc generate [$this globalOoplClass] $def
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)pbstructur.tcl /main/hindenburg/2
-
-
- Class PBStructureGen : {PBDefinitionGen} {
- constructor
- method destructor
- method createPBDefinition
- method genFeatures
- }
-
- constructor PBStructureGen {class this i_name ooplClass} {
- set this [PBDefinitionGen::constructor $class $this $i_name $ooplClass]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBStructureGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this PBDefinitionGen::destructor
- }
-
- method PBStructureGen::createPBDefinition {this} {
- set def [PBStructure new [$this name] [$this ooplClass] \
- -isGlobalType [$this isGlobalType]]
-
- if [$this isGlobalType] {
- PBLibraryEntry new [$this model] $def
- } else {
- [$this container] addObjectStructure $def
- }
-
- return $def
- }
-
- method PBStructureGen::genFeatures {this def} {
- foreach attr [[$this ooplClass] dataAttrSet] {
- set type [[$attr ooplType] generate]
- set field [PBNameType new [$attr getName] $type \
- -arrayDesc [[$attr ooplType] arrayDesc]]
- $def addField $field
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)pbvisualcu.tcl /main/hindenburg/1
-
-
- Class PBVisualCustomUserObjectGen : {PBDefinitionGen} {
- constructor
- method destructor
- method createPBDefinition
- }
-
- constructor PBVisualCustomUserObjectGen {class this i_name ooplClass} {
- set this [PBDefinitionGen::constructor $class $this $i_name $ooplClass]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBVisualCustomUserObjectGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this PBDefinitionGen::destructor
- }
-
- method PBVisualCustomUserObjectGen::createPBDefinition {this} {
- set def [$this PBDefinitionGen::createPBDefinition]
- $def isAutoInstantiate [[$this ooplClass] isAutoInstantiate]
- return $def
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)pbvisualst.tcl /main/hindenburg/1
-
-
- Class PBVisualStandardUserObjectGen : {PBDefinitionGen} {
- constructor
- method destructor
- }
-
- constructor PBVisualStandardUserObjectGen {class this i_name ooplClass} {
- set this [PBDefinitionGen::constructor $class $this $i_name $ooplClass]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBVisualStandardUserObjectGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this PBDefinitionGen::destructor
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)pbwindowge.tcl /main/hindenburg/5
-
-
- Class PBWindowGen : {PBDefinitionGen} {
- constructor
- method destructor
- method createPBDefinition
- method genAssocAttrs
- }
-
- constructor PBWindowGen {class this i_name ooplClass} {
- set this [PBDefinitionGen::constructor $class $this $i_name $ooplClass]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBWindowGen::destructor {this} {
- # Start destructor user section
- # End destructor user section
- $this PBDefinitionGen::destructor
- }
-
- method PBWindowGen::createPBDefinition {this} {
- set def [$this PBDefinitionGen::createPBDefinition]
-
- set windowType [[$this ooplClass] getWindowType]
- if {$windowType == "MDI" || $windowType == "MDIHelp"} {
- set mdiclient [PBVisual new "mdi_1" "" "mdiclient" "mdiclient" \
- -isGlobalType 0]
- $def addContainedClass $mdiclient
- }
- set windowType "[string tolower $windowType]!"
- $def setBuiltinProperty WindowType [PBBuiltinProperty \
- new WindowType WindowType $windowType \
- -where ${PBBuiltinProperty::InTypeDef}]
-
- return $def
- }
-
- method PBWindowGen::genAssocAttrs {this def} {
- foreach assoc [[$this ooplClass] genAssocAttrSet] {
- set oppClass [$assoc getOppositeClass]
- if {$oppClass == ""} {
- # error is already given
- continue
- }
- if {[$oppClass getPBClassKind] == ${PBClassKind::Menu}} {
- set menuName [$oppClass getName]
- $def setBuiltinProperty MenuName [PBBuiltinProperty \
- new MenuName string \"${menuName}\" \
- -where ${PBBuiltinProperty::InTypeDef}]
- $def menuName $menuName
- continue
- }
- $assoc generate [$this globalOoplClass] $def
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
-
- # File: @(#)pbgdataatt.tcl /main/hindenburg/5
-
-
- Class PBGDataAttr : {PBGAttribute} {
- constructor
- method destructor
- method generate
- method generateAccess
- method isConstant
- method isShared
- }
-
- constructor PBGDataAttr {class this name} {
- set this [PBGAttribute::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGDataAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGDataAttr::generate {this class} {
- set type [[$this ooplType] generate]
- set access [$this generateAccess]
- set attr [PBVariable new [$this getName] $type $access \
- -arrayDesc [[$this ooplType] arrayDesc]]
- set defVal [$this getInitialValue]
- if {$defVal != ""} {
- $attr defaultValue $defVal
- }
- if {[$this isConstant]} {
- if {$defVal != ""} {
- $attr isConstant 1
- } else {
- m4_warning $W_CONST_IGNORED [$this getName] \
- [$class name]
- }
- }
- $attr isShared [$this isShared]
- if {[$this isShared]} {
- $class addSharedVar $attr
- } else {
- $class addInstanceVar $attr
- }
- return $attr
- }
-
- method PBGDataAttr::generateAccess {this} {
- set accessList [$this getPropertyValue "attrib_access"]
- switch -exact -- $accessList {
- Public-Public
- {return [PBVarAccess new "" "" ""]}
- Public-Protected
- {return [PBVarAccess new "" "" "protectedwrite"]}
- Public-Private
- {return [PBVarAccess new "" "" "privatewrite"]}
- Protected-Public -
- Protected-Protected
- {return [PBVarAccess new "protected" "" ""]}
- Protected-Private
- {return [PBVarAccess new "protected" "" "privatewrite"]}
- Private-Public -
- Private-Protected -
- Private-Private
- {return [PBVarAccess new "private" "" ""]}
- default
- {return [PBVarAccess new "" "" ""]}
- }
- }
-
- method PBGDataAttr::isConstant {this} {
- if {[$this getPropertyValue is_const_attrib] == "1"} {
- return 1
- }
- return 0
- }
-
- method PBGDataAttr::isShared {this} {
- return [$this isClassFeature]
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGDataAttrD : {PBGDataAttr OPDataAttr} {
- }
-
- selfPromoter OPDataAttr {this} {
- PBGDataAttrD promote $this
- }
-
- # File: @(#)pbggenasso.tcl /main/hindenburg/10
-
-
- Class PBGGenAssocAttr : {PBGAttribute} {
- constructor
- method destructor
- method promoter
- method getThisClass
- method getOppositeClass
- method isValidAssociation
- method genAddAccessor
- method genGetAccessor
- method genGetManyAccessor
- method genRemoveOneAccessor
- method genRemoveAccessor
- method genSetAccessor
- method genAssocVariable
- method getAssocIdentifier
- method getAssocVariable
- method getAccessorAccess
- method genCtor
- method genDtor
- method extendAssoc
- method reduceAssoc
- method setAssoc
- attribute oppClass
- }
-
- constructor PBGGenAssocAttr {class this name} {
- set this [PBGAttribute::constructor $class $this $name]
- $this oppClass "_uninitialized_"
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGGenAssocAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGGenAssocAttr::promoter {this} {
- $this oppClass "_uninitialized_"
- }
-
- method PBGGenAssocAttr::getThisClass {this} {
- return [$this ooplClass]
- }
-
- method PBGGenAssocAttr::getOppositeClass {this} {
- if {[$this oppClass] != "_uninitialized_"} {
- return [$this oppClass]
- }
-
- set type [$this ooplType]
- set ooplClass ""
- if [$type isA OPBaseType] {
- m4_error $E_ASSWITHBASETYPE [$this getName] \
- [[$this getThisClass] getName] [$type getName]
- } elseif [$type isA OPEnumType] {
- m4_error $E_ASSWITHENUMTYPE [$this getName] \
- [[$this getThisClass] getName] [$type getName]
- } else {
- set ooplClass [$type ooplClass]
- if {$ooplClass == ""} {
- m4_error $E_ASSCLASSNONAME [$this getName] \
- [[$this getThisClass] getName]
- }
- }
- $this oppClass $ooplClass
- return $ooplClass
- }
-
- method PBGGenAssocAttr::isValidAssociation {this} {
- set thisClass [$this getThisClass]
- set oppClass [$this getOppositeClass]
- if {$oppClass == ""} {
- # error is already given
- return 0
- }
-
- if {![$thisClass isGlobalType] || ![$oppClass isGlobalType]} {
- m4_error $E_ASSGLOBTYPES [$this getName] \
- [$thisClass getName] [$oppClass getName]
- return 0
- }
-
- if {[$oppClass getPBClassKind] == ${PBClassKind::Structure}} {
- m4_error $E_ASSWITHSTRUCT [$this getName] \
- [$thisClass getName] [$oppClass getName]
- return 0
- }
-
- if {[$thisClass getBuiltinSuperClass] == ""} {
- # error is already given
- return 0
- }
- set classInfo [[PBBuiltinInfo::global] getBuiltinClass \
- [$thisClass getBuiltinSuperClassName]]
- if ![$classInfo hasCtorDtor] {
- m4_error $E_ASSCTORDTOR [$this getName] [$thisClass getName] \
- [$oppClass getName] [$thisClass getName]
- return 0
- }
-
- if {[$oppClass getBuiltinSuperClass] == ""} {
- # error is already given
- return 0
- }
- set oppClassInfo [[PBBuiltinInfo::global] getBuiltinClass \
- [$oppClass getBuiltinSuperClassName]]
- if {[$this opposite] != "" && ![$oppClassInfo hasCtorDtor]} {
- m4_error $E_ASSCTORDTOR [$this getName] [$thisClass getName] \
- [$oppClass getName] [$oppClass getName]
- return 0
- }
-
- return 1
- }
-
- method PBGGenAssocAttr::genAddAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess w]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set ident [$this getAssocIdentifier]
-
- set name "add[cap $ident]"
- set type [PBType new ""]
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- if [$this isQualified] {
- set qualifier [$this qualifier]
- } elseif {$opposite != "" && [$opposite isQualified]} {
- set qualifier [$opposite qualifier]
- } else {
- set qualifier ""
- }
- if {$qualifier != ""} {
- set qualId [$qualifier getName]
- set qualTypeName [[$qualifier ooplType] getName]
- set type [PBType new $qualTypeName]
- set modifier [PBModifier new ""]
- set param [PBParameter new $qualId $type $modifier]
- $accessor addParameter $param
- }
-
- set paramId "new[cap $ident]"
- set paramType [[$this ooplType] generate]
- set modifier [PBModifier new ""]
- set param [PBParameter new $paramId $paramType $modifier]
- $accessor addParameter $param
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
- $sect append "if isNull($paramId) then\n"
- $sect indent +
- $sect append "return\n"
- $sect indent -
- $sect append "end if\n"
-
- if {$opposite != ""} {
- if {[$opposite getMultiplicity] == "one" &&
- ![$opposite isQualified] && ![$this isQualified]} {
- $sect append [$opposite setAssoc $paramId]
- }
- $sect append [$opposite extendAssoc $paramId]
- }
-
- if {[$this isQualified]} {
- set varName [$this getAssocVariable]
- $sect append "classset theSet\n"
- $sect append "theSet = $varName.get($qualId)\n"
- $sect append "if isNull(theSet) then\n"
- $sect indent +
- $sect append "theSet = create classset\n"
- $sect append "$varName.set($qualId, theSet)\n"
- $sect indent -
- $sect append "end if\n"
- $sect append "theSet.add($paramId)\n"
- } else {
- $sect append [$this extendAssoc "" $paramId]
- }
- }
-
- method PBGGenAssocAttr::genGetAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess r]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set varName [$this getAssocVariable]
- set name "get[cap $varName]"
- set type [[$this ooplType] generate]
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
- $sect append "return $varName\n"
- }
-
- method PBGGenAssocAttr::genGetManyAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess r]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set varName [$this getAssocVariable]
- set name "get[cap $varName]"
- set type [PBType new "classset"]
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
- $sect append "return $varName\n"
- }
-
- method PBGGenAssocAttr::genRemoveOneAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess w]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set ident [$this getAssocIdentifier]
-
- set name "remove[cap $ident]"
- set type [PBType new ""]
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- if {$opposite != "" && [$opposite isQualified]} {
- set qualifier [$opposite qualifier]
- set qualId [$qualifier getName]
- set qualTypeName [[$qualifier ooplType] getName]
- set type [PBType new $qualTypeName]
- set modifier [PBModifier new ""]
- set param [PBParameter new $qualId $type $modifier]
- $accessor addParameter $param
- }
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
-
- if {$opposite != ""} {
- $sect append "if not isNull($ident) then\n"
- $sect indent +
- $sect append [$opposite reduceAssoc $ident]
- $sect indent -
- $sect append "end if\n"
- }
- $sect append "setNull($ident)\n"
- }
-
- method PBGGenAssocAttr::genRemoveAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess w]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set ident [$this getAssocIdentifier]
-
- set name "remove[cap $ident]"
- set type [PBType new ""]
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- if {$opposite != "" && [$opposite isQualified]} {
- set qualifier [$opposite qualifier]
- set qualId [$qualifier getName]
- set qualTypeName [[$qualifier ooplType] getName]
- set type [PBType new $qualTypeName]
- set modifier [PBModifier new ""]
- set param [PBParameter new $qualId $type $modifier]
- $accessor addParameter $param
- }
-
- set paramId "old[cap $ident]"
- set paramType [[$this ooplType] generate]
- set modifier [PBModifier new ""]
- set param [PBParameter new $paramId $paramType $modifier]
- $accessor addParameter $param
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
- $sect append "if isNull($paramId) then\n"
- $sect indent +
- $sect append "return\n"
- $sect indent -
- $sect append "end if\n"
-
- if {$opposite != ""} {
- $sect append [$opposite reduceAssoc $paramId]
- }
- $sect append [$this reduceAssoc "" $paramId]
- }
-
- method PBGGenAssocAttr::genSetAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess w]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set ident [$this getAssocIdentifier]
-
- set name "set[cap $ident]"
- set type [PBType new ""]
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- if {$opposite != "" && [$opposite isQualified]} {
- set qualifier [$opposite qualifier]
- set qualId [$qualifier getName]
- set qualTypeName [[$qualifier ooplType] getName]
- set type [PBType new $qualTypeName]
- set modifier [PBModifier new ""]
- set param [PBParameter new $qualId $type $modifier]
- $accessor addParameter $param
- }
-
- set paramId "new[cap $ident]"
- set paramType [[$this ooplType] generate]
- set modifier [PBModifier new ""]
- set param [PBParameter new $paramId $paramType $modifier]
- $accessor addParameter $param
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
- if {$opposite != ""} {
- if {[$opposite isQualified]} {
- $sect append "if not isNull($paramId) then\n"
- $sect indent +
- $sect append [$opposite extendAssoc $paramId]
- $sect indent -
- $sect append "end if\n"
- } else {
- $sect append "if not isNull($ident) then\n"
- $sect indent +
- $sect append [$opposite reduceAssoc $ident]
- $sect indent -
- $sect append "end if\n"
-
- if {[$opposite getMultiplicity] == "one"} {
- $sect append "if not isNull($paramId) then\n"
- $sect indent +
- $sect append [$opposite setAssoc $paramId]
- $sect append [$opposite extendAssoc $paramId]
- $sect indent -
- $sect append "end if\n"
- } else {
- $sect append "if not isNull($paramId) then\n"
- $sect indent +
- $sect append [$opposite extendAssoc $paramId]
- $sect indent -
- $sect append "end if\n"
- }
- }
- }
-
- $sect append "$ident = $paramId\n"
- }
-
- method PBGGenAssocAttr::genAssocVariable {this class} {
- if [$this isQualified] {
- set type [PBType new "classdict"]
- } elseif {[$this getMultiplicity] == "many"} {
- set type [PBType new "classset"]
- } else {
- set type [[$this ooplType] generate]
- }
-
- if {[$this opposite] != ""} {
- set access [PBVarAccess new "public" "" ""]
- } else {
- set access [PBVarAccess new "private" "" ""]
- }
-
- set name [$this getAssocVariable]
- set var [PBVariable new $name $type $access]
- $class addAssocInstanceVar $var
- }
-
- method PBGGenAssocAttr::getAssocIdentifier {this} {
- if {[$this isLinkAttr]} {
- return [uncap [[$this ooplType] getName]Of[cap [$this getName]]]
- }
- return [$this getName]
- }
-
- method PBGGenAssocAttr::getAssocVariable {this} {
- set name [$this getAssocIdentifier]
- if {[$this isQualified]} {
- set name "${name}Dict"
- } elseif {[$this getMultiplicity] == "many"} {
- set name "${name}Set"
- }
- return [uncap $name]
- }
-
- method PBGGenAssocAttr::getAccessorAccess {this mode} {
- set accessList [split [$this getPropertyValue assoc_access] -]
- if {$mode == "r"} {
- set accessStr [lindex $accessList 0]
- } else {
- set accessStr [lindex $accessList 1]
- }
- if {$accessStr == ""} {
- set accessStr "public"
- }
- return [string tolower $accessStr]
- }
-
- method PBGGenAssocAttr::genCtor {this class} {
- set ctor [$class findEvent "constructor"]
- if {$ctor == ""} {
- set ctor [PBConstructor new "constructor" [PBType new ""]]
- $class addScript $ctor
- }
- if {[$ctor preBody] == ""} {
- $ctor preBody [TextSection new]
- }
- set varName [$this getAssocVariable]
- if {[$this isQualified]} {
- set initStr "$varName = create classdict"
- } elseif {[$this getMultiplicity] == "many"} {
- set initStr "$varName = create classset"
- } else {
- set initStr "setNull($varName)"
- }
- [$ctor preBody] append "${initStr}\n"
- }
-
- method PBGGenAssocAttr::genDtor {this class} {
- set dtor [$class findEvent "destructor"]
- if {$dtor == ""} {
- set dtor [PBDestructor new "destructor" [PBType new ""]]
- $class addScript $dtor
- }
- if {[$dtor postBody] == ""} {
- $dtor postBody [TextSection new]
- }
- set varName [$this getAssocVariable]
- if {[$this isQualified] || [$this getMultiplicity] == "many"} {
- [$dtor postBody] append "destroy($varName)\n"
- }
- }
-
- method PBGGenAssocAttr::extendAssoc {this {prefix ""} {element this}} {
- if {$prefix != ""} {
- set prefix "${prefix}."
- }
-
- set varName [$this getAssocVariable]
-
- if {[$this isQualified]} {
- set qualId [[$this qualifier] getName]
- if {[$this getMultiplicity] == "one"} {
- return "$prefix$varName.set($qualId, $element)\n"
- }
- set ident [$this getAssocIdentifier]
- return "${prefix}add[cap $ident]($qualId, $element)\n"
- }
-
- if {[$this getMultiplicity] == "one"} {
- return "$prefix$varName = $element\n"
- }
- return "$prefix$varName.add($element)\n"
- }
-
- method PBGGenAssocAttr::reduceAssoc {this {prefix ""} {element this}} {
- if {$prefix != ""} {
- set prefix "${prefix}."
- }
-
- set varName [$this getAssocVariable]
-
- if {[$this isQualified]} {
- set qualId [[$this qualifier] getName]
- if {[$this getMultiplicity] == "one"} {
- return "$prefix$varName.remove($qualId)\n"
- }
- set ident [$this getAssocIdentifier]
- return "${prefix}remove[cap $ident]($qualId, $element)\n"
- }
-
- if {[$this getMultiplicity] == "one"} {
- return "setNull($prefix$varName)\n"
- }
-
- return "$prefix$varName.remove($element)\n"
- }
-
- method PBGGenAssocAttr::setAssoc {this {prefix ""} {element ""}} {
- if {$prefix != ""} {
- set prefix "${prefix}."
- }
-
- set retStr ""
- if {$element == ""} {
- set retStr "[[$this ooplType] getName] nullRef\n"
- set retStr "${retStr}setNull(nullRef)\n"
- set element "nullRef"
- }
- set retStr "${retStr}${prefix}set[\
- cap [$this getAssocIdentifier]]($element)\n"
- return $retStr
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGGenAssocAttrD : {PBGGenAssocAttr OPGenAssocAttr} {
- }
-
- selfPromoter OPGenAssocAttr {this} {
- PBGGenAssocAttrD promote $this
- }
-
- # File: @(#)pbgassocat.tcl /main/hindenburg/11
-
-
- Class PBGAssocAttr : {PBGGenAssocAttr} {
- constructor
- method destructor
- method isAggregation
- method isContainmentAggregation
- method generate
- }
-
- constructor PBGAssocAttr {class this name} {
- set this [PBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGAssocAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGAssocAttr::isAggregation {this} {
- set compType [[[$this smConnector] getConnector] type]
- if {$compType == "aggregation"} {
- return 1
- }
- return 0
- }
-
- method PBGAssocAttr::isContainmentAggregation {this class} {
- if ![$this isAggregation] {
- return 0
- }
-
- if [$this isAggregate] {
- set fromClass [$this getThisClass]
- set toClass [$this getOppositeClass]
- } elseif {[$this opposite] != ""} {
- set fromClass [$this getOppositeClass]
- set toClass [$this getThisClass]
- } else {
- return 0
- }
-
- set containerType [$fromClass getBuiltinSuperClassName]
- set containeeType [$toClass getBuiltinSuperClassName]
-
- # Is it graphical containment, i.e. is it:
- # - a userobject or window containing a control, or
- # - a tab containing a userobject?
- if {$containerType == "userobject" || $containerType == "window"} {
- set classInfo [[PBBuiltinInfo::global] \
- getBuiltinClass $containeeType]
- if {$classInfo != "" && [$classInfo isControl]} {
- return 1
- }
- }
- if {$containerType == "tab" && $containeeType == "userobject"} {
- return 1
- }
-
- # Is it a menu containing other menus ?
- if {($containerType == "menu" || $containerType == "menucascade") &&
- ($containeeType == "menu" || $containeeType == "menucascade")} {
- return 1
- }
-
- # Is it a (global) class having an 'object structure' ?
- if {[$class isGlobalType] && $containeeType == "structure"} {
- return 1
- }
-
- return 0
- }
-
- method PBGAssocAttr::generate {this globalOoplClass class} {
- set oppClass [$this getOppositeClass]
- if {$oppClass == ""} {
- # error is already given
- return
- }
-
- if [$this isContainmentAggregation $class] {
- if [$this isAggregate] {
- [$this getOppositeClass] generateAsContainedClass \
- [$this getName] $globalOoplClass \
- [$this getThisClass] $class
- } else {
- m4_error $E_NOREVAGGR [$this getName] \
- [[$this getThisClass] getName] \
- [[$this getOppositeClass] getName]
- }
- return
- }
-
- if [$this isAggregate] {
- # This is an aggregate, but it does not represent a valid
- # containment aggregation
- m4_warning $W_AGGRASASSOC [$this getName] \
- [[$this getThisClass] getName] \
- [[$this getOppositeClass] getName]
- }
-
- # 'normal' association generation ...
- #
- if ![$this isValidAssociation] {
- # error is already given
- return
- }
- $this genAssocVariable $class
- if {[$this getMultiplicity] == "one"} {
- $this genRemoveOneAccessor $class
- $this genSetAccessor $class
- $this genGetAccessor $class
- } else {
- $this genAddAccessor $class
- $this genRemoveAccessor $class
- $this genGetManyAccessor $class
- }
- $this genCtor $class
- $this genDtor $class
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGAssocAttrD : {PBGAssocAttr OPAssocAttr} {
- }
-
- selfPromoter OPAssocAttr {this} {
- PBGAssocAttrD promote $this
- }
-
- # File: @(#)pbglinkatt.tcl /main/hindenburg/4
-
-
- Class PBGLinkAttr : {PBGGenAssocAttr} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGLinkAttr {class this name} {
- set this [PBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGLinkAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGLinkAttr::generate {this globalOoplClass class} {
- if ![$this isValidAssociation] {
- return
- }
- $this genAssocVariable $class
- if {[$this getMultiplicity] == "one"} {
- $this genGetAccessor $class
- } else {
- $this genGetManyAccessor $class
- }
- $this genCtor $class
- $this genDtor $class
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGLinkAttrD : {PBGLinkAttr OPLinkAttr} {
- }
-
- selfPromoter OPLinkAttr {this} {
- PBGLinkAttrD promote $this
- }
-
- # File: @(#)pbgqualatt.tcl /main/hindenburg/6
-
-
- Class PBGQualAttr : {PBGGenAssocAttr} {
- constructor
- method destructor
- method generate
- method genGetQualifiedAccessor
- method genRemoveQualifiedAccessor
- method genSetQualifiedAccessor
- }
-
- constructor PBGQualAttr {class this name} {
- set this [PBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGQualAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGQualAttr::generate {this globalOoplClass class} {
- if ![$this isValidAssociation] {
- return
- }
- $this genAssocVariable $class
- $this genGetQualifiedAccessor $class
-
- if {[$this getMultiplicity] == "one"} {
- $this genSetQualifiedAccessor $class
- } else {
- $this genAddAccessor $class
- }
-
- $this genRemoveQualifiedAccessor $class
- $this genCtor $class
- $this genDtor $class
- }
-
- method PBGQualAttr::genGetQualifiedAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess r]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set varName [$this getAssocVariable]
- set name "get[cap $varName]"
- if {[$this getMultiplicity] == "many"} {
- set type [PBType new "classset"]
- } else {
- set type [[$this ooplType] generate]
- }
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- set qualifier [$this qualifier]
- set qualId [$qualifier getName]
- set type [[$qualifier ooplType] generate]
- set modifier [PBModifier new ""]
- set param [PBParameter new $qualId $type $modifier]
- $accessor addParameter $param
-
- # The type of a qualifier must be derived from powerobject ...
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
- # note: no cast in powerbuilder
- $sect append "return $varName.get($qualId)\n"
- }
-
- method PBGQualAttr::genRemoveQualifiedAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess r]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set ident [$this getAssocIdentifier]
-
- set name "remove[cap $ident]"
- set type [PBType new ""]
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- set qualifier [$this qualifier]
- set qualId [$qualifier getName]
- set type [[$qualifier ooplType] generate]
- set modifier [PBModifier new ""]
- set param [PBParameter new $qualId $type $modifier]
- $accessor addParameter $param
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
-
- set paramId "old[cap $ident]"
- set varName [$this getAssocVariable]
- if {[$this getMultiplicity] == "one"} {
- $sect append "powerobject object\n"
- $sect append "object = $varName.get($qualId)\n"
- $sect append "if isNull(object) then\n"
- $sect indent +
- $sect append "return\n"
- $sect indent -
- $sect append "end if\n"
- $sect append [$this reduceAssoc]
-
- if {$opposite != ""} {
- set typeName [[$this ooplType] getName]
- $sect append "$typeName $paramId\n"
- # note: no cast in powerbuilder
- $sect append "$paramId = object\n"
- }
- } else {
- set type [[$this ooplType] generate]
- set modifier [PBModifier new ""]
- set param [PBParameter new $paramId $type $modifier]
- $accessor addParameter $param
-
- $sect append "if isNull($paramId) then\n"
- $sect indent +
- $sect append "return\n"
- $sect indent -
- $sect append "end if\n"
- $sect append "classset theSet\n"
- # note: no cast in powerbuilder
- $sect append "theSet = $varName.get($qualId)\n"
- $sect append "if not isNull(theSet) then\n"
- $sect indent +
- $sect append "theSet.remove($paramId)\n"
- $sect indent -
- $sect append "end if\n"
- }
- if {$opposite != ""} {
- $sect append [$opposite reduceAssoc $paramId]
- }
- }
-
- method PBGQualAttr::genSetQualifiedAccessor {this class} {
- set opposite [$this opposite]
- if {$opposite == ""} {
- set accessStr [$this getAccessorAccess w]
- } else {
- set accessStr "public"
- }
- if {$accessStr == "none"} {
- return
- }
-
- set ident [$this getAssocIdentifier]
-
- set name "set[cap $ident]"
- set type [PBType new ""]
- set access [PBAccess new $accessStr]
-
- set accessor [PBFunction new $name $type $access]
- $class addObjectFunction $accessor
-
- set qualifier [$this qualifier]
- set qualId [$qualifier getName]
- set type [[$qualifier ooplType] generate]
- set modifier [PBModifier new ""]
- set param [PBParameter new $qualId $type $modifier]
- $accessor addParameter $param
-
- set paramId "new[cap $ident]"
- set paramType [[$this ooplType] generate]
- set modifier [PBModifier new ""]
- set param [PBParameter new $paramId $paramType $modifier]
- $accessor addParameter $param
-
- # Generate body
- #
- set sect [TextSection new]
- $accessor body $sect
- $sect append "${PBCookie::associationAccessorMethod}\n"
- $sect append "if isNull($paramId) then\n"
- $sect indent +
- $sect append "return\n"
- $sect indent -
- $sect append "end if\n"
- $sect append "[$this getAssocVariable].set($qualId, $paramId)\n"
-
- if {$opposite != ""} {
- $sect append [$opposite extendAssoc $paramId]
- }
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGQualAttrD : {PBGQualAttr OPQualAttr} {
- }
-
- selfPromoter OPQualAttr {this} {
- PBGQualAttrD promote $this
- }
-
- # File: @(#)pbgreverse.tcl /main/hindenburg/4
-
-
- Class PBGReverseLinkAttr : {PBGGenAssocAttr} {
- constructor
- method destructor
- method generate
- }
-
- constructor PBGReverseLinkAttr {class this name} {
- set this [PBGGenAssocAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGReverseLinkAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- method PBGReverseLinkAttr::generate {this globalOoplClass class} {
- if ![$this isValidAssociation] {
- return
- }
- $this genAssocVariable $class
- if {[$this getMultiplicity] == "one"} {
- $this genGetAccessor $class
- } else {
- $this genGetManyAccessor $class
- }
- $this genCtor $class
- $this genDtor $class
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGReverseLinkAttrD : {PBGReverseLinkAttr OPReverseLinkAttr} {
- }
-
- selfPromoter OPReverseLinkAttr {this} {
- PBGReverseLinkAttrD promote $this
- }
-
- # File: @(#)pbgqualass.tcl /main/hindenburg/2
-
-
- Class PBGQualAssocAttr : {PBGQualAttr} {
- constructor
- method destructor
- }
-
- constructor PBGQualAssocAttr {class this name} {
- set this [PBGQualAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGQualAssocAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGQualAssocAttrD : {PBGQualAssocAttr OPQualAssocAttr} {
- }
-
- selfPromoter OPQualAssocAttr {this} {
- PBGQualAssocAttrD promote $this
- }
-
- # File: @(#)pbgquallin.tcl /main/hindenburg/2
-
-
- Class PBGQualLinkAttr : {PBGQualAttr} {
- constructor
- method destructor
- }
-
- constructor PBGQualLinkAttr {class this name} {
- set this [PBGQualAttr::constructor $class $this $name]
- # Start constructor user section
- # End constructor user section
- return $this
- }
-
- method PBGQualLinkAttr::destructor {this} {
- # Start destructor user section
- # End destructor user section
- }
-
- # Do not delete this line -- regeneration end marker
-
- Class PBGQualLinkAttrD : {PBGQualLinkAttr OPQualLinkAttr} {
- }
-
- selfPromoter OPQualLinkAttr {this} {
- PBGQualLinkAttrD promote $this
- }
-