PC World 1998 October/PCWorld_1998-10_cd.bin/software/prehled/komix/DATA.Z/checkconf.tcl

Text File | 1997-10-20 | 6KB | 173 lines

###########################################################################
##
##  Copyright (c) 1996 by Cadre Technologies Inc.
##                          and Scientific Toolworks Inc.
##
##  This software is furnished under a license and may be used only in
##  accordance with the terms of such license and with the inclusion of
##  the above copyright notice. This software or any other copies thereof
##  may not be provided or otherwise made available to any other person.
##  No title to and ownership of the software is hereby transferred.
##
##  The information in this software is subject to change without notice
##  and should not be construed as a commitment by Cadre Technologies Inc.
##  or Scientific Toolworks Inc.
##
###########################################################################

#
# Boolean options understood by check.tcl.
#
# The first element of each sublist will cause the second element to be
# made "global" and set to either 0 or 1, depending on whether the first
# element was specified as an argument to 'check' after the "--".
#
# The third element in each sublist gives the default value for the option,
# i.e. the value it will get if the option is not specified.
#
#HM added usecase entry to boolean options list
global boolean_options
set boolean_options { {-trace tracing 0} \
              {-debug debug 0} \
              {-time timing 0} \
              {-usecase usecase 0} \
              {-global global 0} }

#
# For generation, the next two functions are loaded from ada83_const.tcl, but
# they generate other things, which we don't want / can't do when
# preparing for checking.
#
# Also need ada83_config for eg set::name, but since that is only used for
# types of generated functions, and the type is not used in later checks,
# this is no problem.
#

# The set name for 'class'
#
proc set_name {class {ordered 0}} {
    return "${class}[expr {$ordered == 1 ? "O" : ""}]Set"
}

# The set type name for 'class'
#
proc set_type_name {class {ordered 0}} {
    return "[expr {$ordered == 1 ? "O" : ""}]SetOf[$class getName]"
}

#
# Every persistent class has this class as virtual base
#
global dbobject_name
set dbobject_name DBObject

#
# This function adds the synthetic classes and methods to the model.
# Use find_class to find a class in the model by name.
#
# Use add_attributes from check_util.tcl to add any attributes to
# any class or operation.
#
# It calls the procedure 'add_user_defined_methods' if it exists to
# let the user add any classes/methods.
#
# This is one of the routines that need to be redefined when using
# a different persistency mechanism.
#
proc add_predefined_methods {ooplmodel} {
    #
    # Add the DBObject and methods
    #
    set dbobj [get_dbobject_class $ooplmodel]

    $ooplmodel addClass State class_enum

    add_operation $ooplmodel $dbobj connectDB int {{dbName char}}
    add_operation $ooplmodel $dbobj beginWork int
    add_operation $ooplmodel $dbobj commit int
    add_operation $ooplmodel $dbobj rollback int
    add_operation $ooplmodel $dbobj getClassName char {{Id int}}
    add_operation $ooplmodel $dbobj getClassId int {{name char}}
    add_operation $ooplmodel $dbobj getState State
    add_operation $ooplmodel $dbobj resetState ""
    add_operation $ooplmodel $dbobj getClassId int
    add_operation $ooplmodel $dbobj processSqlStatus int
    add_operation $ooplmodel $dbobj notFound int

    #
    # Call user-supplied function to add methods
    #
    if {[info procs add_user_defined_methods] != ""} {
        add_user_defined_methods $ooplmodel
    }
}

#
# This routine prepares a database class for checking.
# For the default implementation of persistent objects, this function
# makes DBObject the superclass of every persistent class, and adds
# certain operations used by DBObject.
#
# This is one of the routines that need to be redefined when using
# a different persistency mechanism.
#
proc prepare_db_class {class model} {
    set class_name [$class getName]
    set key_params [make_key_paramlist $class]

    if [is_root_class $class] {
    add_super_class $model $class [get_dbobject_class $model]

    add_operation $model $class findInDB $class_name $key_params
    add_operation $model $class findInDB $class_name \
                    "$key_params \{class_type int\}"

    set settype [set_type_name $class]
    set setname [uncap [set_name $class_name]]
    catch {$model addClass $settype}
    add_operation $model $class searchInDB int \
                "\{$setname $settype\} \{whereClause char\}"
    }
    add_operation $model $class instantiate $class_name $key_params

    add_operation $model $class insertInDB int
    add_operation $model $class readFromDB int
    add_operation $model $class deleteFromDB int
    add_operation $model $class updateInDB int
}

#
# Redefine add_operation for catching errors and for debugging,
# if not done yet.
#
if {[info commands add_operation_orig] == ""} {
    rename add_operation add_operation_orig
}

proc add_operation {args} {
    if {$debug} {
    puts "    >>> add_operation [[lindex $args 1] getName]::[lrange $args 2 end]"
    }

    if [catch {set op [uplevel "add_operation_orig $args"]} msg] {
    m4_fmt_message $msg
        return ""
    }
    return $op
}

#
# Redefine add_super_class for debugging, if not done yet.
#
if {[info commands add_super_class_orig] == ""} {
    rename add_super_class add_super_class_orig
}

proc add_super_class {oopl class super} {
    if {$debug} {
        puts "    >>> add_super_class $oopl [$class getName] [$super getName]"
    }

    return [add_super_class_orig $oopl $class $super]
}