home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / check_util.tcl < prev    next >
Text File  |  1997-03-25  |  9KB  |  341 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1992-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        : @(#)check_util.tcl    /main/hindenburg/2
  17. #    Author        : edri
  18. #    Original date    : 20-10-94
  19. #    Description    : Check utilities
  20. #
  21. #---------------------------------------------------------------------------
  22. #
  23.  
  24. #
  25. # Function to show the errors and warnings.
  26. #
  27. proc show_errors {} {
  28.     m4_message $M_NEWLINE
  29.     m4_message $M_ERRORS [M4CheckManager::getErrorCount]
  30.     m4_message $M_WARNINGS [M4CheckManager::getWarningCount]
  31. }
  32.  
  33. #
  34. # m4_error replacement that constructs an error id based on an error name
  35. # and an event type.  Used to allow for event-specific check configuration.
  36. #
  37. proc m4_event_error {event_type errname args} {
  38.     switch -glob $event_type {
  39.     internal_*    { set event_type internal_event }
  40.     external_*    { set event_type external_event }
  41.     }
  42.     set err ${errname}_[string toupper $event_type]
  43.     eval "m4_error $[get err] $args"
  44. }
  45.  
  46. #
  47. # Return the handle of the DBObject class for the given OoplModel.
  48. #
  49. proc get_dbobject_class {model} {
  50.     set dbobject [find_class $model $dbobject_name]
  51.     if {$dbobject == ""} {
  52.     if {[catch {set dbobject [$model addClass $dbobject_name db_class]}]} {
  53.         m4_error $E_INTERNAL_CLASS db_class
  54.         return ""
  55.     }
  56.     }
  57.     return $dbobject
  58. }
  59.  
  60. #
  61. # Create a paramList for use with add_operation.  The parameters consist
  62. # of those attributes that are key attributes of the given class.
  63. #
  64. proc make_key_paramlist {class} {
  65.     set params {}
  66.     foreach key [get_col_list [$class table] KEYS] {
  67.     set pair {}
  68.     lappend pair [$key getName]
  69.     lappend pair [$key getTypeStd]
  70.     lappend params $pair
  71.     }
  72.     return $params
  73. }
  74.  
  75. #
  76. # Set/Add attributes of an object.
  77. # Useful to set attributes of oopl objects created using add_class,
  78. # add_operation, add_super_class.
  79. #
  80. proc add_attributes {object list} {
  81.     foreach attr $list {
  82.     $object addRunTimeProperty [lindex $attr 0] [lindex $attr 1]
  83.     }
  84. }
  85.  
  86. #
  87. #  Given a class name and optionally an operation name, find the class
  88. #  and feature handles of the class with name 'name' and all features
  89. #  with name 'feat' in the specified OoplModel.  'feat' may be a glob-style
  90. #  pattern.
  91. #
  92. #  Returns a list of one or more elements, the first being the class handle,
  93. #  the rest operation handles.  If the class was not found, returns "".
  94. #
  95. proc find_class {model name {feat ""}} {
  96.     set c [$model classByName $name]
  97.  
  98.     if {"$c" == ""} {
  99.     return ""
  100.     }
  101.  
  102.     if {$feat != ""} {
  103.     set flist ""
  104.  
  105.     foreach f [$c featureSet] {
  106.         if [string match $feat [$f getName]] {
  107.         lappend flist $f
  108.         }
  109.     }
  110.  
  111.     return "$c $flist"
  112.     }
  113.  
  114.     return $c
  115. }
  116.  
  117. #
  118. # Check if the given class is a real root class, i.e. has no non-synthetic
  119. # superclasses
  120. #
  121. proc is_root_class {class} {
  122.     set supers [$class genNodeSet]
  123.     if [lempty $supers] {
  124.     return 1
  125.     }
  126.     foreach g $supers {
  127.     if {[$g isSynthetic] != "1"} {
  128.         return 0
  129.     }
  130.     }
  131.     return 1;
  132. }
  133.  
  134. #
  135. # Return the long name for an event type.
  136. #
  137. proc long_event_type {type} {
  138.     switch -glob $type {
  139.     internal_event    { return "Internal STD Event" }
  140.     internal_action { return "Internal STD Action" }
  141.     internal_activity { return "STD Activity" }
  142.     external_event    { return "External STD Event" }
  143.     external_action { return "External STD Action" }
  144.     event_message    { return "Event Message" }
  145.     comm_message    { return "Communication Message" }
  146.     trace_event    { return "Trace Event" }
  147.     }
  148.     return $type
  149. }
  150.  
  151. #
  152. # Create a string describing an Event object.
  153. # If 'attrs' is 1, the attributes of the event, if present, are added as well.
  154. # If 'condact' is 0, the condition and action, if present, are not added.
  155. #
  156. proc display_event {e {attrs 0} {condact 0}} {
  157.     if {[$e get_obj_type] == "event"} {
  158.     return "MGD Message '[$e getName]'\
  159.         in [$e getDiagramName].[$e getDiagramType]"
  160.     } else {
  161.     # obj_type == "received_event"
  162.     set a ""
  163.     if {$attrs && [has_attributes $e]} {
  164.         set first 1
  165.         foreach n [get_attributes $e] {
  166.         if {!$first} {
  167.             append a ", "
  168.         } else {
  169.             set first 0
  170.         }
  171.         lappend a $n
  172.         }
  173.         if {$a == ""} {
  174.         set a "()"
  175.         } else {
  176.         set a "( $a )"
  177.         }
  178.     }
  179.     if {$condact && [get_event_type $e] == "external_event"} {
  180.         set conds [get_conditions $e]
  181.         if {$conds != ""} {
  182.         set first 1
  183.         foreach cond $conds {
  184.             if {!$first} {
  185.             append a ", "
  186.             } else {
  187.             set first 0
  188.             }
  189.             append a $cond
  190.         }
  191.         }
  192.         set act [get_action $e]
  193.         if {$act != ""} {
  194.         append a {/} $act
  195.         }
  196.     }
  197.     if {$condact && [get_event_type $e] == "external_event"} {
  198.         return "[long_event_type [get_event_type $e]] '[$e getName]'\
  199.             in '[$e getName]$a'\
  200.             in [$e getDiagramName].[$e getDiagramType]"
  201.     }
  202.     return "[long_event_type [get_event_type $e]] '[$e getName]$a'\
  203.             in [$e getDiagramName].[$e getDiagramType]"
  204.     }
  205. }
  206.  
  207. #
  208. # Given an object with the attributes 'diagram_name' and 'diagram_type',
  209. # return a string that concatenates these two.
  210. #
  211. proc display_diagram {obj} {
  212.     return "[$obj getDiagramName].[$obj getDiagramType]"
  213. }
  214.  
  215. #
  216. # Return a list with all Event objects that are leaves of the event hierarchy
  217. # with Event 'e' as root.
  218. #
  219. proc find_leaf_events {e} {
  220.     set leafs {}
  221.     foreach n [get_child_events $e] {
  222.     eval "lappend leafs [find_leaf_events $n]"
  223.     }
  224.  
  225.     # if no decompositions, this event is a leaf event
  226.     if {$leafs == {}} {
  227.     lappend leafs $e
  228.     }
  229.  
  230.     return $leafs
  231. }
  232.  
  233. #
  234. # Return a list with all parent events of the specified Event
  235. #
  236. proc find_parent_events {e} {
  237.     set parents {}
  238.  
  239.     set parent [get_parent_event $e]
  240.  
  241.     while {$parent != ""} {
  242.     lappend parents $parent
  243.     set parent [get_parent_event $parent]
  244.     }
  245.  
  246.     return $parents
  247. }
  248.  
  249. #
  250. # Return a list of methods of the given class.
  251. #
  252. # If 'super' is 1, methods of superclasses are included as well.
  253. #
  254. proc find_methods {class {super 0}} {
  255.     set opers [$class operationSet]
  256.  
  257.     if {$super == 1} {
  258.     foreach g [$class genNodeSet] {
  259.         set new [find_methods [$g superClass] 1]
  260.         if {$new != {}} {
  261.         eval "lappend opers $new"
  262.         }
  263.     }
  264.     }
  265.  
  266.     return $opers
  267. }
  268.  
  269. #
  270. # Return 0 if all names in the given list are unique, 1 if one or more
  271. # names occur more than once.
  272. #
  273. proc is_unique_name_list {names} {
  274.     while {![lempty $names]} {
  275.     set p [lindex $names 0]
  276.     set names [lreplace $names 0 0]
  277.     if {[lsearch $names $p] != -1} {
  278.         return 0
  279.     }
  280.     }
  281.     return 1
  282. }
  283.  
  284. #
  285. # Return 1 if the given event belongs to the given diagram, else 0.
  286. #
  287. proc in_diagram {e diagram} {
  288.     set colon [string first "/" $diagram]
  289.     if {$colon != -1} {
  290.     incr colon
  291.     set diagram [string range $diagram $colon end]
  292.     }
  293.     return [expr {$diagram == "[$e getDiagramName].[$e getDiagramType]"}]
  294. }
  295.  
  296. #
  297. # Return a list of all unique names present in the passed list.
  298. #
  299. proc find_unique_names {list} {
  300.     set unique {}
  301.     foreach n $list {
  302.     if {[lsearch -exact $unique $n] == -1} {
  303.         lappend unique $n
  304.     }
  305.     }
  306.     return $unique
  307. }
  308.  
  309. #
  310. # Based on the access mode of an attribute (data/assoc), set the
  311. # method access of a synthetic operation that is generated from
  312. # that attribute.
  313. #
  314. # 'data' is 1 if attrib is a data attribute, 0 if it's an assoc attribute
  315. # 'rw_mode' is r if op is a read operation, w if it's a write operation
  316. #
  317. proc copy_access_mode {attrib op data rw_mode} {
  318.     if {$op == ""} {
  319.     return
  320.     }
  321.  
  322.     if {$data == 1} {
  323.     set rw [$attrib getPropertyValue attrib_access]
  324.     } else {
  325.     set rw [$attrib getPropertyValue assoc_access]
  326.     }
  327.  
  328.     if {$rw == ""} {
  329.     set rw {Public Public}
  330.     } else {
  331.     set rw [split $rw -]
  332.     }
  333.     set rw_index [expr {$rw_mode == "r" ? "0" : "1"}]
  334.     $op addRunTimeProperty method_access [lindex $rw $rw_index]
  335.  
  336.     if {$debug} {
  337.     puts "    >>> copy_access_mode [$attrib getName] [$op getName]\
  338.                     [$op getPropertyValue method_access]"
  339.     }
  340. }
  341.