home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / delphigtor.tcl < prev    next >
Encoding:
Text File  |  1997-05-02  |  20.5 KB  |  777 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   : May 1997
  19. #       Description     : Classes for code generation
  20. #
  21. #---------------------------------------------------------------------------
  22.  
  23. #---------------------------------------------------------------------------
  24. #      File:           @(#)dpfilehand.tcl    /main/hindenburg/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/hindenburg/9
  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 generateProjectSections
  101.     method generateProjectFile
  102.     method generate
  103.     method generateSpecialFiles
  104.     attribute fileHandler
  105.     attribute ooplModel
  106. }
  107.  
  108. constructor DPGenerator {class this} {
  109.     set this [Generator::constructor $class $this]
  110.     # Start constructor user section
  111.  
  112.     $this fileHandler [DPFileHandler new]
  113.  
  114.     # End constructor user section
  115.     return $this
  116. }
  117.  
  118. method DPGenerator::destructor {this} {
  119.     # Start destructor user section
  120.     # End destructor user section
  121.     $this Generator::destructor
  122. }
  123.  
  124. method DPGenerator::generateProjectSections {this uses code} {
  125.     set startupForm ""
  126.     set nrStartupForms 0
  127.     set systemUsesList {}
  128.     set standardUsesList {}
  129.     set formsList {}
  130.     set newUsesList {}
  131.  
  132.     foreach class [[$this ooplModel] ooplClassSet] {
  133.         if {[$class isExternal] || [$class baseType] == "TComponent"} {
  134.             continue
  135.         }
  136.         if {[$class getPropertyValue "is_startup"] == 1} {
  137.             if {[$class baseType] == "TForm"} {
  138.                 if {$nrStartupForms != 0} {
  139.                     m4_error $E_DOUBLESTARTUP [$class getFormVarName] [$startupForm getFormVarName]
  140.                 } else {
  141.                     incr nrStartupForms
  142.                     set startupForm $class
  143.                 }
  144.             } else {
  145.                 m4_warning $W_CANTBESTARTUP [$class getName]
  146.             }
  147.         }
  148.         if {[$class baseType] == "TForm"} {
  149.             set formsList [linsert $formsList 0 $class]
  150.         }
  151.  
  152.         set libunit [$class getPropertyValue "libunit"]
  153.         if {$libunit != "None" && $libunit != ""} {
  154.             if {$libunit == "Other"} {
  155.                 set name [$class getPropertyValue "userlib"]
  156.             } else {
  157.                 set name $libunit
  158.             }
  159.             if {[lsearch -exact $systemUsesList $name] == -1} {
  160.             set systemUsesList [linsert $systemUsesList 0 $name]
  161.             }
  162.         } else {
  163. #            set name [$class getUnitName]
  164.             if {[lsearch -exact $standardUsesList $class] == -1} {
  165.                 set standardUsesList [linsert $standardUsesList 0 $class]
  166.             }
  167.         }
  168.     }
  169.  
  170.     set first 1
  171.     foreach name $systemUsesList {
  172.         if {$first} {
  173.             set first 0
  174.         } else {
  175.             $uses append ",\n"
  176.         }
  177.         $uses append "${name}"
  178.         set newUsesList [linsert $newUsesList 0 $name]
  179.     }
  180.     foreach class $standardUsesList {
  181.         if {$first} {
  182.             set first 0
  183.         } else {
  184.             $uses append ",\n"
  185.         }
  186.         $uses append "[$class getUnitName] in '[$class getUnitName].pas'"
  187.         set newUsesList [linsert $newUsesList 0 [$class getUnitName]]
  188.         if {[$class baseType] == "TForm"} {
  189.             $uses append "  \{[$class getFormVarName]\}"
  190.         }
  191.     }
  192.     if {[$uses contents] != ""} {
  193.         $uses append "\n"
  194.     }
  195.  
  196.     if {$formsList != "" && $nrStartupForms == 0} {
  197.         set startupForm [lindex $formsList 0]
  198.         m4_warning $W_NOSTARTUP [$startupForm getFormVarName]
  199.     }
  200.  
  201.     $code indent +
  202.     if {$startupForm != ""} {
  203.         $code append "Application.CreateForm([$startupForm getFormTypeName], [$startupForm getFormVarName]);\n"
  204.     }
  205. #    foreach form $formsList {
  206. #        if {[$form getFormVarName] != [$startupForm getFormVarName]} {
  207. #            $code append "Application.CreateForm([$form getFormTypeName], [$form getFormVarName]); ${DPCookie::genProjectCode}\n"
  208. #        }
  209. #    }
  210.     $code indent -
  211.  
  212.     return $newUsesList
  213. }
  214.  
  215. method DPGenerator::generateProjectFile {this fileName uses code newUsesList} {
  216.     set oldProject [TextSection new]
  217.     set newProject [TextSection new]
  218.     set cc [ClientContext::global]
  219.     set projectName [getCurrentSystemName]
  220.     set dprType ${DPFileHandler::DPRType}
  221.     set genUsesList {}
  222.  
  223.     if {[catch {set fileDesc [fstorage::open [[$this fileHandler] getProjectFileName] r]}]} {
  224.  
  225.         # Search for customization file
  226.         $oldProject append [$cc getCustomFileContents "default" "dpr" etc]
  227.     } else {
  228.  
  229.         # Read existing file
  230.         while {![eof $fileDesc]} {
  231.             set line [gets $fileDesc]
  232.             $oldProject append "$line\n"
  233.         }
  234.         fstorage::close $fileDesc
  235.     }
  236.  
  237.     # Check for valid contents and grab sections
  238.     #
  239.     if {![regexp {[     ]*(program|library)[     ]*([^;]*);.((.*)uses.([^;]*);.)?(.*)begin.(.*)} [$oldProject contents] total prjType prjName dummy1 grab1 usesBody grab2 remain]} {
  240.         m4_error $E_PRJCONTENTS
  241.         return $newProject
  242.     }
  243.     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]} {
  244.         m4_error $E_PRJCONTENTS
  245.         return $newProject
  246.     }
  247.  
  248.     # Grab generated uses in old file
  249.     #
  250.     set tempList [split $genuses "\n"]
  251.     foreach line $tempList {
  252.         if {[regexp {^[     ]*//[     ]*([^     ]+)$} $line total name]} {
  253.             set genUsesList [linsert $genUsesList 0 $name]
  254.         }
  255.     }
  256.  
  257.     # Project type and name
  258.     #
  259.     if {$prjName == "<default>"} {
  260.         set prjName $projectName
  261.     }
  262.     $newProject append "${prjType} ${prjName};"
  263.     $newProject append $grab1
  264.     
  265.     # Uses
  266.     #
  267.     set usesList [split $usesBody "\n"]
  268.     if {$uses != ""} {
  269.         $newProject append "\nuses\n"
  270.         $newProject indent +
  271.         set first 1
  272.         set oldremain ""
  273.         foreach line $usesList {
  274.             if {[regexp {^[     ]*(([^     ,;]+)([     ]+in[     ]+[^     ,;]+)?)([,;])?([     ]*.*)$} $line total name unitname filename dummy remain]} {
  275.                 if {[lsearch -exact $genUsesList $unitname] == -1 && [lsearch -exact $newUsesList $unitname] == -1} {
  276.                     if {$first} {
  277.                         set first 0
  278.                     } else {
  279.                         $newProject append ","
  280.                         $newProject append "${oldremain}\n"
  281.                     }
  282.                     set oldremain $remain
  283.                     $newProject append "${name}"
  284.                 }
  285.             }
  286.         }
  287.         if {!$first} {
  288.             if {$uses != ""} {
  289.                 $newProject append ","
  290.             }
  291.             $newProject append "${oldremain}\n"
  292.         }
  293.         $newProject appendSect $uses
  294.         $newProject append ";\n"
  295.         $newProject indent -
  296.     }
  297.     $newProject append $grab2
  298.  
  299.     # Code
  300.     #
  301.     $newProject append "begin\n"
  302.     if {[regexp {(.*)[     ]*Application\.Run;.(.*)} $grabCode total codeBody1 codeBody2]} {
  303.         set codeList [split $codeBody1 "\n"]
  304.         foreach line $codeList {
  305.             if {![regexp "Application.CreateForm" $line]} {
  306.                 if {![regexp {^[     ]*$} $line]} {
  307.                     $newProject append "${line}\n"
  308.                 }
  309.             }
  310.         }
  311.         $newProject appendSect $code
  312.         $newProject indent +
  313.         $newProject append "Application.Run;\n"
  314.         $newProject indent -
  315.         $newProject append $codeBody2
  316.     }
  317.     $newProject append "end.\n\n\n"
  318.  
  319.     $newProject append "${DPCookie::genProjectStart}\n"
  320.     foreach name $newUsesList {
  321.         $newProject append "// ${name}\n"
  322.     }
  323.     $newProject append "${DPCookie::genProjectEnd}\n"
  324.     return $newProject
  325. }
  326.  
  327. method DPGenerator::generate {this classList} {
  328.     set typeToClassDictionary [Dictionary new]
  329.     set project [DPProject new]
  330.     set regenerator [DPRegenerator new [$this fileHandler]]
  331.     set pasType ${DPFileHandler::PASType}
  332.     set formType ${DPFileHandler::DFMType}
  333.  
  334.     $classList foreach class {
  335.         # Generation
  336.         #
  337.         $class generate $project
  338.  
  339.         # Regeneration
  340.         #
  341.  
  342.         # Class file
  343.         set fileDesc [[$this fileHandler] openFile $class $pasType]
  344.         if {$fileDesc != ""} {
  345.             $regenerator regenerate $project $class $fileDesc
  346.  
  347.             [$this fileHandler] closeFile $fileDesc
  348.         }
  349.  
  350.         # Form file
  351.         if {[$class baseType] == "TForm"} {
  352.             set formfileDesc [[$this fileHandler] openFile $class $formType]
  353.             if {$formfileDesc != ""} {
  354.                 $regenerator regenerateForm $project $class $formfileDesc
  355.                 [$this fileHandler] closeFile $formfileDesc
  356.             }
  357.         }
  358.  
  359.         $typeToClassDictionary set $class [Dictionary new]
  360.     }
  361.  
  362.     $project generate $typeToClassDictionary
  363.  
  364.     return $typeToClassDictionary
  365. }
  366.  
  367. method DPGenerator::generateSpecialFiles {this fileList} {
  368.     $fileList foreach specialFile {
  369.         set fileName [[$this fileHandler] getProjectFileName]
  370.         set project [TextSection new]
  371.         set usesSection [TextSection new]
  372.         set codeSection [TextSection new]
  373.         set newUsesList {}
  374.  
  375.         set newUsesList [$this generateProjectSections $usesSection $codeSection]
  376.         m4_message $M_CREATINGSPEC $fileName
  377.         $project appendSect [$this generateProjectFile $fileName $usesSection $codeSection $newUsesList]
  378.         if {[$project contents] != ""} {
  379.             [$this fileHandler] writeSectionToNamedFile $project $fileName
  380.         }
  381.     }
  382. }
  383.  
  384. # Do not delete this line -- regeneration end marker
  385.  
  386. #---------------------------------------------------------------------------
  387. #      File:           @(#)dpregenera.tcl    /main/hindenburg/11
  388. #---------------------------------------------------------------------------
  389.  
  390. # Start user added include file section
  391. # End user added include file section
  392.  
  393. require "regenerato.tcl"
  394.  
  395. Class DPRegenerator : {Regenerator} {
  396.     constructor
  397.     method destructor
  398.     method sanityCheck
  399.     method addUserCodeToMethod
  400.     method grabMethodBody
  401.     method grabUserIncludes
  402.     method processCodeDef
  403.     method grabComponentProperties
  404.     method regenerateForm
  405.     method regenerate
  406.     attribute fileHandler
  407. }
  408.  
  409. constructor DPRegenerator {class this fileHandler} {
  410.     set this [Regenerator::constructor $class $this]
  411.     $this fileHandler $fileHandler
  412.     # Start constructor user section
  413.     # End constructor user section
  414.     return $this
  415. }
  416.  
  417. method DPRegenerator::destructor {this} {
  418.     # Start destructor user section
  419.     # End destructor user section
  420.     $this Regenerator::destructor
  421. }
  422.  
  423. method DPRegenerator::sanityCheck {this fileDesc} {
  424.  
  425.     while {![eof $fileDesc]} {
  426.         set line [gets $fileDesc]
  427.  
  428.         if {[string match *${DPCookie::obsoleteCode} $line]} {
  429.             seek $fileDesc 0
  430.             return 1
  431.         }
  432.         if {[regexp {(IFDEF OLDCODE)} $line]} {
  433.             seek $fileDesc 0
  434.             return 2
  435.         }
  436.     }
  437.     seek $fileDesc 0
  438.     return 0
  439. }
  440.  
  441. method DPRegenerator::addUserCodeToMethod {this project class line userTypes userCode} {
  442.     set dpclass [$project getUnit [$class getName]]
  443.     set methodExpr {^[     ]*(class)?[     ]*(procedure|function|constructor|destructor)[     ]*([^.]*)\.([^(;:]*)(\(([^)]*)\))?[     ]*(:[     ]*([^ ]*))?;}
  444.  
  445.     regexp $methodExpr $line total classType methodType classname name dummy1 params dummy2 returnvalue
  446.  
  447.     if {$dpclass == ""} {
  448.         return
  449.     }
  450.  
  451.     # Find procedure
  452.     set proc [$dpclass getUsermethod [string tolower $name]]
  453.     if {$proc == ""} {
  454.         set proc  [$dpclass getEvent [string tolower $name]]
  455.     }
  456.     if {$proc == ""} {
  457.         if {[$dpclass destructr] != ""} {
  458.             if {[string tolower [[$dpclass destructr] name]] == [string tolower $name]} {
  459.                 set proc [$dpclass destructr]
  460.             }
  461.         }
  462.     }
  463.     if {$proc == ""} {
  464.         if {[$dpclass constructr] != ""} {
  465.             if {[string tolower [[$dpclass constructr] name]] == [string tolower $name]} {
  466.                 set proc [$dpclass constructr]
  467.             }
  468.         }
  469.     }
  470.  
  471.     if {$proc == ""} {
  472.         # Obsolete code
  473.         #
  474.         m4_warning $W_OBSOLMETHOD $name
  475.         set obsCode [TextSection new]
  476.         $obsCode append "${line}\n"
  477.         $obsCode appendSect $userTypes
  478.         $obsCode append "begin\n"
  479.         $obsCode appendSect $userCode
  480.         $obsCode append "end;\n"
  481.         if {[$dpclass obsoletecode] == ""} {
  482.             $dpclass obsoletecode $obsCode
  483.         } else {
  484.             [$dpclass obsoletecode] appendSect $obsCode
  485.         }
  486.         return
  487.     }
  488.  
  489.     # Dirty compare trick using target model!
  490.     #
  491.     set tempSection [TextSection new]
  492.     $proc generateDefinition $tempSection $dpclass
  493.  
  494.     # Old code
  495.     #
  496.     if {[$tempSection contents] != $line} {
  497.         set oldTypes [TextSection new]
  498.         if {[$userTypes contents] != ""} {
  499.             $oldTypes append "\{\$IFDEF OLDCODE\}\n"
  500.             $oldTypes appendSect $userTypes
  501.             $oldTypes append "\{\$ENDIF\}\n"
  502.         }
  503.         $proc usertypes $oldTypes
  504.         set oldCode [TextSection new]
  505.         if {[$userCode contents] != ""} {
  506.             $oldCode append "\{\$IFDEF OLDCODE\}\n"
  507.             $oldCode appendSect $userCode
  508.             $oldCode append "\{\$ELSE\}\n"
  509.             if {[$proc usercode] != ""} {
  510.                 $oldCode appendSect [$proc usercode]
  511.             } else {
  512.                 $oldCode indent +
  513.                 $oldCode append "${DPCookie::implement0}\n"
  514.                 $oldCode indent -
  515.             }
  516.             $oldCode append "\{\$ENDIF\}\n"
  517.         }
  518.         $proc usercode $oldCode
  519.         if {[$oldTypes contents] != "" || [$oldCode contents] != ""} {
  520.             m4_warning $W_OLDCODEMETHOD $name
  521.         }
  522.     } else {
  523.         $proc usercode $userCode
  524.         $proc usertypes $userTypes
  525.     }
  526. }
  527.  
  528. method DPRegenerator::grabMethodBody {this fileDesc usercode usertypes} {
  529.  
  530. # Note: This regenerator does not except multiple begin or ends on one line!!!
  531.  
  532.     # Get usertypes part
  533.     #
  534.     set done 0
  535.     set nestinglevel 0
  536.     set tempSection [TextSection new]
  537.     while {![eof $fileDesc] && !$done} {
  538.         set line [gets $fileDesc]
  539.         if {[regexp ${DPCookie::endUserSection} $line] || [regexp {(([     ]+begin)|(^begin))(([     ]+)|([     ]*$))} $line]} {
  540.             set done 1
  541.             if {[regexp {(([     ]+begin)|(^begin))(([     ]+)|([     ]*$))} $line]} {
  542.                 set nestinglevel 1
  543.             }
  544.         } else {
  545.             if {[regexp ${DPCookie::startUserSection} $line]} {
  546.                 set tempSection [TextSection new]
  547.             } else {
  548.                 $tempSection append "$line\n"
  549.             }
  550.         }
  551.     }
  552.  
  553.     # Only add section if not only white space
  554.     if {[regexp {[^     ]*} $tempSection]} {
  555.         $usertypes appendSect $tempSection
  556.     }
  557.  
  558.     # Get usercode part
  559.     #
  560.     set done 0
  561.     set tempSection [TextSection new]
  562.     while {![eof $fileDesc] && !$done} {
  563.         set line [gets $fileDesc]
  564.  
  565.         if {[regexp {(([     ]+begin)|(^begin))(([     ]+)|([     ]*$))} $line total]} {
  566.             incr nestinglevel
  567.         }
  568.  
  569.         if {[regexp ${DPCookie::endUserSection} $line] || [regexp {(([     ]+end)|(^end));?(([     ]+)|([     ]*$))} $line total]} {
  570.             if {[regexp {(([     ]+end)|(^end));?(([     ]+)|([     ]*$))} $line total]} {
  571.                 incr nestinglevel -1
  572.                 if {$nestinglevel == 0} {
  573.                     set done 1
  574.                     continue
  575.                 }
  576.             } else {
  577.                 set done 1
  578.                 continue
  579.             }
  580.         } else {
  581.             if {[regexp ${DPCookie::startUserSection} $line]} {
  582.                 set tempSection [TextSection new]
  583.                 continue
  584.             }
  585.         }
  586.         $tempSection append "$line\n"
  587.     }
  588.  
  589.     # Only add section if not only white space
  590.     if {[regexp {[^     ]*} [$tempSection contents]]} {
  591.         $usercode appendSect $tempSection
  592.     }
  593.     return
  594. }
  595.  
  596. method DPRegenerator::grabUserIncludes {this project class fileDesc} {
  597.  
  598.     set includes [TextSection new]
  599.     set done 0
  600.     while {!$done} {
  601.         if {[eof $fileDesc]} {
  602.             m4_error $E_SYNTAX ${DPCookie::startUserInclude} "end of file"
  603.             return
  604.         }
  605.         set line [gets $fileDesc]
  606.         if {[regexp ${DPCookie::startUserInclude} $line]} {
  607.             set done 1
  608.         }
  609.         # If type declaration found, apparently no user includes exist
  610.         if {[regexp "type" $line]} {
  611.             return
  612.         }
  613.     }
  614.  
  615.     set done 0
  616.     while {!$done} {
  617.         if {[eof $fileDesc]} {
  618.             m4_error $E_SYNTAX ${DPCookie::endUserInclude} "end of file"
  619.             return
  620.         }
  621.         set line [gets $fileDesc]
  622.         if {[regexp ${DPCookie::endUserInclude} $line]} {
  623.             set done 1
  624.         } else {
  625.             $includes append "${line}\n"
  626.         }
  627.     }
  628.  
  629.     set dpclass [$project getUnit [$class getName]]
  630.     if {$dpclass == "" || [$includes contents] == ""} {
  631.         return
  632.     }
  633.     $dpclass userinclude $includes
  634. }
  635.  
  636. method DPRegenerator::processCodeDef {this project class fileDesc} {
  637.  
  638.     set methodExpr {^[     ]*(class)?[     ]*(procedure|function|constructor|destructor)[     ]*([^.]*)\.([^(;:]*)(\(([^)]*)\))?[     ]*(:[     ]*([^ ]*))?;}
  639.  
  640.     set done 0
  641.     while {!$done} {
  642.         if {[eof $fileDesc]} {
  643.             m4_error $E_SYNTAX "implementation" "end of file"
  644.             return
  645.         }
  646.         set line [gets $fileDesc]
  647.         if {[regexp "implementation" $line]} {
  648.             set done 1
  649.         }
  650.     }
  651.  
  652.     set done 0
  653.     while {![eof $fileDesc] && !$done} {
  654.         set line [gets $fileDesc]
  655.         if {[regexp ${DPCookie::regenMarker} $line]} {
  656.             set done 1
  657.         } else {
  658.             if {[regexp $methodExpr $line total]} {
  659.                 
  660.                 set ucode [TextSection new]
  661.                 set utypes [TextSection new]
  662.                 $this grabMethodBody $fileDesc $ucode $utypes
  663.  
  664.                 $this addUserCodeToMethod $project $class $total $utypes $ucode
  665.             }
  666.         }
  667.     }
  668.     if {![regexp ${DPCookie::regenMarker} $line]} {
  669.         m4_error $E_SYNTAX ${DPCookie::regenMarker} "end of file"
  670.     }
  671. }
  672.  
  673. method DPRegenerator::grabComponentProperties {this fileDesc line form} {
  674.  
  675.     set objectExpr {^[     ]*(object)[     ]*([^:]*)([^$]*)}
  676.  
  677.     while {[regexp $objectExpr $line total dummy1 name type]} {
  678.  
  679.         if {[$form name] == $name} {
  680.             set component $form
  681.         } else {
  682.             if {[[$form control] exists $name]} {
  683.                 set component [$form getControl $name]
  684.             } else {
  685.                 m4_warning $W_OBSOLCOMPONENT $name
  686.                 # Skip (and remove) component
  687.                 while {![regexp {^[     ]*(end)[     ]*} $line]} {
  688.                     set line [gets $fileDesc]
  689.                 }
  690.                 continue
  691.             }
  692.         }
  693.  
  694.         set done 0
  695.         set tempSection [TextSection new]
  696.         while {![eof $fileDesc] && !$done} {
  697.             set line [gets $fileDesc]
  698.             if {[regexp {^[     ]*(object)[     ]*} $line]} {
  699.                 set line [$this grabComponentProperties $fileDesc $line $form]
  700.             }
  701.             if {[regexp {^[     ]*(end)[     ]*} $line]} {
  702.                 set done 1
  703.             } else {
  704.                 # Do not add old event handlers
  705.                 #
  706.                 if {![regexp {[     ]+(on|before|after)[^     ]+} [string tolower $line]]} {
  707.                     regexp {[     ]*([^$]*)} $line total prop
  708.                     $tempSection append "${prop}\n"
  709.                 }
  710.             }
  711.         }
  712.  
  713.         # Add old properties
  714.         #
  715.         if {[regexp {[^     ]*} [$tempSection contents]]} {
  716.             [$component properties] appendSect $tempSection
  717.         }
  718.  
  719.         set line [gets $fileDesc]
  720.     }
  721.     return $line
  722. }
  723.  
  724.  
  725. # Generate all regeneration info from a form file.
  726. # 
  727. # Note: All After/Before/On... properties are removed.
  728. # This is a trick to remove obsolete event handlers
  729. # without extensive checking.
  730. #
  731. method DPRegenerator::regenerateForm {this project class fileDesc} {
  732.     set objectExpr {^[     ]*(object)[     ]*([^:]*)([^$]*)}
  733.  
  734.     # Search for form object
  735.     set done 0
  736.     while {!$done} {
  737.         if {[eof $fileDesc]} {
  738.             m4_error $E_SYNTAX "end (of object)" "end of file"
  739.             return
  740.         }
  741.         set line [gets $fileDesc]
  742.         if {[regexp  $objectExpr $line total dummy name type]} {
  743.             set done 1
  744.         }
  745.     }
  746.  
  747.     set form [$project getForm $name]
  748.     $this grabComponentProperties $fileDesc $line $form 
  749. }
  750.  
  751.  
  752. # Grab all regeneration info from an existing class file.
  753. # 
  754. # Note: All TComponent classes are ignored.
  755. #
  756. method DPRegenerator::regenerate {this project class fileDesc} {
  757.  
  758.     # Process class file
  759.     if {[$class baseType] != "TComponent"} {
  760.         set sanity [$this sanityCheck $fileDesc]
  761.         if {$sanity == 1} {
  762.             m4_error $E_OBSOLETESECT [$class getName]
  763.             return
  764.         } else {
  765.             if {$sanity == 2} {
  766.                 m4_error $E_OLDCODESECT [$class getName]
  767.                 return
  768.             }
  769.         }
  770.         $this grabUserIncludes $project $class $fileDesc
  771.         $this processCodeDef $project $class $fileDesc
  772.     }
  773. }
  774.  
  775. # Do not delete this line -- regeneration end marker
  776.  
  777.