--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/TimerQueueMonitor.st Thu Nov 14 18:18:14 2019 +0100
@@ -0,0 +1,240 @@
+"
+ 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:]
+ ExternalStreamMonitor open
+"
+! !
+
+!TimerQueueMonitor class methodsFor:'defaults'!
+
+defaultLabel
+ ^ 'External Streams 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:'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|
+
+ time := aTimeout at:'time'.
+ action := aTimeout at:'action'.
+ process := aTimeout at:'process'.
+ sema := aTimeout at:'sema'.
+
+ processName := process isNil ifTrue:[''] ifFalse:[process name].
+ actionName := action isNil ifTrue:[''] ifFalse:[action printString].
+ semaName := sema isNil ifTrue:[''] ifFalse:[sema displayString].
+
+ deltaTime := TimeDuration milliseconds:(time - osTimeStampOfList).
+
+ line := (deltaTime printString) paddedTo:10.
+ line := line , ' ' , ((processName contractTo:40) paddedTo:40).
+ action notNil ifTrue:[
+ line := line , ' ' , ((actionName contractTo:40) paddedTo:40).
+ ] ifFalse:[
+ line := line , ' ' , ((semaName contractTo:40) paddedTo:40).
+ ].
+
+ "/ isOpen ifFalse:[
+ "/ color := Color red.
+ "/ ] ifTrue:[
+ "/ color := Color blue.
+ "/ ].
+ "/ line := line withColor:color.
+
+ list add:line.
+ "/ oldSelection notNil ifTrue:[
+ "/ (oldSelection includesIdentical:aStream) 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
+ ].
+ 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$'
+! !
+