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

Text File | 1997-10-20 | 5KB | 175 lines

#---------------------------------------------------------------------------
#
# Copyright (c) 1997 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 Cadre Technologies Inc.
#
# This file contains generic heuristic methods to recognize
# associations and accessor methods
#
# Heuristics used:
#
# - Association recognition:
#   - is the section "association-attribute-storage"
#     if so: this must be an association, find out with which class
#   - is the section "user-defined-attribute"
#     if so: this is a normal attribute
#   - is the type used a "classType" and it is some sort of pointer
#     if so: assume that this is an association
#   - if all the above fail
#     assume that this is a normal attribute
#
# - Accessor methods:
#   - is the section "user-defined-method" or "default-constructor-destructor"
#     if so: this is a normal method
#   - if the name of the method starts with "set", "get", "remove" or "add"
#     and the rest of the name matches one of the attributes in this class
#     if so: this is an accessor method
#   - if all of the above fail, assume that this is a normal method
#

puts "Reverse engineering associations activated."

Class GenRecAttrib : {REAttrib} {
    method drawAssoc
    method isAssocAttr
}

method GenRecAttrib::drawAssoc {this} {
    set assocKind "association"
    set multKind "one"
    set className [$this type]

    # Try do do some template recognition
    if [regexp {(([^_]*)_)?(.*)} $className fullStr under templ name] {
        if [info exist debug] {
            puts "Template breakdown: type=$className templ=$templ name=$name"
        }
        switch -glob [string tolower $templ] {
            "*set*" -
            "*list*" -
            "*array*" -
            "*collection*" -
            "*bag*" -
            "*vector*" {
                    set multKind "many"
                    set className $name
                }
        }
        switch [string tolower $name] {
            "*dict*" {set assocKind "qualif_assoc"}
            "*hash*" {set assocKind "qualif_assoc"}
            "*table*" {set assocKind "qualif_assoc"}
        }
    } else {
        set prop [$this findProp "modifier"]
        if {$prop != ""} {
            if {[$prop value] == "Value"} {
                return 0
            }
        }
        if {([$this section] != "association-attribute-storage") &&
            ([$this section] != "")} {
            return 0
        }
    }

    set roleName [$this name]
    if [regexp -nocase {(.*)(ref|ptr|set|(dict.*))} [$this name] totalname role rest] {
        set roleName $role
    }

    if {$roleName == ""} {
        set roleName "x"
    }

    set cl [[$this reDiagram] findClass $className]
    if {$cl == ""} {
        set cl [[$this reDiagram] addClass $className]
        $cl setProp is_folded 1 comp
    }
    if [info exist debug] {
        puts "Add $assocKind [[$this reClass] getName] -> $multKind [$cl getName] ($roleName)"
    }
    set conn [[$this reDiagram] addConn $assocKind [$this reClass] $cl]
    set lbl [$conn setLabel "role_end" $roleName]
    $conn setProp mult_kind_start "one"
    $conn setProp mult_kind_end $multKind
    set access_prop [$this findProp "attrib_access" name]
    if {$access_prop != ""} {
        set access [$access_prop value]
        $lbl setProp assoc_access $access name
    }

    return 1
}

method GenRecAttrib::isAssocAttr {this} {
    if {[$this section] == "user-defined-attribute"} {
        return 0
    }
    if {[$this typeKind] == "classType"} {
        return [$this drawAssoc]
    }
    return 0
}

selfPromoter REAttrib {this} {
     GenRecAttrib promote $this
}

Class GenRecMethod : {REMethod} {
    method isAccessor
}

method GenRecMethod::isAccessor {this} {
    if {[$this section] == "user-defined-method"} {
        return 0
    }
    if {[$this section] == "default-constructor-destructor"} {
        if [info exists debug] {
            puts "Adding default ctor"
        }
        [$this reClass] addMethod "\$create" "user-defined-method"
        return 1
    }
    if [regexp -nocase {(let|set|add|remove|get)(.+)} [$this name] total acc attrN] {
        foreach attr [[$this reClass] reAttribSet] {
            if [regexp -nocase "${attrN}.*" [$attr name]] {
                set access_prop [$attr findProp "attrib_access" name]
                if {$access_prop == ""} {
                    set access_prop [$attr setProp "attrib_access" "None-None" name]
                }
                set access_rw [split [$access_prop value] "-"]
                set methd_access "None"
                set methd_prop [$this findProp "method_access" comp]
                if {$methd_prop != ""} {
                    set methd_access [$methd_prop value]
                }
                switch $acc {
                    let    -
                    set    -
                    add -
                    remove { set access_rw [list [lindex $access_rw 0] $methd_access] }
                    get { set access_rw [list $methd_access [lindex $access_rw 1]] }
                }

                $access_prop value "[lindex $access_rw 0]-[lindex $access_rw 1]"
                return 1
            }
        }
    }
    return 0
}

selfPromoter REMethod {this} {
     GenRecMethod promote $this
}