home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / pbgentor.tcl < prev    next >
Encoding:
Text File  |  1997-11-07  |  54.1 KB  |  1,916 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            : pbgentor.tcl
  17. #       Author          : 
  18. #       Original date   : November 1997
  19. #       Description     : Classes for code generation
  20. #
  21. #---------------------------------------------------------------------------
  22.  
  23. #---------------------------------------------------------------------------
  24. #      File:           @(#)pbfilehand.tcl    /main/titanic/1
  25. #---------------------------------------------------------------------------
  26.  
  27. # Start user added include file section
  28. # End user added include file section
  29.  
  30. require "filehandle.tcl"
  31.  
  32. Class PBFileHandler : {FileHandler} {
  33.     constructor
  34.     method destructor
  35.     method getFileTypes
  36.     method getSpecialFiles
  37.     method setImpFrom
  38.     attribute srwType
  39.     attribute srmType
  40.     attribute srsType
  41.     attribute sruType
  42. }
  43.  
  44. constructor PBFileHandler {class this} {
  45.     set this [FileHandler::constructor $class $this]
  46.     $this srwType "window"
  47.     $this srmType "menu"
  48.     $this srsType "structure"
  49.     $this sruType "userobject"
  50.     # Start constructor user section
  51.     # End constructor user section
  52.     return $this
  53. }
  54.  
  55. method PBFileHandler::destructor {this} {
  56.     # Start destructor user section
  57.     # End destructor user section
  58.     $this FileHandler::destructor
  59. }
  60.  
  61. method PBFileHandler::getFileTypes {this} {
  62.     set list [List new]
  63.  
  64.     $list append [$this srwType]
  65.     $list append [$this srmType]
  66.     $list append [$this srsType]
  67.     $list append [$this sruType]
  68.  
  69.     return $list
  70. }
  71.  
  72. method PBFileHandler::getSpecialFiles {this} {
  73.     return [List new]
  74. }
  75.  
  76. method PBFileHandler::setImpFrom {this fileName class} {
  77.     $this FileHandler::setImpFrom $fileName $class
  78. }
  79.  
  80. # Do not delete this line -- regeneration end marker
  81.  
  82. #---------------------------------------------------------------------------
  83. #      File:           @(#)pbgenerato.tcl    /main/titanic/8
  84. #---------------------------------------------------------------------------
  85.  
  86. # Start user added include file section
  87. require "pbllibrary.tcl"
  88. require "pbtarget.tcl"
  89. # End user added include file section
  90.  
  91. require "generator.tcl"
  92.  
  93. Class PBGenerator : {Generator} {
  94.     constructor
  95.     method destructor
  96.     method generate
  97.     method check
  98.     method isAutoLibrary
  99.     method getPblLibrary
  100.     method checkOldSrc
  101.     method exportSrc
  102.     method importSrc
  103.     attribute autoLibrary
  104.     attribute classesToImport
  105.     attribute removeOldLib
  106.     attribute pblLibrary
  107. }
  108.  
  109. constructor PBGenerator {class this} {
  110.     set this [Generator::constructor $class $this]
  111.     $this autoLibrary -1
  112.     $this removeOldLib 1
  113.     # Start constructor user section
  114.     # End constructor user section
  115.     return $this
  116. }
  117.  
  118. method PBGenerator::destructor {this} {
  119.     # Start destructor user section
  120.     # End destructor user section
  121.     $this Generator::destructor
  122. }
  123.  
  124. method PBGenerator::generate {this classList} {
  125.  
  126.     set typeToClassDictionary [Dictionary new]
  127.     set pbModel [PBModel new]
  128.     set regenerator [PBRegenerator new]
  129.     set fileHandler [PBFileHandler new]
  130.  
  131.     $classList foreach class {
  132.         # because only for global classes (pb entries) code-files
  133.         #  are generated, skip non globals
  134.         if ![$class isGlobalType] {
  135.             continue
  136.         }
  137.         set pbdefinition [$class generate $pbModel]
  138.         if {$pbdefinition == ""} {
  139.             continue
  140.         }
  141.         set entry [$pbdefinition libraryEntry]
  142.         if {$entry == ""} {
  143.             continue
  144.         }
  145.         set fileType [$entry getFileType]
  146.         set fileDesc [$fileHandler openFile $class $fileType]
  147.         if {$fileDesc != ""} {
  148.             $regenerator regenerate $entry $fileDesc
  149.             $fileHandler closeFile $fileDesc
  150.         }
  151.     }
  152.     $pbModel generate $typeToClassDictionary
  153.     return $typeToClassDictionary
  154. }
  155.  
  156. method PBGenerator::check {this classList} {
  157.     set errornr 0
  158.     set cc [ClientContext::global]
  159.     set PhaseV [$cc currentPhase]
  160.     set sysName "PBBuiltins"
  161.     set sysV [$PhaseV findSystemVersion $sysName "system"]
  162.     if [$sysV isNil] {
  163.         m4_error $E_NOBUILTINDES $sysName
  164.         incr errornr 1
  165.     } else {
  166.         $classList foreach class {
  167.             if ![$class isGlobalType] {
  168.                 continue
  169.             }
  170.             # in pbimport::generateOoplModel tests for valid classes
  171.             #  for checking.
  172.             # puts " Language dependence checking for class: [$class getName]"
  173.             set tmpError [$class check]
  174.             incr errornr $tmpError
  175.             # puts " number of returned errors: $tmpError"
  176.         }
  177.     }
  178.     return $errornr
  179. }
  180.  
  181. method PBGenerator::isAutoLibrary {this} {
  182.     set tmp [$this autoLibrary]
  183.     if {[$this autoLibrary] < 0} {
  184.         $this autoLibrary [PBGenerator::checkAutoLibrary]
  185.     }
  186.     return [$this autoLibrary]
  187. }
  188.  
  189. proc PBGenerator::checkAutoLibrary {} {
  190.     set autoLibrary [PBGenerator::getAutoLibraryProp]
  191.     # platform check
  192.     global tcl_platform
  193.     if {![catch {set platform $tcl_platform(platform)}]} {
  194.         if {([string length $platform] >= 3) && \
  195.                 ([string tolower [string range $platform 0 2]] != "win")} {
  196.             m4_message $MPB_AUTOLIBNOTSUP $platform
  197.             set autoLibrary 0
  198.         }
  199.     }
  200.     if {$autoLibrary} {
  201.         m4_message $MPB_AUTOLIBON
  202.     } else {
  203.         m4_message $MPB_AUTOLIBOFF
  204.     }
  205.     return $autoLibrary
  206. }
  207.  
  208. proc PBGenerator::getAutoLibraryProp {} {
  209.     # retrieve auto library setting and look if it is correct
  210.     # default is off (False)
  211.     set cc [ClientContext::global]
  212.     set cs [$cc currentSystem]
  213.     set autoLibrary [$cs getPropertyValue pb_auto_library]
  214.     if {$cs == ""} {
  215.         return 0
  216.     }
  217.      if { [string tolower $autoLibrary] == "on" } {
  218.         set autoLibrary 1
  219.     } elseif { [string tolower $autoLibrary] == "off" } {
  220.                 set autoLibrary 0
  221.     } elseif { $autoLibrary == "0" } {
  222.         set autoLibrary 0
  223.     } elseif { $autoLibrary == "1" } {
  224.         set autoLibrary 1
  225.     } else {
  226.         # default:
  227.         set autoLibrary 0
  228.     }    
  229.     return $autoLibrary
  230. }
  231.  
  232. proc PBGenerator::setAutoLibraryProp {value} {
  233.     set cc [ClientContext::global]
  234.     set cs [$cc currentSystem]
  235.     if {$cs == ""} {
  236.         return
  237.     }
  238.     $cs setProperty pb_auto_library $value
  239. }
  240.  
  241. method PBGenerator::getPblLibrary {this} {
  242.     set libName [[[[ClientContext::global] currentSystem] system] name]
  243.     set libName [string tolower $libName]
  244.     
  245.     if {[$this pblLibrary] == ""} {
  246.         $this pblLibrary [PblLibrary new]
  247.     }
  248.     # if no library exists create
  249.     if ![[$this pblLibrary] existsLibrary] {
  250.         [$this pblLibrary] createLibrary
  251.     }
  252.  
  253.     return [$this pblLibrary]
  254. }
  255.  
  256. proc PBGenerator::checkOldSource {} {
  257.     # nothing yet
  258. }
  259.  
  260. method PBGenerator::checkOldSrc {this classList} {
  261.     # if any .old file is present return True
  262.     set files [fstorage::dir]
  263.     $classList foreach class {
  264.         if ![$class isGlobalType] {
  265.             continue
  266.         }
  267.         set kind [$class getPBClassKind]
  268.         if {$kind == ${PBClassKind::NotSupported}} {
  269.             continue
  270.         }
  271.         set entryName [$class getName]
  272.         set entryType [PBLibraryEntry::getFileTypeByKind $kind]
  273.         set entryExt [PBLibraryEntry::getSrcFileTypeByFileType $entryType]
  274.         set fileName "$entryName\.$entryExt"
  275.         if {[regexp "\.old" $files]} {
  276.             # There is one so..., True
  277.             return 1
  278.         }
  279.     }
  280.     # no classes, or old files:
  281.     return 0
  282. }
  283.  
  284. method PBGenerator::exportSrc {this classList} {
  285.     # first determine whether autoLibrary
  286.     if [$this isAutoLibrary] {
  287.         # get Library handler
  288.         $this pblLibrary [$this getPblLibrary]
  289.         # check whether there are old-libraries
  290.         if {[[$this pblLibrary] existsOldLibrary]} {
  291.             m4_error $EPB_OLDLIBEXISTS $libName
  292.             # there is an old library
  293.             # so turn off auto feature
  294.             $this autoLibrary 0
  295.             return 1
  296.         } else {
  297.             # export sourcefiles from library
  298.             # if they don't exists inside library
  299.             # it does not matter (import will create them)
  300.             m4_message $MPB_EXPORTING
  301.             set errornr [[$this pblLibrary] export $classList]
  302.             return $errornr
  303.         }
  304.         # now it's possible to generate and create source...
  305.     }
  306.     return 0
  307. }
  308.  
  309. method PBGenerator::importSrc {this classList} {
  310.     # if there were no errors do import
  311.     # but if autoLibrary is (turned) off, do nothing
  312.     if [$this isAutoLibrary] {
  313.         # check whether there are old-libraries
  314.         if {[[$this pblLibrary] existsOldLibrary]} {
  315.             # there is an old library
  316.             # so do nothing
  317.         } else {
  318.             # before importing copy library
  319.             [$this pblLibrary] createOldLibrary
  320.             # now import sourcefiles to library
  321.             m4_message $MPB_IMPORTING
  322.             set errornr [[$this pblLibrary] import $classList]
  323.  
  324.             if {$errornr == 0} {
  325.                 # nothing went wrong, so remove old library
  326.                 [$this pblLibrary] removeOldLibrary
  327.             } else {
  328.                 # something went wrong durig import so restore the old
  329.                 #  library
  330.                 [$this pblLibrary] restoreLibrary
  331.                 return 1
  332.             }
  333.         }
  334.         # everything went ok
  335.         return 0
  336.     } else {
  337.         return 1
  338.     }
  339. }
  340.  
  341. # Do not delete this line -- regeneration end marker
  342.  
  343. #---------------------------------------------------------------------------
  344. #      File:           @(#)pbregenera.tcl    /main/titanic/16
  345. #---------------------------------------------------------------------------
  346.  
  347. # Start user added include file section
  348.  
  349. # End user added include file section
  350.  
  351. require "regenerato.tcl"
  352.  
  353. Class PBRegenerator : {Regenerator} {
  354.     constructor
  355.     method destructor
  356.     method regenerate
  357.     method checkEntryFiles
  358.     method processFile
  359.     method processForward
  360.     method processType
  361.     method skipType
  362.     method processVariables
  363.     method skipVariables
  364.     method processPrototypes
  365.     method processStructure
  366.     method processEntryStructure
  367.     method processEvent
  368.     method skipEvent
  369.     method processFunction
  370.     method skipFunction
  371.     method processSubroutine
  372.     method skipSubroutine
  373.     method processBinaryData
  374.     method skipBinaryData
  375.     method processOn
  376.     method skipOn
  377.     method processOnCreate
  378.     method processOnDestroy
  379.     method processParameter
  380.     method addObsoleteClass
  381.     method removeObsoleteClass
  382.     attribute currentClass
  383.     attribute currentEntry
  384.     attribute obsolete
  385.     attribute pbdebug
  386.     attribute obsoleteClassSet
  387. }
  388.  
  389. constructor PBRegenerator {class this} {
  390.     set this [Regenerator::constructor $class $this]
  391.     $this obsoleteClassSet [List new]
  392.     # Start constructor user section
  393.     $this pbdebug 0
  394.     # End constructor user section
  395.     return $this
  396. }
  397.  
  398. method PBRegenerator::destructor {this} {
  399.     # Start destructor user section
  400.  
  401.     # End destructor user section
  402.     $this Regenerator::destructor
  403. }
  404.  
  405. method PBRegenerator::regenerate {this entry fileDesc} {
  406.     $this currentEntry $entry
  407.     
  408.     $this obsolete 0
  409.     
  410.     set oldFileDesc $fileDesc
  411.     
  412.     $this currentClass [[$this currentEntry] globalDefinition]
  413.     
  414.     # All functions return True (!= 0) if syntax is correctly ended. 
  415.     # This allows checking of an not correctly terminated file.
  416.     
  417.     # if obsolete code is present then stop
  418.     if { ![$this checkEntryFiles $entry $fileDesc]} {
  419.         return 0
  420.     }
  421.     
  422.     # process file:
  423.     # header:
  424.     if { ![eof $fileDesc] } {
  425.         set line [gets $fileDesc]
  426.     } else {
  427.         set line ""
  428.     }
  429.     if { [regexp {^ *\$PBExportHeader\$(.*)} $line \
  430.               total entryFileName] } {
  431.         if { ![eof $fileDesc] } {
  432.             set line [gets $fileDesc]
  433.         } else {
  434.             set line ""
  435.         }
  436.     }
  437.     if { [regexp {^ *\$PBExportComments\$(.*)} $line \
  438.               total entryComment] } {
  439.         [$this currentEntry] exportComments $entryComment
  440.         if { ![eof $fileDesc] } {
  441.             set line [gets $fileDesc]
  442.         } else {
  443.             set line ""
  444.         }
  445.     }
  446.     if { [regexp {^ *forward(.*|)} $line total] } {
  447.         $this processForward [$this currentEntry] $fileDesc
  448.         if { ![eof $fileDesc] } {
  449.             set line [gets $fileDesc]
  450.         } else {
  451.             set line ""
  452.         }
  453.     }
  454.  
  455.     while { ![eof $fileDesc] } {
  456.         if { [regexp {^ *global type ([^ ]*) from ([^ ]*) *}\
  457.                 $line total type from] } {
  458.             # when called correctly the type corresponds with currentEntry!
  459.             # if unsure a name comparison CAN be done
  460.             $this currentClass [[$this currentEntry] globalDefinition]
  461.             [$this currentClass] isRegenerated 1
  462.  
  463.             if {[string tolower $from] == "structure"} {
  464.                 # process type body and add variables to body of entry
  465.                 set ret [$this processStructure [$this currentClass] $fileDesc]
  466.             } else {
  467.                 # process type body and add variables to body of entry
  468.                 set ret [$this processType [$this currentClass] $fileDesc]
  469.             }
  470.         } elseif { [regexp {^ *global ([^ ]*) ([^ ]*) *}\
  471.                 $line total type name] } {
  472.             # just to be on the save side
  473.             $this currentClass [[$this currentEntry] globalDefinition]
  474.             [$this currentClass] isRegenerated 1
  475.         } elseif { [regexp {^ *type variables[ ]*} $line total] } {
  476.             # first get vars TextSection
  477.             if { [[$this currentClass] isA "PBClass"] } {
  478.                 if { [[$this currentClass] nonModeledInstanceVars] != "" } {
  479.                     set vars [[$this currentClass] nonModeledInstanceVars] 
  480.                 } else {
  481.                     set vars [TextSection new]
  482.                     [$this currentClass] nonModeledInstanceVars $vars
  483.                 }
  484.                 if { [[$this currentClass] nonModeledInstanceVars] == "" } {
  485.                 }
  486.                 set ret [$this processVariables $vars $fileDesc]
  487.             } else {
  488.                 # currentClass cannot contain instance vars though it is present
  489.                 m4_warning $W_OBSOLVARS [[$this currentClass] name]
  490.                 $this obsolete 1
  491.                 set ret [$this skipVariables $fileDesc]
  492.                 if { ! $ret } {
  493.                         m4_error $E_ENDEXPECT "instance variables" \
  494.                             [[$this currentClass] name]
  495.                     }
  496.             }        
  497.         } elseif { [regexp {^ *shared variables.*} $line total] } {
  498.  
  499.             # shared variables are part of entry, so set currentClass 
  500.             # to given entry:
  501.             $this currentClass [[$this currentEntry] globalDefinition]
  502.             # first get vars TextSection
  503.             if { [[$this currentClass] isA "PBClass"] } {
  504.                 if { [[$this currentClass] nonModeledSharedVars] != "" } {
  505.                     set vars [[$this currentClass] nonModeledSharedVars] 
  506.                 } else {
  507.                     set vars [TextSection new]
  508.                     [$this currentClass] nonModeledSharedVars $vars
  509.                 }
  510.                 if { [[$this currentClass] nonModeledSharedVars] == "" } {
  511.                 }
  512.                 set ret [$this processVariables $vars $fileDesc]
  513.             } else {
  514.                 # currentClass cannot contain instance vars though it is present
  515.                 m4_warning $W_OBSOLVARS [[$this currentClass] name]
  516.                 $this obsolete 1
  517.                 set ret [$this skipVariables $fileDesc]
  518.                 if { ! $ret } {
  519.                         m4_error $E_ENDEXPECT "variables" \
  520.                             [[$this currentClass] name]
  521.                     }
  522.             }
  523.         } elseif { [regexp {^ *forward prototypes.*} $line total] } {
  524.             set ret [$this processPrototypes [$this currentClass] $fileDesc]
  525.         } elseif { [regexp {^ *type ([^ ]*) from ([^ ]*) within ([^ ]*)(| | .*)}\
  526.                         $line total name from within] } {
  527.             # first find corresponding class (recursively)
  528.             if { [[[$this currentEntry] globalDefinition] isA \
  529.                       "PBVisualContainer"] } {
  530.                 $this currentClass [[[$this currentEntry] globalDefinition] \
  531.                         findContainedClass $name 1]
  532.                 if {[$this currentClass] != ""} {
  533.                     [$this currentClass] isRegenerated 1
  534.                     # found now use container to move to sortedContainedClass
  535.                     set containee [[$this currentClass] container]
  536.                     if {$containee != ""} {
  537.                         $containee moveContainedClass [$this currentClass]
  538.                     }
  539.                     set ret [$this processType [$this currentClass] $fileDesc]
  540.                 } else {
  541.                     # object is gone
  542.                     m4_warning $W_OBSOLPROPS $name
  543.                     $this obsolete 1
  544.                     set ret [$this skipType $fileDesc]
  545.                 }
  546.             } else {
  547.                 # a contained class is found but cannot be inserted
  548.                 m4_warning $W_OBSOLCLASSENTRY $name [[$this currentEntry] \
  549.                                                          getName]
  550.                 $this addObsoleteClass $name
  551.                 $this obsolete 1
  552.                 set ret [$this skipType $fileDesc]
  553.             }
  554.         } elseif { [regexp {^ *type ([^ ]*) *from *([^ ]*)(| | .*)}\
  555.                 $line total name from] } {
  556.             if { [string tolower $from] == "structure" } {
  557.                 # if a structure then do nothing, inserted by generator
  558.                 set ret [$this skipType $fileDesc]
  559.             } elseif { [[[$this currentEntry] globalDefinition] isA \
  560.                             "PBVisualContainer"] } {
  561.                 # first find corresponding class (recursively)
  562.                 $this currentClass [[[$this currentEntry] globalDefinition] \
  563.                         findContainedClass $name 1]
  564.                 if {[$this currentClass] != ""} {
  565.                     [$this currentClass] isRegenerated 1
  566.                     # found now use container to move to sortedContainedClass
  567.                     set containee [[$this currentClass] container]
  568.                     if {$containee != ""} {
  569.                         $containee moveContainedClass [$this currentClass]
  570.                     }
  571.                     set ret [$this processType [$this currentClass] $fileDesc]
  572.                 } else {
  573.                     # object is gone
  574.                     m4_warning $W_OBSOLPROPS $name
  575.                     $this obsolete 1
  576.                     set ret [$this skipType $fileDesc]
  577.                 }
  578.             } else {
  579.                 # a contained class is found but cannot be inserted
  580.                 m4_warning $W_OBSOLCLASSENTRY $name \
  581.                     [[$this currentEntry] getName]
  582.                 $this addObsoleteClass $name
  583.                 $this obsolete 1
  584.                 set ret [$this skipType $fileDesc]
  585.             }
  586.             if { ! $ret } {
  587.                 m4_error $E_ENDEXPECT "type" [[$this currentClass] name]
  588.             }
  589.         } elseif { [regexp {^ *event *([^ ]*)::([^ ]*) *;(.*)$}\
  590.                         $line total class name methLine] } {
  591.             set classname "$class::$name"
  592.             if {([[[$this currentEntry] globalDefinition] isA \
  593.                       "PBVisualContainer"]) && \
  594.                     [[[$this currentEntry] globalDefinition] \
  595.                          controlPresentInSupers $class] } {
  596.                 set body [TextSection new]
  597.                 set ret [$this processEvent $body $fileDesc $line]
  598.                 $body append "end event\n"
  599.                 if {![[[[$this currentEntry] globalDefinition] \
  600.                            derivedControlBody] exists $classname]} {
  601.                     [[$this currentEntry] globalDefinition] \
  602.                         setDerivedControlBody $classname $body
  603.                 } else {
  604.                     m4_warning $W_OBSOLMETHCONTR $name $class
  605.                     $this obsolete 1
  606.                 }
  607.             } else {
  608.                 m4_warning $W_OBSOLMETHCONTR $name $classname
  609.                 $this obsolete 1
  610.                 set ret [$this skipEvent $fileDesc]
  611.             }
  612.             # generate syntax error if ret is false 
  613.             if { ! $ret } {
  614.                 m4_error $E_ENDEXPECTMETHOD "event" $name \
  615.                     [[$this currentClass] name]
  616.             }
  617.         } elseif { [regexp {^ *on *([^ ]*)::([^ ]*) *;(.*)$}\
  618.                         $line total class name methLine] } {
  619.             set classname "$class::$name"
  620.             if {([[[$this currentEntry] globalDefinition] isA \
  621.                       "PBVisualContainer"]) && \
  622.                     [[[$this currentEntry] globalDefinition] \
  623.                          controlPresentInSupers $class] } {
  624.                 set body [TextSection new]
  625.                 set ret [$this processOn $body $fileDesc $line]
  626.                 $body append "end on\n"
  627.                 if {![[[[$this currentEntry] globalDefinition] \
  628.                            derivedControlBody] exists $classname]} {
  629.                     [[$this currentEntry] globalDefinition] \
  630.                         setDerivedControlBody $classname $body
  631.                 } else {
  632.                     m4_warning $W_OBSOLMETHCONTR $name $class
  633.                     $this obsolete 1
  634.                 }
  635.             } else {
  636.                 m4_warning $W_OBSOLMETHCONTR $name $classname
  637.                 $this obsolete 1
  638.                 set ret [$this skipOn $fileDesc]
  639.             }
  640.             # generate syntax error if ret is false 
  641.             if { ! $ret } {
  642.                 m4_error $E_ENDEXPECTMETHOD "event" $name \
  643.                     [[$this currentClass] name]
  644.             }
  645.         } elseif { [regexp {^ *event *([^ ]*) *; *(call[^;]*;|)(.*)$}\
  646.                         $line total name callSuper methLine] } {
  647.             # first check for association method
  648.             if { [regexp "^ *${PBCookie::associationAccessorMethod}" \
  649.                       $methLine] } {
  650.                 # association
  651.                 set ret [$this skipEvent $fileDesc]
  652.             } elseif { [$this currentClass] == "" } {
  653.                 m4_warning $W_OBSOLEVENT $name ""
  654.                 $this obsolete 1
  655.                 set ret [$this skipEvent $fileDesc]            
  656.             } else {
  657.                 set body ""
  658.                 # first find corresponding function
  659.                 # so check whether it can have functions:
  660.                 if { ![[$this currentClass] isA "PBClass"] } {
  661.                     # currentClass cannot contain events though it is present
  662.                     m4_warning $W_OBSOLEVENTCLASS $name \
  663.                         [[$this currentClass] name]
  664.                     $this obsolete 1
  665.                     set ret [$this skipEvent $fileDesc]
  666.                 } else {
  667.                     set event [[$this currentClass] findEvent $name]
  668.                     if { $event  != "" } {
  669.                         # perfect matching method, if it has a body then move 
  670.                         # this body to another method (check function, not the
  671.                         # events (no event overloading))
  672.                         if { [$event body] != ""} {
  673.                             # body is already filled, although this was perfect
  674.                             # match, so find other and move body to other 
  675.                             # matching function (by name only)
  676.                             set body [$event body]
  677.                             set func [[$this currentClass] matchObjectFunction \
  678.                                           $name]
  679.                             if {$func != ""} {
  680.                                 # matchOF already checks for empty bodies
  681.                                 m4_warning $W_OLDMETHOD $name \
  682.                                     [[$this currentClass] name]
  683.                                 $func body $body
  684.                             } else {
  685.                                 # nothing suitable found: all already filled,
  686.                                 # or no matching names
  687.                                 m4_warning $W_OBSOLEVENT $name \
  688.                                     [[$this currentClass] name]
  689.                                 $this obsolete 1
  690.                             }
  691.                         }
  692.                         set body [TextSection new]
  693.                         $event body $body
  694.                         if { $callSuper != "" } {
  695.                             $event extendAncestorScript 1
  696.                         }
  697.                     } else {
  698.                         # find a matching function and store code in this body
  699.                         # preceding a comment line
  700.                         # not find a event (no overloading)
  701.                         set func [[$this currentClass] matchObjectFunction \
  702.                                   $name]
  703.                         if {$func != ""} {
  704.                             # matchOF already checks for empty bodies
  705.                             set body [TextSection new]
  706.                             m4_warning $W_OLDMETHOD $name \
  707.                                 [[$this currentClass] name]
  708.                             $func body $body
  709.                             $body append {// Old code section}
  710.                             $body append "\n"
  711.                         } else {
  712.                             # nothing suitable found: all already filled, or no
  713.                             # matching names
  714.                             m4_warning $W_OBSOLEVENT $name \
  715.                                 [[$this currentClass] name]
  716.                             $this obsolete 1
  717.                         }
  718.                     }
  719.                     # if a body set then there was some match, and now fill body.
  720.                     if { $body != "" } {
  721.                         # processEvent checks association methods
  722.                         #   (and skip those)
  723.                         set ret [$this processEvent $body $fileDesc $methLine]
  724.                     } else {
  725.                         # obsolete code user defined
  726.                         $this obsolete 1
  727.                         set ret [$this skipEvent $fileDesc]
  728.                     }
  729.                 }
  730.             }
  731.             # generate syntax error if ret is false 
  732.             if { ! $ret } {
  733.                 m4_error $E_ENDEXPECTMETHOD "event" $name \
  734.                     [[$this currentClass] name]
  735.             }
  736.         } elseif { [regexp {^ *(|[^ ]* )function ([^ ]*) ([^ ]*) (\([^);]*\)) *; *(.*)$}\
  737.                 $line total access type name args methLine] } {
  738.             # obsolete code when not a association
  739.             if { [regexp "^ *${PBCookie::associationAccessorMethod}" \
  740.                       $methLine] } {
  741.                 # association
  742.                 set ret [$this skipFunction $fileDesc]
  743.             } elseif { [$this currentClass] == "" } {
  744.                 $this obsolete 1
  745.                 set ret [$this skipFunction $fileDesc]            
  746.             } else {
  747.                 set body ""
  748.                 # first find corresponding function
  749.                 # so check whether it can have functions:
  750.                 if { ![[$this currentClass] isA "PBClass"] } {
  751.                     # currentEntry cannot contain functions though it is present
  752.                     m4_warning $W_OBSOLFUNCTCLASS $name \
  753.                         [[$this currentClass] name]
  754.                     $this obsolete 1
  755.                     set ret [$this skipFunction $fileDesc]
  756.                 } else {
  757.                     # generate parameter list for finding correct function 
  758.                     #   (overloading)
  759.                     set paramList [$this processParameter $args]
  760.                     set function [[$this currentClass] findObjectFunction \
  761.                                       $name $paramList]
  762.                     if { $function != "" } {
  763.                         # perfect matching method, if it has a body then move
  764.                         # this body to another method (first check function 
  765.                         # then events
  766.                         if { [$function body] != ""} {
  767.                             # body is already filled, although this was 
  768.                             # perfect match, so find other and move body 
  769.                             # to other matching function (by name only)
  770.                             set body [$function body]
  771.                             set func [[$this currentClass] \
  772.                                           matchObjectFunction $name]
  773.                             if {$func != ""} {
  774.                                 # matchOF already checks for empty bodies
  775.                                 $func body $body
  776.                             } else {
  777.                                 set event [[$this currentClass] matchEvent \
  778.                                                $name]
  779.                                 if {$event != ""} {
  780.                                     # matchE already checks for empty bodies
  781.                                     $event body $body
  782.                                 } else {
  783.                                     # nothing suitable found: all already 
  784.                                     # filled, or no matching names
  785.                                     m4_warning $W_OBSOLMETHOD $name \
  786.                                         [[$this currentClass] name]
  787.                                     $this obsolete 1
  788.                                 }
  789.                             }
  790.                         }
  791.                         set body [TextSection new]
  792.                         $function body $body
  793.                     } else {
  794.                         # find a matching and store code in 
  795.                         # this body preceding a comment line
  796.                         set func [[$this currentClass] matchObjectFunction \
  797.                                       $name]
  798.                         if {$func != ""} {
  799.                             # matchOF already checks for empty bodies
  800.                             set body [TextSection new]
  801.                             m4_warning $W_OLDMETHOD $name \
  802.                                 [[$this currentClass] name]
  803.                             $func body $body
  804.                             $body append {// Old code section}
  805.                             $body append "\n"
  806.                         } else {
  807.                             set event [[$this currentClass] matchEvent $name]
  808.                             if {$event != ""} {
  809.                                 # matchE already checks for empty bodies
  810.                                 m4_warning $W_OLDMETHOD $name \
  811.                                     [[$this currentClass] name]
  812.                                 set body [TextSection new]
  813.                                 $event body $body
  814.                                 $body append {// Old code section}
  815.                                 $body append "\n"
  816.                             } else {
  817.                                 # nothing suitable found: all already filled,
  818.                                 # or no matching names
  819.                                 m4_warning $W_OBSOLFUNCT $name \
  820.                                     [[$this currentClass] name]
  821.                                 $this obsolete 1
  822.                             }
  823.                         }
  824.                     }
  825.                     # if a body set then there was some match, and now 
  826.                     # fill body.
  827.                     if { $body != "" } {
  828.                         # processFunction checks association methods 
  829.                         #  (and skip those)
  830.                         set ret [$this processFunction $body $fileDesc \
  831.                                      $methLine]
  832.                     } else {
  833.                         # obsolete code, user defined
  834.                         $this obsolete 1
  835.                         set ret [$this skipFunction $fileDesc]
  836.                     }
  837.                 }
  838.             }
  839.             # generate syntax error if ret is false 
  840.             if { ! $ret } {
  841.                 m4_error $E_ENDEXPECTMETHOD "function" $name \
  842.                     [[$this currentClass] name]
  843.             }
  844.         } elseif { [regexp {^ *(|[^ ]* )subroutine ([^ ]*) (\([^);]*\)) *; *(.*)$}\
  845.                        $line total access name args methLine] } {
  846.             # first check for association method
  847.             if { [regexp "^ *${PBCookie::associationAccessorMethod}" \
  848.                       $methLine] } {
  849.                 # association
  850.                 set ret [$this skipSubroutine $fileDesc]        
  851.             } elseif { [$this currentClass] == "" } {
  852.                 $this obsolete 1
  853.                 set ret [$this skipSubroutine $fileDesc]            
  854.             } else {            
  855.                 set body ""
  856.                 # first find corresponding function
  857.                 # so check whether it can have functions:
  858.                 if { ![[$this currentClass] isA "PBClass"] } {
  859.                     # currentEntry cannot contain functions though it is present
  860.                     m4_warning $W_OBSOLSUBRTCLASS $name \
  861.                         [[$this currentClass] name]
  862.                     $this obsolete 1
  863.                     set ret [$this skipSubroutine $fileDesc]
  864.                 } else {
  865.                     # generate parameter list for finding correct function 
  866.                     #   (overloading)
  867.                     set paramList [$this processParameter $args]
  868.                     set function [[$this currentClass] findObjectFunction \
  869.                                       $name $paramList]
  870.                     if { $function != "" } {
  871.                         # perfect matching method, if it has a body then move
  872.                         # this body to another method (first check function
  873.                         # then events
  874.                         if { [$function body] != ""} {
  875.                             # body is already filled, although this was perfect
  876.                             # match, so find other and move body to other
  877.                             # matching function (by name only)
  878.                             set body [$function body]
  879.                             set func [[$this currentClass] matchObjectFunction \
  880.                                           $name]
  881.                             if {$func != ""} {
  882.                                 # matchOF already checks for empty bodies
  883.                                 $func body $body
  884.                             } else {
  885.                                 set event [[$this currentClass] matchEvent\
  886.                                                $name]
  887.                                 if {$event != ""} {
  888.                                     # matchE already checks for empty bodies
  889.                                     $event body $body
  890.                                 } else {
  891.                                     # nothing suitable found: all already
  892.                                     # filled, or no matching names
  893.                                     m4_warning $W_OBSOLMETHOD $name \
  894.                                         [[$this currentClass] name]
  895.                                     $this obsolete 1
  896.                                 }
  897.                             }
  898.                         }
  899.                         set body [TextSection new]
  900.                         $function body $body
  901.                     } else {
  902.                         # find a matching and store code in this body 
  903.                         # preceding a comment line
  904.                         set func [[$this currentClass] matchObjectFunction \
  905.                                       $name]
  906.                         if {$func != ""} {
  907.                             # matchOF already checks for empty bodies
  908.                             set body [TextSection new]
  909.                             m4_warning $W_OLDMETHOD $name [[$this currentClass]
  910.                                                            name]
  911.                             $func body $body
  912.                             $body append {// Old code section}
  913.                             $body append "\n"
  914.                         } else {
  915.                             set event [[$this currentClass] matchEvent $name]
  916.                             if {$event != ""} {
  917.                                 # matchE already checks for empty bodies
  918.                                 m4_warning $W_OLDMETHOD $name \
  919.                                     [[$this currentClass] name]
  920.                                 set body [TextSection new]
  921.                                 $event body $body
  922.                                 $body append {// Old code section}
  923.                                 $body append "\n"
  924.                             } else {
  925.                                 # nothing suitable found: all already filled, 
  926.                                 # or no matching names
  927.                                 m4_warning $W_OBSOLSUBRT $name \
  928.                                     [[$this currentClass] name]
  929.                                 $this obsolete 1
  930.                             }
  931.                         }
  932.                     }
  933.                     # if a body set then there was some match, 
  934.                     # and now fill body.
  935.                     if { $body != "" } {
  936.                         # processSubroutine checks association methods 
  937.                         # (and skip those)
  938.                         set ret [$this processSubroutine $body $fileDesc \
  939.                                      $methLine]
  940.                     } else {
  941.                         # obsolete code user defined
  942.                         $this obsolete 1
  943.                         set ret [$this skipSubroutine $fileDesc]
  944.                     }
  945.                 }
  946.             }
  947.             # generate syntax error if ret is false 
  948.             if { ! $ret } {
  949.                 m4_error $E_ENDEXPECTMETHOD "subroutine" $name \
  950.                     [[$this currentClass] name]
  951.             }
  952.         } elseif { [regexp {^ *on *([^ .]*)\.([^ ]*) *$} $line \
  953.                         total class name ] } {
  954.             # first find corresponding class as defined by class in on
  955.             set onClass ""
  956.             if { [$this currentClass] != "" } {
  957.                 if { [string tolower [[$this currentClass] name]] == \
  958.                          [string tolower $class] } {
  959.                     set onClass [$this currentClass]
  960.                 } else {
  961.                     if {[[[$this currentEntry] globalDefinition] isA \
  962.                             "PBVisualContainer"]} {
  963.                         set onClass [[[$this currentEntry] globalDefinition] \
  964.                                          findContainedClass $name 1]
  965.                     }
  966.                 }
  967.             } else {
  968.                 if {[[[$this currentEntry] globalDefinition] isA \
  969.                         "PBVisualContainer"]} {
  970.                     set onClass [[[$this currentEntry] globalDefinition] \
  971.                                      findContainedClass $name 1]
  972.                 }
  973.             }        
  974.             if { $onClass == "" } {
  975.                 # onClass not present
  976.                 # but maybe it's a creation of menuitem present in one 
  977.                 # of the superclasses...
  978.                 if {([string tolower $name] == "create") && \
  979.                         ([[$this currentEntry] getKind] == \
  980.                              ${PBClassKind::Menu}) && \
  981.                         [[[$this currentEntry] globalDefinition] \
  982.                              controlPresentInSupers $class] } {
  983.                     set classname "$class::create"
  984.                     set body [TextSection new]
  985.                     set ret [$this processOn $body $fileDesc $line]
  986.                     $body append "end on\n"
  987.                     if {![[[[$this currentEntry] globalDefinition] \
  988.                                derivedControlBody] exists $classname]} {
  989.                         [[$this currentEntry] globalDefinition] \
  990.                             setDerivedControlBody $classname $body
  991.                     } else {
  992.                         m4_warning $W_OBSOLMETHCONTR $name $class
  993.                         $this obsolete 1
  994.                     }
  995.                 } else {
  996.                     m4_warning $W_OBSOLMETHCONTR $name $class
  997.                     $this obsolete 1
  998.                     set ret [$this skipOn $fileDesc]
  999.                 }
  1000.                 if { ! $ret } {
  1001.                     m4_error $E_ENDEXPECTMETHOD "on" $name $class
  1002.                 }
  1003.                 
  1004.             } else {
  1005.                 # first find corresponding function
  1006.                 # so check whether it can have functions:
  1007.                 if { [$onClass isA "PBClass"] } {
  1008.                     if { [string tolower $name] == "destroy" } {
  1009.                         set methLine ""
  1010.                         if { [$onClass isA "PBVisual"] } {
  1011.                             # only Visual class has an extensive destroy section
  1012.                             set ret [$this processOnDestroy $onClass \
  1013.                                          $fileDesc $methLine]
  1014.                         } else {
  1015.                             set ret [$this skipOn $fileDesc]
  1016.                         }
  1017.                         
  1018.                         if { ! $ret } {
  1019.                             m4_error $E_ENDEXPECTMETHOD "on" $name \
  1020.                                 [$onClass name]
  1021.                         }
  1022.                     } elseif { [string tolower $name] == "create" } {
  1023.                         set methLine ""
  1024.                         if { [$onClass isA "PBVisual"] } {
  1025.                             # only Visual class has an extensive create section
  1026.                             set ret [$this processOnCreate $onClass \
  1027.                                          $fileDesc $methLine]
  1028.                         } else {
  1029.                             set ret [$this skipOn $fileDesc]
  1030.                         }
  1031.                         if { ! $ret } {
  1032.                             m4_error $E_ENDEXPECTMETHOD "on" $name \
  1033.                                 [$onClass name]
  1034.                         }
  1035.                     } else {
  1036.                         # this is a on event (hopefully)
  1037.                         set event [onClass findEvent $name]
  1038.                         if { $event != "" } {
  1039.                             if { [$event body] } {
  1040.                                 set body [$event body] 
  1041.                             } else {
  1042.                                 set body [TextSection new]
  1043.                                 $event body $body
  1044.                             }
  1045.                             set ret [$this processOn $body $fileDesc $methLine ]
  1046.                             if { ! $ret } {
  1047.                                 m4_error $E_ENDEXPECTMETHOD "on" $name \
  1048.                                     [$onClass name]
  1049.                             }
  1050.                         } else {
  1051.                             # obsolete code
  1052.                             m4_warning $W_OBSOLON $name [$onClass name]
  1053.                             $this obsolete 1
  1054.                             set ret [$this skipOn $fileDesc]
  1055.                             # generate syntax error if ret is false 
  1056.                             if { ! $ret } {
  1057.                                 m4_error $E_ENDEXPECTMETHOD "on" $name \
  1058.                                     [$onClass name]
  1059.                             }
  1060.                         }
  1061.                     }
  1062.                 } else {
  1063.                     # currentClass cannot contain events though it is present
  1064.                     m4_warning $W_OBSOLONCLASS $name [$onClass name]
  1065.                     $this obsolete 1
  1066.                     set ret [$this skipOn $fileDesc]
  1067.                     if { ! $ret } {
  1068.                         m4_error $E_ENDEXPECTMETHOD "on" $name [$onClass name]
  1069.                     }
  1070.                 }
  1071.             }
  1072.         } elseif { [regexp {^ *on ([^ ;]*) *;(.*)$} $line \
  1073.                         total name methLine] } {
  1074.             # treated as event!
  1075.             # first find corresponding event
  1076.             # so check whether it can have functions:
  1077.             if { [$this currentClass] == "" } {
  1078.                 $this obsolete 1
  1079.                 m4_warning $W_OBSOLON $name ""
  1080.                 set ret [$this skipOn $fileDesc]            
  1081.             } elseif { [[$this currentClass] isA "PBClass"] } {
  1082.                 set event [[$this currentClass] findEvent $name]
  1083.                 if { $event != "" } {
  1084.                     if { [$event body] != ""} {
  1085.                         set body [$event body] 
  1086.                     } else {
  1087.                         set body [TextSection new]
  1088.                         $event body $body
  1089.                     }
  1090.                     set ret [$this processOn $body $fileDesc $methLine]
  1091.                 } else {
  1092.                     # obsolete code
  1093.                     m4_warning $W_OBSOLON $name [[$this currentClass] name]
  1094.                     $this obsolete 1
  1095.                     set ret [$this skipOn $fileDesc]
  1096.                 }
  1097.             } else {
  1098.                 # currentClass cannot contain events though it is present
  1099.                 m4_warning $W_OBSOLONCLASS $name [[$this currentClass] name]
  1100.                 $this obsolete 1
  1101.                 set ret [$this skipOn $fileDesc]
  1102.             }
  1103.             # generate syntax error if ret is false
  1104.             if { [$this currentClass] == "" } {
  1105.                 set tmp ""
  1106.             } else {
  1107.                 set tmp [[$this currentClass] name]
  1108.             }        
  1109.             if { ! $ret } {
  1110.                 m4_error $E_ENDEXPECTMETHOD "on" $name $tmp
  1111.             }    
  1112.         } elseif { [regexp "^ *${PBCookie::startBinaryDataSection}.*"\
  1113.                 $line total name methLine] } {
  1114.             # first find corresponding event
  1115.             # so check whether it can have functions:
  1116.             $this currentClass [[$this currentEntry] globalDefinition]
  1117.             if { [[$this currentClass] isA "PBVisualContainer"] } {
  1118.                 if { [$this currentClass] binaryData != "" } {
  1119.                     set binaryData [[$this currentClass] binaryData]
  1120.                 } else {
  1121.                     set binaryData [TextSection new]
  1122.                     [$this currentClass] binaryData $body
  1123.                 }
  1124.                 set ret [$this processBinaryData $binaryData $fileDesc]
  1125.                 # generate syntax error if ret is false 
  1126.                 if { ! $ret } {
  1127.                     m4_error $E_ENDEXPECTBINARY [[$this currentClass] name]
  1128.                 }
  1129.             } else {
  1130.                 # currentClass cannot contain events though it is present
  1131.                 m4_warning $W_OBSOLBINARY [[$this currentClass] name]
  1132.                 $this obsolete 1
  1133.                 set ret [$this skipBinaryData $fileDesc]
  1134.                 if { ! $ret } {
  1135.                     m4_error $E_ENDEXPECTBINARY [[$this currentClass] name]
  1136.                 }
  1137.             }
  1138.         } elseif { [regexp {^ *$} $line] } {
  1139.             set ret 1
  1140.         } else {
  1141.             puts "Unexpected syntax: $line"
  1142.             puts " Must be a begin-line of a section (eg. method, type declaration)"
  1143.             puts " Possibly a wrong end-line (eg. end-line inside comment)"
  1144.             set ret 0
  1145.         }
  1146.  
  1147.         # end parser
  1148.         if { ! $ret } {
  1149.             # something went wrong
  1150.                m4_error $E_STOP [[$this currentEntry] getName]
  1151.             return
  1152.             # return 0
  1153.         }
  1154.         if { ![eof $fileDesc] } {
  1155.             set line [gets $fileDesc]
  1156.         } else {
  1157.             set line ""
  1158.         }
  1159.     }
  1160.  
  1161.     if { [$this obsolete] == 1 } {
  1162.         # read file pointed by setting pointer back and reread it
  1163.         seek $fileDesc 0
  1164.         set cont [TextSection new]
  1165.         while { ![eof $fileDesc] } {
  1166.             $cont append "[gets $fileDesc]\n"
  1167.         }
  1168.         # write old file
  1169.         set oldFileHandler [PBFileHandler new]
  1170.         $oldFileHandler writeSectionToFile $cont \
  1171.                 [[[$this currentEntry] globalDefinition] ooplClass] \
  1172.                 "old.[[$this currentEntry] getFileType]"
  1173.     }
  1174.     # everthing went succesfully (maybe some obsolete code)
  1175.     return
  1176.     # return 1
  1177. }
  1178.  
  1179. method PBRegenerator::checkEntryFiles {this entry fileDesc} {
  1180.     # if any .old file is present stop regenerating!
  1181.     set files [fstorage::dir]
  1182.  
  1183.     if {[regexp "[$entry getName]\.old" $files]} {
  1184.         m4_error $E_HASOLD
  1185.         return 0
  1186.     } else {
  1187.         return 1
  1188.     }
  1189. }
  1190.  
  1191. method PBRegenerator::processFile {this entry fileDesc} {
  1192.     # none (obsolete)
  1193. }
  1194.  
  1195. method PBRegenerator::processForward {this entry fileDesc} {
  1196.     # read and skip all lines until a "end forward"
  1197.     # return false if eof
  1198.     set done 0
  1199.     while { ![eof $fileDesc] && !$done } {
  1200.         set line [gets $fileDesc]
  1201.  
  1202.         if { [regexp {^end forward[ \t]*$} $line ] } {
  1203.             set done 1
  1204.             break
  1205.         }
  1206.     }
  1207.     set ret $done
  1208.     return $ret
  1209. }
  1210.  
  1211. method PBRegenerator::processType {this class fileDesc} {
  1212.     # read and parse all lines until a "end type"
  1213.     set done 0
  1214.     while { ![eof $fileDesc] && !$done } {
  1215.         set line [gets $fileDesc]
  1216.         set type ""
  1217.         set typename ""
  1218.         set eventname ""
  1219.         set value ""
  1220.         if { [regexp {^end type[ \t]*$} $line ] } {
  1221.             set done 1
  1222.             break
  1223.         }
  1224.         if { [regexp {^ *([^ ]*) ([^ =]*) *=[ ]*([^\{ ].*)$}\
  1225.                   $line total type typename value] } {
  1226.  
  1227.            } elseif { [regexp {^ *([^ ]*) ([^ =]*) *=[ ]*(\{[^\{\}]*\})}\
  1228.                         $line total type typename value] } {
  1229.  
  1230.         } elseif { [regexp {^ *([^ ]*) ([^ =]*) *=[ ]*(\{[^\}]*)$}\
  1231.                         $line total type typename value] } {
  1232.             # append value until closing brace is read
  1233.             set end 0
  1234.             while {![eof $fileDesc] && !$end } {
  1235.                 set line [gets $fileDesc]
  1236.                 if { [regexp {[^\}]*\}} $line] } {
  1237.                     set end 1
  1238.                     set value "$value\n$line"
  1239.                 } else {
  1240.                     set value "$value\n$line"
  1241.                 }
  1242.             }
  1243.         } elseif { [regexp {^ *event ([^ ]*) ([^ ]*)}\
  1244.                         $line total eventname eventid] } {
  1245.         
  1246.         } elseif { [regexp {^ *event type ([^ ]*) ([^ ]*) \( \)} \
  1247.                         $line total type eventname] } {
  1248.             
  1249.         } elseif { [regexp {^ *event ([^ ]*) (\([^\)]*\))} \
  1250.                         $line total eventname] } {
  1251.         
  1252.         } elseif { [regexp {([^ ]*) ([^ ]*)} $line total type name] } {
  1253.             if { $type == $name } {
  1254.                 # equals so probable a contained element
  1255.             } else {
  1256.                 # a declared something
  1257.                 set typename $name
  1258.             }
  1259.         } else {
  1260.         }
  1261.         # if there is a typename add a builtin property to the class
  1262.         if { [$class isA "PBVisual"] } {
  1263.             if { $typename != "" && \
  1264.                     [string tolower $typename] != "menuname" && \
  1265.                     [string tolower $typename] != "windowtype"} {
  1266.                 $class setBuiltinProperty $typename \
  1267.                         [PBBuiltinProperty new $typename $type $value \
  1268.                         -where ${PBBuiltinProperty::InTypeDef} ]
  1269.             }
  1270.         }
  1271.     }
  1272.     # generate syntax error because done not set
  1273.     if { !$done } {
  1274.         m4_error $E_ENDEXPECT "type" [$class name]
  1275.     }
  1276.     set ret $done
  1277.     return $ret
  1278. }
  1279.  
  1280. method PBRegenerator::skipType {this fileDesc} {
  1281.     # read and skip all lines until a "end type"
  1282.     # return false if eof
  1283.     set done 0
  1284.     while { ![eof $fileDesc] && !$done } {
  1285.         set line [gets $fileDesc]
  1286.         if { [regexp {^end type[ \t]*} $line ] } {
  1287.             set done 1
  1288.             break
  1289.         }
  1290.     }
  1291.     set ret $done
  1292.     return $ret
  1293. }
  1294.  
  1295. method PBRegenerator::processVariables {this body fileDesc} {
  1296.     # read and skip all lines (= variables) except those after 
  1297.     # the non-modelled user defined attributes (and Declare ... ;) )
  1298.     set done 0
  1299.     # process variable section
  1300.     # return false if eof
  1301.     while { ![eof $fileDesc] && !$done } {
  1302.         set line [gets $fileDesc]
  1303.         if { [regexp {^end variables[ \t]*$} $line ] } {
  1304.             # exit all
  1305.             set done 1
  1306.         } elseif { [regexp {^ *DECLARE.*} [string toupper $line] ] } {
  1307.             # declared SQL query/function, non-object-team support 
  1308.             #   so user defined:
  1309.             $body append $line
  1310.             $body append "\n"
  1311.             # read all lines until a line ends with ";"
  1312.             set declare 0
  1313.             while { ![eof $fileDesc] && !$declare } {
  1314.                 set line [gets $fileDesc]
  1315.                 if { [regexp {[^;]*;.*} $line ] } {
  1316.                     $body append $line
  1317.                     $body append "\n"
  1318.                     set declare 1
  1319.  
  1320.                 } elseif { [regexp {^end variables[ \t]*} $line ] } {
  1321.                     # exit all
  1322.                     set done 1
  1323.                     set declare 1
  1324.                     m4_error $E_DECLARESYNTAX [[$this currentClass] name]
  1325.                 } else {
  1326.                     $body append $line
  1327.                     $body append "\n"
  1328.                 }
  1329.             }
  1330.         } elseif { [regexp "${PBCookie::nonModeledAttributeSection}" $line ] } {
  1331.             # read all lines until next section (or "end variables" or EOF)
  1332.             set next 0
  1333.             set emptyLine 0
  1334.             set emptyLineStr ""
  1335.             while { ![eof $fileDesc] && !$next } {
  1336.                 set line [gets $fileDesc]
  1337.                 if { [regexp {^end variables[ \t]*$} $line ] } {
  1338.                     # exit all
  1339.                     set done 1
  1340.                     set next 1
  1341.                 } elseif { [regexp {^[ \t]*$} $line] } {
  1342.                     # some special empty line handling
  1343.                     # when empty line remember this and
  1344.                     # only store this line when NOT end of section
  1345.                     if { $emptyLine == 1 } {
  1346.                         # when already an empty line in buffer store this one
  1347.                         $body append $emptyLineStr
  1348.                         $body append "\n"
  1349.                     } else {
  1350.                         set emptyLine 1
  1351.                         set emptyLineStr $line
  1352.                     }
  1353.                 } elseif { ![regexp "${PBCookie::dataAttributeSection}" \
  1354.                                  $line] && \
  1355.                            ![regexp "${PBCookie::associationAttributeSection}" \
  1356.                                  $line] && \
  1357.                            ![regexp "${PBCookie::controlClassMapSection}" \
  1358.                                  $line] } {
  1359.                     if { $emptyLine == 1 } {
  1360.                         # there is an empty line waiting to be stored first
  1361.                         $body append $emptyLineStr
  1362.                         $body append "\n"
  1363.                         set emptyLine 0
  1364.                         set emptyLineStr ""
  1365.                     }
  1366.                     $body append $line
  1367.                     $body append "\n"
  1368.                 } else {
  1369.                     # exit this section
  1370.                     set next 1
  1371.                 }
  1372.             }
  1373.         } else {
  1374.         }
  1375.         #end while
  1376.     }
  1377.     set ret $done
  1378.  
  1379.     return $ret
  1380. }
  1381.  
  1382. method PBRegenerator::skipVariables {this fileDesc} {
  1383.     # read and skip all lines until a "end type"
  1384.     # return false if eof
  1385.     set done 0
  1386.     while { ![eof $fileDesc] && !$done } {
  1387.         set line [gets $fileDesc]
  1388.  
  1389.         if { [regexp {^end variables[ \t]*$} $line ] } {
  1390.             set done 1
  1391.             break
  1392.         }
  1393.     }
  1394.  
  1395.     set ret $done
  1396.     return $ret
  1397. }
  1398.  
  1399. method PBRegenerator::processPrototypes {this class fileDesc} {
  1400.     # read and skip all lines until a "end prototypes"
  1401.     # return false if eof
  1402.     set done 0
  1403.     while { ![eof $fileDesc] && !$done } {
  1404.         set line [gets $fileDesc]
  1405.  
  1406.         if { [regexp {^end prototypes[ \t]*$} $line ] } {
  1407.             set done 1
  1408.             break
  1409.         }
  1410.     }
  1411.  
  1412.     # generate syntax error because done not set
  1413.     if { !$done } {
  1414.         m4_error $E_ENDEXPECT "prototypes" [$class name]
  1415.     }
  1416.  
  1417.     set ret $done
  1418.     return $ret
  1419. }
  1420.  
  1421. method PBRegenerator::processStructure {this class fileDesc} {
  1422.     # read and skip all lines until a "end type"
  1423.     # return false if eof
  1424.     set done 0
  1425.     while { ![eof $fileDesc] && !$done } {
  1426.         set line [gets $fileDesc]
  1427.  
  1428.         if { [regexp {^end type[ \t]*$} $line ] } {
  1429.             set done 1
  1430.             break
  1431.         }
  1432.     }
  1433.  
  1434.     # generate syntax error because done not set
  1435.     if { !$done } {
  1436.         m4_error $E_ENDEXPECTMETHOD "type" "(structure)" [$class name]
  1437.     }
  1438.  
  1439.     set ret $done
  1440.     return $ret
  1441. }
  1442.  
  1443. method PBRegenerator::processEntryStructure {this class fileDesc} {
  1444.     # read and skip all lines until a "end type"
  1445.     # return false if eof
  1446.     set done 0
  1447.     while { ![eof $fileDesc] && !$done } {
  1448.         set line [gets $fileDesc]
  1449.  
  1450.         if { [regexp {^end type[ \t]*$} $line ] } {
  1451.             set done 1
  1452.             break
  1453.         }
  1454.     }
  1455.     
  1456.     # generate syntax error because done not set
  1457.     if { !$done } {
  1458.         m4_error $E_ENDEXPECTMETHOD "type" "(structure)" [$class name]
  1459.     }
  1460.  
  1461.     set ret $done
  1462.     return $ret
  1463. }
  1464.  
  1465. method PBRegenerator::processEvent {this body fileDesc line} {
  1466.     # read and add all lines until a "end type"
  1467.     # return false if eof
  1468.     # if there is a start and end marker only get code between those
  1469.     #    eg constructor and destructor events
  1470.     #    deletes added code before any startmarker!
  1471.     #    stops adding after end marker!
  1472.     set done 0
  1473.     set skip 0
  1474.     set bodyTmp [TextSection new]
  1475.  
  1476.     while { ![eof $fileDesc] && !$done } {
  1477.         if { [regexp {^end event[ \t]*$} $line ] } {
  1478.             set done 1
  1479.             break
  1480.         } elseif { [regexp "^ *${PBCookie::endUserSection}" $line ] } {
  1481.             set skip 1
  1482.             # nothing
  1483.         } elseif { [regexp "^ *${PBCookie::startUserSection}" $line ] } {
  1484.             set skip 0
  1485.             set bodyTmp [TextSection new]
  1486.             # nothing
  1487.         } else {
  1488.             # add line to body
  1489.             if {$skip == 0} {
  1490.                 $bodyTmp append $line
  1491.                 $bodyTmp append "\n"
  1492.             }
  1493.         }
  1494.         # read next line
  1495.         set line [gets $fileDesc]
  1496.     }
  1497.  
  1498.     $body appendSect $bodyTmp
  1499.     set ret $done
  1500.     return $ret
  1501. }
  1502.  
  1503. method PBRegenerator::skipEvent {this fileDesc} {
  1504.     # read and skip all lines until a "end event"
  1505.     # return false if eof
  1506.     set done 0
  1507.     while { ![eof $fileDesc] && !$done } {
  1508.         set line [gets $fileDesc]
  1509.  
  1510.         if { [regexp {^end event[ \t]*$} $line ] } {
  1511.             set done 1
  1512.             break
  1513.         }
  1514.     }
  1515.  
  1516.     set ret $done
  1517.     return $ret
  1518. }
  1519.  
  1520. method PBRegenerator::processFunction {this body fileDesc line} {
  1521.     # read and add all lines until a "end type"
  1522.     # return false if eof
  1523.     set done 0
  1524.  
  1525.     # set to false:
  1526.     set skip 0
  1527.     set bodyTmp [TextSection new]
  1528.  
  1529.     while { ![eof $fileDesc] &&  !$done } {
  1530.         if { [regexp {^end function[ \t]*$} $line ] } {
  1531.             set done 1
  1532.             break
  1533.         } elseif { [regexp "^ *${PBCookie::associationAccessorMethod}" \
  1534.                         $line] } {
  1535.             set skip 1
  1536.  
  1537.             # nothing
  1538.         } elseif { [regexp {^ *// User defined method.*} $line] } {
  1539.             set skip 0
  1540.  
  1541.             # nothing
  1542.         } else {
  1543.             # add line to body
  1544.             $bodyTmp append $line
  1545.             $bodyTmp append "\n"
  1546.         }
  1547.         # read next line
  1548.         set line [gets $fileDesc]
  1549.     }
  1550.  
  1551.     if { $skip == 0} {
  1552.         $body appendSect $bodyTmp
  1553.     }
  1554.  
  1555.     set ret $done
  1556.     return $ret
  1557. }
  1558.  
  1559. method PBRegenerator::skipFunction {this fileDesc} {
  1560.     # read and skip all lines until a "end function"
  1561.     # return false if eof
  1562.     set done 0
  1563.     
  1564.     while { ![eof $fileDesc] && !$done } {
  1565.         set line [gets $fileDesc]
  1566.         
  1567.         if { [regexp {^end function[ \t]*$} $line ] } {
  1568.             set done 1
  1569.             break
  1570.         }
  1571.     }
  1572.     
  1573.     set ret $done
  1574.     return $ret
  1575. }
  1576.  
  1577. method PBRegenerator::processSubroutine {this body fileDesc line} {
  1578.     # read and add all lines until a "end type"
  1579.     # return false if eof
  1580.     set done 0
  1581.     
  1582.     # set to false:
  1583.     set skip 0
  1584.     set bodyTmp [TextSection new]
  1585.     
  1586.     while { ![eof $fileDesc] &&  !$done } {
  1587.         if { [regexp {^end subroutine[ \t]*$} $line ] } {
  1588.             set done 1
  1589.             break
  1590.         } elseif { [regexp "^ *${PBCookie::associationAccessorMethod}" \
  1591.                         $line ] } {    
  1592.             set skip 1
  1593.             # nothing
  1594.         } elseif { [regexp {^ *// User defined method.*} $line ] } {
  1595.             set skip 0
  1596.             # nothing                
  1597.         } else {
  1598.             # add line to body
  1599.             $bodyTmp append $line
  1600.             $bodyTmp append "\n"
  1601.         }
  1602.         # read next line
  1603.         set line [gets $fileDesc]
  1604.     }
  1605.     
  1606.     if { $skip == 0} {
  1607.         $body appendSect $bodyTmp
  1608.     }
  1609.     
  1610.     set ret $done
  1611.     return $ret
  1612. }
  1613.  
  1614. method PBRegenerator::skipSubroutine {this fileDesc} {
  1615.     # read and skip all lines until a "end function"
  1616.     # return false if eof
  1617.     set done 0
  1618.     while { ![eof $fileDesc] && !$done } {
  1619.         set line [gets $fileDesc]
  1620.  
  1621.         if { [regexp {^end subroutine[ \t]*} $line ] } {
  1622.             set done 1
  1623.             break
  1624.         }
  1625.     }
  1626.  
  1627.     set ret $done
  1628.     return $ret
  1629. }
  1630.  
  1631. method PBRegenerator::processBinaryData {this body fileDesc} {
  1632.     # read and add all lines until a "End of PowerBuilder Binary Data Section : No Source Expected After This Point"
  1633.     # return false if eof
  1634.     set done 0
  1635.     while { ![eof $fileDesc] &&  !$done } {
  1636.         if { [regexp "^ *${PBCookie::endBinaryDataSection}.*" $line ] } {
  1637.             set done 1
  1638.             break       
  1639.         } else {
  1640.             # add line to body
  1641.             $body append $line
  1642.             $body append "\n"
  1643.         }
  1644.         # read next line
  1645.         set line [gets $fileDesc]
  1646.     }
  1647.  
  1648.     set ret $done
  1649.     return $ret
  1650. }
  1651.  
  1652. method PBRegenerator::skipBinaryData {this fileDesc} {
  1653.     # read and skip all lines until a 
  1654.     # "End of PowerBuilder Binary Data Section : 
  1655.     #         No Source Expected After This Point"
  1656.     # return false if eof
  1657.     set done 0
  1658.     while { ![eof $fileDesc] && !$done } {
  1659.         set line [gets $fileDesc]
  1660.  
  1661.         if { [regexp "^ *${PBCookie::endBinaryDataSection}.*" $line ] } {
  1662.             set done 1
  1663.             break
  1664.         }
  1665.     }
  1666.  
  1667.     set ret $done
  1668.     return $ret
  1669. }
  1670.  
  1671. method PBRegenerator::processOn {this body fileDesc line} {
  1672.     # read and add all lines until a "end type"
  1673.     # return false if eof
  1674.     set done 0
  1675.     while { ![eof $fileDesc] &&  !$done } {
  1676.         if { [regexp {^end on[ \t]*$} $line ] } {
  1677.             set done 1
  1678.             break
  1679.         } elseif { [regexp "^ *${PBCookie::associationAccessorMethod}.*" \
  1680.                         $line ] } {
  1681.             # nothing
  1682.         } elseif { [regexp {// User defined method.*} $line ] } {
  1683.             # nothing
  1684.         } else {
  1685.             # add line to body
  1686.             $body append $line
  1687.             $body append "\n"
  1688.         }
  1689.         # read next line
  1690.         set line [gets $fileDesc]
  1691.     }
  1692.  
  1693.     set ret $done
  1694.     return $ret
  1695. }
  1696.  
  1697. method PBRegenerator::skipOn {this fileDesc} {
  1698.     # read and skip all lines until a "end on"
  1699.     # return false if eof
  1700.     set done 0
  1701.     while { ![eof $fileDesc] && !$done } {
  1702.         set line [gets $fileDesc]
  1703.  
  1704.         if { [regexp {^end on[ \t]*$} $line ] } {
  1705.             set done 1
  1706.             break
  1707.         }
  1708.     }
  1709.  
  1710.     set ret $done
  1711.     return $ret
  1712. }
  1713.  
  1714. method PBRegenerator::processOnCreate {this class fileDesc line} {
  1715.     # scan on-body for property initializations
  1716.     set done 0
  1717.     set thisClassName [string tolower [$class name]]
  1718.     
  1719.     # get crappy section
  1720.     if { [$class onCreateResidue] != "" } {
  1721.         set body [$class onCreateResidue] 
  1722.     } else {
  1723.         set body [TextSection new]
  1724.         $class onCreateResidue $body
  1725.     }
  1726.  
  1727.     while { ![eof $fileDesc] && !$done } {
  1728.         set line [gets $fileDesc]
  1729.         set type ""
  1730.         set name ""
  1731.         set value ""
  1732.  
  1733.         if { [regexp {^end on[ \t]*$} $line ] } {
  1734.             set done 1
  1735.             break
  1736.         }
  1737.         if { [regexp {^ *this\.([^ =]*) *= *create .*} $line \
  1738.                   total ] } {
  1739.  
  1740.         } elseif { [regexp {^ *this\.([^ =]*) *= *([^\{ ].*)$} $line \
  1741.                         total name value] } {
  1742.         
  1743.         } elseif { [regexp {^ *this\.([^ =]*) *= *(\{[^\}]*\})} $line \
  1744.                         total name value] } {
  1745.  
  1746.         } elseif { [regexp {^ *if.*} $line] } {
  1747.  
  1748.         } elseif { [regexp {^ *this\.([^ =]*) *= *(\{[^\}]*\})$} $line \
  1749.                         total name value] } {
  1750.  
  1751.         } elseif { [regexp {^ *this\.([^ =]*) *= *(\{[^\}]*)$} $line \
  1752.                         total name value] } {
  1753.             # append value until closing brace is read
  1754.             set end 0
  1755.             while {![eof $fileDesc] && !$end } {
  1756.                 set line [gets $fileDesc]
  1757.                 if { [regexp {[^\}]*\}.*} $line] } {
  1758.                     set end 1
  1759.                     set value "$value\n$line"
  1760.                 } else {
  1761.                     set value "$value\n$line"
  1762.                 }
  1763.             }
  1764.         } elseif { [regexp {^ *([^ =]*) *= *([^ ]*) *$} $line \
  1765.                         total name value] } {
  1766.             set tmpname [string tolower $name]
  1767.             set tmpvalue [string tolower $value]
  1768.             if {($tmpname == $thisClassName) &&\
  1769.                     ($tmpvalue == "this")} {
  1770.                 set name ""
  1771.             }
  1772.         } elseif { [regexp {^ *TriggerEvent\( *this *, *(\"|)constructor(\"|) *\) *$} $line total ] } {
  1773.         } elseif { [regexp {^ *int *iCurrent *$} $line \
  1774.                         total ] } {
  1775.         } elseif { [regexp {^ *iCurrent=UpperBound.*$} $line \
  1776.                         total ] } {
  1777.         } elseif { [regexp {^ *call ([^:]*)::create *} $line \
  1778.                         total callname] } {
  1779.             if {($callname != [$class superClassName]) && \
  1780.                     ($callname != "super")} {
  1781.                 # add unknown line to crappy section.
  1782.                 $body append $line
  1783.                 $body append "\n"
  1784.             } 
  1785.         } else {
  1786.             # add unknown lines to crappy section.
  1787.             $body append $line
  1788.             $body append "\n"
  1789.         }
  1790.  
  1791.         # these exceptions may not be added:
  1792.         set tmpname [string tolower $name]
  1793.         if {[string length $tmpname] >= 5} {
  1794.             set tmpname2 [string range $tmpname 0 4]
  1795.             if {($tmpname2 == "item\[")} {
  1796.                 set name ""
  1797.             }
  1798.         }
  1799.         if {[string length $tmpname] >= 8} {
  1800.             set tmpname2 [string range $tmpname 0 7]
  1801.             if {($tmpname2 == "control\[") } {
  1802.                 set name ""
  1803.             }
  1804.         }
  1805.         if {$tmpname == "icurrent"} {
  1806.             set name ""
  1807.         }
  1808.  
  1809.         # if there is a name add a builtin property to the class
  1810.         if { $name != "" } {
  1811.             $class setBuiltinProperty $name \
  1812.                 [PBBuiltinProperty new $name $type $value \
  1813.                      -where ${PBBuiltinProperty::InOnCreate} ]
  1814.  
  1815.         }
  1816.     }
  1817.     set ret $done
  1818.     return $ret
  1819. }
  1820.  
  1821. method PBRegenerator::processOnDestroy {this class fileDesc line} {
  1822.     # skip on body and return false when eof
  1823.     set done 0
  1824.  
  1825.     if { [$class onDestroyResidue] != "" } {
  1826.         set body [$class onDestroyResidue] 
  1827.     } else {
  1828.         set body [TextSection new]
  1829.         $class onDestroyResidue $body
  1830.     }
  1831.  
  1832.     while { ![eof $fileDesc] && !$done } {
  1833.         set line [gets $fileDesc]
  1834.  
  1835.         if { [regexp {^end on[ \t]*$} $line ] } {
  1836.             set done 1
  1837.             set line ""
  1838.             break
  1839.         } elseif { [regexp {^ *destroy\(this\.([^)]*)\).*} $line \
  1840.                        total name] } {
  1841.             if {[$class findContainedClass $name] != ""} {
  1842.                 set line ""
  1843.             } elseif {[[$this obsoleteClassSet] search -exact $name] >= 0} {
  1844.                 # was an obsolete class
  1845.                 set line ""
  1846.             }
  1847.         } elseif { [regexp {^ *TriggerEvent\( *this *, *(\"|)destructor(\"|) *\) *$} $line total ] } {
  1848.             set line ""
  1849.         } elseif { [regexp {^ *if IsValid\(MenuID\) then destroy\(MenuID\) *$} $line total ] } {
  1850.             set line ""
  1851.         } elseif { [regexp {^ *call ([^:]*)::destroy *} $line \
  1852.                         total callname] } {
  1853.             if {($callname == [$class superClassName]) || \
  1854.                     ($callname == "super")} {
  1855.                 set line ""
  1856.             } 
  1857.         }
  1858.         if {$line != "" } {
  1859.             # add unknown lines to crappy section.
  1860.             $body append $line
  1861.             $body append "\n"
  1862.         }
  1863.     }
  1864.     set ret $done
  1865.     return $ret
  1866. }
  1867.  
  1868. method PBRegenerator::processParameter {this line} {
  1869.     # create list of argument/parameter types from string given by line
  1870.  
  1871.     set lst [List new]
  1872.  
  1873.     # strip parentheses
  1874.     if { [regexp {^ *\(([^)]*)\) *$} $line total params] } {
  1875.         set params [string tolower $params]
  1876.  
  1877.     } else {
  1878.         set params [string tolower $line]
  1879.  
  1880.  
  1881.     }
  1882.     while { [regexp {^ *(reference |ref |readonly |value |)([^ ]*) ([^ ,]*) *,(.*)} $params total passBy type name params_] } {
  1883.  
  1884.  
  1885.             set params $params_
  1886.  
  1887.             $lst append $type
  1888.     }
  1889.         
  1890.     if { [regexp {^ *(reference |ref |readonly |value |)([^ ]*) ([^ ]*) *} $params total passBy type name] } {
  1891.  
  1892.             $lst append $type
  1893.  
  1894.     }
  1895.  
  1896.     set i 0
  1897.     $lst foreach arg {
  1898.         incr i 1
  1899.     }
  1900.  
  1901.  
  1902.     return $lst
  1903. }
  1904.  
  1905. # Do not delete this line -- regeneration end marker
  1906.  
  1907. method PBRegenerator::addObsoleteClass {this newObsoleteClass} {
  1908.     [$this obsoleteClassSet] append $newObsoleteClass
  1909.  
  1910. }
  1911.  
  1912. method PBRegenerator::removeObsoleteClass {this oldObsoleteClass} {
  1913.     [$this obsoleteClassSet] removeValue $oldObsoleteClass
  1914. }
  1915.  
  1916.