"{ Encoding: utf8 }"

"
 COPYRIGHT (c) 1997 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"
"{ Package: 'stx:libtool' }"

"{ NameSpace: Smalltalk }"

SystemStatusMonitor subclass:#TimerQueueMonitor
	instanceVariableNames:'timeouts showTime'
	classVariableNames:''
	poolDictionaries:''
	category:'Monitors-ST/X'
!

!TimerQueueMonitor class methodsFor:'documentation'!

copyright
"
 COPYRIGHT (c) 1997 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"


!

documentation
"
    This view shows smalltalk's external stream instances - a debugging tool.

    [disclaimer:]
        this is based on one of the oldest tools in the system, written in the early 90's.
        It does in no way reflect the way GUIs are designed/written these days.
        However, after all those years, they are still very very useful (and not found in many other systems)  
        
    [see also:]
        Stream ExternalStream
        WindowGroup
        ProcessMonitor
        SemaphoreMonitor OSProcessMonitor

    [author:]
        Claus Gittinger

    [start with:]
        TimerQueueMonitor open
"
! !

!TimerQueueMonitor class methodsFor:'defaults'!

defaultLabel
    ^ 'TimerQueue Monitor'

    "Created: 23.1.1997 / 02:52:53 / cg"
! !

!TimerQueueMonitor class methodsFor:'menu specs'!

mainMenu
    "This resource specification was automatically generated
     by the MenuEditor of ST/X."

    "Do not manually edit this!! If it is corrupted,
     the MenuEditor may not be able to read the specification."


    "
     MenuEditor new openOnClass:TimerQueueMonitor andSelector:#mainMenu
     (Menu new fromLiteralArrayEncoding:(TimerQueueMonitor mainMenu)) startUp
    "

    <resource: #menu>

    ^ 
     #(Menu 
       (MenuItem
          label: 'File'
          submenuChannel: fileMenu
       ) 
       (MenuItem
          label: 'View'
          submenuChannel: viewMenu
       )
     )
! !

!TimerQueueMonitor methodsFor:'initialization'!

initialize
    super initialize.
    showTime := true.
! !

!TimerQueueMonitor methodsFor:'menu'!

browseAction
    self selectedEntriesDo:[:entry |
        |action|

        (action := entry at:'action' ifAbsent:[nil]) notNil ifTrue:[
            |home mthd|

            (home := action home) notNil ifTrue:[
                (mthd := home method) notNil ifTrue:[      
                    SystemBrowser default openInClass:mthd mclass selector:mthd selector
                ]
            ]
        ]
    ]
!

debugProcess
    self selectedEntriesDo:[:entry |
        |process sema|

        (process := entry at:'process' ifAbsent:[nil]) isNil ifTrue:[
            (sema := entry at:'sema' ifAbsent:[nil]) notNil ifTrue:[
                process := sema waitingProcesses firstIfEmpty:nil
            ]
        ].
        process notNil ifTrue:[
            Debugger openOn:process
        ]
    ]
!

inspectProcess
    self selectedEntriesDo:[:entry |
        |process|

        (process := entry at:'process' ifAbsent:[nil]) notNil ifTrue:[
            process inspect.
        ]
    ]
!

inspectSemaphore
    self selectedEntriesDo:[:entry |
        |sema|

        (sema := entry at:'sema' ifAbsent:[nil]) notNil ifTrue:[
            sema inspect.
        ]
    ]
!

selectedEntriesDo:aBlock
    |t sel|

    [
        t := timeouts copy.
        sel := listView selection
    ] valueUninterruptably.

    (sel ? #()) do:[:eachIndex |
        |entry|

        entry := t at:(eachIndex - self numberOfHeadlines) ifAbsent:[nil].
        aBlock value:entry
    ]
!

statusMenu
    "return a popUpMenu"

    <resource: #programMenu>

    |labels selectors m|

    labels := resources array:#(
                         'Inspect Semaphore'
                         'Inspect Process'
                         '-'
                         'Debug Process'
                         'Browse Action'
                        ).
    selectors := #(
                         inspectSemaphore
                         inspectProcess
                         nil
                         debugProcess
                         browseAction
                        ).

    m := PopUpMenu labels:labels
                   selectors:selectors.


    listView hasSelection ifFalse:[
        m disableAll:#(
                         inspectSemaphore
                         inspectProcess
                         debugProcess
                         browseAction
                      )
    ].
    ^ m

    "Modified: / 17-06-1998 / 14:17:05 / cg"
    "Modified: / 23-02-2017 / 15:18:50 / stefan"
! !

!TimerQueueMonitor methodsFor:'queries'!

