home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / delphigtor.tcl < prev    next >
Encoding:
Text File  |  1997-11-07  |  24.1 KB  |  941 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            : delphigtor.tcl
  17. #       Author          : 
  18. #       Original date   : November 1997
  19. #       Description     : Classes for code generation
  20. #
  21. #---------------------------------------------------------------------------
  22.  
  23. #---------------------------------------------------------------------------
  24. #      File:           @(#)dpfilehand.tcl    /main/titanic/3
  25. #---------------------------------------------------------------------------
  26.  
  27. # Start user added include file section
  28. # End user added include file section
  29.  
  30. require "filehandle.tcl"
  31.  
  32. Class DPFileHandler : {FileHandler} {
  33.     constructor
  34.     method destructor
  35.     method getFileName
  36.     method getSpecialFiles
  37.     method getFileTypes
  38.     method getProjectFileName
  39. }
  40.  
  41. global DPFileHandler::DPRType
  42. set DPFileHandler::DPRType "dpr"
  43.  
  44. global DPFileHandler::PASType
  45. set DPFileHandler::PASType "pas"
  46.  
  47. global DPFileHandler::DFMType
  48. set DPFileHandler::DFMType "txt"
  49.  
  50.  
  51. constructor DPFileHandler {class this} {
  52.     set this [FileHandler::constructor $class $this]
  53.     # Start constructor user section
  54.     # End constructor user section
  55.     return $this
  56. }
  57.  
  58. method DPFileHandler::destructor {this} {
  59.     # Start destructor user section
  60.     # End destructor user section
  61.     $this FileHandler::destructor
  62. }
  63.  
  64. method DPFileHandler::getFileName {this class fileType} {
  65.     return "[$class getUnitName].$fileType"
  66. }
  67.  
  68. method DPFileHandler::getSpecialFiles {this} {
  69.     set list [List new]
  70.     $list append [$this getProjectFileName]
  71.     return $list
  72. }
  73.  
  74. method DPFileHandler::getFileTypes {this} {
  75.     set list [List new]
  76.     $list append ${DPFileHandler::DPRType}
  77.     $list append ${DPFileHandler::PASType}
  78.     $list append ${DPFileHandler::DFMType}
  79.     return $list
  80. }
  81.  
  82. method DPFileHandler::getProjectFileName {this} {
  83.     return "[getCurrentSystemName].${DPFileHandler::DPRType}"
  84. }
  85.  
  86. # Do not delete this line -- regeneration end marker
  87.  
  88. #---------------------------------------------------------------------------
  89. #      File:           @(#)dpgenerato.tcl    /main/titanic/14
  90. #---------------------------------------------------------------------------
  91.  
  92. # Start user added include file section
  93. # End user added include file section
  94.  
  95. require "generator.tcl"
  96.  
  97. Class DPGenerator : {Generator} {
  98.     constructor
  99.     method destructor
  100.     method check
  101.     method checkProject
  102.     method checkSpecialFiles
  103.     method generateProjectSections
  104.     method generateProjectFile
  105.     method generate
  106.     method generateSpecialFiles
  107.     attribute fileHandler
  108.     attribute ooplModel
  109. }
  110.  
  111. constructor DPGenerator {class this} {
  112.     set this [Generator::constructor $class $this]
  113.     # Start constructor user section
  114.  
  115.     $this fileHandler [DPFileHandler new]
  116.  
  117.     # End constructor user section
  118.     return $this
  119. }
  120.  
  121. method DPGenerator::destructor {this} {
  122.     # Start destructor user section
  123.     # End destructor user section
  124.     $this Generator::destructor
  125. }
  126.  
  127. method DPGenerator::check {this classList} {
  128.     $classList foreach cl {
  129.         $cl check
  130.     }
  131. }
  132.  
  133. method DPGenerator::checkProject {this} {
  134.     set errornr 0
  135.     set nrStartupForms 0
  136.     set nrTForms 0
  137.     set formsList {}
  138.  
  139.     foreach class [[$this ooplModel] ooplClassSet] {
  140.         if {[$class isExternal] || [$class isComponentDummy]} {
  141.             continue
  142.         }
  143.         if {[$class getPropertyValue "is_mainform"] == 1} {
  144.             if {[$class isForm] && ![$class isDataModule]} {
  145.                 if {$nrStartupForms != 0} {
  146.                     m4_error $E_DOUBLESTARTUP [$class getFormVarName] [$startupForm getFormVarName]
  147.                     incr errornr 1
  148.                 } else {
  149.                     incr nrStartupForms
  150.                     set startupForm $class
  151.                 }
  152.             } else {
  153.                 m4_warning $W_CANTBESTARTUP [$class getName]
  154.             }
  155.         }
  156.         if {[$class isForm]} {
  157.             set formsList [linsert $formsList 0 $class]
  158.             if {![$class isDataModule]} {
  159.                 incr nrTForms
  160.             }
  161.         }
  162.     }
  163.  
  164.     if {$nrTForms != 0 && $nrStartupForms == 0} {
  165.         set FormNr 0
  166.         while {[[lindex $formsList $FormNr] isDataModule]} {
  167.             incr FormNr
  168.         }
  169.         set startupForm [lindex $formsList $FormNr]
  170.         m4_warning $W_NOSTARTUP [$startupForm getFormVarName]
  171.     }
  172.  
  173.     return $errornr
  174. }
  175.  
  176. method DPGenerator::checkSpecialFiles {this fileList} {
  177.     set errornr 0
  178.  
  179.     $fileList foreach specialFile {
  180.         incr errornr [$this checkProject]
  181.     }
  182.  
  183.     return $erronr
  184. }
  185.  
  186. method DPGenerator::generateProjectSections {this uses code} {
  187.     if {[$this checkProject] > 0} {
  188.         return
  189.     }
  190.  
  191.     set startupForm ""
  192.     set nrStartupForms 0
  193.     set nrTForms 0
  194.     set systemUsesList {}
  195.     set standardUsesList {}
  196.     set formsList {}
  197.     set newUsesList {}
  198.  
  199.     foreach class [[$this ooplModel] ooplClassSet] {
  200.         if {[$class isExternal] || [$class isComponentDummy]} {
  201.             continue
  202.         }
  203.         if {[$class getPropertyValue "is_mainform"] == 1} {
  204.             if {[$class isForm] && ![$class isDataModule]} {
  205.                 set startupForm $class
  206.                 incr nrStartupForms
  207.             } 
  208.         }
  209.         if {[$class isForm]} {
  210.             set formsList [linsert $formsList 0 $class]
  211.             if {![$class isDataModule]} {
  212.                 incr nrTForms
  213.             }
  214.         }
  215.  
  216.         set libunit [$class getPropertyValue "libunit"]
  217.         if {$libunit != "None" && $libunit != ""} {
  218.             if {$libunit == "Other"} {
  219.                 set name [$class getPropertyValue "userlib"]
  220.             } else {
  221.                 set name $libunit
  222.             }
  223.             if {[lsearch -exact $systemUsesList $name] == -1} {
  224.             set systemUsesList [linsert $systemUsesList 0 $name]
  225.             }
  226.         } else {
  227.             if {[lsearch -exact $standardUsesList $class] == -1} {
  228.                 set standardUsesList [linsert $standardUsesList 0 $class]
  229.             }
  230.         }
  231.     }
  232.  
  233.     set first 1
  234.     foreach name $systemUsesList {
  235.         if {$first} {
  236.             set first 0
  237.         } else {
  238.             $uses append ",\n"
  239.         }
  240.         $uses append "${name}"
  241.         set newUsesList [linsert $newUsesList 0 $name]
  242.     }
  243.     foreach class $standardUsesList {
  244.         if {$first} {
  245.             set first 0
  246.         } else {
  247.             $uses append ",\n"
  248.         }
  249.         $uses append "[$class getUnitName] in '[$class getUnitName].pas'"
  250.         set newUsesList [linsert $newUsesList 0 [$class getUnitName]]
  251.  
  252.         # Append Delphi markers in project file
  253.         #
  254.         if {[$class isDataModule]} {
  255.             $uses append "  \{[$class getFormVarName]: TDataModule\}"
  256.         } else {
  257.             if {[$class isForm]} {
  258.                 $uses append "  \{[$class getFormVarName]\}"
  259.             }
  260.         }
  261.     }
  262.     if {[$uses contents] != ""} {
  263.         $uses append "\n"
  264.     }
  265.  
  266.     if {$nrTForms != 0 && $nrStartupForms == 0} {
  267.         set FormNr 0
  268.         while {[[lindex $formsList $FormNr] isDataModule]} {
  269.             incr FormNr
  270.         }
  271.         set startupForm [lindex $formsList $FormNr]
  272.     }
  273.  
  274.     $code indent +
  275.     if {$startupForm != ""} {
  276.         $code append "Application.CreateForm([$startupForm getFormTypeName], [$startupForm getFormVarName]);\n"
  277.     }
  278. #    foreach form $formsList {
  279. #        if {[$form getFormVarName] != [$startupForm getFormVarName]} {
  280. #            $code append "Application.CreateForm([$form getFormTypeName], [$form getFormVarName]); ${DPCookie::genProjectCode}\n"
  281. #        }
  282. #    }
  283.     $code indent -
  284.  
  285.     return $newUsesList
  286. }
  287.  
  288. method DPGenerator::generateProjectFile {this fileName uses code newUsesList} {
  289.     set oldProject [DPTextSection new]
  290.     set newProject [DPTextSection new]
  291.     set cc [ClientContext::global]
  292.     set projectName [getCurrentSystemName]
  293.     set dprType ${DPFileHandler::DPRType}
  294.     set genUsesList {}
  295.  
  296.     #
  297.     # Read either the customization file or the existing project file
  298.     #
  299.  
  300.     if {[catch {set fileDesc [fstorage::open [[$this fileHandler] getProjectFileName] r]}]} {
  301.  
  302.         # Search for customization file
  303.         $oldProject append [$cc getCustomFileContents "default" "dpr" etc]
  304.     } else {
  305.  
  306.         # Read existing file
  307.         set done 0
  308.         while {![eof $fileDesc] && !$done} {
  309.             set line [gets $fileDesc]
  310.             if {![regexp {(//).*} $line]} {
  311.                 set done 1
  312.                 $oldProject append "$line\n"
  313.             }
  314.         }
  315.         while {![eof $fileDesc]} {
  316.             set line [gets $fileDesc]
  317.             $oldProject append "$line\n"
  318.         }
  319.         fstorage::close $fileDesc
  320.     }
  321.  
  322.     #
  323.     # Check existing project file for valid contents and grab sections
  324.     #
  325.  
  326.     if {![regexp {[     ]*(program|library)[     ]*([^;]*);.((.*)uses.([^;]*);.)?(.*)begin.(.*)} [$oldProject contents] total prjType prjName dummy1 grab1 usesBody grab2 remain]} {
  327.         m4_error $E_PRJCONTENTS
  328.         return $newProject
  329.     }
  330.     if {![regexp {(.*)[     ]*end\..*(// Do not delete this block -- regeneration marker -- start)(.*)(// Do not delete this block -- regeneration marker -- end)} $remain total grabCode dummy1 genuses dummy2]} {
  331.         m4_error $E_PRJCONTENTS
  332.         return $newProject
  333.     }
  334.  
  335.     #
  336.     # Grab generated uses in existing project  file
  337.     #
  338.  
  339.     set tempList [split $genuses "\n"]
  340.     foreach line $tempList {
  341.         if {[regexp {^[     ]*//[     ]*([^     ]+)$} $line total name]} {
  342.             set genUsesList [linsert $genUsesList 0 $name]
  343.         }
  344.     }
  345.  
  346.     #
  347.     # Create project type and name
  348.     #
  349.  
  350.     if {$prjName == "<default>"} {
  351.         set prjName $projectName
  352.     }
  353.     $newProject append "${prjType} ${prjName};"
  354.     $newProject append $grab1
  355.     
  356.     #
  357.     # Create uses list
  358.     #
  359.  
  360.     set usesList [split $usesBody "\n"]
  361.     if {$uses != ""} {
  362.         $newProject append "\nuses\n"
  363.         $newProject indent +
  364.         set first 1
  365.         set oldremain ""
  366.         foreach line $usesList {
  367.             if {[regexp {^[     ]*(([^     ,;]+)([     ]+in[     ]+[^     ,;]+)?)([,;])?([     ]*.*)$} $line total name unitname filename dummy remain]} {
  368.                 if {[lsearch -exact $genUsesList $unitname] == -1 && [lsearch -exact $newUsesList $unitname] == -1} {
  369.                     if {$first} {
  370.                         set first 0
  371.                     } else {
  372.                         $newProject append ","
  373.                         $newProject append "${oldremain}\n"
  374.                     }
  375.                     set oldremain $remain
  376.                     $newProject append "${name}"
  377.                 }
  378.             }
  379.         }
  380.         if {!$first} {
  381.             if {$uses != ""} {
  382.                 $newProject append ","
  383.             }
  384.             $newProject append "${oldremain}\n"
  385.         }
  386.         $newProject appendSect $uses
  387.         $newProject append ";\n"
  388.         $newProject indent -
  389.     }
  390.     $newProject append $grab2
  391.  
  392.     #
  393.     # Create project code
  394.     #
  395.  
  396.     $newProject append "begin\n"
  397.     if {[regexp {(.*)[     ]*Application\.Run;.(.*)} $grabCode total codeBody1 codeBody2]} {
  398.         set codeList [split $codeBody1 "\n"]
  399.         foreach line $codeList {
  400.             if {![regexp "Application.CreateForm" $line]} {
  401.                 if {![regexp {^[     ]*$} $line]} {
  402.                     $newProject append "${line}\n"
  403.                 }
  404.             }
  405.         }
  406.         $newProject appendSect $code
  407.         $newProject indent +
  408.         $newProject append "Application.Run;\n"
  409.         $newProject indent -
  410.         $newProject append $codeBody2
  411.     }
  412.     $newProject append "end.\n\n\n"
  413.  
  414.     $newProject append "${DPCookie::genProjectStart}\n"
  415.     foreach name $newUsesList {
  416.         $newProject append "// ${name}\n"
  417.     }
  418.     $newProject append "${DPCookie::genProjectEnd}\n"
  419.  
  420.     return $newProject
  421. }
  422.  
  423. method DPGenerator::generate {this classList} {
  424.     set typeToClassDictionary [Dictionary new]
  425.     set project [DPProject new]
  426.     set regenerator [DPRegenerator new [$this fileHandler]]
  427.     set pasType ${DPFileHandler::PASType}
  428.     set formType ${DPFileHandler::DFMType}
  429.  
  430.     $classList foreach class {
  431.         # Generation
  432.         #
  433.         m4_message $M_GEN_FOR [$class getName]
  434.         $class generate $project
  435.  
  436.         # Regeneration
  437.         #
  438.  
  439.         # Class file
  440.         set fileDesc [[$this fileHandler] openFile $class $pasType]
  441.         if {$fileDesc != ""} {
  442.             $regenerator regenerate $project $class $fileDesc
  443.  
  444.             [$this fileHandler] closeFile $fileDesc
  445.         }
  446.  
  447.         # Form file
  448.         if {[$class isForm]} {
  449.  
  450.             set formfileDesc [[$this fileHandler] openFile $class $formType]
  451.             if {$formfileDesc != ""} {
  452.                 $regenerator regenerateForm $project $class $formfileDesc
  453.                 [$this fileHandler] closeFile $formfileDesc
  454.             }
  455.         }
  456.  
  457.         $typeToClassDictionary set $class [Dictionary new]
  458.     }
  459.  
  460.     $project generate $typeToClassDictionary
  461.  
  462.     return $typeToClassDictionary
  463. }
  464.  
  465. method DPGenerator::generateSpecialFiles {this fileList} {
  466.     $fileList foreach specialFile {
  467.         set fileName [[$this fileHandler] getProjectFileName]
  468.         set project [DPTextSection new]
  469.         set usesSection [DPTextSection new]
  470.         set codeSection [DPTextSection new]
  471.         set newUsesList {}
  472.  
  473.         set newUsesList [$this generateProjectSections $usesSection $codeSection]
  474.         expandHeaderIntoSection $fileName ${DPFileHandler::DPRType} $project
  475.         $project appendSect [$this generateProjectFile $fileName $usesSection $codeSection $newUsesList]
  476.         if {[$project contents] != ""} {
  477.             if [section_equals_file $project $fileName] {
  478.                 m4_message $M_NOCHANGESPEC $fileName
  479.             } else {
  480.                 m4_message $M_CREATINGSPEC $fileName
  481.                 [$this fileHandler] writeSectionToNamedFile $project $fileName
  482.             }
  483.         }
  484.     }
  485. }
  486.  
  487. # Do not delete this line -- regeneration end marker
  488.  
  489. #---------------------------------------------------------------------------
  490. #      File:           @(#)dpregenera.tcl    /main/titanic/13
  491. #---------------------------------------------------------------------------
  492.  
  493. # Start user added include file section
  494. # End user added include file section
  495.  
  496. require "regenerato.tcl"
  497.  
  498. Class DPRegenerator : {Regenerator} {
  499.     constructor
  500.     method destructor
  501.     method sanityCheck
  502.     method addUserCodeToMethod
  503.     method grabMethodBody
  504.     method grabUserIncludes
  505.     method processCodeDef
  506.     method grabComponentProperties
  507.     method regenerateForm
  508.     method regenerate
  509.     attribute fileHandler
  510. }
  511.  
  512. constructor DPRegenerator {class this fileHandler} {
  513.     set this [Regenerator::constructor $class $this]
  514.     $this fileHandler $fileHandler
  515.     # Start constructor user section
  516.     # End constructor user section
  517.     return $this
  518. }
  519.  
  520. method DPRegenerator::destructor {this} {
  521.     # Start destructor user section
  522.     # End destructor user section
  523.     $this Regenerator::destructor
  524. }
  525.  
  526. method DPRegenerator::sanityCheck {this fileDesc} {
  527.  
  528.     while {![eof $fileDesc]} {
  529.         set line [gets $fileDesc]
  530.  
  531.         if {[string match *${DPCookie::obsoleteCode} $line]} {
  532.             seek $fileDesc 0
  533.             return 1
  534.         }
  535.         if {[regexp {(IFDEF OLDCODE)} $line]} {
  536.             seek $fileDesc 0
  537.             return 2
  538.         }
  539.     }
  540.     seek $fileDesc 0
  541.     return 0
  542. }
  543.  
  544. method DPRegenerator::addUserCodeToMethod {this project class line userTypes userCode} {
  545.     set dpclass [$project getUnit [$class getName]]
  546.     set methodExpr {^[     ]*(class)?[     ]*(procedure|function|constructor|destructor)[     ]*([^.]*)\.([^(;:]*)(\(([^)]*)\))?[     ]*(:[     ]*([^ ]*))?;}
  547.  
  548.     regexp $methodExpr $line total classType methodType classname name dummy1 params dummy2 returnvalue
  549.  
  550.     if {$dpclass == ""} {
  551.         return
  552.     }
  553.  
  554.     #
  555.     # Find procedure for class
  556.     #
  557.     set proc ""
  558.     [$dpclass usermethodSet] foreach method {
  559.         if {[string tolower [$method name]] == [string tolower $name]} {
  560.             set proc $method
  561.         }
  562.     }
  563.     if {$proc == ""} {
  564.         [$dpclass eventSet] foreach method {
  565.             if {[string tolower [$method name]] == [string tolower $name]} {
  566.                 set proc $method
  567.             }
  568.         }
  569.     }
  570.  
  571.     # Not found, maybe it's the destructor?
  572.  
  573.     if {$proc == ""} {
  574.         if {[$dpclass destructr] != ""} {
  575.             if {[string tolower [[$dpclass destructr] name]] == [string tolower $name]} {
  576.                 set proc [$dpclass destructr]
  577.             }
  578.         }
  579.     }
  580.  
  581.     # Not found, maybe it's the constructor?
  582.  
  583.     if {$proc == ""} {
  584.         if {[$dpclass constructr] != ""} {
  585.             if {[string tolower [[$dpclass constructr] name]] == [string tolower $name]} {
  586.                 set proc [$dpclass constructr]
  587.             }
  588.         }
  589.     }
  590.  
  591.     #
  592.     # If method still not found, add it to the obsolete code section
  593.     #
  594.  
  595.     if {$proc == ""} {
  596.         m4_warning $W_OBSOLMETHOD $name
  597.         set obsCode [DPTextSection new]
  598.         $obsCode append "${line}\n"
  599.         $obsCode appendSect $userTypes
  600.         $obsCode append "begin\n"
  601.         $obsCode appendSect $userCode
  602.         $obsCode append "end;\n"
  603.         if {[$dpclass obsoletecode] == ""} {
  604.             $dpclass obsoletecode $obsCode
  605.         } else {
  606.             [$dpclass obsoletecode] appendSect $obsCode
  607.         }
  608.         return
  609.     }
  610.  
  611.     #
  612.     # Dirty compare trick using target model!
  613.     #
  614.     # A temporary textsection is created with the complete method
  615.     # definition to easily compare arguments and other method modifiers.
  616.     #
  617.  
  618.     set tempSection [DPTextSection new]
  619.     $proc generateDefinition $tempSection $dpclass
  620.  
  621.     #
  622.     # If the method declaration changed, add an OLDCODE section.
  623.     # Else, add the grabbed code parts.
  624.     #
  625.  
  626.     if {[$tempSection contents] != $line} {
  627.         set oldTypes [DPTextSection new]
  628.         if {[$userTypes contents] != ""} {
  629.             $oldTypes append "\{\$IFDEF OLDCODE\}\n"
  630.             $oldTypes appendSect $userTypes
  631.             $oldTypes append "\{\$ENDIF\}\n"
  632.         }
  633.         $proc usertypes $oldTypes
  634.         set oldCode [DPTextSection new]
  635.         if {[$userCode contents] != ""} {
  636.             $oldCode append "\{\$IFDEF OLDCODE\}\n"
  637.             $oldCode appendSect $userCode
  638.             $oldCode append "\{\$ELSE\}\n"
  639.             if {[$proc usercode] != ""} {
  640.                 $oldCode appendSect [$proc usercode]
  641.             } else {
  642.                 $oldCode indent +
  643.                 $oldCode append "${DPCookie::implement0}\n"
  644.                 $oldCode indent -
  645.             }
  646.             $oldCode append "\{\$ENDIF\}\n"
  647.         }
  648.         $proc usercode $oldCode
  649.         if {[$oldTypes contents] != "" || [$oldCode contents] != ""} {
  650.             m4_warning $W_OLDCODEMETHOD $name
  651.         }
  652.     } else {
  653.         $proc usercode $userCode
  654.         $proc usertypes $userTypes
  655.     }
  656. }
  657.  
  658. method DPRegenerator::grabMethodBody {this fileDesc usercode usertypes} {
  659.  
  660. # Note: This regenerator does not except multiple begin or ends on one line!!!
  661.  
  662.     #
  663.     # Get user types part
  664.     #
  665.  
  666.     set done 0
  667.     set nestinglevel 0
  668.     set tempSection [DPTextSection new]
  669.     while {![eof $fileDesc] && !$done} {
  670.         set line [gets $fileDesc]
  671.         if {[regexp ${DPCookie::endUserSection} $line] || [regexp {(([     ]+begin)|(^begin))(([     ]+)|([     ]*$))} $line]} {
  672.             set done 1
  673.             if {[regexp {(([     ]+begin)|(^begin))(([     ]+)|([     ]*$))} $line]} {
  674.                 set nestinglevel 1
  675.             }
  676.         } else {
  677.             if {[regexp ${DPCookie::startUserSection} $line]} {
  678.                 set tempSection [DPTextSection new]
  679.             } else {
  680.                 $tempSection append "$line\n"
  681.             }
  682.         }
  683.     }
  684.  
  685.     # Only add section if not only white space
  686.     if {[regexp {[^     ]*} $tempSection]} {
  687.         $usertypes appendSect $tempSection
  688.     }
  689.  
  690.     # Get user code part
  691.     #
  692.     set done 0
  693.     set tempSection [DPTextSection new]
  694.     while {![eof $fileDesc] && !$done} {
  695.         set line [gets $fileDesc]
  696.  
  697.         if {[regexp {(([     ]+begin)|(^begin))(([     ]+)|([     ]*$))} $line total]} {
  698.             incr nestinglevel
  699.         }
  700.  
  701.         if {[regexp ${DPCookie::endUserSection} $line] || [regexp {(([     ]+end)|(^end));?(([     ]+)|([     ]*$))} $line total]} {
  702.             if {[regexp {(([     ]+end)|(^end));?(([     ]+)|([     ]*$))} $line total]} {
  703.                 incr nestinglevel -1
  704.                 if {$nestinglevel == 0} {
  705.                     set done 1
  706.                     continue
  707.                 }
  708.             } else {
  709.                 set done 1
  710.                 continue
  711.             }
  712.         } else {
  713.             if {[regexp ${DPCookie::startUserSection} $line]} {
  714.                 set tempSection [DPTextSection new]
  715.                 continue
  716.             }
  717.         }
  718.         $tempSection append "$line\n"
  719.     }
  720.  
  721.     # Only add section if not only white space
  722.     if {[regexp {[^     ]*} [$tempSection contents]]} {
  723.         $usercode appendSect $tempSection
  724.     }
  725.     return
  726. }
  727.  
  728. method DPRegenerator::grabUserIncludes {this project class fileDesc} {
  729.  
  730.     set includes [DPTextSection new]
  731.     set done 0
  732.     while {!$done} {
  733.         if {[eof $fileDesc]} {
  734.             m4_error $E_SYNTAX ${DPCookie::startUserInclude} "end of file"
  735.             return ""
  736.         }
  737.         set line [gets $fileDesc]
  738.         if {[regexp ${DPCookie::startUserInclude} $line]} {
  739.             set done 1
  740.         }
  741.  
  742.         # If type declaration found, apparently no user includes exist
  743.  
  744.         if {[regexp "type" $line]} {
  745.             return ""
  746.         }
  747.     }
  748.  
  749.     set done 0
  750.     while {!$done} {
  751.         if {[eof $fileDesc]} {
  752.             m4_error $E_SYNTAX ${DPCookie::endUserInclude} "end of file"
  753.             return ""
  754.         }
  755.         set line [gets $fileDesc]
  756.         if {[regexp ${DPCookie::endUserInclude} $line]} {
  757.             set done 1
  758.         } else {
  759.             $includes append "${line}\n"
  760.         }
  761.     }
  762.  
  763.     return [$includes contents]
  764. }
  765.  
  766. method DPRegenerator::processCodeDef {this project class fileDesc} {
  767.  
  768.     # Check the implementation part of the unit for methods to regenerate or 
  769.     # make obsolete
  770.  
  771.     set methodExpr {^[     ]*(class)?[     ]*(procedure|function|constructor|destructor)[     ]*([^.]*)\.([^(;:]*)(\(([^)]*)\))?[     ]*(:[     ]*([^ ]*))?;}
  772.  
  773.  
  774.     # Get all methods upto the regeneration marker 
  775.     #
  776.  
  777.     set done 0
  778.     while {![eof $fileDesc] && !$done} {
  779.         set line [gets $fileDesc]
  780.         if {[regexp ${DPCookie::regenMarker} $line]} {
  781.             set done 1
  782.         } else {
  783.             if {[regexp $methodExpr $line total]} {
  784.                 
  785.                 set ucode [DPTextSection new]
  786.                 set utypes [DPTextSection new]
  787.                 $this grabMethodBody $fileDesc $ucode $utypes
  788.  
  789.                 $this addUserCodeToMethod $project $class $total $utypes $ucode
  790.             }
  791.         }
  792.     }
  793.     if {![regexp ${DPCookie::regenMarker} $line]} {
  794.         m4_error $E_SYNTAX ${DPCookie::regenMarker} "end of file"
  795.     }
  796. }
  797.  
  798. method DPRegenerator::grabComponentProperties {this fileDesc line form} {
  799.  
  800.     set objectExpr {^[     ]*(object)[     ]*([^:]*)([^$]*)}
  801.  
  802.     # This is a recursive method. It calls itself for every object at
  803.     # a deeper nesting level
  804.     #
  805.  
  806.     while {[regexp $objectExpr $line total dummy1 name type]} {
  807.  
  808.         if {[$form name] == $name} {
  809.             set component $form
  810.         } else {
  811.             if {[[$form control] exists $name]} {
  812.                 set component [$form getControl $name]
  813.                 [$component parent] addSortedChild $component
  814.                 [$component parent] removeChild $component
  815.             } else {
  816.                 m4_warning $W_OBSOLCOMP $name
  817.                 # Skip (and remove) component
  818.                 while {![regexp {^[     ]*(end)[     ]*} $line]} {
  819.                     set line [gets $fileDesc]
  820.                 }
  821.                 continue
  822.             }
  823.         }
  824.  
  825.         set done 0
  826.         set tempSection [DPTextSection new]
  827.         while {![eof $fileDesc] && !$done} {
  828.             set line [gets $fileDesc]
  829.             if {[regexp {^[     ]*(object)[     ]*} $line]} {
  830.                 set line [$this grabComponentProperties $fileDesc $line $form]
  831.             }
  832.             if {[regexp {^[     ]*(end)[     ]*} $line]} {
  833.                 set done 1
  834.             } else {
  835.                 
  836.                 # Do not add old event handlers (recognized by starting On/Before/After)
  837.                 #
  838.                 if {![regexp {[     ]+(on|before|after)[^     ]+} [string tolower $line]]} {
  839.                     regexp {[     ]*([^$]*)} $line total prop
  840.                     $tempSection append "${prop}\n"
  841.                 }
  842.             }
  843.         }
  844.  
  845.         # Add old properties
  846.         #
  847.         if {[regexp {[^     ]*} [$tempSection contents]]} {
  848.             [$component properties] appendSect $tempSection
  849.         }
  850.  
  851.         set line [gets $fileDesc]
  852.     }
  853.     return $line
  854. }
  855.  
  856.  
  857. # Generate all regeneration info from a form file.
  858. # 
  859. # Note: All After/Before/On... properties are removed.
  860. # This is a trick to remove obsolete event handlers
  861. # without extensive checking.
  862. #
  863. method DPRegenerator::regenerateForm {this project class fileDesc} {
  864.     set objectExpr {^[     ]*(object)[     ]*([^:]*)([^$]*)}
  865.  
  866.     # Search for form object
  867.     set done 0
  868.     while {!$done} {
  869.         if {[eof $fileDesc]} {
  870.             m4_error $E_SYNTAX "end (of object)" "end of file"
  871.             return
  872.         }
  873.         set line [gets $fileDesc]
  874.         if {[regexp  $objectExpr $line total dummy name type]} {
  875.             set done 1
  876.         }
  877.     }
  878.  
  879.     set form [$project getForm $name]
  880.     $this grabComponentProperties $fileDesc $line $form 
  881. }
  882.  
  883.  
  884. # Grab all regeneration info from an existing class file.
  885. # 
  886. # Note: All TComponent classes are ignored.
  887. #
  888. method DPRegenerator::regenerate {this project class fileDesc} {
  889.  
  890.     # Process class file
  891.     if {[$class baseType] != "TComponent"} {
  892.         set sanity [$this sanityCheck $fileDesc]
  893.         if {$sanity == 1} {
  894.             m4_error $E_OBSOLETESECT [$class getName]
  895.             return
  896.         } else {
  897.             if {$sanity == 2} {
  898.                 m4_error $E_OLDCODESECT [$class getName]
  899.                 return
  900.             }
  901.         }
  902.         set classtype [$class getPropertyValue "class_type"]
  903.         if {$classtype == ""} {
  904.             set classtype "Class"
  905.         }
  906.         if {([$class get_obj_type] == "class") && ($classtype == "Class") } {
  907.             set dpclass [$project getUnit [$class getName]]
  908.             set userincludes [DPTextSection new]
  909.             set impuserincludes [DPTextSection new]
  910.  
  911.             # Grab user includes in interface part
  912.             $userincludes append [$this grabUserIncludes $project $class $fileDesc]
  913.  
  914.             # Skip all lines until the implementation part
  915.             set done 0
  916.             while {!$done} {
  917.                 if {[eof $fileDesc]} {
  918.                     m4_error $E_SYNTAX "implementation" "end of file"
  919.                     return
  920.                 }
  921.                 set line [gets $fileDesc]
  922.                 if {[regexp "implementation" $line]} {
  923.                     set done 1
  924.                 }
  925.             }
  926.  
  927.             # Grab user includes in implementation part
  928.             $impuserincludes append [$this grabUserIncludes $project $class $fileDesc]
  929.  
  930.             if {$dpclass != ""} {
  931.                 $dpclass userinclude $userincludes
  932.                 $dpclass impuserinclude $impuserincludes
  933.             }
  934.             $this processCodeDef $project $class $fileDesc
  935.         }
  936.     }
  937. }
  938.  
  939. # Do not delete this line -- regeneration end marker
  940.  
  941.