home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / oper_missing.tcl < prev    next >
Encoding:
Text File  |  1997-06-03  |  8.5 KB  |  374 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #    (c) Cadre Technologies Inc. 1996
  4. #
  5. #    File:        @(#)oper_missing.tcl    /main/hindenburg/8
  6. #    Author:        Harm Leijendeckers
  7. #    Description:    Report on missing operations
  8. #    Usage in:    SystemVersion and CAD editor
  9. #    Options:    -o <className1> [<className2> ...]
  10. #
  11. #---------------------------------------------------------------------------
  12. # SccsId = @(#)oper_missing.tcl    /main/hindenburg/8    3 Jun 1997    Copyright 1996 Cadre Technologies Inc.
  13.  
  14.  
  15. eval [$cc getCustomFileContents semanticbase tcl reports]
  16.  
  17.  
  18. Class ReportOperMissing : {SemanticBase} {
  19.     constructor
  20.     method systemReport
  21.     method fileReport
  22.     method doReport
  23.  
  24.     method doClass
  25.     method getAllOperations
  26.     method getAllConnectors
  27.     method getConnectors
  28.  
  29.     attribute QOAllCdms
  30. }
  31.  
  32.  
  33. constructor ReportOperMissing {class this} {
  34.     set this [SemanticBase::constructor $class $this]
  35.     $this reportName "Missing Operations"
  36.     return $this
  37. }
  38.  
  39.  
  40. method ReportOperMissing::fileReport {this} {
  41.     return [$this phaseReport]
  42. }
  43.  
  44.  
  45. method ReportOperMissing::systemReport {this} {
  46.     return [$this phaseReport]
  47. }
  48.  
  49.  
  50. method ReportOperMissing::doReport {this model} {
  51.     set report [$this report]
  52.  
  53.     if [lempty $Options] {
  54.     $report print "Error: This report needs argument '-o <className1>\
  55.                \[<className2> ...\]'" line
  56.     return -1
  57.     }
  58.  
  59.     if ![[$this systemV] isNil] {
  60.     set allCdms [query "file.type == cdm" $this.systemV.localFileVersions]
  61.     } else {
  62.     set allCdms [query "file.type == cdm" \
  63.         $this.phaseV.systemVersions.localFileVersions]
  64.     }
  65.     $this QOAllCdms [QueryObject new allCdms file.name]
  66.  
  67.     set Options [lsort [flatten $Options]]
  68.     while { ![lempty $Options] } {
  69.     set className [lvarpop Options]
  70.     $this doClass $model $className
  71.     if [$report lineno] {
  72.         $report line
  73.         $report line
  74.         $report line
  75.     }
  76.     }
  77.  
  78.     $report page
  79.     $report remove header
  80.  
  81.     return 0
  82. }
  83.  
  84.  
  85. method ReportOperMissing::doClass {this model className} {
  86.     set report [$this report]
  87.  
  88.     $report space 2
  89.     $report print "* Class: $className" line
  90.  
  91.     set connDictBag [$this getAllConnectors $model $className]
  92.     if ![$connDictBag size] {
  93.     $report space 8
  94.     $report print "** no events to this class found **" line
  95.     return
  96.     }
  97.  
  98.     $report line
  99.     $report space 4
  100.     $report print Event 28
  101.     $report print "Req. Args" 11
  102.     $report print Type 18
  103.     $report print Diagram line
  104.     $report space 4
  105.     $report print - 114 fill line
  106.  
  107.     # retrieve operations in a UniqueBag
  108.     set operBag [$this getAllOperations $className]
  109.  
  110.     $connDictBag foreach connName argBag {
  111.     $argBag foreach argcount connectorList {
  112.         # in a ccd there are no args at connectors
  113.         if { $argcount == "?" } {
  114.         if [$operBag exists $connName] {
  115.             continue
  116.         }
  117.         } elseif [$operBag exists $connName $argcount] {
  118.         continue
  119.         }
  120.  
  121.         $connectorList foreach connector {
  122.         $report space 4
  123.         $report print $connName 27
  124.         $report space 4
  125.         $report print $argcount 8
  126.         $report print [$connector type] 17
  127.         $report space
  128.         $report print [[$connector diagram] text]
  129.         $report line
  130.         }
  131.     }
  132.     }
  133. }
  134.  
  135.  
  136. method ReportOperMissing::getAllOperations {this className} {
  137.     set result [UniqueBag new]
  138.     set cdm [query "file.name == \"$className\"" [$this QOAllCdms]]
  139.  
  140.     if [lempty $cdm] {
  141.     return $result
  142.     }
  143.  
  144.     $cdm loadRowData {{name_type}} rowDataList
  145.     foreach rowData $rowDataList {
  146.     set row          [lvarpop rowData]
  147.     if { [$row type] != "method" } {
  148.         continue
  149.     }
  150.     set rowItems     [lvarpop rowData]
  151.     set rowProps     [lvarpop rowData]
  152.     set cellDataList [lvarpop rowData]
  153.  
  154.     set classItem    [query "type == pe" $rowItems]
  155.     if [lempty $classItem] {
  156.         continue
  157.     }
  158.  
  159.     $result set [$classItem name] [llength $cellDataList]
  160.     }
  161.  
  162.     return $result
  163.  
  164. }
  165.  
  166.  
  167. method ReportOperMissing::getAllConnectors {this model className} {
  168.     set result [Dictionary new]
  169.  
  170.     set ccdConns [$this getConnectors $model $className $OMT_CCD_Message \
  171.           $OMT_CCD_Class $OMT_CCD_Container $OMT_CCD_ClassRef]
  172.     set etdConns [$this getConnectors $model $className $OMT_ETD_Event \
  173.           $OMT_ETD_Initiator $OMT_ETD_Object]
  174.     # all event messages in all std's to the class
  175.     set stdConns [$this getConnectors $model $className $OMT_STD_EventMessage \
  176.           $OMT_STD_Class]
  177.  
  178.     # all messages in std of the class
  179.     set classItem [[$this project] findItem $className cl]
  180.     if ![$classItem isNil] {
  181.     set stdItem [[$this project] findItem top pe $classItem]
  182.     if ![$stdItem isNil] {
  183.         [$this phaseV] getDecompositions $stdItem [$this configV] \
  184.                          decompFiles std dummy std
  185.         if ![lempty $std] {
  186.         set filemodel [SMFileModel new [$this configV] $std]
  187.         set stdConns [concat [$filemodel getSMObjects $OMT_STD_Event] \
  188.                 [$filemodel getSMObjects $OMT_STD_StateEvent] \
  189.                 $stdConns]
  190.         }
  191.     }
  192.     }
  193.  
  194.     foreach smconn [concat $ccdConns $etdConns $stdConns] {
  195.     set connLabel [$smconn getLabel]
  196.     if [$connLabel isNil] {
  197.         continue
  198.     }
  199.     set itemRefs [$connLabel itemRefs]
  200.     set msgtxt [query -s item.name "item.type == pe" $itemRefs]
  201.     # use lempty iso == ""
  202.     if [lempty $msgtxt] {
  203.         continue
  204.     }
  205.  
  206.     set nrargs [llength [query "item.type != pe" $itemRefs]]
  207.     # in a ccd there are no args at connectors
  208.     if [$smconn isA SMConnector] {
  209.         set conn [$smconn getConnector]
  210.         if { [$conn type] == "com_message" } {
  211.         set nrargs ?
  212.         }
  213.     }
  214.  
  215.     set slotBag [$result set $msgtxt]
  216.     if [lempty $slotBag] {
  217.         set slotBag [UniqueBag new]
  218.         $result set $msgtxt $slotBag
  219.     }
  220.  
  221.     $slotBag set $nrargs $conn
  222.     }
  223.  
  224.     return $result
  225. }
  226.  
  227.  
  228. method ReportOperMissing::getConnectors {this model className connType args} {
  229.     set result {}
  230.     foreach toType $args {
  231.     foreach conn [$model getSMObjects $connType] {
  232.         # skip conns with no name
  233.         if [[$conn getItem] isNil] {
  234.         continue
  235.         }
  236.  
  237.         # skip conns where getTo != className
  238.         set toNode [$conn getTo $toType]
  239.         if [lempty $toNode] {
  240.         continue
  241.         }
  242.         set item [$toNode getItem]
  243.         if [$item isNil] {
  244.         # exception for etd nodes
  245.         set item [$toNode getItem 0 name_type cl]
  246.         }
  247.         if ![$item isNil] {
  248.         if { [$item name] == "$className" } {
  249.             lappend result $conn
  250.         }
  251.         }
  252.     }
  253.     }
  254.  
  255.     return $result
  256. }
  257.  
  258.  
  259. # ----------------------------------------------------------------------
  260. #
  261. #  Class Bag
  262. #
  263. # ----------------------------------------------------------------------
  264.  
  265.  
  266. Class Bag : {Dictionary} {
  267.     constructor
  268.     method destructor
  269.  
  270. # overloaded:
  271.     method set
  272.     method contents
  273.     method exists
  274. }
  275.  
  276.  
  277. constructor Bag {class this} {
  278.     set this [Dictionary::constructor $class $this]
  279.     return $this
  280. }
  281.  
  282.  
  283. method Bag::destructor {this} {
  284.     return [Dictionary::destructor $this]
  285. }
  286.  
  287.  
  288. # Overloaded from Dictionary.
  289. #
  290. method Bag::set {this key {value ""}} {
  291.     # retrieval
  292.     if { $value == "" } {
  293.     if ![$this Dictionary::exists $key] {
  294.         return
  295.     }
  296.     return [[$this Dictionary::set $key] contents]
  297.     }
  298.  
  299.     # append
  300.     if ![$this Dictionary::exists $key] {
  301.     $this Dictionary::set $key [List new]
  302.     }
  303.  
  304.     [$this Dictionary::set $key] append $value
  305. }
  306.  
  307.  
  308. # Overloaded from Dictionary.
  309. #
  310. method Bag::contents {this} {
  311.     $this foreach key valueList {
  312.     lappend result "$key [list [$valueList contents]]"
  313.     }
  314.     return [join $result]
  315. }
  316.  
  317.  
  318. # Overloaded from Dictionary.
  319. #
  320. method Bag::exists {this key {value ""}} {
  321.     if { $value == "" } {
  322.     return [$this Dictionary::exists $key]
  323.     }
  324.  
  325.     if ![$this Dictionary::exists $key] {
  326.     return 0
  327.     }
  328.  
  329.     if { [[$this Dictionary::set $key] search $value] != -1 } {
  330.     return 1
  331.     }
  332.  
  333.     return 0
  334. }
  335.  
  336.  
  337. # ----------------------------------------------------------------------
  338. #
  339. #  Class UniqueBag
  340. #
  341. # ----------------------------------------------------------------------
  342.  
  343.  
  344. Class UniqueBag : {Bag} {
  345.     constructor
  346.  
  347. # overloaded:
  348.     method set
  349. }
  350.  
  351.  
  352. constructor UniqueBag {class this} {
  353.     set this [Bag::constructor $class $this]
  354.     return $this
  355. }
  356.  
  357.  
  358. # Overloaded from Bag. Don't insert duplicates for one key.
  359. #
  360. method UniqueBag::set {this key {value ""}} {
  361.     if { $value != "" } {
  362.     if { [lsearch [$this set $key] $value] != -1 } {
  363.         return ""
  364.     }
  365.     }
  366.  
  367.     return [$this Bag::set $key $value]
  368. }
  369.  
  370.  
  371. # ----------------------------------------------------------------------
  372. #
  373. set executeMe [ReportOperMissing new]
  374.