home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / checks.tcl < prev    next >
Text File  |  1996-12-04  |  20KB  |  666 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1993-1995 by Cadre Technologies Inc.
  4. #
  5. # This software is furnished under a license and may be used only in
  6. # accordance with the terms of such license and with the inclusion of
  7. # the above copyright notice. This software or any other copies thereof
  8. # may not be provided or otherwise made available to any other person.
  9. # No title to and ownership of the software is hereby transferred.
  10. #
  11. # The information in this software is subject to change without notice
  12. # and should not be construed as a commitment by Cadre Technologies Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #       File            : @(#)checks.tcl    /main/hindenburg/1
  17. #       Author          : edri
  18. #    Original date   : 11-10-94
  19. #       Description     : All kinds of checks.
  20. #
  21. #---------------------------------------------------------------------------
  22. #
  23.  
  24. #
  25. # Check if this class does not directly inherit from the same
  26. # class more than once.
  27. #
  28. proc check_direct_supers {class} {
  29.     set super_names ""
  30.     foreach g [$class genNodeSet] {
  31.         lappend super_names [$g getSuperClassName]
  32.     }
  33.  
  34.     # remove all unique names from super_names
  35.     set unique_supers [find_unique_names $super_names]
  36.     foreach u $unique_supers {
  37.     set i [lsearch $super_names $u]
  38.     set super_names [lreplace $super_names $i $i]
  39.     }
  40.  
  41.     # any name left indicates an error
  42.     foreach c [find_unique_names $super_names] {
  43.     m4_error $E_SAME_DIRECT_SUPERS [$class getName] $c
  44.     }
  45. }
  46.  
  47. #
  48. # Check if the attribute names of this class are unique; includes checking
  49. # for duplicate assoc_attribs.  Duplicate attribute names are checked for
  50. # while loading the model, because these are certain to cause collisions.
  51. #
  52. # These checks see if methods generated from data_ and assoc_attribs
  53. # will confict.  This can only happen in these cases:
  54. #
  55. #     - between a data_attrib and an assoc_attrib that have the same name,
  56. #    and where the assoc_attrib has a multiplicity of one,
  57. #
  58. #     - between two assoc_attribs with the same name, compatible types
  59. #    and same multiplicity.
  60. #
  61. proc causes_conflict {assoc1 assoc2} {
  62.     set type1 [$assoc1 get_obj_type]
  63.     set type2 [$assoc2 get_obj_type]
  64.  
  65.     return [expr {
  66.     $assoc1 != $assoc2 &&
  67.     [$assoc1 getName] == [$assoc2 getName] &&
  68.     [$assoc1 getMultiplicity] == [$assoc2 getMultiplicity] &&
  69.         ($type1 == $type2 || "db_$type1" == $type2 || $type1 == "db_$type2")
  70.     }]
  71. }
  72.  
  73. proc check_class_attributes {class} {
  74.     # check data attribute against all assoc_attribs
  75.  
  76.     foreach attrib [$class dataAttrSet] {
  77.     set name [$attrib getName]
  78.     foreach assoc [$class genAssocAttrSet] {
  79.         if {[$assoc getName] == $name &&
  80.         [$assoc getMultiplicity] == "one"} {
  81.             m4_error $E_CONFLICTING_DATA_AND_ASSOC_ATTRIB \
  82.             [$class getName] $name [display_diagram $assoc]
  83.         }
  84.     }
  85.     }
  86.  
  87.     # check assoc_attribute
  88.  
  89.     foreach assoc1 [$class genAssocAttrSet] {
  90.     foreach assoc2 [$class genAssocAttrSet] {
  91.         # Trick to prevent to prevent double checks.
  92.         if {$assoc1 >= $assoc2} {
  93.         continue
  94.         }
  95.  
  96.         if [causes_conflict $assoc1 $assoc2] {
  97.         m4_error $E_CONFLICTING_ASSOC_ATTRIBS \
  98.             [$class getName] [$assoc1 getName] \
  99.             [display_diagram $assoc1] [display_diagram $assoc2]
  100.         }
  101.     }
  102.     }
  103. }
  104.  
  105. #
  106. # Check if the given class has unique names for all associations.
  107. #
  108. # Only for assoc_attribs that have a "link", since only there the association
  109. # name is used by the code-generator.
  110. #
  111. proc check_class_associations {class} {
  112.     foreach a [$class genAssocAttrSet] {
  113.     set a_link [get_link $a]
  114.     if {$a_link != ""} {
  115.         foreach b [$class genAssocAttrSet] {
  116.         # Trick to prevent to prevent double checks.
  117.         if {$a >= $b} {
  118.             continue
  119.         }
  120.         set b_link [get_link $b]
  121.         if {$b_link != ""} {
  122.             set a_relation [$a_link relation]
  123.             set b_relation [$b_link relation]
  124.             if {$a_relation != $b_relation} {
  125.             # if they're the same, this class is a link class, with
  126.             # links to both association classes, but only one
  127.             # association.
  128.             set a_name [$a_relation getName]
  129.             set b_name [$b_relation getName]
  130.             if {$a_name == $b_name && $a_name != ""} {
  131.                 set diags "[display_diagram $a] [display_diagram $b]"
  132.                 if {[lindex $diags 0] == [lindex $diags 1]} {
  133.                 set diags " [lindex $diags 0]"
  134.                 } else {
  135.                 set diags "s [join $diags " and "]"
  136.                 }
  137.                 m4_error $E_CONFLICTING_ASSOC_NAMES \
  138.                      [$class getName] $a_name $diags
  139.             }
  140.             }
  141.         }
  142.         }
  143.     }
  144.     }
  145. }
  146.  
  147. #
  148. # Check if all attributes of a received_event have distinct names.
  149. #
  150. proc check_event_attributes {event class} {
  151.     if [$event hasAttributes] {
  152.     if {![is_unique_name_list [$event getAttributes]]} {
  153.         m4_error $E_SAME_EVENT_ATTRIBUTE_NAMES \
  154.             [display_event $event 1] [$class getName]
  155.     }
  156.     }
  157. }
  158.  
  159. #
  160. # Check for the given received_event received by the given class whether
  161. # that event is handled by a method of the class.
  162. #
  163. # For an event to be valid, one of the following must hold:
  164. #
  165. # - if the received event does not have an associated MGD event,
  166. #    an operation with the same name as the event and with the same
  167. #    number of parameters as the number of event attributes must exist
  168. #    in the class' methods;
  169. #
  170. # - if the received event does have an associated MGD message, then
  171. #    every most decomposed message ("leaf event") in the MGD hierarchy
  172. #    with the received event as root, must have one or more parent messages
  173. #    for which an operation exists in the class' methods.  This ensures
  174. #    that every type of message that can occur, is handled by the class.
  175. #
  176. proc check_method_for_event {r class diagram {quiet 0}} {
  177.     set class_name [$class getName]
  178.     set r_type [$r getEventType]
  179.     #
  180.     # Determine whether we need to consider methods of superclasses,
  181.     # and the minimum access right for an operation handling the event.
  182.     #
  183.     switch -glob $r_type {
  184.     internal_*    {set super 0; set access_needed "Private"}
  185.     external_*    -
  186.     event_message    -
  187.     comm_message    -
  188.     trace_event    {set super 1; set access_needed "Public"}
  189.     }
  190.  
  191.     #
  192.     # If this event is sent to the class by the class itself, "Private"
  193.     # access is all that's needed.  This also takes care of STD
  194.     # internal_- and external_events.
  195.     #
  196.     if {$class_name == [$r getSenderName]} {
  197.     set access_needed "Private"
  198.     }
  199.  
  200.     if [$r hasAttributes] {
  201.     set nattrs [llength [$r getAttributes]]
  202.     } else {
  203.     set nattrs -1
  204.     }
  205.  
  206.     set e [get_event $r]
  207.     if {$e == ""} {
  208.     m4_warning $W_NO_CORR_MSGDEF_FOUND \
  209.         [display_event $r] [$r getSenderName] $class_name
  210.  
  211.     # check event
  212.     #
  213.     if {[$r getName] != ""} {
  214.         set info ""
  215.         if {!$super} {
  216.         set result [find_event_method [$class operationSet] \
  217.                 [$r getName] $nattrs $access_needed info]
  218.         } else {
  219.         set result [find_event_method [$class getPropertyValue flat_methods] \
  220.                 [$r getName] $nattrs $access_needed info]
  221.         }
  222.         if {$result == 1} {
  223.         if {!$quiet} {
  224.             m4_event_error $r_type E_NO_MATCHING_OPERATION1 \
  225.                  $class_name [display_event $r]
  226.         }
  227.         return 0
  228.         } elseif {$result == 2} {
  229.         if {!$quiet} {
  230.             m4_event_error $r_type E_PARAM_ATTR_MISMATCH1 \
  231.                  $class_name [display_event $r] $info $nattrs
  232.         }
  233.         return 0
  234.         } elseif {$result == 3} {
  235.         if {!$quiet} {
  236.             m4_event_error $r_type E_METHOD_ACCESS1 $class_name \
  237.                  [display_event $r] $info $access_needed
  238.         }
  239.         return 0
  240.         }
  241.     }
  242.  
  243.     # check action
  244.     #
  245.     set action [$r getAction]
  246.     if {$action == ""} {return 0}
  247.     set nattrs -1
  248.     regsub {(..ternal_)event} $r_type {\1action} r_type
  249.     set info ""
  250.     if {!$super} {
  251.         set result [find_event_method [$class operationSet] \
  252.             $action $nattrs $access_needed info]
  253.     } else {
  254.         set result [find_event_method [$class getPropertyValue flat_methods] \
  255.             $action $nattrs $access_needed info]
  256.     }
  257.     if {$result == 1} {
  258.         if {!$quiet} {
  259.         m4_event_error $r_type E_NO_MATCHING_OPERATION1 \
  260.              $class_name "[long_event_type $r_type] '$action' in [display_diagram $r]"
  261.         }
  262.         return 0
  263.     } elseif {$result == 2} {
  264.         if {!$quiet} {
  265.         m4_event_error $r_type E_PARAM_ATTR_MISMATCH1 \
  266.              $class_name "[long_event_type $r_type] '$action' in [display_diagram $r]" $info $nattrs
  267.         }
  268.         return 0
  269.     } elseif {$result == 3} {
  270.         if {!$quiet} {
  271.         m4_event_error $r_type E_METHOD_ACCESS1 $class_name \
  272.              "[long_event_type $r_type] '$action' in [display_diagram $r]" $info $access_needed
  273.         }
  274.         return 0
  275.     }
  276.  
  277.     } else {
  278.     foreach leaf [find_leaf_events $e] {
  279.         set ok 0
  280.         set bad_params 0
  281.         set bad_access 0
  282.         set name_nparams 0
  283.         set name_access ""
  284.         set parents [concat $leaf [find_parent_events $leaf]]
  285.         foreach parent $parents {
  286.         set info ""
  287.         if {!$super} {
  288.             set result [find_event_method [$class operationSet] \
  289.                 [$parent getName] $nattrs $access_needed \
  290.                 info]
  291.         } else {
  292.             set result [find_event_method [$class getPropertyValue flat_methods] \
  293.                 [$parent getName] $nattrs $access_needed \
  294.                 info]
  295.         }
  296.         if {$result == 0} {
  297.             set ok 1
  298.             break
  299.         } elseif {$result == 2 && !$bad_params} {
  300.             # remember the first (most derived) event found
  301.             set bad_params 1
  302.             set name [$parent getName]
  303.             set name_nparams $info
  304.         } elseif {$result == 3 && !$bad_access} {
  305.             # remember the first (most derived) event found
  306.             set bad_access 1
  307.             set name [$parent getName]
  308.             set name_access $info
  309.         }
  310.         }
  311.         if {!$ok} {
  312.         set parent_names {}
  313.         foreach parent $parents {
  314.             lappend parent_names [$parent getName]
  315.         }
  316.         if {!$quiet} {
  317.             if $bad_params {
  318.             m4_event_error $r_type E_PARAM_ATTR_MISMATCH2 $name \
  319.                  $class_name [display_event $r] \
  320.                  $name_nparams $nattrs
  321.             } elseif $bad_access {
  322.             m4_event_error $r_type E_METHOD_ACCESS2 $name $class_name \
  323.                  [display_event $r] $name_access $access_needed
  324.             } else {
  325.             m4_event_error $r_type E_NO_MATCHING_OPERATION2 $class_name \
  326.                  [display_event $r] [display_event $leaf] $parent_names
  327.             }
  328.         } else {
  329.                     #
  330.                     #  No need to continue, since the caller is only interested
  331.                     #  in the correctness of this event, and here it is clear
  332.                     #  that it is not correct.
  333.                     #
  334.                     return 0
  335.                 }
  336.         }
  337.     }
  338.     }
  339.     return 1
  340. }
  341.  
  342. #
  343. # Given an operation and an access right string ("Private", "Protected",
  344. # "Public", or "" as synonym for "Public", return whether the operation
  345. # can be called.
  346. #
  347. proc check_access {oper needed} {
  348.     set access [$oper getPropertyValue method_access]
  349.     switch $needed {
  350.         "Private"
  351.             {if {$access == "None"} {
  352.                 return 0
  353.             } else {
  354.                 return 1
  355.             }}
  356.         "Protected"
  357.             {if {$access == "Private" || $access == "None"} {
  358.                 return 0
  359.             } else {
  360.                 return 1
  361.             }}
  362.         "Public"
  363.             {if {$access == "Private" || $access == "Protected" || $access == "None"} {
  364.                 return 0
  365.             else
  366.                 return 1
  367.             }}
  368.     }
  369.     return 1
  370. }
  371.  
  372. #
  373. # Given a list of Operations and a single event name, see if the event is
  374. # handled by the class.  This is so if the class has an operation with the
  375. # same name as the event.  Also check if the operation found has at least
  376. # accessibility as specified by 'access'.
  377. #
  378. # If 'nattrs' is >= 0, the operation must have the same number of parameters
  379. # as the specified number, if 'nattrs' == -1 the parameter count of the
  380. # operation is ignored.
  381. #
  382. # Returns:
  383. #    0 if a matching operation is found (correct parameters and access rights),
  384. #    1 if no operation is found at all,
  385. #    2 if an operation is found with the correct name but with the wrong
  386. #        number of parameters,
  387. #    3 if a matching operation was found, but with the wrong accessibility.
  388. #
  389. proc find_event_method {opers event nattrs access i} {
  390.     upvar $i info
  391.     set found_name 0
  392.     set bad_access 0
  393.     foreach o $opers {
  394.         if {[$o getName] != $event} {
  395.             continue
  396.         }
  397.  
  398.         # found one, if attributes need not be checked, we're done
  399.     if {$nattrs == -1} {
  400.             if [check_access $o $access] {
  401.                 return 0
  402.             } else {
  403.                 set bad_access 1
  404.                 set info [$o getPropertyValue method_access]
  405.                 continue
  406.             }
  407.         }
  408.  
  409.     # found one, check if parameters match attributes
  410.         if {[llength [get_parameters $o]] == $nattrs} {
  411.             if [check_access $o $access] {
  412.                 return 0
  413.             } else {
  414.                 set bad_access 1
  415.                 set info [$o getPropertyValue method_access]
  416.             }
  417.     } else {
  418.             # remember that a correct name was found
  419.             set found_name 1
  420.             set info [llength [get_parameters $o]]
  421.         }
  422.     }
  423.     if $found_name {
  424.         return 2
  425.     }
  426.     if $bad_access {
  427.         return 3
  428.     }
  429.     return 1
  430. }
  431.  
  432. #
  433. # The given class is a special class, not allowed to receive events; check this.
  434. #
  435. proc check_special_class {class diagram} {
  436.     set events [$class receivedEventSet]
  437.     foreach e $events {
  438.         if {$diagram == "" || [in_diagram $e $diagram]} {
  439.         m4_event_error [$e getEventType] E_CLASS_CANNOT_RECEIVE \
  440.                      [$class getName] [display_event $e] [$class get_obj_type]
  441.         }
  442.     }
  443. }
  444.  
  445. #
  446. # Check to see if the given trace_event occurs as any comm_message to the
  447. # same class as the trace_event in any CCD in the system.
  448. #
  449. # This function assumes that the comm_message events are loaded in the
  450. # ooplmodel (i.e. that "ccd" was passed to option "-events").
  451. #
  452. proc check_corr_ccd_message {r class diagram} {
  453.     if {[M4CheckManager::errorControl  $E_NO_CORR_CCDMSG_FOUND] == "off"} {
  454.         return
  455.     }
  456.  
  457.     set r_name [$r getName]
  458.     set r_found 0
  459.  
  460.     foreach ccd_r [$class receivedEventSet] {
  461.     if {[$ccd_r getEventType] == "comm_message" &&
  462.         [$ccd_r getName] == $r_name} {
  463.         set r_found 1
  464.         break
  465.     }
  466.     }
  467.  
  468.     if {!$r_found} {
  469.     m4_warning $E_NO_CORR_CCDMSG_FOUND [display_event $r] \
  470.            [$r getSenderName] [$class getName]
  471.     }
  472. }
  473.  
  474. #
  475. #  Check if each received_event of the subject is handled by one of
  476. #  the classes in this CAD.
  477. #
  478. proc check_cad_subject {subject} {
  479.     if {[M4CheckManager::errorControl  $E_NO_MATCHING_OPER_IN_SUBJECT] == "off"} {
  480.         return
  481.     }
  482.  
  483.     set subject_name [$subject getName]
  484.     set subject_type [$subject get_obj_type]
  485.     set diagram "[$subject getDiagramName].[$subject getDiagramType]"
  486.  
  487.     #
  488.     #  Load and prepare the model for all classes in the diagram and
  489.     #  check for every event received by the subject whether it is
  490.     #  handled by some class.
  491.     #
  492.     if [catch {set classes [get_diagram_classes $subject_name cad]} msg] {
  493.         puts stdout $msg
  494.         return
  495.     }
  496.     if [lempty $classes] {
  497.         m4_error $E_SUBJECT_IS_EMPTY "CAD" $subject_name $diagram
  498.         return
  499.     }
  500.  
  501.     set model [load_model $classes ccd 0 1 0]
  502.     if {$model == ""} {
  503.         m4_message $M_LOADING_MODEL_FAILED $subject_type $subject_name
  504.         return
  505.     }
  506.     set oopl [$model ooplModel]
  507.     prepare $oopl check
  508.  
  509.     foreach e [$subject receivedEventSet] {
  510.     set found 0
  511.     foreach c [getSelectedOoplClasses $oopl $classes] {
  512.             if [check_method_for_event $e $c "" 1] {
  513.                 set found 1
  514.                 break
  515.             }
  516.     }
  517.         if {!$found} {
  518.             m4_error $E_NO_MATCHING_OPER_IN_SUBJECT \
  519.                      "CAD" $subject_name [display_event $e]
  520.         }
  521.     }
  522.     $model delete
  523. }
  524.  
  525. #
  526. #  Check if each received_event of the subject is received by one of the
  527. #  classes in the CCD specified by the subject.  This CCD should exist in
  528. #  the current system.
  529. #
  530. #  This function assumes that all classes occurring in the CCD have been
  531. #  loaded in the current ooplmodel.
  532. #
  533. proc check_ccd_subject {subject} {
  534.     if {[M4CheckManager::errorControl  $E_NO_MATCHING_OPER_IN_SUBJECT] == "off"} {
  535.         return
  536.     }
  537.  
  538.     set subject_name [$subject getName]
  539.     set subject_type [$subject get_obj_type]
  540.     set diagram "[$subject getDiagramName].[$subject getDiagramType]"
  541.  
  542.     if [catch {set classes [get_diagram_classes $subject_name ccd]} msg] {
  543.         puts stdout $msg
  544.         return
  545.     }
  546.  
  547.     foreach r [$subject receivedEventSet] {
  548.         set r_name [$r getName]
  549.         set r_found 0
  550.         foreach c $classes {
  551.             set class [find_class $ooplmodel $c]
  552.             if {$class != ""} {
  553.                 foreach cr [$class receivedEventSet] {
  554.                     if {$r_name == [$cr getName]} {
  555.                         set r_found 1
  556.                         break
  557.                     }
  558.                 }
  559.             }
  560.             if {$r_found} {
  561.                 break
  562.             }
  563.         }
  564.         if {!$r_found} {
  565.             m4_error $E_NO_MATCHING_MSG_IN_SUBJECT $r_name $subject_name $diagram
  566.         }
  567.     }
  568. }
  569.  
  570. #
  571. #  Check if each received_event of the subject is handled by one of
  572. #  the classes in this system.
  573. #
  574. proc check_system_subject {subject} {
  575.     if {[M4CheckManager::errorControl  $E_NO_MATCHING_OPER_IN_SUBJECT] == "off"} {
  576.         return
  577.     }
  578.  
  579.     set currSystemVersion [[ClientContext::global] currentSystem]
  580.     if $currSystemVersion {
  581.     set systemName [[$currSystemVersion system] name]
  582.     } else {
  583.     set systemName ""
  584.     }
  585.  
  586.     #set systemName [OTShContext::getSystemName]
  587.     set subject_name [$subject getName]
  588.     set subject_type [$subject get_obj_type]
  589.     set diagram "[$subject getDiagramName].[$subject getDiagramType]"
  590.  
  591.     #
  592.     #  Go to the system specified by the subject, load and prepare the model
  593.     #  for all classes in the system and check for every event received by
  594.     #  the subject whether it is handled by some class.
  595.     #
  596.     if [catch {goto_system $subject_name} msg] {
  597.     m4_error $E_BAD_SYSTEM_SUBJECT $subject_name $diagram $msg
  598.     return
  599.     }
  600.     if [catch {set classes [get_system_classes]} msg] {
  601.         puts stdout $msg
  602.     catch {goto_system $systemName}
  603.         return
  604.     }
  605.     if [lempty $classes] {
  606.         m4_error $E_SUBJECT_IS_EMPTY "System" $subject_name $diagram
  607.     catch {goto_system $systemName}
  608.         return
  609.     }
  610.  
  611.     set model [load_model $classes ccd 0 1 0]
  612.     if {$model == ""} {
  613.         m4_message $M_LOADING_SUBJMODEL_FAILED $subject_type $subject_name
  614.     catch {goto_system $systemName}
  615.         return
  616.     }
  617.     set oopl [$model ooplModel]
  618.     prepare $oopl check
  619.  
  620.     foreach e [$subject receivedEventSet] {
  621.     set found 0
  622.     foreach c [getSelectedOoplClasses $oopl $classes] {
  623.             if [check_method_for_event $e $c "" 1] {
  624.                 set found 1
  625.                 break
  626.             }
  627.     }
  628.         if {!$found} {
  629.             m4_error $E_NO_MATCHING_OPER_IN_SUBJECT \
  630.                      "system" $subject_name [display_event $e]
  631.         }
  632.     }
  633.     $model delete
  634.  
  635.     #
  636.     #  Go to the original system
  637.     #
  638.     if [catch {goto_system $systemName} msg] {
  639.     puts stdout $msg
  640.     return
  641.     }
  642. }
  643.  
  644. #
  645. # If this event has the receiving object as the sending object, check
  646. # if the arrival time is later than the send time.
  647. #
  648. proc check_etd_times {r class diagram} {
  649. #
  650. # Does not work, for two reasons:
  651. # 1) save diagram does not update begin_y/end_y when stripping diagram,
  652. #    so that only coordinates of first connector are saved (if intermediate
  653. #    vertices are used)
  654. # 2) given class may have two distinct 'timelines' in the same
  655. #    diagram, and the event may be sent from one to the other,
  656. #    making it invalid to compare src and dst times
  657. # This check is better done in libetd.
  658. #
  659. #    if {[$r getSenderName] == [$class getName]} {
  660. #        if {[get_dst_time $r] < [get_src_time $r]} {
  661. #            m4_error $E_RECEIVED_BEFORE_SENT \
  662. #                     [$class getName] [display_event $r]
  663. #        }
  664. #    }
  665. }
  666.