PC World 1997 November/PCWorld_1997-11_cd.bin/software/programy/komix/DATA.Z/guiclassin.tcl

Text File | 1996-12-06 | 5.0 KB | 171 lines

#---------------------------------------------------------------------------
#
# Copyright (c) 1996 by Cayenne Software 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 Cayenne Software Inc.
#
#---------------------------------------------------------------------------
#
#    File        : @(#)guiclassin.tcl    /main/hindenburg/3
#    Author        :
#    Original date    : 30-7-1996
#    Description    :
#
#---------------------------------------------------------------------------
#

# Note: this class needs libsql.tcl to be required first!

Class GuiClassInfo : {GCObject} {
    constructor
    method destructor
    method init
    method printInfo
    attribute guiClass
    attribute refClassName
    attribute refClass
    attribute refClassHierarchy
    attribute refColumns
    attribute initStatus
}

constructor GuiClassInfo {class this guiClass} {
        set this [GCObject::constructor $class $this]
    $this initStatus [$this init $guiClass]
        return $this
}

method GuiClassInfo::destructor {this} {
}

# Initialize:
# - guiClass: the guiClass
# - refClass: the class referred by the guiClass
# - refClassHierarchy: all classes (in hierachical order) having data
#   attributes referred by data attributes of the guiClass; the first class in
#   this list always is the rootclass
# - refColumns: the columns corresponding with the data attributes of the
#   guiClass
#
method GuiClassInfo::init {this guiClass} {
    $this guiClass $guiClass
    $this refClassName ""
    $this refClass ""
    $this refClassHierarchy ""
    $this refColumns ""

    # init refClass ...
    #
    set refClassName [$guiClass getPropertyValue "referred_class"]
    if {$refClassName == ""} {
        puts "ERROR: Property 'Referred Class' of gui-class\
            [$guiClass getName] not set."
        return -1
    }
    $this refClassName $refClassName
    set refClass [[$guiClass ooplModel] classByName $refClassName]
    if {$refClass == ""} {
        puts "ERROR: Class '$refClassName' referred by gui-class\
            '[$guiClass getName]' not found."
        return -1
    }
    $this refClass $refClass
    if {![$refClass isPersistent]} {
        puts "ERROR: Class '$refClassName' referred by gui-class\
            '[$guiClass getName]' is not persistent."
        return -1
    }

    # init refClassHierarchy and refColumns ...
    #
    set retVal 0
    set hier [get_hierarchy $refClass]
    foreach cl $hier {
        if {[$cl isPersistent]} {
            foreach attr [$cl dataAttrSet] {
                set attr2Class([$attr getName]) $cl
                set attr2Col([$attr getName]) [$attr column]
                if {![$attr isNullable]} {
                    set notNullCols([$attr column]) $attr
                }
            }
        } else {
            puts "ERROR: Superclass '[$cl getName]' of persistent\
                class '$refClassName' is not persistent"
            set retVal -1
        }
    }
    set rootClass [lindex $hier 0]
    # default put all keys up front
    if ![$rootClass isPersistent] {
        set retVal -1
        set refCols ""
    } else {
        set refCols [get_col_list [$rootClass table] KEYS]
    }
    set refClasses $rootClass
    foreach attr [$guiClass dataAttrSet] {
        set attrName [$attr getName]
        if {![info exists attr2Class($attrName)]} {
            puts "WARNING: Attribute '$attrName' of gui-class\
                '[$guiClass getName]' does not have a matching\
                attribute in referred class '$refClassName' or\
                one of its ancestors: it will be discarded."
        } else {
            set cl $attr2Class($attrName)
            if {[lsearch -exact $refClasses $cl] == -1} {
                lappend refClasses $cl
            }
            # here it is sure attr2Col($attrName) exists too
            set col $attr2Col($attrName)
            if {[lsearch -exact $refCols $col] == -1} {
                lappend refCols $col
            }
        }
    }
    # look for not referred not-nullable attributes
    if {[info exists notNullCols]} {
        foreach col [array names notNullCols] {
        if {[lsearch -exact $refCols $col] == -1} {
            set attr $notNullCols($col)
            puts "ERROR: Not nullable attribute '[$attr getName]'\
            of class '[[$attr ooplClass] getName]' is not\
            referred in gui-class '[$guiClass getName]'."
            set retVal -1
        }
        }
    }

    foreach cl $hier {
        if {[lsearch -exact $refClasses $cl] != -1} {
            lappend refClassHierarchy $cl
        }
    }
    $this refClassHierarchy $refClassHierarchy
    $this refColumns $refCols

    return $retVal
}

method GuiClassInfo::printInfo {this} {
    puts "*** Start GuiClassInfo ***"
        puts "guiClass:        [$this guiClass] ('[[$this guiClass] getName])'"
        puts "refClass:        [$this refClass] ('[$this refClassName]')"
        puts "refClassHierarchy:"
    foreach cl [$this refClassHierarchy] {
        puts "            $cl ('[$cl getName]')"
    }
        puts "refColumns:        "
    foreach col [$this refColumns] {
        puts "            $col ('[$col getUniqueName]')"
    }
    puts "*** End GuiClassInfo ***"
}