PC World 1998 October/PCWorld_1998-10_cd.bin/software/prehled/komix/DATA.Z/communications.tcl

Text File | 1997-09-10 | 6.8 KB | 278 lines

#---------------------------------------------------------------------------
#
#    (c) Cadre Technologies Inc. 1995
#
#    File:        @(#)communications.tcl    /main/titanic/7
#    Author:        Harm Leijendeckers
#    Description:    Report on communications
#    Usage in:    SystemVersion, CCD and COD editor
#
#---------------------------------------------------------------------------
# SccsId = @(#)communications.tcl    /main/titanic/7    10 Sep 1997    Copyright 1995 Cadre Technologies Inc.


eval [$cc getCustomFileContents semanticbase tcl reports]


Class ReportCommunications : {SemanticBase} {
    constructor

    method doReport

    method getClasses
    method getEvents
    method objName
    method printEvent
    method printConnector
}


constructor ReportCommunications {class this} {
    set this [SemanticBase::constructor $class $this]
    $this reportName Communications
    return $this
}


method ReportCommunications::getClasses {this model} {

    if [[$this fileV] isNil] {
        if { [lsearch $Options "ccd"] != -1 } {
        set classes "[concat [$model getSMObjects $OMT_CCD_Node]]"
        $this reportName "CCD Communications"
    } else {
        set classes "[concat [$model getSMObjects $OMT_COD_Node]]"
    }
    } else {
    switch [[[$this fileV] file] type] {
            ccd {
        set classes [concat [$model getSMObjects $OMT_CCD_Node]]
        $this reportName "CCD Communications"
        }
        cod {
        set classes [concat [$model getSMObjects $OMT_COD_Node]]
        }
    }
    }
    return $classes
}


method ReportCommunications::getEvents {this class} {
    set eventsSent {}
    set eventsRcvd {}

    switch [[$class getSemType] getFileType] {
    ccd {
        foreach conn [$class getConnectorsOut $OMT_CCD_Message $ANY] {
        lappend eventsSent "$conn 0"
        }
        foreach conn [$class getConnectorsIn  $OMT_CCD_Message $ANY] {
        lappend eventsRcvd "$conn 0"
        }
    }
    cod {
        ## Report the messages sent between objects and actors
        foreach conn [$class getConnectorsIn $OMT_COD_Conn $ANY] {
        set events [$conn getSubordinateObjects \
                        $OMT_COD_Message]
        foreach event $events {
            set comp [lindex [$event getComponents] 0]
            set dir  [$comp getPropertyValue msg_direction]
            if { $dir == "forward" } {
            lappend eventsRcvd "$event 0"
            } else {
            lappend eventsSent "$event 1"
            }
        }
        }
        foreach conn [$class getConnectorsOut $OMT_COD_Conn $ANY] {
        set events [$conn getSubordinateObjects \
                        $OMT_COD_Message]
        foreach event $events {
            set comp [lindex [$event getComponents] 0]
            set dir  [$comp getPropertyValue msg_direction]
            if { $dir == "forward" } {
            lappend eventsSent "$event 0"
            } else {
            lappend eventsRcvd "$event 1"
            }
        }
        }
    }
        default {
        }
    }
    return "[list $eventsSent] [list $eventsRcvd]"
}


method ReportCommunications::doReport {this model} {

    set report [$this report]
    set classes [$this getClasses $model]
    if [lempty $classes] { return 0 }

    # strange sorting because some 'classes' don't have an item (instances).
    set sortedClasses [concat \
    [query "getItem.isNil == 1" $classes] \
    [osort getItem.name [query "getItem.isNil == 0" $classes]]]

    foreach class $sortedClasses {
        set allEvents [$this getEvents $class]
        set eventsSent [lindex $allEvents 0]
        set eventsRcvd [lindex $allEvents 1]

    $report print "[$this objName $class]" line

    if { [lempty $eventsSent] && [lempty $eventsRcvd] } {
            $report print "  ** No communication **" line
            $report line
        continue
    }

    # all events sent
    if ![lempty $eventsSent] {
        $report space 2
        $report print Sends 40
        $report print To 38
        $report print In line
        foreach sentEvent $eventsSent {
                if { [lindex $sentEvent 1] == 1 } {
                    # Swap
            $this printEvent [lindex $sentEvent 0] in
        } else {
            $this printEvent [lindex $sentEvent 0] out
        }
        }
    }

    # all events received
    if ![lempty $eventsRcvd] {
        $report space 2
        $report print Receives 40
        $report print From 38
        $report print In line
        foreach rcvdEvent $eventsRcvd {
                if { [lindex $rcvdEvent 1] == 1 } {
                    # Swap
            $this printEvent [lindex $rcvdEvent 0] out
        } else {
            $this printEvent [lindex $rcvdEvent 0] in
        }
        }
    }

    $report line
    }

    $report page

    return 0
}


method ReportCommunications::objName {this smObj} {
    set type [query -s type $smObj.getComponents]

    set objName ""
    set item [$smObj getItem]
    set qi [ORB::nil]
    if [$item isNil] {
    case $type in {
        instance {
        set item [$smObj getItem 0 name_type de]
        set qi [$smObj getItem 0 name_type cl]
        }
    }
    }

    if ![$item isNil] {
    append objName [$item name]
    if ![$qi isNil] {
        append objName ":"
    }
    }
    if ![$qi isNil] {
    append objName [$qi name]
    }
    if {"$objName" == ""} {
    set objName ?
    }

    return "$objName ($type)"
}


method ReportCommunications::printEvent {this event io} {
    if [$event isA SMConnector] {
    set conn [$event getConnector]
    set items [query $conn.segments.labels.itemRefs.item]
    if [lempty $items] {
        set items [ORB::nil]
    }
    foreach item $items {
        $this printConnector $event $item {} $io
    }
    return
    }

    if [$event isA SMNode] {
    set conn [$event getSuperiorObjects $OMT_COD_Conn]
    $this printConnector $conn [$event getItem] $event $io
    }
}


method ReportCommunications::printConnector {this smConn item event io} {
    set report [$this report]

    set objName ?
    if ![$item isNil] {
    set objName [$item name]
    } elseif ![lempty $event] {
        # No ':' in a messageflow name gives no item!
        set label [$event getLabel]
    if ![$label isNil] { set objName [$label value] }
    }

    set type ""
    if ![lempty $event] {
    set comp [lindex [$event getComponents] 0]
    set type [$comp getPropertyValue msg_type]
        if ![lempty $type] {
             set objName "($type) $objName"
        }
    }

    $report space 4
    $report print $objName 39
    $report space

    case [[$smConn getSemType] getFileType] in {
    ccd {
        if { $io == "in" } {
        set toComp [$smConn getFrom $OMT_CCD_Node]
        } else {
        set toComp [$smConn getTo   $OMT_CCD_Node]
        }
    }
    cod {
        if { $io == "in" } {
        set toComp [$smConn getFrom $OMT_COD_Node]
        } else {
        set toComp [$smConn getTo   $OMT_COD_Node]
        }
    }
    }

    $report print "[$this objName $toComp]" 37
    $report space
    $report print [$this fullFileName [$smConn getDefiningDiagram]] line
}


# ----------------------------------------------------------------------
#
set executeMe [ReportCommunications new]