home *** CD-ROM | disk | FTP | other *** search
- #---------------------------------------------------------------------------
- #
- # Copyright (c) 1993-1995 by Cadre Technologies 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.
- #
- #---------------------------------------------------------------------------
- #
- # File : @(#)checks.tcl /main/hindenburg/1
- # Author : edri
- # Original date : 11-10-94
- # Description : All kinds of checks.
- #
- #---------------------------------------------------------------------------
- #
-
- #
- # Check if this class does not directly inherit from the same
- # class more than once.
- #
- proc check_direct_supers {class} {
- set super_names ""
- foreach g [$class genNodeSet] {
- lappend super_names [$g getSuperClassName]
- }
-
- # remove all unique names from super_names
- set unique_supers [find_unique_names $super_names]
- foreach u $unique_supers {
- set i [lsearch $super_names $u]
- set super_names [lreplace $super_names $i $i]
- }
-
- # any name left indicates an error
- foreach c [find_unique_names $super_names] {
- m4_error $E_SAME_DIRECT_SUPERS [$class getName] $c
- }
- }
-
- #
- # Check if the attribute names of this class are unique; includes checking
- # for duplicate assoc_attribs. Duplicate attribute names are checked for
- # while loading the model, because these are certain to cause collisions.
- #
- # These checks see if methods generated from data_ and assoc_attribs
- # will confict. This can only happen in these cases:
- #
- # - between a data_attrib and an assoc_attrib that have the same name,
- # and where the assoc_attrib has a multiplicity of one,
- #
- # - between two assoc_attribs with the same name, compatible types
- # and same multiplicity.
- #
- proc causes_conflict {assoc1 assoc2} {
- set type1 [$assoc1 get_obj_type]
- set type2 [$assoc2 get_obj_type]
-
- return [expr {
- $assoc1 != $assoc2 &&
- [$assoc1 getName] == [$assoc2 getName] &&
- [$assoc1 getMultiplicity] == [$assoc2 getMultiplicity] &&
- ($type1 == $type2 || "db_$type1" == $type2 || $type1 == "db_$type2")
- }]
- }
-
- proc check_class_attributes {class} {
- # check data attribute against all assoc_attribs
-
- foreach attrib [$class dataAttrSet] {
- set name [$attrib getName]
- foreach assoc [$class genAssocAttrSet] {
- if {[$assoc getName] == $name &&
- [$assoc getMultiplicity] == "one"} {
- m4_error $E_CONFLICTING_DATA_AND_ASSOC_ATTRIB \
- [$class getName] $name [display_diagram $assoc]
- }
- }
- }
-
- # check assoc_attribute
-
- foreach assoc1 [$class genAssocAttrSet] {
- foreach assoc2 [$class genAssocAttrSet] {
- # Trick to prevent to prevent double checks.
- if {$assoc1 >= $assoc2} {
- continue
- }
-
- if [causes_conflict $assoc1 $assoc2] {
- m4_error $E_CONFLICTING_ASSOC_ATTRIBS \
- [$class getName] [$assoc1 getName] \
- [display_diagram $assoc1] [display_diagram $assoc2]
- }
- }
- }
- }
-
- #
- # Check if the given class has unique names for all associations.
- #
- # Only for assoc_attribs that have a "link", since only there the association
- # name is used by the code-generator.
- #
- proc check_class_associations {class} {
- foreach a [$class genAssocAttrSet] {
- set a_link [get_link $a]
- if {$a_link != ""} {
- foreach b [$class genAssocAttrSet] {
- # Trick to prevent to prevent double checks.
- if {$a >= $b} {
- continue
- }
- set b_link [get_link $b]
- if {$b_link != ""} {
- set a_relation [$a_link relation]
- set b_relation [$b_link relation]
- if {$a_relation != $b_relation} {
- # if they're the same, this class is a link class, with
- # links to both association classes, but only one
- # association.
- set a_name [$a_relation getName]
- set b_name [$b_relation getName]
- if {$a_name == $b_name && $a_name != ""} {
- set diags "[display_diagram $a] [display_diagram $b]"
- if {[lindex $diags 0] == [lindex $diags 1]} {
- set diags " [lindex $diags 0]"
- } else {
- set diags "s [join $diags " and "]"
- }
- m4_error $E_CONFLICTING_ASSOC_NAMES \
- [$class getName] $a_name $diags
- }
- }
- }
- }
- }
- }
- }
-
- #
- # Check if all attributes of a received_event have distinct names.
- #
- proc check_event_attributes {event class} {
- if [$event hasAttributes] {
- if {![is_unique_name_list [$event getAttributes]]} {
- m4_error $E_SAME_EVENT_ATTRIBUTE_NAMES \
- [display_event $event 1] [$class getName]
- }
- }
- }
-
- #
- # Check for the given received_event received by the given class whether
- # that event is handled by a method of the class.
- #
- # For an event to be valid, one of the following must hold:
- #
- # - if the received event does not have an associated MGD event,
- # an operation with the same name as the event and with the same
- # number of parameters as the number of event attributes must exist
- # in the class' methods;
- #
- # - if the received event does have an associated MGD message, then
- # every most decomposed message ("leaf event") in the MGD hierarchy
- # with the received event as root, must have one or more parent messages
- # for which an operation exists in the class' methods. This ensures
- # that every type of message that can occur, is handled by the class.
- #
- proc check_method_for_event {r class diagram {quiet 0}} {
- set class_name [$class getName]
- set r_type [$r getEventType]
- #
- # Determine whether we need to consider methods of superclasses,
- # and the minimum access right for an operation handling the event.
- #
- switch -glob $r_type {
- internal_* {set super 0; set access_needed "Private"}
- external_* -
- event_message -
- comm_message -
- trace_event {set super 1; set access_needed "Public"}
- }
-
- #
- # If this event is sent to the class by the class itself, "Private"
- # access is all that's needed. This also takes care of STD
- # internal_- and external_events.
- #
- if {$class_name == [$r getSenderName]} {
- set access_needed "Private"
- }
-
- if [$r hasAttributes] {
- set nattrs [llength [$r getAttributes]]
- } else {
- set nattrs -1
- }
-
- set e [get_event $r]
- if {$e == ""} {
- m4_warning $W_NO_CORR_MSGDEF_FOUND \
- [display_event $r] [$r getSenderName] $class_name
-
- # check event
- #
- if {[$r getName] != ""} {
- set info ""
- if {!$super} {
- set result [find_event_method [$class operationSet] \
- [$r getName] $nattrs $access_needed info]
- } else {
- set result [find_event_method [$class getPropertyValue flat_methods] \
- [$r getName] $nattrs $access_needed info]
- }
- if {$result == 1} {
- if {!$quiet} {
- m4_event_error $r_type E_NO_MATCHING_OPERATION1 \
- $class_name [display_event $r]
- }
- return 0
- } elseif {$result == 2} {
- if {!$quiet} {
- m4_event_error $r_type E_PARAM_ATTR_MISMATCH1 \
- $class_name [display_event $r] $info $nattrs
- }
- return 0
- } elseif {$result == 3} {
- if {!$quiet} {
- m4_event_error $r_type E_METHOD_ACCESS1 $class_name \
- [display_event $r] $info $access_needed
- }
- return 0
- }
- }
-
- # check action
- #
- set action [$r getAction]
- if {$action == ""} {return 0}
- set nattrs -1
- regsub {(..ternal_)event} $r_type {\1action} r_type
- set info ""
- if {!$super} {
- set result [find_event_method [$class operationSet] \
- $action $nattrs $access_needed info]
- } else {
- set result [find_event_method [$class getPropertyValue flat_methods] \
- $action $nattrs $access_needed info]
- }
- if {$result == 1} {
- if {!$quiet} {
- m4_event_error $r_type E_NO_MATCHING_OPERATION1 \
- $class_name "[long_event_type $r_type] '$action' in [display_diagram $r]"
- }
- return 0
- } elseif {$result == 2} {
- if {!$quiet} {
- m4_event_error $r_type E_PARAM_ATTR_MISMATCH1 \
- $class_name "[long_event_type $r_type] '$action' in [display_diagram $r]" $info $nattrs
- }
- return 0
- } elseif {$result == 3} {
- if {!$quiet} {
- m4_event_error $r_type E_METHOD_ACCESS1 $class_name \
- "[long_event_type $r_type] '$action' in [display_diagram $r]" $info $access_needed
- }
- return 0
- }
-
- } else {
- foreach leaf [find_leaf_events $e] {
- set ok 0
- set bad_params 0
- set bad_access 0
- set name_nparams 0
- set name_access ""
- set parents [concat $leaf [find_parent_events $leaf]]
- foreach parent $parents {
- set info ""
- if {!$super} {
- set result [find_event_method [$class operationSet] \
- [$parent getName] $nattrs $access_needed \
- info]
- } else {
- set result [find_event_method [$class getPropertyValue flat_methods] \
- [$parent getName] $nattrs $access_needed \
- info]
- }
- if {$result == 0} {
- set ok 1
- break
- } elseif {$result == 2 && !$bad_params} {
- # remember the first (most derived) event found
- set bad_params 1
- set name [$parent getName]
- set name_nparams $info
- } elseif {$result == 3 && !$bad_access} {
- # remember the first (most derived) event found
- set bad_access 1
- set name [$parent getName]
- set name_access $info
- }
- }
- if {!$ok} {
- set parent_names {}
- foreach parent $parents {
- lappend parent_names [$parent getName]
- }
- if {!$quiet} {
- if $bad_params {
- m4_event_error $r_type E_PARAM_ATTR_MISMATCH2 $name \
- $class_name [display_event $r] \
- $name_nparams $nattrs
- } elseif $bad_access {
- m4_event_error $r_type E_METHOD_ACCESS2 $name $class_name \
- [display_event $r] $name_access $access_needed
- } else {
- m4_event_error $r_type E_NO_MATCHING_OPERATION2 $class_name \
- [display_event $r] [display_event $leaf] $parent_names
- }
- } else {
- #
- # No need to continue, since the caller is only interested
- # in the correctness of this event, and here it is clear
- # that it is not correct.
- #
- return 0
- }
- }
- }
- }
- return 1
- }
-
- #
- # Given an operation and an access right string ("Private", "Protected",
- # "Public", or "" as synonym for "Public", return whether the operation
- # can be called.
- #
- proc check_access {oper needed} {
- set access [$oper getPropertyValue method_access]
- switch $needed {
- "Private"
- {if {$access == "None"} {
- return 0
- } else {
- return 1
- }}
- "Protected"
- {if {$access == "Private" || $access == "None"} {
- return 0
- } else {
- return 1
- }}
- "Public"
- {if {$access == "Private" || $access == "Protected" || $access == "None"} {
- return 0
- else
- return 1
- }}
- }
- return 1
- }
-
- #
- # Given a list of Operations and a single event name, see if the event is
- # handled by the class. This is so if the class has an operation with the
- # same name as the event. Also check if the operation found has at least
- # accessibility as specified by 'access'.
- #
- # If 'nattrs' is >= 0, the operation must have the same number of parameters
- # as the specified number, if 'nattrs' == -1 the parameter count of the
- # operation is ignored.
- #
- # Returns:
- # 0 if a matching operation is found (correct parameters and access rights),
- # 1 if no operation is found at all,
- # 2 if an operation is found with the correct name but with the wrong
- # number of parameters,
- # 3 if a matching operation was found, but with the wrong accessibility.
- #
- proc find_event_method {opers event nattrs access i} {
- upvar $i info
- set found_name 0
- set bad_access 0
- foreach o $opers {
- if {[$o getName] != $event} {
- continue
- }
-
- # found one, if attributes need not be checked, we're done
- if {$nattrs == -1} {
- if [check_access $o $access] {
- return 0
- } else {
- set bad_access 1
- set info [$o getPropertyValue method_access]
- continue
- }
- }
-
- # found one, check if parameters match attributes
- if {[llength [get_parameters $o]] == $nattrs} {
- if [check_access $o $access] {
- return 0
- } else {
- set bad_access 1
- set info [$o getPropertyValue method_access]
- }
- } else {
- # remember that a correct name was found
- set found_name 1
- set info [llength [get_parameters $o]]
- }
- }
- if $found_name {
- return 2
- }
- if $bad_access {
- return 3
- }
- return 1
- }
-
- #
- # The given class is a special class, not allowed to receive events; check this.
- #
- proc check_special_class {class diagram} {
- set events [$class receivedEventSet]
- foreach e $events {
- if {$diagram == "" || [in_diagram $e $diagram]} {
- m4_event_error [$e getEventType] E_CLASS_CANNOT_RECEIVE \
- [$class getName] [display_event $e] [$class get_obj_type]
- }
- }
- }
-
- #
- # Check to see if the given trace_event occurs as any comm_message to the
- # same class as the trace_event in any CCD in the system.
- #
- # This function assumes that the comm_message events are loaded in the
- # ooplmodel (i.e. that "ccd" was passed to option "-events").
- #
- proc check_corr_ccd_message {r class diagram} {
- if {[M4CheckManager::errorControl $E_NO_CORR_CCDMSG_FOUND] == "off"} {
- return
- }
-
- set r_name [$r getName]
- set r_found 0
-
- foreach ccd_r [$class receivedEventSet] {
- if {[$ccd_r getEventType] == "comm_message" &&
- [$ccd_r getName] == $r_name} {
- set r_found 1
- break
- }
- }
-
- if {!$r_found} {
- m4_warning $E_NO_CORR_CCDMSG_FOUND [display_event $r] \
- [$r getSenderName] [$class getName]
- }
- }
-
- #
- # Check if each received_event of the subject is handled by one of
- # the classes in this CAD.
- #
- proc check_cad_subject {subject} {
- if {[M4CheckManager::errorControl $E_NO_MATCHING_OPER_IN_SUBJECT] == "off"} {
- return
- }
-
- set subject_name [$subject getName]
- set subject_type [$subject get_obj_type]
- set diagram "[$subject getDiagramName].[$subject getDiagramType]"
-
- #
- # Load and prepare the model for all classes in the diagram and
- # check for every event received by the subject whether it is
- # handled by some class.
- #
- if [catch {set classes [get_diagram_classes $subject_name cad]} msg] {
- puts stdout $msg
- return
- }
- if [lempty $classes] {
- m4_error $E_SUBJECT_IS_EMPTY "CAD" $subject_name $diagram
- return
- }
-
- set model [load_model $classes ccd 0 1 0]
- if {$model == ""} {
- m4_message $M_LOADING_MODEL_FAILED $subject_type $subject_name
- return
- }
- set oopl [$model ooplModel]
- prepare $oopl check
-
- foreach e [$subject receivedEventSet] {
- set found 0
- foreach c [getSelectedOoplClasses $oopl $classes] {
- if [check_method_for_event $e $c "" 1] {
- set found 1
- break
- }
- }
- if {!$found} {
- m4_error $E_NO_MATCHING_OPER_IN_SUBJECT \
- "CAD" $subject_name [display_event $e]
- }
- }
- $model delete
- }
-
- #
- # Check if each received_event of the subject is received by one of the
- # classes in the CCD specified by the subject. This CCD should exist in
- # the current system.
- #
- # This function assumes that all classes occurring in the CCD have been
- # loaded in the current ooplmodel.
- #
- proc check_ccd_subject {subject} {
- if {[M4CheckManager::errorControl $E_NO_MATCHING_OPER_IN_SUBJECT] == "off"} {
- return
- }
-
- set subject_name [$subject getName]
- set subject_type [$subject get_obj_type]
- set diagram "[$subject getDiagramName].[$subject getDiagramType]"
-
- if [catch {set classes [get_diagram_classes $subject_name ccd]} msg] {
- puts stdout $msg
- return
- }
-
- foreach r [$subject receivedEventSet] {
- set r_name [$r getName]
- set r_found 0
- foreach c $classes {
- set class [find_class $ooplmodel $c]
- if {$class != ""} {
- foreach cr [$class receivedEventSet] {
- if {$r_name == [$cr getName]} {
- set r_found 1
- break
- }
- }
- }
- if {$r_found} {
- break
- }
- }
- if {!$r_found} {
- m4_error $E_NO_MATCHING_MSG_IN_SUBJECT $r_name $subject_name $diagram
- }
- }
- }
-
- #
- # Check if each received_event of the subject is handled by one of
- # the classes in this system.
- #
- proc check_system_subject {subject} {
- if {[M4CheckManager::errorControl $E_NO_MATCHING_OPER_IN_SUBJECT] == "off"} {
- return
- }
-
- set currSystemVersion [[ClientContext::global] currentSystem]
- if $currSystemVersion {
- set systemName [[$currSystemVersion system] name]
- } else {
- set systemName ""
- }
-
- #set systemName [OTShContext::getSystemName]
- set subject_name [$subject getName]
- set subject_type [$subject get_obj_type]
- set diagram "[$subject getDiagramName].[$subject getDiagramType]"
-
- #
- # Go to the system specified by the subject, load and prepare the model
- # for all classes in the system and check for every event received by
- # the subject whether it is handled by some class.
- #
- if [catch {goto_system $subject_name} msg] {
- m4_error $E_BAD_SYSTEM_SUBJECT $subject_name $diagram $msg
- return
- }
- if [catch {set classes [get_system_classes]} msg] {
- puts stdout $msg
- catch {goto_system $systemName}
- return
- }
- if [lempty $classes] {
- m4_error $E_SUBJECT_IS_EMPTY "System" $subject_name $diagram
- catch {goto_system $systemName}
- return
- }
-
- set model [load_model $classes ccd 0 1 0]
- if {$model == ""} {
- m4_message $M_LOADING_SUBJMODEL_FAILED $subject_type $subject_name
- catch {goto_system $systemName}
- return
- }
- set oopl [$model ooplModel]
- prepare $oopl check
-
- foreach e [$subject receivedEventSet] {
- set found 0
- foreach c [getSelectedOoplClasses $oopl $classes] {
- if [check_method_for_event $e $c "" 1] {
- set found 1
- break
- }
- }
- if {!$found} {
- m4_error $E_NO_MATCHING_OPER_IN_SUBJECT \
- "system" $subject_name [display_event $e]
- }
- }
- $model delete
-
- #
- # Go to the original system
- #
- if [catch {goto_system $systemName} msg] {
- puts stdout $msg
- return
- }
- }
-
- #
- # If this event has the receiving object as the sending object, check
- # if the arrival time is later than the send time.
- #
- proc check_etd_times {r class diagram} {
- #
- # Does not work, for two reasons:
- # 1) save diagram does not update begin_y/end_y when stripping diagram,
- # so that only coordinates of first connector are saved (if intermediate
- # vertices are used)
- # 2) given class may have two distinct 'timelines' in the same
- # diagram, and the event may be sent from one to the other,
- # making it invalid to compare src and dst times
- # This check is better done in libetd.
- #
- # if {[$r getSenderName] == [$class getName]} {
- # if {[get_dst_time $r] < [get_src_time $r]} {
- # m4_error $E_RECEIVED_BEFORE_SENT \
- # [$class getName] [display_event $r]
- # }
- # }
- }
-