home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / oper_missing.tcl < prev    next >
Text File  |  1997-11-28  |  11KB  |  475 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #    (c) Cayenne Software Inc. 1996,1997
  4. #
  5. #    File:        @(#)oper_missing.tcl    /main/titanic/10
  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/titanic/10    28 Nov 1997    Copyright 1997 Cayenne Software 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 getAllEvents
  27.     method getConnectors
  28.     method getConos
  29.  
  30.     attribute QOAllCdms
  31. }
  32.  
  33.  
  34. constructor ReportOperMissing {class this} {
  35.     set this [SemanticBase::constructor $class $this]
  36.     $this reportName "Missing Operations"
  37.     return $this
  38. }
  39.  
  40.  
  41. method ReportOperMissing::fileReport {this} {
  42.     return [$this phaseReport]
  43. }
  44.  
  45.  
  46. method ReportOperMissing::systemReport {this} {
  47.     return [$this phaseReport]
  48. }
  49.  
  50.  
  51. method ReportOperMissing::doReport {this model} {
  52.     set report [$this report]
  53.  
  54.  
  55.     if ![[$this systemV] isNil] {
  56.     set allCdms [query "file.type == cdm" $this.systemV.localFileVersions]
  57.     } else {
  58.     set allCdms [query "file.type == cdm" \
  59.         $this.phaseV.systemVersions.localFileVersions]
  60.     }
  61.  
  62.  
  63.     $this QOAllCdms [QueryObject new allCdms file.name]
  64.  
  65.     if [lempty $Options] {
  66.         set Options [query -s "file.name" [$this QOAllCdms]]
  67.     }
  68.     if [lempty $Options] {
  69.         $report print "Error: No classes found" line
  70.         $report print "Error: This report needs argument '-o <className1>\
  71.                        \[<className2> ...\]'" line
  72.         return -1
  73.  
  74.     }
  75.  
  76.     set Options [lsort [flatten $Options]]
  77.     while { ![lempty $Options] } {
  78.     set className [lvarpop Options]
  79.     $this doClass $model $className
  80.     if [$report lineno] {
  81.         $report line
  82.         $report line
  83.         $report line
  84.     }
  85.     }
  86.  
  87.     $report page
  88.     $report remove header
  89.  
  90.     return 0
  91. }
  92.  
  93.  
  94. method ReportOperMissing::doClass {this model className} {
  95.     set report [$this report]
  96.  
  97.     $report space 2
  98.     $report print "* Class: $className" line
  99.  
  100.     set eventDictBag [$this getAllEvents $model $className]
  101.     if ![$eventDictBag size] {
  102.     $report space 8
  103.     $report print "** no events to this class found **" line
  104.     return
  105.     }
  106.  
  107.     $report line
  108.     $report space 4
  109.     $report print Event 18
  110.     $report print "Req. Args" 10
  111.     $report print Type 18
  112.     $report print To 20
  113.     $report print Diagram line
  114.     $report space 4
  115.     $report print - 114 fill line
  116.  
  117.     # retrieve operations in a UniqueBag
  118.     set operBag [$this getAllOperations $className]
  119.  
  120.     $eventDictBag foreach eventName argBag {
  121.     $argBag foreach argcount compList {
  122.         # in a ccd there are no args at connectors
  123.         if { $argcount == "?" } {
  124.         if [$operBag exists $eventName] {
  125.             continue
  126.         }
  127.         } elseif [$operBag exists $eventName $argcount] {
  128.         continue
  129.         }
  130.  
  131.         set toNodes ""
  132.         $compList foreach comp {
  133.         if [$comp isA Connector] {
  134.             set receiver [$comp to]
  135.         } elseif [$comp isA ConnectedNode] {
  136.             set receiver [$comp from]
  137.         } else {
  138.             set dir [$comp getPropertyValue msg_direction]
  139.             if { $dir == "backward" } {
  140.             set receiver [[[$comp from] connector] from]
  141.             } else {
  142.             set receiver [[[$comp from] connector] to]
  143.             }
  144.         }
  145.         set objLabel [lindex [$receiver labels] 0]
  146.         if ![$objLabel isNil] {
  147.             set label [$objLabel value]
  148.             if { [lsearch $toNodes $label] != -1 } continue
  149.             lappend toNodes $label
  150.         }
  151.  
  152.         $report space 4
  153.         $report print $eventName 24
  154.         $report space 
  155.         $report print $argcount 2
  156.         $report space 
  157.         $report print [$comp type] 17
  158.         $report space
  159.         $report print $label 19
  160.         $report space
  161.         $report print [[$comp diagram] text]
  162.         $report line
  163.         }
  164.     }
  165.     }
  166. }
  167.  
  168.  
  169. method ReportOperMissing::getAllOperations {this className} {
  170.     set result [UniqueBag new]
  171.     set cdm [query "file.name == $className" [$this QOAllCdms]]
  172.  
  173.     if [lempty $cdm] {
  174.     return $result
  175.     }
  176.  
  177.     $cdm loadRowData {{name_type}} rowDataList
  178.     foreach rowData $rowDataList {
  179.     set row          [lvarpop rowData]
  180.     if { [$row type] != "method" } {
  181.         continue
  182.     }
  183.     set rowItems     [lvarpop rowData]
  184.     set rowProps     [lvarpop rowData]
  185.     set cellDataList [lvarpop rowData]
  186.  
  187.     set classItem    [query "type == pe" $rowItems]
  188.     if [lempty $classItem] {
  189.         continue
  190.     }
  191.  
  192.     $result set [$classItem name] [llength $cellDataList]
  193.     }
  194.  
  195.     return $result
  196.  
  197. }
  198.  
  199.  
  200. method ReportOperMissing::getAllEvents {this model className} {
  201.     set result [Dictionary new]
  202.  
  203.     set ccdConns [$this getConnectors $model $className $OMT_CCD_Message \
  204.           $OMT_CCD_Class $OMT_CCD_Container $OMT_CCD_ClassRef]
  205.     set codConos [$this getConos $model $className $OMT_COD_Message \
  206.           $OMT_COD_Instance]
  207.     set etdConns [$this getConnectors $model $className $OMT_ETD_Event \
  208.           $OMT_ETD_Initiator $OMT_ETD_Object]
  209.     # all event messages in all std's to the class
  210.     set stdConns [$this getConnectors $model $className $OMT_STD_EventMessage \
  211.           $OMT_STD_Class]
  212.  
  213.     # all messages in std of the class
  214.     set classItem [[$this project] findItem $className cl]
  215.  
  216.     if ![$classItem isNil] {
  217.         set wi [[$this systemV] findDefinition $classItem [$this configV]]
  218.         set decl  {}
  219.         if ![$wi isNil] {
  220.         set decl [$wi qualifiedDeclarations]
  221.         }
  222.         set files {}
  223.         foreach def $decl {
  224.             [$this phaseV] getDecompositions \
  225.             [$def item] [$this configV] decompFiles std dummy stds
  226.             if  ![lempty $stds] {
  227.         lappend files [concat $stds]
  228.         }
  229.         }
  230.         foreach file $files {
  231.         set filemodel [SMFileModel new [$this configV] $file]
  232.         set stdConns  [concat \
  233.                 [$filemodel getSMObjects $OMT_STD_Event] \
  234.                 [$filemodel getSMObjects $OMT_STD_StateEvent] \
  235.                 $stdConns ]
  236.         }
  237.     }
  238.  
  239.     foreach smobj [concat $ccdConns $codConos $etdConns $stdConns] {
  240.     set label [$smobj getLabel]
  241.     if [$label isNil] {
  242.         continue
  243.     }
  244.  
  245.     set itemRefs [$label itemRefs]
  246.     set msgtxt [query -s item.name "item.type == pe" $itemRefs]
  247.     # use lempty iso == ""
  248.     if [lempty $msgtxt] {
  249.         # continue
  250.         # Show also messages without item (no semi-col. in COD flow)
  251.         set msgtxt [$this objName $smobj]
  252.         if {"$msgtxt" == "?"} continue
  253.     }
  254.  
  255.     set comp [$smobj getComponents]
  256.  
  257.     # in a ccd there are no args at connectors
  258.         switch [$comp type] {
  259.         com_message {
  260.         set nrargs ?
  261.         } 
  262.         cod_message -
  263.         etd_event {
  264.                 set type [$comp getPropertyValue msg_type]
  265.                 # See all (non-return) messages as operations...
  266.                 # if { "$type" != "nested" } continue
  267.                 if { "$type" == "return" } continue
  268.         set nrargs [llength [query "item.type != pe" $itemRefs]]
  269.         } 
  270.             default {
  271.         set nrargs [llength [query "item.type != pe" $itemRefs]]
  272.         } 
  273.     }
  274.  
  275.     set slotBag [$result set $msgtxt]
  276.     if [lempty $slotBag] {
  277.         set slotBag [UniqueBag new]
  278.         $result set $msgtxt $slotBag
  279.     }
  280.  
  281.     $slotBag set $nrargs $comp
  282.     }
  283.  
  284.     return $result
  285. }
  286.  
  287.  
  288. method ReportOperMissing::getConnectors {this model className connType args} {
  289.     set result {}
  290.     foreach toType $args {
  291.     foreach conn [$model getSMObjects $connType] {
  292.         # skip conns with no name
  293.         if [[$conn getItem] isNil] {
  294.         continue
  295.         }
  296.  
  297.         # skip conns where getTo != className
  298.         set toNode [$conn getTo $toType]
  299.         if [lempty $toNode] {
  300.         continue
  301.         }
  302.         set item [$toNode getItem]
  303.         if [$item isNil] {
  304.         # exception for etd nodes
  305.         set item [$toNode getItem 0 name_type cl]
  306.         }
  307.         if ![$item isNil] {
  308.         if { [$item name] == "$className" } {
  309.             lappend result $conn
  310.         }
  311.         }
  312.     }
  313.     }
  314.  
  315.     return $result
  316. }
  317.  
  318.  
  319. method ReportOperMissing::getConos {this model className conoType args} {
  320.     set result {}
  321.  
  322.     foreach toType $args {
  323.     foreach cono [$model getSMObjects $conoType] {
  324.         # skip conos with no name
  325.         # if [[$cono getItem] isNil] {
  326.         # }
  327.         if {[$this objName $cono] == "?"} {
  328.             continue
  329.         }
  330.  
  331.         # skip conos where getTo != className
  332.         set conn [$cono getSuperiorObjects $OMT_COD_Conn]
  333.  
  334.         set comp [lindex [$cono getComponents] 0]
  335.         set dir  [$comp getPropertyValue msg_direction]
  336.         if { $dir == "forward" } {
  337.         set node [$conn getTo $toType]
  338.         } else {
  339.         set node [$conn getFrom $toType]
  340.         }
  341.         if [lempty $node] {
  342.         continue
  343.         }
  344.         set item [$node getItem]
  345.         if [$item isNil] {
  346.         # exception for cod nodes
  347.         set item [$node getItem 0 name_type cl]
  348.         }
  349.         if ![$item isNil] {
  350.         if {[$item name] == "$className"} {
  351.             lappend result $cono
  352.         }
  353.         }
  354.     }
  355.     }
  356.     return $result
  357. }
  358.  
  359.  
  360. # ----------------------------------------------------------------------
  361. #
  362. #  Class Bag
  363. #
  364. # ----------------------------------------------------------------------
  365.  
  366.  
  367. Class Bag : {Dictionary} {
  368.     constructor
  369.     method destructor
  370.  
  371. # overloaded:
  372.     method set
  373.     method contents
  374.     method exists
  375. }
  376.  
  377.  
  378. constructor Bag {class this} {
  379.     set this [Dictionary::constructor $class $this]
  380.     return $this
  381. }
  382.  
  383.  
  384. method Bag::destructor {this} {
  385.     return [Dictionary::destructor $this]
  386. }
  387.  
  388.  
  389. # Overloaded from Dictionary.
  390. #
  391. method Bag::set {this key {value ""}} {
  392.     # retrieval
  393.     if { $value == "" } {
  394.     if ![$this Dictionary::exists $key] {
  395.         return
  396.     }
  397.     return [[$this Dictionary::set $key] contents]
  398.     }
  399.  
  400.     # append
  401.     if ![$this Dictionary::exists $key] {
  402.     $this Dictionary::set $key [List new]
  403.     }
  404.  
  405.     [$this Dictionary::set $key] append $value
  406. }
  407.  
  408.  
  409. # Overloaded from Dictionary.
  410. #
  411. method Bag::contents {this} {
  412.     $this foreach key valueList {
  413.     lappend result "$key [list [$valueList contents]]"
  414.     }
  415.     return [join $result]
  416. }
  417.  
  418.  
  419. # Overloaded from Dictionary.
  420. #
  421. method Bag::exists {this key {value ""}} {
  422.     if { $value == "" } {
  423.     return [$this Dictionary::exists $key]
  424.     }
  425.  
  426.     if ![$this Dictionary::exists $key] {
  427.     return 0
  428.     }
  429.  
  430.     if { [[$this Dictionary::set $key] search $value] != -1 } {
  431.     return 1
  432.     }
  433.  
  434.     return 0
  435. }
  436.  
  437.  
  438. # ----------------------------------------------------------------------
  439. #
  440. #  Class UniqueBag
  441. #
  442. # ----------------------------------------------------------------------
  443.  
  444.  
  445. Class UniqueBag : {Bag} {
  446.     constructor
  447.  
  448. # overloaded:
  449.     method set
  450. }
  451.  
  452.  
  453. constructor UniqueBag {class this} {
  454.     set this [Bag::constructor $class $this]
  455.     return $this
  456. }
  457.  
  458.  
  459. # Overloaded from Bag. Don't insert duplicates for one key.
  460. #
  461. method UniqueBag::set {this key {value ""}} {
  462.     if { $value != "" } {
  463.     if { [lsearch [$this set $key] $value] != -1 } {
  464.         return ""
  465.     }
  466.     }
  467.  
  468.     return [$this Bag::set $key $value]
  469. }
  470.  
  471.  
  472. # ----------------------------------------------------------------------
  473. #
  474. set executeMe [ReportOperMissing new]
  475.