home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / checkconf.tcl < prev    next >
Encoding:
Text File  |  1997-10-20  |  5.6 KB  |  173 lines
  1. ###########################################################################
  2. ##
  3. ##  Copyright (c) 1996 by Cadre Technologies Inc.
  4. ##                          and Scientific Toolworks Inc.
  5. ##
  6. ##  This software is furnished under a license and may be used only in
  7. ##  accordance with the terms of such license and with the inclusion of
  8. ##  the above copyright notice. This software or any other copies thereof
  9. ##  may not be provided or otherwise made available to any other person.
  10. ##  No title to and ownership of the software is hereby transferred.
  11. ##
  12. ##  The information in this software is subject to change without notice
  13. ##  and should not be construed as a commitment by Cadre Technologies Inc.
  14. ##  or Scientific Toolworks Inc.
  15. ##
  16. ###########################################################################
  17.  
  18. #
  19. # Boolean options understood by check.tcl.
  20. #
  21. # The first element of each sublist will cause the second element to be
  22. # made "global" and set to either 0 or 1, depending on whether the first
  23. # element was specified as an argument to 'check' after the "--".
  24. #
  25. # The third element in each sublist gives the default value for the option,
  26. # i.e. the value it will get if the option is not specified.
  27. #
  28. #HM added usecase entry to boolean options list
  29. global boolean_options
  30. set boolean_options { {-trace tracing 0} \
  31.               {-debug debug 0} \
  32.               {-time timing 0} \
  33.               {-usecase usecase 0} \
  34.               {-global global 0} }
  35.  
  36. #
  37. # For generation, the next two functions are loaded from ada83_const.tcl, but
  38. # they generate other things, which we don't want / can't do when
  39. # preparing for checking.
  40. #
  41. # Also need ada83_config for eg set::name, but since that is only used for
  42. # types of generated functions, and the type is not used in later checks,
  43. # this is no problem.
  44. #
  45.  
  46. # The set name for 'class'
  47. #
  48. proc set_name {class {ordered 0}} {
  49.     return "${class}[expr {$ordered == 1 ? "O" : ""}]Set"
  50. }
  51.  
  52. # The set type name for 'class'
  53. #
  54. proc set_type_name {class {ordered 0}} {
  55.     return "[expr {$ordered == 1 ? "O" : ""}]SetOf[$class getName]"
  56. }
  57.  
  58. #
  59. # Every persistent class has this class as virtual base
  60. #
  61. global dbobject_name
  62. set dbobject_name DBObject
  63.  
  64. #
  65. # This function adds the synthetic classes and methods to the model.
  66. # Use find_class to find a class in the model by name.
  67. #
  68. # Use add_attributes from check_util.tcl to add any attributes to
  69. # any class or operation.
  70. #
  71. # It calls the procedure 'add_user_defined_methods' if it exists to
  72. # let the user add any classes/methods.
  73. #
  74. # This is one of the routines that need to be redefined when using
  75. # a different persistency mechanism.
  76. #
  77. proc add_predefined_methods {ooplmodel} {
  78.     #
  79.     # Add the DBObject and methods
  80.     #
  81.     set dbobj [get_dbobject_class $ooplmodel]
  82.  
  83.     $ooplmodel addClass State class_enum
  84.  
  85.     add_operation $ooplmodel $dbobj connectDB int {{dbName char}}
  86.     add_operation $ooplmodel $dbobj beginWork int
  87.     add_operation $ooplmodel $dbobj commit int
  88.     add_operation $ooplmodel $dbobj rollback int
  89.     add_operation $ooplmodel $dbobj getClassName char {{Id int}}
  90.     add_operation $ooplmodel $dbobj getClassId int {{name char}}
  91.     add_operation $ooplmodel $dbobj getState State
  92.     add_operation $ooplmodel $dbobj resetState ""
  93.     add_operation $ooplmodel $dbobj getClassId int
  94.     add_operation $ooplmodel $dbobj processSqlStatus int
  95.     add_operation $ooplmodel $dbobj notFound int
  96.  
  97.     #
  98.     # Call user-supplied function to add methods
  99.     #
  100.     if {[info procs add_user_defined_methods] != ""} {
  101.         add_user_defined_methods $ooplmodel
  102.     }
  103. }
  104.  
  105. #
  106. # This routine prepares a database class for checking.
  107. # For the default implementation of persistent objects, this function
  108. # makes DBObject the superclass of every persistent class, and adds
  109. # certain operations used by DBObject.
  110. #
  111. # This is one of the routines that need to be redefined when using
  112. # a different persistency mechanism.
  113. #
  114. proc prepare_db_class {class model} {
  115.     set class_name [$class getName]
  116.     set key_params [make_key_paramlist $class]
  117.  
  118.     if [is_root_class $class] {
  119.     add_super_class $model $class [get_dbobject_class $model]
  120.  
  121.     add_operation $model $class findInDB $class_name $key_params
  122.     add_operation $model $class findInDB $class_name \
  123.                     "$key_params \{class_type int\}"
  124.  
  125.     set settype [set_type_name $class]
  126.     set setname [uncap [set_name $class_name]]
  127.     catch {$model addClass $settype}
  128.     add_operation $model $class searchInDB int \
  129.                 "\{$setname $settype\} \{whereClause char\}"
  130.     }
  131.     add_operation $model $class instantiate $class_name $key_params
  132.  
  133.     add_operation $model $class insertInDB int
  134.     add_operation $model $class readFromDB int
  135.     add_operation $model $class deleteFromDB int
  136.     add_operation $model $class updateInDB int
  137. }
  138.  
  139. #
  140. # Redefine add_operation for catching errors and for debugging,
  141. # if not done yet.
  142. #
  143. if {[info commands add_operation_orig] == ""} {
  144.     rename add_operation add_operation_orig
  145. }
  146.  
  147. proc add_operation {args} {
  148.     if {$debug} {
  149.     puts "    >>> add_operation [[lindex $args 1] getName]::[lrange $args 2 end]"
  150.     }
  151.  
  152.     if [catch {set op [uplevel "add_operation_orig $args"]} msg] {
  153.     m4_fmt_message $msg
  154.         return ""
  155.     }
  156.     return $op
  157. }
  158.  
  159. #
  160. # Redefine add_super_class for debugging, if not done yet.
  161. #
  162. if {[info commands add_super_class_orig] == ""} {
  163.     rename add_super_class add_super_class_orig
  164. }
  165.  
  166. proc add_super_class {oopl class super} {
  167.     if {$debug} {
  168.         puts "    >>> add_super_class $oopl [$class getName] [$super getName]"
  169.     }
  170.  
  171.     return [add_super_class_orig $oopl $class $super]
  172. }
  173.