home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / pbtarget.tcl < prev    next >
Text File  |  1997-11-07  |  69KB  |  2,534 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1997 by Cayenne Software, Inc.
  4. #
  5. # This software is furnished under a license and may be used only in
  6. # accordance with the terms of such license and with the inclusion of
  7. # the above copyright notice. This software or any other copies thereof
  8. # may not be provided or otherwise made available to any other person.
  9. # No title to and ownership of the software is hereby transferred.
  10. #
  11. # The information in this software is subject to change without notice
  12. # and should not be construed as a commitment by Cayenne Software, Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #       File            : pbtarget.tcl
  17. #       Author          : 
  18. #       Original date   : November 1997
  19. #       Description     : Classes for code generation
  20. #
  21. #---------------------------------------------------------------------------
  22.  
  23. #---------------------------------------------------------------------------
  24. #      File:           @(#)pbaccess.tcl    /main/titanic/1
  25. #---------------------------------------------------------------------------
  26.  
  27. # Start user added include file section
  28. # End user added include file section
  29.  
  30.  
  31. Class PBAccess : {GCObject} {
  32.     constructor
  33.     method destructor
  34.     method generate
  35.     attribute accessRight
  36. }
  37.  
  38. constructor PBAccess {class this i_accessRight} {
  39.     set this [GCObject::constructor $class $this]
  40.     $this accessRight $i_accessRight
  41.     # Start constructor user section
  42.     # End constructor user section
  43.     return $this
  44. }
  45.  
  46. method PBAccess::destructor {this} {
  47.     # Start destructor user section
  48.     # End destructor user section
  49. }
  50.  
  51. method PBAccess::generate {this} {
  52.     return [$this accessRight]
  53. }
  54.  
  55. # Do not delete this line -- regeneration end marker
  56.  
  57. #---------------------------------------------------------------------------
  58. #      File:           @(#)pbbuiltinp.tcl    /main/titanic/2
  59. #---------------------------------------------------------------------------
  60.  
  61. # Start user added include file section
  62. # End user added include file section
  63.  
  64.  
  65. Class PBBuiltinProperty : {GCObject} {
  66.     constructor
  67.     method destructor
  68.     method generate
  69.     method clone
  70.     attribute name
  71.     attribute type
  72.     attribute value
  73.     attribute where
  74. }
  75.  
  76. global PBBuiltinProperty::InTypeDef
  77. set PBBuiltinProperty::InTypeDef 0
  78.  
  79. global PBBuiltinProperty::InOnCreate
  80. set PBBuiltinProperty::InOnCreate 1
  81.  
  82.  
  83. constructor PBBuiltinProperty {class this i_name i_type i_value} {
  84.     set this [GCObject::constructor $class $this]
  85.     $this name $i_name
  86.     $this type $i_type
  87.     $this value $i_value
  88.     # Start constructor user section
  89.  
  90.     # initialize 'where'
  91.     $this where ${PBBuiltinProperty::InTypeDef}
  92.  
  93.     # End constructor user section
  94.     return $this
  95. }
  96.  
  97. method PBBuiltinProperty::destructor {this} {
  98.     # Start destructor user section
  99.     # End destructor user section
  100. }
  101.  
  102. method PBBuiltinProperty::generate {this} {
  103.     if {[$this where] == ${PBBuiltinProperty::InTypeDef}} {
  104.         return "[$this type] [$this name] = [$this value]"
  105.     }
  106.     if {[$this where] == ${PBBuiltinProperty::InOnCreate}} {
  107.         return "this.[$this name] = [$this value]"
  108.     }
  109.     return ""
  110. }
  111.  
  112. method PBBuiltinProperty::clone {this} {
  113.     return [PBBuiltinProperty new [$this name] [$this type] [$this value] \
  114.         -where [$this where]]
  115. }
  116.  
  117. # Do not delete this line -- regeneration end marker
  118.  
  119. #---------------------------------------------------------------------------
  120. #      File:           @(#)pbclasskin.tcl    /main/titanic/1
  121. #---------------------------------------------------------------------------
  122.  
  123. # Start user added include file section
  124. # End user added include file section
  125.  
  126.  
  127. Class PBClassKind : {GCObject} {
  128.     constructor
  129.     method destructor
  130. }
  131.  
  132. global PBClassKind::Window
  133. set PBClassKind::Window "Window"
  134.  
  135. global PBClassKind::Menu
  136. set PBClassKind::Menu "Menu"
  137.  
  138. global PBClassKind::Structure
  139. set PBClassKind::Structure "Structure"
  140.  
  141. global PBClassKind::VCUserObject
  142. set PBClassKind::VCUserObject "VisualCustomUserObject"
  143.  
  144. global PBClassKind::VSUserObject
  145. set PBClassKind::VSUserObject "VisualStandardUserObject"
  146.  
  147. global PBClassKind::CCUserObject
  148. set PBClassKind::CCUserObject "ClassCustomUserObject"
  149.  
  150. global PBClassKind::CSUserObject
  151. set PBClassKind::CSUserObject "ClassStandardUserObject"
  152.  
  153. global PBClassKind::NotSupported
  154. set PBClassKind::NotSupported "NotSupported"
  155.  
  156.  
  157. constructor PBClassKind {class this} {
  158.     set this [GCObject::constructor $class $this]
  159.     # Start constructor user section
  160.     # End constructor user section
  161.     return $this
  162. }
  163.  
  164. method PBClassKind::destructor {this} {
  165.     # Start destructor user section
  166.     # End destructor user section
  167. }
  168.  
  169. # Do not delete this line -- regeneration end marker
  170.  
  171. #---------------------------------------------------------------------------
  172. #      File:           @(#)pbcookie.tcl    /main/titanic/3
  173. #---------------------------------------------------------------------------
  174.  
  175. # Start user added include file section
  176. # End user added include file section
  177.  
  178.  
  179. Class PBCookie : {GCObject} {
  180.     constructor
  181.     method destructor
  182. }
  183.  
  184. global PBCookie::implementThisFunction
  185. set PBCookie::implementThisFunction "// Implement this function !!"
  186.  
  187. global PBCookie::implementThisEvent
  188. set PBCookie::implementThisEvent "// Implement this event !!"
  189.  
  190. global PBCookie::dataAttributeSection
  191. set PBCookie::dataAttributeSection "// User defined attributes"
  192.  
  193. global PBCookie::associationAttributeSection
  194. set PBCookie::associationAttributeSection "// Association attributes"
  195.  
  196. global PBCookie::nonModeledAttributeSection
  197. set PBCookie::nonModeledAttributeSection "// Non modeled user defined attributes"
  198.  
  199. global PBCookie::associationAccessorMethod
  200. set PBCookie::associationAccessorMethod "// Association accessor method"
  201.  
  202. global PBCookie::startUserSection
  203. set PBCookie::startUserSection "// Start user code section"
  204.  
  205. global PBCookie::endUserSection
  206. set PBCookie::endUserSection "// End user code section"
  207.  
  208. global PBCookie::startBinaryDataSection
  209. set PBCookie::startBinaryDataSection "Start of PowerBuilder Binary Data Section : Do NOT Edit"
  210.  
  211. global PBCookie::endBinaryDataSection
  212. set PBCookie::endBinaryDataSection "End of PowerBuilder Binary Data Section : No Source Expected After This Point"
  213.  
  214. global PBCookie::controlClassMapSection
  215. set PBCookie::controlClassMapSection "// Control to class mappings"
  216.  
  217.  
  218. constructor PBCookie {class this} {
  219.     set this [GCObject::constructor $class $this]
  220.     # Start constructor user section
  221.     # End constructor user section
  222.     return $this
  223. }
  224.  
  225. method PBCookie::destructor {this} {
  226.     # Start destructor user section
  227.     # End destructor user section
  228. }
  229.  
  230. # Do not delete this line -- regeneration end marker
  231.  
  232. #---------------------------------------------------------------------------
  233. #      File:           @(#)pbdefiniti.tcl    /main/titanic/4
  234. #---------------------------------------------------------------------------
  235.  
  236. # Start user added include file section
  237. # End user added include file section
  238.  
  239.  
  240. Class PBDefinition : {GCObject} {
  241.     constructor
  242.     method destructor
  243.     method getGlobalDefinition
  244.     method controlPresentInSupers
  245.     method libraryEntry
  246.     attribute name
  247.     attribute isGlobalType
  248.     attribute isRegenerated
  249.     attribute _libraryEntry
  250.     attribute ooplClass
  251. }
  252.  
  253. constructor PBDefinition {class this i_name ooplClass} {
  254.     set this [GCObject::constructor $class $this]
  255.     $this isGlobalType 1
  256.     $this isRegenerated 0
  257.     $this name $i_name
  258.     $this ooplClass $ooplClass
  259.     # Start constructor user section
  260.     # End constructor user section
  261.     return $this
  262. }
  263.  
  264. method PBDefinition::destructor {this} {
  265.     # Start destructor user section
  266.     # End destructor user section
  267. }
  268.  
  269. method PBDefinition::getGlobalDefinition {this} {
  270.     return $this
  271. }
  272.  
  273. method PBDefinition::controlPresentInSupers {this name} {
  274.     set ooplClass [$this ooplClass]
  275.     if {$ooplClass == ""} {
  276.         return 0
  277.     }
  278.     # look in oopl model for the control 
  279.     while {($ooplClass != "") && \
  280.                !([$ooplClass isBuiltin]) } {
  281.         if {[PBDefinition::controlPresentInSuper $ooplClass $name]} {
  282.             return 1
  283.         }
  284.         set ooplClass [$ooplClass getSuperClass]
  285.     }
  286.     return 0
  287. }
  288.  
  289. proc PBDefinition::controlPresentInSuper {ooplClass name} {
  290.     if {($ooplClass == "") || \
  291.             ([$ooplClass isBuiltin])} {
  292.         return 0
  293.     }
  294.     set assocSet [$ooplClass genAssocAttrSet]
  295.     foreach assoc $assocSet {
  296.         set oppClass [$assoc getOppositeClass]
  297.         set assocName [$assoc getName]
  298.         if {$assocName == $name} {
  299.             return 1
  300.         }
  301.         if {[PBDefinition::controlPresentInSuper $oppClass $name]} {
  302.             return 1
  303.         }
  304.     }
  305.     return 0
  306. }
  307.  
  308. # Do not delete this line -- regeneration end marker
  309.  
  310. method PBDefinition::libraryEntry {this args} {
  311.     if {$args == ""} {
  312.         return [$this _libraryEntry]
  313.     }
  314.     set ref [$this _libraryEntry]
  315.     if {$ref != ""} {
  316.         $ref _globalDefinition ""
  317.     }
  318.     set obj [lindex $args 0]
  319.     if {$obj != ""} {
  320.         $obj _globalDefinition $this
  321.     }
  322.     $this _libraryEntry $obj
  323. }
  324.  
  325. #---------------------------------------------------------------------------
  326. #      File:           @(#)pbfeature.tcl    /main/titanic/1
  327. #---------------------------------------------------------------------------
  328.  
  329. # Start user added include file section
  330. # End user added include file section
  331.  
  332.  
  333. Class PBFeature : {GCObject} {
  334.     constructor
  335.     method destructor
  336.     attribute name
  337.     attribute type
  338. }
  339.  
  340. constructor PBFeature {class this i_name type} {
  341.     set this [GCObject::constructor $class $this]
  342.     $this name $i_name
  343.     $this type $type
  344.     # Start constructor user section
  345.     # End constructor user section
  346.     return $this
  347. }
  348.  
  349. method PBFeature::destructor {this} {
  350.     # Start destructor user section
  351.     # End destructor user section
  352. }
  353.  
  354. # Do not delete this line -- regeneration end marker
  355.  
  356. #---------------------------------------------------------------------------
  357. #      File:           @(#)pblibrarye.tcl    /main/titanic/3
  358. #---------------------------------------------------------------------------
  359.  
  360. # Start user added include file section
  361. # End user added include file section
  362.  
  363.  
  364. Class PBLibraryEntry : {GCObject} {
  365.     constructor
  366.     method destructor
  367.     method getName
  368.     method getKind
  369.     method getFileType
  370.     method getSrcFileType
  371.     method generate
  372.     method genExportHeader
  373.     method genExportComments
  374.     method model
  375.     method globalDefinition
  376.     attribute _model
  377.     attribute _globalDefinition
  378.     attribute exportComments
  379. }
  380.  
  381. constructor PBLibraryEntry {class this model globalDefinition} {
  382.     set this [GCObject::constructor $class $this]
  383.     $this _model $model
  384.     [$model _libraryEntrySet] append $this
  385.     $this _globalDefinition $globalDefinition
  386.     $globalDefinition _libraryEntry $this
  387.     # Start constructor user section
  388.     $this exportComments ""
  389.     # End constructor user section
  390.     return $this
  391. }
  392.  
  393. method PBLibraryEntry::destructor {this} {
  394.     # Start destructor user section
  395.     # End destructor user section
  396. }
  397.  
  398. method PBLibraryEntry::getName {this} {
  399.     return [[$this globalDefinition] name]
  400. }
  401.  
  402. method PBLibraryEntry::getKind {this} {
  403.     return [[$this globalDefinition] getKind]
  404. }
  405.  
  406. method PBLibraryEntry::getFileType {this} {
  407.     set kind [$this getKind]
  408.  
  409.     return [PBLibraryEntry::getFileTypeByKind $kind]
  410. }
  411.  
  412. proc PBLibraryEntry::getFileTypeByKind {kind} {
  413.     if {$kind == ${PBClassKind::Window}} {
  414.         return "window"
  415.     } elseif {$kind == ${PBClassKind::Menu}} {
  416.         return "menu"
  417.     } elseif {$kind == ${PBClassKind::Structure}} {
  418.         return "structure"
  419.     } elseif {$kind == ${PBClassKind::VCUserObject} ||
  420.             $kind == ${PBClassKind::VSUserObject} ||
  421.             $kind == ${PBClassKind::CCUserObject} ||
  422.             $kind == ${PBClassKind::CSUserObject}} {
  423.         return "userobject"
  424.     }
  425.     return ""
  426. }
  427.  
  428. method PBLibraryEntry::getSrcFileType {this} {
  429.     set fileType [$this getFileType]
  430.  
  431.     return [PBLibraryEntry::getSrcFileTypeByFileType $fileType]
  432. }
  433.  
  434. proc PBLibraryEntry::getSrcFileTypeByFileType {fileType} {
  435.     if {$fileType == ""} {
  436.         return ""
  437.     }
  438.     return "sr[string index $fileType 0]"
  439. }
  440.  
  441. method PBLibraryEntry::generate {this} {
  442.     set sect [TextSection new]
  443.     $this genExportHeader $sect
  444.     $this genExportComments $sect
  445.     [$this globalDefinition] generate $sect
  446.     return $sect
  447. }
  448.  
  449. method PBLibraryEntry::genExportHeader {this sect} {
  450.     $sect append \
  451.         "\$PBExportHeader\$[$this getName].[$this getSrcFileType]\n"
  452. }
  453.  
  454. method PBLibraryEntry::genExportComments {this sect} {
  455.     if {[$this exportComments] != ""} {
  456.         set comment [$this exportComments]
  457.     } else {
  458.         set comment "Generated by ObjectTeam"
  459.     }
  460.     $sect append "\$PBExportComments\$$comment\n"
  461. }
  462.  
  463. # Do not delete this line -- regeneration end marker
  464.  
  465. method PBLibraryEntry::model {this args} {
  466.     if {$args == ""} {
  467.         return [$this _model]
  468.     }
  469.     set ref [$this _model]
  470.     if {$ref != ""} {
  471.         [$ref _libraryEntrySet] removeValue $this
  472.     }
  473.     set obj [lindex $args 0]
  474.     if {$obj != ""} {
  475.         [$obj _libraryEntrySet] append $this
  476.     }
  477.     $this _model $obj
  478. }
  479.  
  480. method PBLibraryEntry::globalDefinition {this args} {
  481.     if {$args == ""} {
  482.         return [$this _globalDefinition]
  483.     }
  484.     set ref [$this _globalDefinition]
  485.     if {$ref != ""} {
  486.         $ref _libraryEntry ""
  487.     }
  488.     set obj [lindex $args 0]
  489.     if {$obj != ""} {
  490.         $obj _libraryEntry $this
  491.     }
  492.     $this _globalDefinition $obj
  493. }
  494.  
  495. #---------------------------------------------------------------------------
  496. #      File:           @(#)pbmodel.tcl    /main/titanic/1
  497. #---------------------------------------------------------------------------
  498.  
  499. # Start user added include file section
  500. # End user added include file section
  501.  
  502.  
  503. Class PBModel : {GCObject} {
  504.     constructor
  505.     method destructor
  506.     method generate
  507.     method findLibraryEntry
  508.     method libraryEntrySet
  509.     method addLibraryEntry
  510.     method removeLibraryEntry
  511.     attribute _libraryEntrySet
  512. }
  513.  
  514. constructor PBModel {class this} {
  515.     set this [GCObject::constructor $class $this]
  516.     $this _libraryEntrySet [List new]
  517.     # Start constructor user section
  518.     # End constructor user section
  519.     return $this
  520. }
  521.  
  522. method PBModel::destructor {this} {
  523.     # Start destructor user section
  524.     # End destructor user section
  525. }
  526.  
  527. method PBModel::generate {this TypeToClassDict} {
  528.     [$this libraryEntrySet] foreach entry {
  529.         set sectionDict [Dictionary new]
  530.         $sectionDict set [$entry getFileType] [$entry generate]
  531.         set ooplClass [[$entry globalDefinition] ooplClass]
  532.         $TypeToClassDict set $ooplClass $sectionDict
  533.     }
  534. }
  535.  
  536. method PBModel::findLibraryEntry {this name kind} {
  537.     [$this libraryEntrySet] foreach entry {
  538.         if {[$entry getName] == $name && [$entry getKind] == $kind} {
  539.             return $entry
  540.         }
  541.     }
  542.  
  543.     return ""
  544. }
  545.  
  546. # Do not delete this line -- regeneration end marker
  547.  
  548. method PBModel::libraryEntrySet {this} {
  549.     return [$this _libraryEntrySet]
  550. }
  551.  
  552. method PBModel::addLibraryEntry {this newLibraryEntry} {
  553.     [$this _libraryEntrySet] append $newLibraryEntry
  554.     $newLibraryEntry _model $this
  555. }
  556.  
  557. method PBModel::removeLibraryEntry {this oldLibraryEntry} {
  558.     $oldLibraryEntry _model ""
  559.     [$this _libraryEntrySet] removeValue $oldLibraryEntry
  560. }
  561.  
  562. #---------------------------------------------------------------------------
  563. #      File:           @(#)pbmodifier.tcl    /main/titanic/1
  564. #---------------------------------------------------------------------------
  565.  
  566. # Start user added include file section
  567. # End user added include file section
  568.  
  569.  
  570. Class PBModifier : {GCObject} {
  571.     constructor
  572.     method destructor
  573.     method generate
  574.     attribute name
  575. }
  576.  
  577. constructor PBModifier {class this i_name} {
  578.     set this [GCObject::constructor $class $this]
  579.     $this name $i_name
  580.     # Start constructor user section
  581.     # End constructor user section
  582.     return $this
  583. }
  584.  
  585. method PBModifier::destructor {this} {
  586.     # Start destructor user section
  587.     # End destructor user section
  588. }
  589.  
  590. method PBModifier::generate {this} {
  591.     return [$this name]
  592. }
  593.  
  594. # Do not delete this line -- regeneration end marker
  595.  
  596. #---------------------------------------------------------------------------
  597. #      File:           @(#)pbtype.tcl    /main/titanic/1
  598. #---------------------------------------------------------------------------
  599.  
  600. # Start user added include file section
  601. # End user added include file section
  602.  
  603.  
  604. Class PBType : {GCObject} {
  605.     constructor
  606.     method destructor
  607.     method generate
  608.     attribute name
  609. }
  610.  
  611. constructor PBType {class this i_name} {
  612.     set this [GCObject::constructor $class $this]
  613.     $this name $i_name
  614.     # Start constructor user section
  615.     # End constructor user section
  616.     return $this
  617. }
  618.  
  619. method PBType::destructor {this} {
  620.     # Start destructor user section
  621.     # End destructor user section
  622. }
  623.  
  624. method PBType::generate {this} {
  625.     return [$this name]
  626. }
  627.  
  628. # Do not delete this line -- regeneration end marker
  629.  
  630. #---------------------------------------------------------------------------
  631. #      File:           @(#)pbclass.tcl    /main/titanic/11
  632. #---------------------------------------------------------------------------
  633.  
  634. # Start user added include file section
  635. # End user added include file section
  636.  
  637.  
  638. Class PBClass : {PBDefinition} {
  639.     constructor
  640.     method destructor
  641.     method generate
  642.     method generateForward
  643.     method generateTypeDef
  644.     method generateInstanceVars
  645.     method generateDerivedControls
  646.     method generateControlClassMapping
  647.     method genOnCreateBody
  648.     method genOnDestroyBody
  649.     method genTypeSignature
  650.     method findObjectStructure
  651.     method findObjectFunctions
  652.     method findObjectFunction
  653.     method findUserEvent
  654.     method findScript
  655.     method findEvent
  656.     method matchObjectFunction
  657.     method matchEvent
  658.     method objectStructureSet
  659.     method addObjectStructure
  660.     method removeObjectStructure
  661.     method addInstanceVar
  662.     method removeInstanceVar
  663.     method addAssocInstanceVar
  664.     method removeAssocInstanceVar
  665.     method addSharedVar
  666.     method removeSharedVar
  667.     method addObjectFunction
  668.     method removeObjectFunction
  669.     method addUserEvent
  670.     method removeUserEvent
  671.     method addScript
  672.     method removeScript
  673.     attribute superClassName
  674.     attribute builtinSuperClassName
  675.     attribute nonModeledSharedVars
  676.     attribute _objectStructureSet
  677.     attribute instanceVarSet
  678.     attribute assocInstanceVarSet
  679.     attribute sharedVarSet
  680.     attribute objectFunctionSet
  681.     attribute userEventSet
  682.     attribute scriptSet
  683.     attribute onDestroyBody
  684.     attribute onCreateBody
  685.     attribute localExternalFuncs
  686.     attribute nonModeledInstanceVars
  687. }
  688.  
  689. constructor PBClass {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  690.     set this [PBDefinition::constructor $class $this $i_name $ooplClass]
  691.     $this superClassName $i_superClassName
  692.     $this builtinSuperClassName $i_builtinSuperClassName
  693.     $this _objectStructureSet [List new]
  694.     $this instanceVarSet [List new]
  695.     $this assocInstanceVarSet [List new]
  696.     $this sharedVarSet [List new]
  697.     $this objectFunctionSet [List new]
  698.     $this userEventSet [List new]
  699.     $this scriptSet [List new]
  700.     # Start constructor user section
  701.     # End constructor user section
  702.     return $this
  703. }
  704.  
  705. method PBClass::destructor {this} {
  706.     # Start destructor user section
  707.     # End destructor user section
  708.     $this PBDefinition::destructor
  709. }
  710.  
  711. method PBClass::generate {this sect} {
  712.     if [$this isGlobalType] {
  713.         # Generate forward
  714.         #
  715.         $sect append "forward\n"
  716.         $this generateForward $sect
  717.         $sect append "end forward\n\n"
  718.  
  719.         # Generate object structures
  720.         #
  721.         [$this objectStructureSet] foreach struct {
  722.             $struct generate $sect
  723.             $sect append "\n"
  724.         }
  725.  
  726.         # Generate shared variables
  727.         #
  728.         $sect append "shared variables\n"
  729.         $sect append "${PBCookie::dataAttributeSection}\n"
  730.         [$this sharedVarSet] foreach var {
  731.             $var generate $sect
  732.             $sect append "\n"
  733.         }
  734.         $sect append "\n${PBCookie::nonModeledAttributeSection}\n"
  735.         if {[$this nonModeledSharedVars] != ""} {
  736.             $sect appendSect [$this nonModeledSharedVars]
  737.         }
  738.         $sect append "\n"
  739.         $sect append "end variables\n\n"
  740.     }
  741.  
  742.     # Generate type definition
  743.     #
  744.     $sect append "[$this genTypeSignature]\n"
  745.     $this generateTypeDef $sect
  746.     $sect append "end type\n"
  747.  
  748.     if [$this isGlobalType] {
  749.         # Generate global reference variable declaration
  750.         #
  751.         $sect append "global [$this name] [$this name]\n\n"
  752.  
  753.         # Generate type prototypes (i.e. local external functions)
  754.         #
  755.         if {[$this localExternalFuncs] != ""} {
  756.             $sect append "type prototypes\n"
  757.             $sect appendSect [$this localExternalFuncs]
  758.             $sect append "end prototypes\n\n"
  759.         }
  760.  
  761.         # Generate instance variables
  762.         #
  763.         $sect append "type variables\n"
  764.         $this generateInstanceVars $sect
  765.         $sect append "end variables\n\n"
  766.  
  767.         # Generate function prototypes
  768.         #
  769.         set defSect [TextSection new]
  770.         if ![[$this objectFunctionSet] empty] {
  771.             $sect append "forward prototypes\n"
  772.             [$this objectFunctionSet] foreach func {
  773.                 $func generate $sect $defSect
  774.                 $defSect append "\n"
  775.             }
  776.             $sect append "end prototypes\n\n"
  777.         }
  778.     } else {
  779.         $sect append "\n"
  780.     }
  781.  
  782.     # Generate user event bodies
  783.     #
  784.     [$this userEventSet] foreach event {
  785.         $event generate $sect "eventDefinition"
  786.         $sect append "\n"
  787.     }
  788.  
  789.     if [$this isGlobalType] {
  790.         # Generate function bodies
  791.         #
  792.         if {[$defSect contents] != ""} {
  793.             $sect appendSect $defSect
  794.         }
  795.     }
  796.     
  797.     # Generate on create & on destroy
  798.     #
  799.     $this genOnCreateBody
  800.     set bodySect [$this onCreateBody]
  801.     if {$bodySect != "" && [$bodySect contents] != ""} {
  802.         $sect append "on [$this name].create\n"
  803.         $sect appendSect $bodySect
  804.         $sect append "end on\n\n"
  805.     }
  806.     $this genOnDestroyBody
  807.     set bodySect [$this onDestroyBody]
  808.     if {$bodySect != "" && [$bodySect contents] != ""} {
  809.         $sect append "on [$this name].destroy\n"
  810.         $sect appendSect $bodySect
  811.         $sect append "end on\n\n"
  812.     }
  813.  
  814.     # Generate script bodies
  815.     #
  816.     [$this scriptSet] foreach script {
  817.         $script generate $sect "eventDefinition"
  818.         $sect append "\n"
  819.     }
  820.  
  821.     if [$this isGlobalType] {
  822.         # Generate derived ControlClass creatrion bodies for
  823.         #    menus and redefined events of controls defined
  824.         #    in super classes
  825.         $this generateDerivedControls $sect
  826.     }
  827.  
  828. }
  829.  
  830. method PBClass::generateForward {this sect} {
  831.     $sect append "[$this genTypeSignature]\n"
  832.     $sect append "end type\n"
  833. }
  834.  
  835. method PBClass::generateTypeDef {this sect} {
  836.     # Generate event declarations
  837.     #
  838.     [$this userEventSet] foreach event {
  839.         $event generate $sect "eventDeclaration"
  840.         $sect append "\n"
  841.     }
  842. }
  843.  
  844. method PBClass::generateInstanceVars {this sect} {
  845.     $sect append "${PBCookie::dataAttributeSection}\n"
  846.     [$this instanceVarSet] foreach var {
  847.         $var generate $sect
  848.         $sect append "\n"
  849.     }
  850.     $sect append "\n${PBCookie::associationAttributeSection}\n"
  851.     [$this assocInstanceVarSet] foreach var {
  852.         $var generate $sect
  853.         $sect append "\n"
  854.     }
  855.     $sect append "\n${PBCookie::nonModeledAttributeSection}\n"
  856.     if {[$this nonModeledInstanceVars] != ""} {
  857.         $sect appendSect [$this nonModeledInstanceVars]
  858.     }
  859.     $sect append "\n"
  860.     $sect append "${PBCookie::controlClassMapSection}\n"
  861.     $this generateControlClassMapping $sect
  862. }
  863.  
  864. method PBClass::generateDerivedControls {this sect} {
  865.     # Default no 'DerivedControls' part
  866.     #
  867. }
  868.  
  869. method PBClass::generateControlClassMapping {this sect} {
  870.     set ooplClass [$this ooplClass]
  871.     if {[$this ooplClass] != ""} {
  872.         $sect append "//    [$this name] --> [$ooplClass getName]\n"
  873.     }
  874.     # Generate for object structures
  875.     [$this objectStructureSet] foreach struct {
  876.         $sect append "//    [$struct name] --> [[$struct ooplClass] getName]\n"
  877.     }
  878. }
  879.  
  880. method PBClass::genOnCreateBody {this} {
  881.     # Default no 'on create' part
  882.     #
  883. }
  884.  
  885. method PBClass::genOnDestroyBody {this} {
  886.     # Default no 'on destroy' part
  887.     #
  888. }
  889.  
  890. method PBClass::genTypeSignature {this} {
  891.     set signature ""
  892.     if [$this isGlobalType] {
  893.         set signature "global "
  894.     }
  895.     set signature \
  896.         "${signature}type [$this name] from [$this superClassName]"
  897.     return $signature
  898. }
  899.  
  900. method PBClass::findObjectStructure {this name} {
  901.     set name [string tolower $name]
  902.     [$this objectStructureSet] foreach struct {
  903.         if {[string tolower [$struct name]] == $name} {
  904.             return $struct
  905.         }
  906.     }
  907.  
  908.     return ""
  909. }
  910.  
  911. method PBClass::findObjectFunctions {this name} {
  912.     set list [List new]
  913.     set name [string tolower $name]
  914.  
  915.     [$this objectFunctionSet] foreach func {
  916.         if {[string tolower [$func name]] == $name} {
  917.             $list append $func
  918.         }
  919.     }
  920.  
  921.     return $list
  922. }
  923.  
  924. method PBClass::findObjectFunction {this name argTypes} {
  925.     set name [string tolower $name]
  926.  
  927.     [$this objectFunctionSet] foreach func {
  928.         if {[string tolower [$func name]] != $name} {
  929.             continue
  930.         }
  931.         set paramTypes [list]
  932.         [$func parameterSet] foreach param {
  933.             lappend paramTypes [string tolower [[$param type] name]]
  934.         }
  935.         if {$paramTypes == [string tolower [$argTypes contents]]} {
  936.             return $func
  937.         }
  938.     }
  939.  
  940.     return ""
  941. }
  942.  
  943. method PBClass::findUserEvent {this name} {
  944.     set name [string tolower $name]
  945.  
  946.     [$this userEventSet] foreach event {
  947.         if {[string tolower [$event name]] == $name} {
  948.             return $event
  949.         }
  950.     }
  951.  
  952.     return ""
  953. }
  954.  
  955. method PBClass::findScript {this name} {
  956.     set name [string tolower $name]
  957.  
  958.     [$this scriptSet] foreach script {
  959.         if {[string tolower [$script name]] == $name} {
  960.             return $script
  961.         }
  962.     }
  963.  
  964.     return ""
  965. }
  966.  
  967. method PBClass::findEvent {this name} {
  968.     set event [$this findScript $name]
  969.     if {$event == "" } {
  970.         set event [$this findUserEvent $name]
  971.     }
  972.     return $event
  973. }
  974.  
  975. method PBClass::matchObjectFunction {this name} {
  976.     # finds a function with the same name with an empty body
  977.     # because of overloadeing the argument type (and number) 
  978.     # does not have to match
  979.     set name [string tolower $name]
  980.  
  981.     [$this objectFunctionSet] foreach func {
  982.         if {[string tolower [$func name]] == $name} {
  983.             if {[$func body] == ""} {
  984.                 return $func
  985.             }
  986.         }
  987.     }
  988.     return ""    
  989. }
  990.  
  991. method PBClass::matchEvent {this name} {
  992.     # finds a event with the same name with an empty body
  993.     # because there is no overloading there's no need for
  994.     # finding a following match like at functions.
  995.     set name [string tolower $name]
  996.     
  997.     set event [$this findEvent $name]
  998.     if {$event != ""} {
  999.         if {[$event body] == ""} {
  1000.             return $event
  1001.         }
  1002.     }
  1003.     return ""
  1004. }
  1005.  
  1006. # Do not delete this line -- regeneration end marker
  1007.  
  1008. method PBClass::objectStructureSet {this} {
  1009.     return [$this _objectStructureSet]
  1010. }
  1011.  
  1012. method PBClass::addObjectStructure {this newObjectStructure} {
  1013.     [$this _objectStructureSet] append $newObjectStructure
  1014.     $newObjectStructure _theClass $this
  1015. }
  1016.  
  1017. method PBClass::removeObjectStructure {this oldObjectStructure} {
  1018.     $oldObjectStructure _theClass ""
  1019.     [$this _objectStructureSet] removeValue $oldObjectStructure
  1020. }
  1021.  
  1022. method PBClass::addInstanceVar {this newInstanceVar} {
  1023.     [$this instanceVarSet] append $newInstanceVar
  1024.  
  1025. }
  1026.  
  1027. method PBClass::removeInstanceVar {this oldInstanceVar} {
  1028.     [$this instanceVarSet] removeValue $oldInstanceVar
  1029. }
  1030.  
  1031. method PBClass::addAssocInstanceVar {this newAssocInstanceVar} {
  1032.     [$this assocInstanceVarSet] append $newAssocInstanceVar
  1033.  
  1034. }
  1035.  
  1036. method PBClass::removeAssocInstanceVar {this oldAssocInstanceVar} {
  1037.     [$this assocInstanceVarSet] removeValue $oldAssocInstanceVar
  1038. }
  1039.  
  1040. method PBClass::addSharedVar {this newSharedVar} {
  1041.     [$this sharedVarSet] append $newSharedVar
  1042.  
  1043. }
  1044.  
  1045. method PBClass::removeSharedVar {this oldSharedVar} {
  1046.     [$this sharedVarSet] removeValue $oldSharedVar
  1047. }
  1048.  
  1049. method PBClass::addObjectFunction {this newObjectFunction} {
  1050.     [$this objectFunctionSet] append $newObjectFunction
  1051.  
  1052. }
  1053.  
  1054. method PBClass::removeObjectFunction {this oldObjectFunction} {
  1055.     [$this objectFunctionSet] removeValue $oldObjectFunction
  1056. }
  1057.  
  1058. method PBClass::addUserEvent {this newUserEvent} {
  1059.     [$this userEventSet] append $newUserEvent
  1060.  
  1061. }
  1062.  
  1063. method PBClass::removeUserEvent {this oldUserEvent} {
  1064.     [$this userEventSet] removeValue $oldUserEvent
  1065. }
  1066.  
  1067. method PBClass::addScript {this newScript} {
  1068.     [$this scriptSet] append $newScript
  1069.  
  1070. }
  1071.  
  1072. method PBClass::removeScript {this oldScript} {
  1073.     [$this scriptSet] removeValue $oldScript
  1074. }
  1075.  
  1076. #---------------------------------------------------------------------------
  1077. #      File:           @(#)pbvisual.tcl    /main/titanic/7
  1078. #---------------------------------------------------------------------------
  1079.  
  1080. # Start user added include file section
  1081. # End user added include file section
  1082.  
  1083.  
  1084. Class PBVisual : {PBClass} {
  1085.     constructor
  1086.     method destructor
  1087.     method generate
  1088.     method genTypeSignature
  1089.     method generateTypeDef
  1090.     method generateControlClassMapping
  1091.     method genOnCreateBody
  1092.     method genOnDestroyBody
  1093.     method generateBuiltinProperties
  1094.     method getGlobalDefinition
  1095.     method setBuiltinProperty
  1096.     method removeBuiltinProperty
  1097.     method addSortedNameKey
  1098.     method removeSortedNameKey
  1099.     method getBuiltinProperty
  1100.     attribute container
  1101.     attribute sortedNameKeySet
  1102.     attribute onDestroyResidue
  1103.     attribute onCreateResidue
  1104.     attribute builtinProperty
  1105. }
  1106.  
  1107. constructor PBVisual {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  1108.     set this [PBClass::constructor $class $this $i_name $ooplClass $i_superClassName $i_builtinSuperClassName]
  1109.     $this sortedNameKeySet [List new]
  1110.     $this builtinProperty [Dictionary new]
  1111.     # Start constructor user section
  1112.     # End constructor user section
  1113.     return $this
  1114. }
  1115.  
  1116. method PBVisual::destructor {this} {
  1117.     # Start destructor user section
  1118.     # End destructor user section
  1119.     $this PBClass::destructor
  1120. }
  1121.  
  1122. method PBVisual::generate {this sect} {
  1123.     # If this a newly generated object, provide some default property
  1124.     # settings.
  1125.     #
  1126.     if ![$this isRegenerated] {
  1127.         set classInfo [[PBBuiltinInfo::global] \
  1128.             getBuiltinClass [$this builtinSuperClassName]]
  1129.         if {$classInfo != ""} {
  1130.             [$classInfo mandatoryProp] foreach propName prop {
  1131.                 $this setBuiltinProperty $propName [$prop clone]
  1132.             }
  1133.             set residue [$classInfo initialOnCreateResidue]
  1134.             if {$residue != ""} {
  1135.                 # no need to clone the TextSection here
  1136.                 $this onCreateResidue $residue
  1137.             }
  1138.             set residue [$classInfo initialOnDestroyResidue]
  1139.             if {$residue != ""} {
  1140.                 # no need to clone the TextSection here
  1141.                 $this onDestroyResidue $residue
  1142.             }
  1143.         }
  1144.     }
  1145.     $this PBClass::generate $sect
  1146. }
  1147.  
  1148. method PBVisual::genTypeSignature {this} {
  1149.     set signature [$this PBClass::genTypeSignature]
  1150.     if {[$this container] != ""} {
  1151.         set signature "${signature} within [[$this container] name]"
  1152.     }
  1153.     return $signature
  1154. }
  1155.  
  1156. method PBVisual::generateTypeDef {this sect} {
  1157.     # Generate builtin property settings
  1158.     #
  1159.     $this generateBuiltinProperties $sect ${PBBuiltinProperty::InTypeDef}
  1160.  
  1161.     $this PBClass::generateTypeDef $sect
  1162. }
  1163.  
  1164. method PBVisual::generateControlClassMapping {this sect} {
  1165.     $this PBClass::generateControlClassMapping $sect 
  1166. }
  1167.  
  1168. method PBVisual::genOnCreateBody {this} {
  1169.     if {[$this onCreateBody] == ""} {
  1170.         $this onCreateBody [TextSection new]
  1171.     }
  1172.     set sect [$this onCreateBody]
  1173.  
  1174.     # Gen builtin property settings
  1175.     #
  1176.     $this generateBuiltinProperties $sect ${PBBuiltinProperty::InOnCreate}
  1177.     
  1178.     $this PBClass::genOnCreateBody
  1179.  
  1180.     if {[$this onCreateResidue] != ""} {
  1181.         $sect appendSect [$this onCreateResidue]
  1182.     }
  1183. }
  1184.  
  1185. method PBVisual::genOnDestroyBody {this} {
  1186.     if {[$this onDestroyBody] == ""} {
  1187.         $this onDestroyBody [TextSection new]
  1188.     }
  1189.     set sect [$this onDestroyBody]
  1190.  
  1191.     $this PBClass::genOnDestroyBody
  1192.  
  1193.     if {[$this onDestroyResidue] != ""} {
  1194.         $sect appendSect [$this onDestroyResidue]
  1195.     }
  1196. }
  1197.  
  1198. method PBVisual::generateBuiltinProperties {this sect where} {
  1199.     [$this sortedNameKeySet] foreach name {
  1200.         if {[[$this builtinProperty] exists $name]} {
  1201.             set prop [[$this builtinProperty] set $name]
  1202.             if {$prop != ""} {
  1203.                 if {[$prop where] == $where} {
  1204.                     $sect append "[$prop generate]\n"
  1205.                 }
  1206.             }
  1207.         }    
  1208.     }
  1209. }
  1210.  
  1211. method PBVisual::getGlobalDefinition {this} {
  1212.     set container [$this container]
  1213.     if {$container != ""} {
  1214.         return [$container getGlobalDefinition]
  1215.     }
  1216.     return $this
  1217. }
  1218.  
  1219. method PBVisual::setBuiltinProperty {this name newBuiltinProperty} {
  1220.     # first append key to sortedNameKeySet
  1221.     set i [[$this sortedNameKeySet] search -exact $name]
  1222.     if {$i >= 0} {
  1223.         [$this sortedNameKeySet] remove $i
  1224.     }
  1225.     [$this sortedNameKeySet] append $name
  1226.  
  1227.     [$this builtinProperty] set $name $newBuiltinProperty
  1228. }
  1229.  
  1230. method PBVisual::removeBuiltinProperty {this name} {
  1231.     set i [[$this sortedNameKeySet] search -exact $name]
  1232.     if {$i >= 0} {
  1233.         [$this sortedNameKeySet] remove $i
  1234.     }    
  1235.     [$this builtinProperty] unset $name
  1236. }
  1237.  
  1238. # Do not delete this line -- regeneration end marker
  1239.  
  1240. method PBVisual::addSortedNameKey {this newSortedNameKey} {
  1241.     [$this sortedNameKeySet] append $newSortedNameKey
  1242.  
  1243. }
  1244.  
  1245. method PBVisual::removeSortedNameKey {this oldSortedNameKey} {
  1246.     [$this sortedNameKeySet] removeValue $oldSortedNameKey
  1247. }
  1248.  
  1249. method PBVisual::getBuiltinProperty {this name} {
  1250.     return [[$this builtinProperty] set $name]
  1251. }
  1252.  
  1253. #---------------------------------------------------------------------------
  1254. #      File:           @(#)pbvisualco.tcl    /main/titanic/7
  1255. #---------------------------------------------------------------------------
  1256.  
  1257. # Start user added include file section
  1258. # End user added include file section
  1259.  
  1260.  
  1261. Class PBVisualContainer : {PBVisual} {
  1262.     constructor
  1263.     method destructor
  1264.     method generate
  1265.     method generateTypeDef
  1266.     method generateForward
  1267.     method generateInstanceVars
  1268.     method generateControlClassMapping
  1269.     method generateDerivedControls
  1270.     method genOnCreateBody
  1271.     method genOnDestroyBody
  1272.     method findContainedClass
  1273.     method moveContainedClass
  1274.     method moveAllContainedClass
  1275.     method addContainedClass
  1276.     method removeContainedClass
  1277.     method addSortedContainedClass
  1278.     method removeSortedContainedClass
  1279.     method setDerivedControlBody
  1280.     method removeDerivedControlBody
  1281.     method getDerivedControlBody
  1282.     attribute containerArray
  1283.     attribute sortedDerivedControlKeySet
  1284.     attribute containedClassSet
  1285.     attribute sortedContainedClassSet
  1286.     attribute binaryData
  1287.     attribute derivedControlBody
  1288. }
  1289.  
  1290. constructor PBVisualContainer {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  1291.     set this [PBVisual::constructor $class $this $i_name $ooplClass $i_superClassName $i_builtinSuperClassName]
  1292.     $this containerArray "Control"
  1293.     $this sortedDerivedControlKeySet [List new]
  1294.     $this containedClassSet [List new]
  1295.     $this sortedContainedClassSet [List new]
  1296.     $this derivedControlBody [Dictionary new]
  1297.     # Start constructor user section
  1298.     # End constructor user section
  1299.     return $this
  1300. }
  1301.  
  1302. method PBVisualContainer::destructor {this} {
  1303.     # Start destructor user section
  1304.     # End destructor user section
  1305.     $this PBVisual::destructor
  1306. }
  1307.  
  1308. method PBVisualContainer::generate {this sect} {
  1309.     # if there are any move to sorted (else they won't be generated)
  1310.     $this moveAllContainedClass
  1311.  
  1312.     $this PBVisual::generate $sect
  1313.  
  1314.     [$this sortedContainedClassSet] foreach class {
  1315.         $class generate $sect
  1316.     }
  1317.  
  1318.     if {[$this binaryData] != ""} {
  1319.         $sect append "\n${PBCookie::startBinaryDataSection}\n"
  1320.         $sect appendSect [$this binaryData]
  1321.         $sect append ${PBCookie::endBinaryDataSection}
  1322.     }
  1323. }
  1324.  
  1325. method PBVisualContainer::generateTypeDef {this sect} {
  1326.     $this PBVisual::generateTypeDef $sect
  1327.  
  1328.     # Generate contained object variables
  1329.     #
  1330.     [$this sortedContainedClassSet] foreach class {
  1331.         $sect append "[$class name] [$class name]\n"
  1332.     }
  1333. }
  1334.  
  1335. method PBVisualContainer::generateForward {this sect} {
  1336.     # if there are any move to sorted (else they won't be generated)
  1337.     $this moveAllContainedClass
  1338.  
  1339.     $this PBVisual::generateForward $sect
  1340.  
  1341.     set containedClassList [$this sortedContainedClassSet]
  1342.     if [$containedClassList empty] {
  1343.         return
  1344.     }
  1345.     $containedClassList foreach class {
  1346.         $class generateForward $sect
  1347.     }
  1348.     if [$this isGlobalType] {
  1349.         return
  1350.     }
  1351.     $sect append "[$this genTypeSignature]\n"
  1352.     $containedClassList foreach class {
  1353.         $sect append "[$class name] [$class name]\n"
  1354.     }
  1355.     $sect append "end type\n"
  1356. }
  1357.  
  1358. method PBVisualContainer::generateInstanceVars {this sect} {
  1359.     $this PBVisual::generateInstanceVars $sect
  1360. }
  1361.  
  1362. method PBVisualContainer::generateControlClassMapping {this sect} {
  1363.     $this PBVisual::generateControlClassMapping $sect 
  1364.     [$this sortedContainedClassSet] foreach class {
  1365.         $class generateControlClassMapping $sect
  1366.     }
  1367. }
  1368.  
  1369. method PBVisualContainer::generateDerivedControls {this sect} {
  1370.     if [$this isGlobalType] {
  1371.         [$this sortedDerivedControlKeySet] foreach drvCtrl {
  1372.             if {[[$this derivedControlBody] exists $drvCtrl]} {
  1373.                 set drvCtrlBody [[$this derivedControlBody] set $drvCtrl]
  1374.                 if {$drvCtrlBody != ""} {
  1375.                     $sect appendSect $drvCtrlBody
  1376.                     $sect append "\n"
  1377.                 }
  1378.             } else {
  1379.                 # there's a key in the sorted list, but not in the dictionary
  1380.             }
  1381.         }
  1382.     }
  1383. }
  1384.  
  1385. method PBVisualContainer::genOnCreateBody {this} {
  1386.     if {[$this onCreateBody] == ""} {
  1387.         $this onCreateBody [TextSection new]
  1388.     }
  1389.     set sect [$this onCreateBody]
  1390.  
  1391.     if {[$this superClassName] != [$this builtinSuperClassName]} {
  1392.         set isDirectSubClassOfBuiltin 0
  1393.     } else {
  1394.         set isDirectSubClassOfBuiltin 1
  1395.     }
  1396.     set containedClassList [$this sortedContainedClassSet]
  1397.  
  1398.     #if {$isDirectSubClassOfBuiltin && [$containedClassList empty]} 
  1399.     #    do nothing
  1400.     #
  1401.     if {!$isDirectSubClassOfBuiltin && [$containedClassList empty]} {
  1402.         set classInfo [[PBBuiltinInfo::global] \
  1403.             getBuiltinClass [$this builtinSuperClassName]]
  1404.         if {[$this isGlobalType] && [$classInfo isGrContainer]} {
  1405.             $sect append "call [$this superClassName]::create\n"
  1406.         }
  1407.     } elseif {$isDirectSubClassOfBuiltin && ![$containedClassList empty]} {
  1408.         $containedClassList foreach class {
  1409.             $sect append "this.[$class name]=create [$class name]\n"
  1410.         }
  1411.         $sect append "this.[$this containerArray]\[\]=\{ "
  1412.         set first 1
  1413.         $containedClassList foreach class {
  1414.             if !$first {
  1415.                 $sect append ",&\n"
  1416.             } else {
  1417.                 set first 0
  1418.             }
  1419.             $sect append "this.[$class name]"
  1420.         }
  1421.         $sect append "\}\n"
  1422.     } elseif {!$isDirectSubClassOfBuiltin && ![$containedClassList empty]} {
  1423.         $sect append "int iCurrent\n"
  1424.         if [$this isGlobalType] {
  1425.             $sect append "call [$this superClassName]::create\n"
  1426.         }
  1427.         $containedClassList foreach class {
  1428.             $sect append "this.[$class name]=create [$class name]\n"
  1429.         }
  1430.         $sect append \
  1431.             "iCurrent=UpperBound(this.[$this containerArray])\n"
  1432.         set i 1
  1433.         $containedClassList foreach class {
  1434.             $sect append "this.[$this containerArray\
  1435.                 ]\[iCurrent+${i}\]=this.[$class name]\n"
  1436.             incr i
  1437.         }
  1438.     }
  1439.  
  1440.     $this PBVisual::genOnCreateBody
  1441. }
  1442.  
  1443. method PBVisualContainer::genOnDestroyBody {this} {
  1444.     if {[$this onDestroyBody] == ""} {
  1445.         $this onDestroyBody [TextSection new]
  1446.     }
  1447.     set sect [$this onDestroyBody]
  1448.  
  1449.     if {[$this superClassName] != [$this builtinSuperClassName]} {
  1450.         set isDirectSubClassOfBuiltin 0
  1451.     } else {
  1452.         set isDirectSubClassOfBuiltin 1
  1453.     }
  1454.     set containedClassList [$this sortedContainedClassSet]
  1455.  
  1456.     #if {$isDirectSubClassOfBuiltin && [$containedClassList empty]}
  1457.     #    do nothing
  1458.     #
  1459.     set classInfo [[PBBuiltinInfo::global] \
  1460.         getBuiltinClass [$this builtinSuperClassName]]
  1461.     if {!$isDirectSubClassOfBuiltin && [$this isGlobalType] &&
  1462.             [$classInfo isGrContainer]} {
  1463.         $sect append "call [$this superClassName]::destroy\n"
  1464.     }
  1465.     $containedClassList foreach class {
  1466.         $sect append "destroy(this.[$class name])\n"
  1467.     }
  1468.  
  1469.     $this PBVisual::genOnDestroyBody
  1470. }
  1471.  
  1472. method PBVisualContainer::findContainedClass {this name {recursive 0}} {
  1473.     [$this sortedContainedClassSet] foreach class {
  1474.         if {[$class name] == $name} {
  1475.             return $class
  1476.         }
  1477.         if {$recursive && [$class isA "PBVisualContainer"]} {
  1478.             set cl [$class findContainedClass $name $recursive]
  1479.             if {$cl != ""} {
  1480.                 return $cl
  1481.             }
  1482.         }
  1483.     }
  1484.     [$this containedClassSet] foreach class {
  1485.         if {[$class name] == $name} {
  1486.             return $class
  1487.         }
  1488.         if {$recursive && [$class isA "PBVisualContainer"]} {
  1489.             set cl [$class findContainedClass $name $recursive]
  1490.             if {$cl != ""} {
  1491.                 return $cl
  1492.             }
  1493.         }
  1494.     }
  1495.  
  1496.     return ""
  1497. }
  1498.  
  1499. method PBVisualContainer::moveContainedClass {this mvContainedClass} {
  1500.     [$this containedClassSet] removeValue $mvContainedClass
  1501.     [$this sortedContainedClassSet] append $mvContainedClass
  1502. }
  1503.  
  1504. method PBVisualContainer::moveAllContainedClass {this} {
  1505.     while {![[$this containedClassSet] empty]} {
  1506.         set mvContainedClass [[$this containedClassSet] index 0]
  1507.         [$this containedClassSet] remove 0
  1508.         [$this sortedContainedClassSet] append $mvContainedClass
  1509.     }
  1510. }
  1511.  
  1512. method PBVisualContainer::addContainedClass {this newContainedClass} {
  1513.     [$this containedClassSet] append $newContainedClass
  1514.     $newContainedClass container $this
  1515. }
  1516.  
  1517. method PBVisualContainer::removeContainedClass {this oldContainedClass} {
  1518.     $oldContainedClass container ""
  1519.     [$this containedClassSet] removeValue $oldContainedClass
  1520. }
  1521.  
  1522. method PBVisualContainer::addSortedContainedClass {this newContainedClass} {
  1523.     [$this sortedContainedClassSet] append $newContainedClass
  1524.     $newContainedClass container $this
  1525. }
  1526.  
  1527. method PBVisualContainer::removeSortedContainedClass {this oldContainedClass} {
  1528.     $oldContainedClass container ""
  1529.     [$this sortedContainedClassSet] removeValue $oldContainedClass
  1530. }
  1531.  
  1532. method PBVisualContainer::setDerivedControlBody {this derivedControl newDerivedControlBody} {
  1533.     # first append key to sortedDerivedControlKeys
  1534.     set i [[$this sortedDerivedControlKeySet] search -exact $derivedControl]
  1535.     if {$i >= 0} {
  1536.         [$this sortedDerivedControlKeySet] remove $i
  1537.     }
  1538.     [$this sortedDerivedControlKeySet] append $derivedControl
  1539.  
  1540.     [$this derivedControlBody] set $derivedControl $newDerivedControlBody
  1541. }
  1542.  
  1543. method PBVisualContainer::removeDerivedControlBody {this derivedControl} {
  1544.     set i [[$this sortedDerivedControlKeySet] search -exact $derivedControl]
  1545.     if {$i >= 0} {
  1546.         [$this sortedDerivedControlKeySet] remove $i
  1547.     }    
  1548.     [$this derivedControlBody] unset $derivedControl
  1549. }
  1550.  
  1551. # Do not delete this line -- regeneration end marker
  1552.  
  1553. method PBVisualContainer::getDerivedControlBody {this derivedControl} {
  1554.     return [[$this derivedControlBody] set $derivedControl]
  1555. }
  1556.  
  1557. #---------------------------------------------------------------------------
  1558. #      File:           @(#)pbmenu.tcl    /main/titanic/2
  1559. #---------------------------------------------------------------------------
  1560.  
  1561. # Start user added include file section
  1562. # End user added include file section
  1563.  
  1564.  
  1565. Class PBMenu : {PBVisualContainer} {
  1566.     constructor
  1567.     method destructor
  1568.     method genOnCreateBody
  1569.     method getKind
  1570.     method genDerivedMenuCreations
  1571. }
  1572.  
  1573. constructor PBMenu {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  1574.     set this [PBVisualContainer::constructor $class $this $i_name $ooplClass $i_superClassName $i_builtinSuperClassName]
  1575.     # Start constructor user section
  1576.     $this containerArray "Item"
  1577.     # End constructor user section
  1578.     return $this
  1579. }
  1580.  
  1581. method PBMenu::destructor {this} {
  1582.     # Start destructor user section
  1583.     # End destructor user section
  1584.     $this PBVisualContainer::destructor
  1585. }
  1586.  
  1587. method PBMenu::genOnCreateBody {this} {
  1588.     # a little hack to add all menu items of superclasses after 
  1589.     # regeneration
  1590.     $this genDerivedMenuCreations
  1591.  
  1592.     if {[$this onCreateBody] == ""} {
  1593.         $this onCreateBody [TextSection new]
  1594.     }
  1595.     set sect [$this onCreateBody]
  1596.     if [$this isGlobalType] {
  1597.         $sect append "[$this name]=this\n"
  1598.     }
  1599.     $this PBVisualContainer::genOnCreateBody
  1600. }
  1601.  
  1602. method PBMenu::getKind {this} {
  1603.     return ${PBClassKind::Menu}
  1604. }
  1605.  
  1606. method PBMenu::genDerivedMenuCreations {this} {
  1607.     if {![$this isGlobalType]} {
  1608.         return
  1609.     }
  1610.     # visits all superclass control and make an entry in the 
  1611.     # derivedControlBody section (if not already present)
  1612.     set superSet [List new]
  1613.     set menuSet [List new]
  1614.     set ooplClass [$this ooplClass]
  1615.     if {$ooplClass == ""} {
  1616.         return
  1617.     }
  1618.     # only creation methods of supers must be generated
  1619.     set ooplClass [$ooplClass getSuperClass]
  1620.     # create list with most super class (not equals a builtinClass) first 
  1621.     while {($ooplClass != "") && \
  1622.                !([$ooplClass isBuiltin]) && \
  1623.                ([string tolower [$ooplClass getPBClassKind]] == "menu") } {
  1624.         # put in front:
  1625.         $superSet insert $ooplClass
  1626.         set ooplClass [$ooplClass getSuperClass]
  1627.     }
  1628.     set tmpList ""
  1629.     $superSet foreach superClass {
  1630.         set pbMenu [$superClass getName]
  1631.         set tmpList2 [PBMenu::getMenuItems $pbMenu $superClass]
  1632.         if {$tmpList2 != "" } {
  1633.             if {$tmpList != "" } {
  1634.                 set tmpList [concat $tmpList $tmpList2]
  1635.             } else {
  1636.                 set tmpList $tmpList2
  1637.             }
  1638.         }
  1639.     }
  1640.     if {$tmpList != "" } {
  1641.         $menuSet contents $tmpList
  1642.     }
  1643.     $menuSet foreach menu {
  1644.         if {![regexp {^ *([^ `]*)`([^ ]*) *$} $menu \
  1645.                  total className controlName] } {
  1646.             continue
  1647.         }
  1648.         set menucreate "$controlName::create"
  1649.         if {[[$this derivedControlBody] exists $menucreate]} {
  1650.             # do nothing
  1651.         } else {
  1652.             # add
  1653.             set sect [TextSection new]
  1654.             $sect append "on $controlName.create\n"
  1655.             # $sect append "// created by ObjectTeam\n"
  1656.             $sect append "call $className`$controlName::create\n"
  1657.             $sect append "this.Tag=\"\"\n"
  1658.             $sect append "end on\n"
  1659.             $sect append "\n"
  1660.             $this setDerivedControlBody $menu $sect
  1661.         }
  1662.     }
  1663. }
  1664.  
  1665. proc PBMenu::getMenuItems {pbMenu ooplClass} {
  1666.     set controlList ""
  1667.     if {($ooplClass == "") || \
  1668.             ([$ooplClass isBuiltin]) || \
  1669.             (([string length [$ooplClass getPBClassKind]] >= 4) &&
  1670.              ([string tolower [string range \
  1671.                                    [$ooplClass getPBClassKind] 0 3]] != \
  1672.                   "menu")) } {
  1673.         return ""
  1674.     }
  1675.     set assocSet [$ooplClass genAssocAttrSet]
  1676.     foreach assoc $assocSet {
  1677.         set oppClass [$assoc getOppositeClass]
  1678.         set assocName "$pbMenu`[$assoc getName]"
  1679.         # add to derivedControlSet
  1680.         lappend controlList $assocName
  1681.         set subItems [PBMenu::getMenuItems $pbMenu $oppClass]
  1682.         if {$subItems != ""} {
  1683.             set controlList [concat $controlList $subItems]
  1684.         }
  1685.     }
  1686.     return $controlList
  1687. }
  1688.  
  1689. # Do not delete this line -- regeneration end marker
  1690.  
  1691. #---------------------------------------------------------------------------
  1692. #      File:           @(#)pboperatio.tcl    /main/titanic/1
  1693. #---------------------------------------------------------------------------
  1694.  
  1695. # Start user added include file section
  1696. # End user added include file section
  1697.  
  1698.  
  1699. Class PBOperation : {PBFeature} {
  1700.     constructor
  1701.     method destructor
  1702.     method genParameterList
  1703.     method genSignature
  1704.     method addParameter
  1705.     method removeParameter
  1706.     attribute body
  1707.     attribute parameterSet
  1708. }
  1709.  
  1710. constructor PBOperation {class this i_name type} {
  1711.     set this [PBFeature::constructor $class $this $i_name $type]
  1712.     $this parameterSet [List new]
  1713.     # Start constructor user section
  1714.     # End constructor user section
  1715.     return $this
  1716. }
  1717.  
  1718. method PBOperation::destructor {this} {
  1719.     # Start destructor user section
  1720.     # End destructor user section
  1721.     $this PBFeature::destructor
  1722. }
  1723.  
  1724. method PBOperation::genParameterList {this} {
  1725.     set sect [TextSection new]
  1726.     set first 1
  1727.  
  1728.     [$this parameterSet] foreach parameter {
  1729.         if $first {
  1730.             set first 0
  1731.         } else {
  1732.             $sect append ", "
  1733.         }
  1734.         $parameter generate $sect
  1735.     }
  1736.  
  1737.     return $sect
  1738. }
  1739.  
  1740. method PBOperation::genSignature {this} {
  1741.     return "[$this name] ([[$this genParameterList] contents])"
  1742. }
  1743.  
  1744. # Do not delete this line -- regeneration end marker
  1745.  
  1746. method PBOperation::addParameter {this newParameter} {
  1747.     [$this parameterSet] append $newParameter
  1748.  
  1749. }
  1750.  
  1751. method PBOperation::removeParameter {this oldParameter} {
  1752.     [$this parameterSet] removeValue $oldParameter
  1753. }
  1754.  
  1755. #---------------------------------------------------------------------------
  1756. #      File:           @(#)pbwindow.tcl    /main/titanic/5
  1757. #---------------------------------------------------------------------------
  1758.  
  1759. # Start user added include file section
  1760. # End user added include file section
  1761.  
  1762.  
  1763. Class PBWindow : {PBVisualContainer} {
  1764.     constructor
  1765.     method destructor
  1766.     method generate
  1767.     method genOnCreateBody
  1768.     method genOnDestroyBody
  1769.     method getKind
  1770.     attribute menuName
  1771. }
  1772.  
  1773. constructor PBWindow {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  1774.     set this [PBVisualContainer::constructor $class $this $i_name $ooplClass $i_superClassName $i_builtinSuperClassName]
  1775.     $this menuName ""
  1776.     # Start constructor user section
  1777.     # End constructor user section
  1778.     return $this
  1779. }
  1780.  
  1781. method PBWindow::destructor {this} {
  1782.     # Start destructor user section
  1783.     # End destructor user section
  1784.     $this PBVisualContainer::destructor
  1785. }
  1786.  
  1787. method PBWindow::generate {this sect} {
  1788.     # add trigger for both con/destructor if open and close are present.
  1789.     set openEvent [$this findEvent "open"]
  1790.     set ctorEvent [$this findEvent "constructor"]
  1791.     if {$openEvent != "" && $ctorEvent != ""} {    
  1792.         set eventsect [TextSection new]
  1793.         $eventsect append "TriggerEvent (this, \"constructor\")\n"
  1794.         $eventsect append "${PBCookie::startUserSection}\n"
  1795.         if {[$openEvent body] != ""} {
  1796.             $eventsect appendSect [$openEvent body]
  1797.         }
  1798.         $eventsect append "${PBCookie::endUserSection}\n"
  1799.         $openEvent body $eventsect
  1800.     }
  1801.     set closeEvent [$this findEvent "close"]
  1802.     set dtorEvent [$this findEvent "destructor"]
  1803.     if {$closeEvent != "" && $dtorEvent != ""} {
  1804.         set eventsect [TextSection new]
  1805.         $eventsect append "TriggerEvent (this, \"destructor\")\n"
  1806.         $eventsect append "${PBCookie::startUserSection}\n"
  1807.         if {[$closeEvent body] != ""} {
  1808.             $eventsect appendSect [$closeEvent body]
  1809.         }
  1810.         $eventsect append "${PBCookie::endUserSection}\n"
  1811.         $closeEvent body $eventsect
  1812.     }
  1813.  
  1814.     $this PBVisualContainer::generate $sect
  1815. }
  1816.  
  1817. method PBWindow::genOnCreateBody {this} {
  1818.     if {[$this onCreateBody] == ""} {
  1819.         $this onCreateBody [TextSection new]
  1820.     }
  1821.     set sect [$this onCreateBody]
  1822.  
  1823.     set menuName [$this menuName]
  1824.     if {$menuName != ""} {
  1825.         $sect append "if this.MenuName = \"${menuName}\" then this.MenuID = create ${menuName}\n"
  1826.     }
  1827.     $this PBVisualContainer::genOnCreateBody
  1828. }
  1829.  
  1830. method PBWindow::genOnDestroyBody {this} {
  1831.     if {[$this onDestroyBody] == ""} {
  1832.         $this onDestroyBody [TextSection new]
  1833.     }
  1834.     set sect [$this onDestroyBody]
  1835.  
  1836.     if {[$this menuName] != ""} {
  1837.         $sect append "if IsValid(MenuID) then destroy(MenuID)\n"
  1838.     }
  1839.     $this PBVisualContainer::genOnDestroyBody
  1840. }
  1841.  
  1842. method PBWindow::getKind {this} {
  1843.     return ${PBClassKind::Window}
  1844. }
  1845.  
  1846. # Do not delete this line -- regeneration end marker
  1847.  
  1848. #---------------------------------------------------------------------------
  1849. #      File:           @(#)pbnametype.tcl    /main/titanic/2
  1850. #---------------------------------------------------------------------------
  1851.  
  1852. # Start user added include file section
  1853. # End user added include file section
  1854.  
  1855.  
  1856. Class PBNameType : {PBFeature} {
  1857.     constructor
  1858.     method destructor
  1859.     method generate
  1860.     attribute arrayDesc
  1861. }
  1862.  
  1863. constructor PBNameType {class this i_name type} {
  1864.     set this [PBFeature::constructor $class $this $i_name $type]
  1865.     $this arrayDesc ""
  1866.     # Start constructor user section
  1867.     # End constructor user section
  1868.     return $this
  1869. }
  1870.  
  1871. method PBNameType::destructor {this} {
  1872.     # Start destructor user section
  1873.     # End destructor user section
  1874.     $this PBFeature::destructor
  1875. }
  1876.  
  1877. method PBNameType::generate {this sect} {
  1878.     $sect append "[[$this type] generate] [$this name][$this arrayDesc]"
  1879. }
  1880.  
  1881. # Do not delete this line -- regeneration end marker
  1882.  
  1883. #---------------------------------------------------------------------------
  1884. #      File:           @(#)pbparamete.tcl    /main/titanic/1
  1885. #---------------------------------------------------------------------------
  1886.  
  1887. # Start user added include file section
  1888. # End user added include file section
  1889.  
  1890.  
  1891. Class PBParameter : {PBNameType} {
  1892.     constructor
  1893.     method destructor
  1894.     method generate
  1895.     attribute modifier
  1896. }
  1897.  
  1898. constructor PBParameter {class this i_name type modifier} {
  1899.     set this [PBNameType::constructor $class $this $i_name $type]
  1900.     $this modifier $modifier
  1901.     # Start constructor user section
  1902.     # End constructor user section
  1903.     return $this
  1904. }
  1905.  
  1906. method PBParameter::destructor {this} {
  1907.     # Start destructor user section
  1908.     # End destructor user section
  1909.     $this PBNameType::destructor
  1910. }
  1911.  
  1912. method PBParameter::generate {this sect} {
  1913.     if {[$this modifier] != ""} {
  1914.         set modifier [[$this modifier] generate]
  1915.         if {$modifier != ""} {
  1916.             $sect append "$modifier "
  1917.         }
  1918.     }
  1919.     $this PBNameType::generate $sect
  1920. }
  1921.  
  1922. # Do not delete this line -- regeneration end marker
  1923.  
  1924. #---------------------------------------------------------------------------
  1925. #      File:           @(#)pbclasscus.tcl    /main/titanic/2
  1926. #---------------------------------------------------------------------------
  1927.  
  1928. # Start user added include file section
  1929. # End user added include file section
  1930.  
  1931.  
  1932. Class PBClassCustomUserObject : {PBClass} {
  1933.     constructor
  1934.     method destructor
  1935.     method genTypeSignature
  1936.     method genOnCreateBody
  1937.     method genOnDestroyBody
  1938.     method getKind
  1939.     attribute isAutoInstantiate
  1940. }
  1941.  
  1942. constructor PBClassCustomUserObject {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  1943.     set this [PBClass::constructor $class $this $i_name $ooplClass $i_superClassName $i_builtinSuperClassName]
  1944.     $this isAutoInstantiate 0
  1945.     # Start constructor user section
  1946.     # End constructor user section
  1947.     return $this
  1948. }
  1949.  
  1950. method PBClassCustomUserObject::destructor {this} {
  1951.     # Start destructor user section
  1952.     # End destructor user section
  1953.     $this PBClass::destructor
  1954. }
  1955.  
  1956. method PBClassCustomUserObject::genTypeSignature {this} {
  1957.     set signature [$this PBClass::genTypeSignature]
  1958.     if [$this isAutoInstantiate] {
  1959.         set signature "$signature autoinstantiate"
  1960.     }
  1961.     return $signature
  1962. }
  1963.  
  1964. method PBClassCustomUserObject::genOnCreateBody {this} {
  1965.     set sect [TextSection new]
  1966.  
  1967.     $this onCreateBody $sect
  1968.     $sect append "TriggerEvent( this, \"constructor\" )\n"
  1969. }
  1970.  
  1971. method PBClassCustomUserObject::genOnDestroyBody {this} {
  1972.     set sect [TextSection new]
  1973.  
  1974.     $this onDestroyBody $sect
  1975.     $sect append "TriggerEvent( this, \"destructor\" )\n"
  1976. }
  1977.  
  1978. method PBClassCustomUserObject::getKind {this} {
  1979.     return ${PBClassKind::CCUserObject}
  1980. }
  1981.  
  1982. # Do not delete this line -- regeneration end marker
  1983.  
  1984. #---------------------------------------------------------------------------
  1985. #      File:           @(#)pbvariable.tcl    /main/titanic/1
  1986. #---------------------------------------------------------------------------
  1987.  
  1988. # Start user added include file section
  1989. # End user added include file section
  1990.  
  1991.  
  1992. Class PBVariable : {PBNameType} {
  1993.     constructor
  1994.     method destructor
  1995.     method generate
  1996.     attribute defaultValue
  1997.     attribute isShared
  1998.     attribute isConstant
  1999.     attribute access
  2000. }
  2001.  
  2002. constructor PBVariable {class this i_name type access} {
  2003.     set this [PBNameType::constructor $class $this $i_name $type]
  2004.     $this defaultValue ""
  2005.     $this isShared 0
  2006.     $this isConstant 0
  2007.     $this access $access
  2008.     # Start constructor user section
  2009.     # End constructor user section
  2010.     return $this
  2011. }
  2012.  
  2013. method PBVariable::destructor {this} {
  2014.     # Start destructor user section
  2015.     # End destructor user section
  2016.     $this PBNameType::destructor
  2017. }
  2018.  
  2019. method PBVariable::generate {this sect} {
  2020.     if [$this isConstant] {
  2021.         $sect append "constant "
  2022.         set access [[$this access] PBAccess::generate]
  2023.     } else {
  2024.         set access [[$this access] generate]
  2025.     }
  2026.     if {![$this isShared] && $access != ""} {
  2027.         $sect append "$access "
  2028.     }
  2029.     $this PBNameType::generate $sect
  2030.     if {[$this defaultValue] != ""} {
  2031.         $sect append " = [$this defaultValue]"
  2032.     }
  2033. }
  2034.  
  2035. # Do not delete this line -- regeneration end marker
  2036.  
  2037. #---------------------------------------------------------------------------
  2038. #      File:           @(#)pbfunction.tcl    /main/titanic/2
  2039. #---------------------------------------------------------------------------
  2040.  
  2041. # Start user added include file section
  2042. # End user added include file section
  2043.  
  2044.  
  2045. Class PBFunction : {PBOperation} {
  2046.     constructor
  2047.     method destructor
  2048.     method generate
  2049.     attribute access
  2050. }
  2051.  
  2052. constructor PBFunction {class this i_name type access} {
  2053.     set this [PBOperation::constructor $class $this $i_name $type]
  2054.     $this access $access
  2055.     # Start constructor user section
  2056.     # End constructor user section
  2057.     return $this
  2058. }
  2059.  
  2060. method PBFunction::destructor {this} {
  2061.     # Start destructor user section
  2062.     # End destructor user section
  2063.     $this PBOperation::destructor
  2064. }
  2065.  
  2066. method PBFunction::generate {this declSect defSect} {
  2067.     set funcStart ""
  2068.  
  2069.     set access [[$this access] generate]
  2070.     if {$access != ""} {
  2071.         set funcStart "$access "
  2072.     }
  2073.     set type [[$this type] generate]
  2074.     if {$type != ""} {
  2075.         set funcStart "${funcStart}function $type "
  2076.     } else {
  2077.         set funcStart "${funcStart}subroutine "
  2078.     }
  2079.     set funcStart "${funcStart}[$this genSignature]"
  2080.  
  2081.     $declSect append "${funcStart}\n"
  2082.     $defSect append "${funcStart};"
  2083.     if {[$this body] != ""} {
  2084.         $defSect appendSect [$this body]
  2085.     } else {
  2086.         $defSect append "${PBCookie::implementThisFunction}\n"
  2087.         if {$type != ""} {
  2088.             $defSect append "$type dummy\n"
  2089.             $defSect append "return dummy\n"
  2090.         }
  2091.     }
  2092.     if {$type != ""} {
  2093.         $defSect append "end function\n"
  2094.     } else {
  2095.         $defSect append "end subroutine\n"
  2096.     }
  2097. }
  2098.  
  2099. # Do not delete this line -- regeneration end marker
  2100.  
  2101. #---------------------------------------------------------------------------
  2102. #      File:           @(#)pbevent.tcl    /main/titanic/4
  2103. #---------------------------------------------------------------------------
  2104.  
  2105. # Start user added include file section
  2106. # End user added include file section
  2107.  
  2108.  
  2109. Class PBEvent : {PBOperation} {
  2110.     constructor
  2111.     method destructor
  2112.     method genSignature
  2113.     method generate
  2114.     attribute extendAncestorScript
  2115. }
  2116.  
  2117. constructor PBEvent {class this i_name type} {
  2118.     set this [PBOperation::constructor $class $this $i_name $type]
  2119.     $this extendAncestorScript 0
  2120.     # Start constructor user section
  2121.     # End constructor user section
  2122.     return $this
  2123. }
  2124.  
  2125. method PBEvent::destructor {this} {
  2126.     # Start destructor user section
  2127.     # End destructor user section
  2128.     $this PBOperation::destructor
  2129. }
  2130.  
  2131. method PBEvent::genSignature {this} {
  2132.     set paramList [$this parameterSet]
  2133.     if ![$paramList empty] {
  2134.         set firstParam [$paramList index]
  2135.         set paramType [[$firstParam type] name]
  2136.         if {$paramType == "eventid"} {
  2137.             set paramName [$firstParam name]
  2138.             return "[$this name] $paramName"
  2139.         }
  2140.     }
  2141.  
  2142.     return [$this PBOperation::genSignature]
  2143. }
  2144.  
  2145. method PBEvent::generate {this sect what} {
  2146.     if {$what == "eventDeclaration"} {
  2147.         $sect append "event "
  2148.         set type [[$this type] generate]
  2149.         if {$type != ""} {
  2150.             $sect append "type $type "
  2151.         }
  2152.         $sect append [$this genSignature]
  2153.     } else {
  2154.         # $what == "eventDefinition"
  2155.         $sect append "event [$this name]\;"
  2156.         if [$this extendAncestorScript] {
  2157.             $sect append "call super::[$this name]\;"
  2158.         }
  2159.         if {[$this body] != ""} {
  2160.             $sect appendSect [$this body]
  2161.         } else {
  2162.             $sect append "${PBCookie::implementThisEvent}\n"
  2163.             set type [[$this type] generate]
  2164.             if {$type != ""} {
  2165.                 $sect append "$type dummy\n"
  2166.                 $sect append "return dummy\n"
  2167.             }
  2168.         }
  2169.         $sect append "end event\n"
  2170.     }
  2171. }
  2172.  
  2173. # Do not delete this line -- regeneration end marker
  2174.  
  2175. #---------------------------------------------------------------------------
  2176. #      File:           @(#)pbclasssta.tcl    /main/titanic/1
  2177. #---------------------------------------------------------------------------
  2178.  
  2179. # Start user added include file section
  2180. # End user added include file section
  2181.  
  2182.  
  2183. Class PBClassStandardUserObject : {PBClass} {
  2184.     constructor
  2185.     method destructor
  2186.     method genOnCreateBody
  2187.     method genOnDestroyBody
  2188.     method getKind
  2189. }
  2190.  
  2191. constructor PBClassStandardUserObject {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  2192.     set this [PBClass::constructor $class $this $i_name $ooplClass $i_superClassName $i_builtinSuperClassName]
  2193.     # Start constructor user section
  2194.     # End constructor user section
  2195.     return $this
  2196. }
  2197.  
  2198. method PBClassStandardUserObject::destructor {this} {
  2199.     # Start destructor user section
  2200.     # End destructor user section
  2201.     $this PBClass::destructor
  2202. }
  2203.  
  2204. method PBClassStandardUserObject::genOnCreateBody {this} {
  2205.     set sect [TextSection new]
  2206.  
  2207.     $this onCreateBody $sect
  2208.     $sect append "call [$this builtinSuperClassName]::create\n"
  2209.     $sect append "TriggerEvent( this, \"constructor\" )\n"
  2210. }
  2211.  
  2212. method PBClassStandardUserObject::genOnDestroyBody {this} {
  2213.     set sect [TextSection new]
  2214.  
  2215.     $this onDestroyBody $sect
  2216.     $sect append "call [$this builtinSuperClassName]::destroy\n"
  2217.     $sect append "TriggerEvent( this, \"destructor\" )\n"
  2218. }
  2219.  
  2220. method PBClassStandardUserObject::getKind {this} {
  2221.     return ${PBClassKind::CSUserObject}
  2222. }
  2223.  
  2224. # Do not delete this line -- regeneration end marker
  2225.  
  2226. #---------------------------------------------------------------------------
  2227. #      File:           @(#)pbstructur.tcl    /main/titanic/2
  2228. #---------------------------------------------------------------------------
  2229.  
  2230. # Start user added include file section
  2231. # End user added include file section
  2232.  
  2233.  
  2234. Class PBStructure : {PBDefinition} {
  2235.     constructor
  2236.     method destructor
  2237.     method generate
  2238.     method getKind
  2239.     method getGlobalDefinition
  2240.     method theClass
  2241.     method addField
  2242.     method removeField
  2243.     attribute _theClass
  2244.     attribute fieldSet
  2245. }
  2246.  
  2247. constructor PBStructure {class this i_name ooplClass} {
  2248.     set this [PBDefinition::constructor $class $this $i_name $ooplClass]
  2249.     $this fieldSet [List new]
  2250.     # Start constructor user section
  2251.     # End constructor user section
  2252.     return $this
  2253. }
  2254.  
  2255. method PBStructure::destructor {this} {
  2256.     # Start destructor user section
  2257.     # End destructor user section
  2258.     $this PBDefinition::destructor
  2259. }
  2260.  
  2261. method PBStructure::generate {this sect} {
  2262.     if [$this isGlobalType] {
  2263.         $sect append "global "
  2264.     }
  2265.     $sect append "type [$this name] from structure\n"
  2266.     [$this fieldSet] foreach field {
  2267.         $sect append "\t"
  2268.         $field generate $sect
  2269.         $sect append "\n"
  2270.     }
  2271.     $sect append "end type\n"
  2272. }
  2273.  
  2274. method PBStructure::getKind {this} {
  2275.     return ${PBClassKind::Structure}
  2276. }
  2277.  
  2278. method PBStructure::getGlobalDefinition {this} {
  2279.     set class [$this theClass]
  2280.     if {$class != ""} {
  2281.         return $class
  2282.     }
  2283.     return $this
  2284. }
  2285.  
  2286. # Do not delete this line -- regeneration end marker
  2287.  
  2288. method PBStructure::theClass {this args} {
  2289.     if {$args == ""} {
  2290.         return [$this _theClass]
  2291.     }
  2292.     set ref [$this _theClass]
  2293.     if {$ref != ""} {
  2294.         [$ref _objectStructureSet] removeValue $this
  2295.     }
  2296.     set obj [lindex $args 0]
  2297.     if {$obj != ""} {
  2298.         [$obj _objectStructureSet] append $this
  2299.     }
  2300.     $this _theClass $obj
  2301. }
  2302.  
  2303. method PBStructure::addField {this newField} {
  2304.     [$this fieldSet] append $newField
  2305.  
  2306. }
  2307.  
  2308. method PBStructure::removeField {this oldField} {
  2309.     [$this fieldSet] removeValue $oldField
  2310. }
  2311.  
  2312. #---------------------------------------------------------------------------
  2313. #      File:           @(#)pbconstruc.tcl    /main/titanic/1
  2314. #---------------------------------------------------------------------------
  2315.  
  2316. # Start user added include file section
  2317. # End user added include file section
  2318.  
  2319.  
  2320. Class PBConstructor : {PBEvent} {
  2321.     constructor
  2322.     method destructor
  2323.     method generate
  2324.     attribute preBody
  2325. }
  2326.  
  2327. constructor PBConstructor {class this i_name type} {
  2328.     set this [PBEvent::constructor $class $this $i_name $type]
  2329.     # Start constructor user section
  2330.     # End constructor user section
  2331.     return $this
  2332. }
  2333.  
  2334. method PBConstructor::destructor {this} {
  2335.     # Start destructor user section
  2336.     # End destructor user section
  2337.     $this PBEvent::destructor
  2338. }
  2339.  
  2340. method PBConstructor::generate {this sect what} {
  2341.     if {$what == "eventDefinition"} {
  2342.         # Add cookie strings and preBody to body
  2343.         #
  2344.         set newBody [TextSection new]
  2345.  
  2346.         if {[$this preBody] != ""} {
  2347.             $newBody appendSect [$this preBody]
  2348.         }
  2349.         $newBody append "${PBCookie::startUserSection}\n"
  2350.         if {[$this body] != ""} {
  2351.             $newBody appendSect [$this body]
  2352.         }
  2353.         $newBody append "${PBCookie::endUserSection}\n"
  2354.         $this body $newBody
  2355.     }
  2356.  
  2357.     $this PBEvent::generate $sect $what
  2358. }
  2359.  
  2360. # Do not delete this line -- regeneration end marker
  2361.  
  2362. #---------------------------------------------------------------------------
  2363. #      File:           @(#)pbdestruct.tcl    /main/titanic/1
  2364. #---------------------------------------------------------------------------
  2365.  
  2366. # Start user added include file section
  2367. # End user added include file section
  2368.  
  2369.  
  2370. Class PBDestructor : {PBEvent} {
  2371.     constructor
  2372.     method destructor
  2373.     method generate
  2374.     attribute postBody
  2375. }
  2376.  
  2377. constructor PBDestructor {class this i_name type} {
  2378.     set this [PBEvent::constructor $class $this $i_name $type]
  2379.     # Start constructor user section
  2380.     # End constructor user section
  2381.     return $this
  2382. }
  2383.  
  2384. method PBDestructor::destructor {this} {
  2385.     # Start destructor user section
  2386.     # End destructor user section
  2387.     $this PBEvent::destructor
  2388. }
  2389.  
  2390. method PBDestructor::generate {this sect what} {
  2391.     if {$what == "eventDefinition"} {
  2392.         # Add cookie strings and postBody to body
  2393.         #
  2394.         set newBody [TextSection new]
  2395.  
  2396.         $newBody append "${PBCookie::startUserSection}\n"
  2397.         if {[$this body] != ""} {
  2398.             $newBody appendSect [$this body]
  2399.         }
  2400.         $newBody append "${PBCookie::endUserSection}\n"
  2401.         if {[$this postBody] != ""} {
  2402.             $newBody appendSect [$this postBody]
  2403.         }
  2404.         $this body $newBody
  2405.     }
  2406.  
  2407.     $this PBEvent::generate $sect $what
  2408. }
  2409.  
  2410. # Do not delete this line -- regeneration end marker
  2411.  
  2412. #---------------------------------------------------------------------------
  2413. #      File:           @(#)pbvaracces.tcl    /main/titanic/1
  2414. #---------------------------------------------------------------------------
  2415.  
  2416. # Start user added include file section
  2417. # End user added include file section
  2418.  
  2419.  
  2420. Class PBVarAccess : {PBAccess} {
  2421.     constructor
  2422.     method destructor
  2423.     method generate
  2424.     attribute readAccess
  2425.     attribute writeAccess
  2426. }
  2427.  
  2428. constructor PBVarAccess {class this i_accessRight i_readAccess i_writeAccess} {
  2429.     set this [PBAccess::constructor $class $this $i_accessRight]
  2430.     $this readAccess $i_readAccess
  2431.     $this writeAccess $i_writeAccess
  2432.     # Start constructor user section
  2433.     # End constructor user section
  2434.     return $this
  2435. }
  2436.  
  2437. method PBVarAccess::destructor {this} {
  2438.     # Start destructor user section
  2439.     # End destructor user section
  2440.     $this PBAccess::destructor
  2441. }
  2442.  
  2443. method PBVarAccess::generate {this} {
  2444.     set access [$this PBAccess::generate]
  2445.     if {[$this readAccess] != ""} {
  2446.         set access "${access} [$this readAccess]"
  2447.     }
  2448.     if {[$this writeAccess] != ""} {
  2449.         set access "${access} [$this writeAccess]"
  2450.     }
  2451.     return [string trim $access]
  2452. }
  2453.  
  2454. # Do not delete this line -- regeneration end marker
  2455.  
  2456. #---------------------------------------------------------------------------
  2457. #      File:           @(#)pbvisualcu.tcl    /main/titanic/2
  2458. #---------------------------------------------------------------------------
  2459.  
  2460. # Start user added include file section
  2461. # End user added include file section
  2462.  
  2463.  
  2464. Class PBVisualCustomUserObject : {PBVisualContainer} {
  2465.     constructor
  2466.     method destructor
  2467.     method genTypeSignature
  2468.     method getKind
  2469.     attribute isAutoInstantiate
  2470. }
  2471.  
  2472. constructor PBVisualCustomUserObject {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  2473.     set this [PBVisualContainer::constructor $class $this $i_name $ooplClass $i_superClassName $i_builtinSuperClassName]
  2474.     $this isAutoInstantiate 0
  2475.     # Start constructor user section
  2476.     # End constructor user section
  2477.     return $this
  2478. }
  2479.  
  2480. method PBVisualCustomUserObject::destructor {this} {
  2481.     # Start destructor user section
  2482.     # End destructor user section
  2483.     $this PBVisualContainer::destructor
  2484. }
  2485.  
  2486. method PBVisualCustomUserObject::genTypeSignature {this} {
  2487.     set signature [$this PBVisual::genTypeSignature]
  2488.     if [$this isAutoInstantiate] {
  2489.         set signature "$signature autoinstantiate"
  2490.     }
  2491.     return $signature
  2492. }
  2493.  
  2494. method PBVisualCustomUserObject::getKind {this} {
  2495.     return ${PBClassKind::VCUserObject}
  2496. }
  2497.  
  2498. # Do not delete this line -- regeneration end marker
  2499.  
  2500. #---------------------------------------------------------------------------
  2501. #      File:           @(#)pbvisualst.tcl    /main/titanic/1
  2502. #---------------------------------------------------------------------------
  2503.  
  2504. # Start user added include file section
  2505. # End user added include file section
  2506.  
  2507.  
  2508.  
  2509. Class PBVisualStandardUserObject : {PBVisualContainer} {
  2510.     constructor
  2511.     method destructor
  2512.     method getKind
  2513. }
  2514.  
  2515. constructor PBVisualStandardUserObject {class this i_name ooplClass i_superClassName i_builtinSuperClassName} {
  2516.     set this [PBVisualContainer::constructor $class $this $i_name $ooplClass $i_superClassName $i_builtinSuperClassName]
  2517.     # Start constructor user section
  2518.     # End constructor user section
  2519.     return $this
  2520. }
  2521.  
  2522. method PBVisualStandardUserObject::destructor {this} {
  2523.     # Start destructor user section
  2524.     # End destructor user section
  2525.     $this PBVisualContainer::destructor
  2526. }
  2527.  
  2528. method PBVisualStandardUserObject::getKind {this} {
  2529.     return ${PBClassKind::VSUserObject}
  2530. }
  2531.  
  2532. # Do not delete this line -- regeneration end marker
  2533.  
  2534.