numberOfHeadlines
    ^ 2 + (showTime == true ifTrue:1 ifFalse:0)

    "Modified: / 29-10-2018 / 15:24:14 / Claus Gittinger"
! !

!TimerQueueMonitor methodsFor:'updating'!

titleLine
    ^ 'When        Process                                  Action/Semaphore'.
    
    "
     TimeQueueMonitor open
    "
!

updateList
    "update list of timeouts"

    |newInfo t list|

    shown ifTrue:[
        newInfo := Processor timeoutList.
        self updateStatus:newInfo
    ].
    self installDelayedUpdate.

    "Modified: / 29-10-2018 / 15:39:43 / Claus Gittinger"
!

updateStatus:newInfo
    "update status display of timeouts"

    |numberOfHeadlines newTimeoutList oldList list 
     oldSelection newSelection osTimeStampOfList|

    newInfo isNil ifTrue:[^ self].

    shown ifTrue:[
        osTimeStampOfList := newInfo first.
        newTimeoutList := newInfo second.
        newTimeoutList sort:[:t1 :t2 | (t1 at:'time') < (t2 at:'time') ].

        numberOfHeadlines := self numberOfHeadlines.
        oldList := listView list.

        oldSelection := listView selection.
        oldSelection notNil ifTrue:[
            oldSelection := oldSelection 
                                select:[:lNr | lNr > numberOfHeadlines]
                                thenCollect:[:lineNr | 
                                    timeouts at:(lineNr - numberOfHeadlines) ifAbsent:nil 
                                ].
            newSelection := OrderedCollection new.
        ].

        list := OrderedCollection new:(newTimeoutList size + numberOfHeadlines).
        (showTime == true) ifTrue:[
            list add:'Time: ',(Time now printString).
        ].
        list add:self titleLine.
        list add:(String new:(self titleLine size+20) withAll:$-).

        newTimeoutList notNil ifTrue:[
            newTimeoutList do:[:aTimeout |
                |time process processName action actionName sema semaName deltaTime
                 color line millis|

                time := aTimeout at:'time'.
                action := aTimeout at:'action'.
                process := aTimeout at:'process'.
                sema := aTimeout at:'sema'.

                process isNil ifTrue:[
                    sema notNil ifTrue:[
                        process := sema waitingProcesses firstIfEmpty:nil
                    ]
                ].

                processName := process isNil ifTrue:[''] ifFalse:[process name].
                actionName := action isNil ifTrue:[''] ifFalse:[action printString].
                semaName := sema isNil ifTrue:[''] ifFalse:[sema displayString].

                millis := (time - osTimeStampOfList).
                millis > 1000 ifTrue:[
                    millis > 2000 ifTrue:[
                        millis > 5000 ifTrue:[
                            millis := millis roundTo:500.
                        ] ifFalse:[
                            millis := millis roundTo:100.
                        ]
                    ] ifFalse:[
                        millis := millis roundTo:10
                    ].
                ].
                deltaTime := TimeDuration milliseconds:millis.

                line := (deltaTime printString) paddedTo:11.
                line := line , ' ' , ((processName contractTo:40) paddedTo:40).
                action notNil ifTrue:[
                    line := line , ' ' , (actionName contractTo:50) .
                ] ifFalse:[
                    line := line , ' ' , (semaName contractTo:50).
                ].

    "/            isOpen ifFalse:[
    "/                color := Color red.
    "/            ] ifTrue:[
    "/                color := Color blue.
    "/            ].
    "/            line := line withColor:color.

                list add:line.
                oldSelection notNil ifTrue:[
                    (oldSelection contains:[:tmo | 
                                    (tmo at:'process') == process
                                      and:[ (tmo at:'action') == action
                                      and:[ (tmo at:'sema') == sema ]]]
                    ) ifTrue:[
                        newSelection add:list size.
                    ]
                ]
            ].
        ].

        "avoid flicker"
        (oldList notNil and:[oldList size == list size]) ifTrue:[
            list keysAndValuesDo:[:idx :entry |
                (oldList at:idx) ~= entry ifTrue:[
                    listView at:idx put:entry
                ]
            ]
        ] ifFalse:[
            listView setList:list.
            "the first few entries cannot be selected"
            1 to:numberOfHeadlines do:[:lNr | listView attributeAt:lNr put:#disabled].
        ].
        newSelection notNil ifTrue:[
            listView selectWithoutScroll:newSelection
        ].
        listView flush.
        timeouts := newTimeoutList.
    ].
    self installDelayedUpdate.

    "Modified: / 11-10-2017 / 13:56:14 / cg"
    "Modified: / 07-06-2019 / 22:10:36 / Claus Gittinger"
! !

!TimerQueueMonitor class methodsFor:'documentation'!

version_CVS
    ^ '$Header$'
! !