diff -r 66b523a67429 -r 1cdacb64232c ExternalStreamMonitor.st --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/ExternalStreamMonitor.st Tue Jan 17 00:58:01 2017 +0100 @@ -0,0 +1,511 @@ +" + 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:#ExternalStreamMonitor + instanceVariableNames:'semaphores streams filterOpenStreamsOnlyHolder + filterSocketsOnlyHolder filterConnectedSocketsOnlyHolder' + classVariableNames:'' + poolDictionaries:'' + category:'Monitors-ST/X' +! + +!ExternalStreamMonitor 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 semaphores - a debugging tool. + + [disclaimer:] + this is 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. + + [see also:] + Semaphore SemaphoreSet + Process ProcessorScheduler + WindowGroup + ProcessMonitor + + [author:] + Claus Gittinger + + [start with:] + SemaphoreMonitor open +" +! ! + +!ExternalStreamMonitor class methodsFor:'defaults'! + +defaultLabel + ^ 'External Streams Monitor' + + "Created: 23.1.1997 / 02:52:53 / cg" +! ! + +!ExternalStreamMonitor class methodsFor:'menu specs'! + +filterMenu + "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:ExternalStreamMonitor andSelector:#filterMenu + (Menu new fromLiteralArrayEncoding:(ExternalStreamMonitor filterMenu)) startUp + " + + + + ^ + #(Menu + ( + (MenuItem + label: 'Open Streams Only' + hideMenuOnActivated: false + indication: filterOpenStreamsOnlyHolder + ) + (MenuItem + label: '-' + ) + (MenuItem + label: 'Sockets Only' + hideMenuOnActivated: false + indication: filterSocketsOnlyHolder + ) + (MenuItem + label: 'Connected Sockets Only' + hideMenuOnActivated: false + indication: filterConnectedSocketsOnlyHolder + ) + ) + nil + nil + ) +! + +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:ExternalStreamMonitor andSelector:#mainMenu + (Menu new fromLiteralArrayEncoding:(ExternalStreamMonitor mainMenu)) startUp + " + + + + ^ + #(Menu + ( + (MenuItem + label: 'File' + submenu: + (Menu + ( + (MenuItem + label: 'Exit' + itemValue: closeRequestToTopView + ) + ) + nil + nil + ) + ) + (MenuItem + label: 'Filter' + submenuChannel: filterMenu + ) + ) + nil + nil + ) +! ! + +!ExternalStreamMonitor methodsFor:'aspects'! + +filterConnectedSocketsOnlyHolder + filterConnectedSocketsOnlyHolder isNil ifTrue:[ + filterConnectedSocketsOnlyHolder := false asValue. + filterConnectedSocketsOnlyHolder onChangeSend:#filterConnectedSocketsOnlyHolderChanged to:self. + ]. + ^ filterConnectedSocketsOnlyHolder +! + +filterOpenStreamsOnlyHolder + filterOpenStreamsOnlyHolder isNil ifTrue:[ + filterOpenStreamsOnlyHolder := false asValue. + filterSocketsOnlyHolder onChangeSend:#filterOpenStreamsOnlyHolder to:self. + ]. + ^ filterOpenStreamsOnlyHolder +! + +filterSocketsOnlyHolder + filterSocketsOnlyHolder isNil ifTrue:[ + filterSocketsOnlyHolder := false asValue. + filterSocketsOnlyHolder onChangeSend:#filterSocketsOnlyHolderChanged to:self. + ]. + ^ filterSocketsOnlyHolder +! ! + +!ExternalStreamMonitor methodsFor:'drawing'! + +titleLine + OperatingSystem isMSWINDOWSlike ifTrue:[ + ^ 'Type Global Handle Detail'. + ] ifFalse:[ + ^ 'Type Global FD Detail'. + ]. + + " + ExternalStreamMonitor open + " + + "Modified: / 17.6.1998 / 14:52:48 / cg" +! + +updateList + "update list of semaphores" + + |newList| + + shown ifTrue:[ + newList := ExternalStream allSubInstances. + + self filterSocketsOnlyHolder value ifTrue:[ + newList := newList select:[:eachStream | eachStream isSocket]. + ]. + self filterOpenStreamsOnlyHolder value ifTrue:[ + newList := newList select:[:eachStream | eachStream isOpen]. + ]. + self filterConnectedSocketsOnlyHolder value ifTrue:[ + newList := newList select:[:eachStream | eachStream isSocket and:[eachStream isConnected]]. + ]. + + "sort by hashKey - will not always generate unique numbers, + but most of the time, this works ... for now" + + newList sort:[:s1 :s2 | + s1 className < s2 className + or:[ s1 className = s2 className + and:[false]] + ]. + + newList ~= streams ifTrue:[ + self updateStatus:newList + ]. + ]. + self installDelayedUpdate. +! + +updateStatus:newStreamsList + "update status display of semaphores" + + |oldList list oldSelection newSelection| + + shown ifTrue:[ + oldList := listView list. + oldSelection := listView selection. + oldSelection notNil ifTrue:[ + oldSelection := oldSelection collect:[:lineNr | streams at:(lineNr - self numberOfHeadlines) ]. + newSelection := OrderedCollection new. + ]. + + newStreamsList notNil ifTrue:[ + streams := WeakArray withAll:newStreamsList. + ]. + streams notNil ifTrue:[ + list := OrderedCollection new:(streams size + self numberOfHeadlines). + list add:self titleLine. + list add:(String new:self titleLine size withAll:$-). + + streams validElementsDo:[:aStream | + |waiters waitersNames type globalNameOrNil handleString + isOpen handle detail color line| + +"/ "/ need a copy - it may change while being enumerated +"/ [ +"/ count := aSemaphore count. +"/ waiters := aSemaphore waitingProcesses copy. +"/ ] valueUninterruptably. + +"/ str := '' writeStream. +"/ [ +"/ waiters notNil ifTrue:[ +"/ waiters do:[:aProcess | +"/ str nextPut:$[. +"/ aProcess id printOn:str. +"/ str nextPutAll:' '''. +"/ str nextPutAll:(aProcess name contractTo:40). +"/ str nextPutAll:'''<'. +"/ aProcess priority printOn:str. +"/ str nextPutAll:'>]'. +"/ str space. +"/ ]. +"/ ] +"/ ] valueUninterruptably. +"/ waitersNames := str contents. + +"/ (aSemaphore respondsTo:#name) ifTrue:[ +"/ nm := aSemaphore name. +"/ nm isNil ifTrue:[ +"/ nm := '' +"/ ] +"/ ] ifFalse:[ +"/ nm := '' +"/ ]. + type := aStream className. + + globalNameOrNil := Smalltalk keyAtValue:aStream. + + aStream isFileStream ifTrue:[ + detail := aStream pathName. + ] ifFalse:[ + aStream isSocket ifTrue:[ + aStream getPeer notNil ifTrue:[ + detail := aStream getPeerName printString,aStream getPeer printString. + ] + ] ifFalse:[ + ]. + ]. + + OperatingSystem isMSWINDOWSlike ifTrue:[ + aStream isOpen ifTrue:[ + handle := aStream fileHandle. + handleString := handle address hexPrintString + ]. + handleString := (handleString ? '') leftPaddedTo:7 + ] ifFalse:[ + aStream isOpen ifTrue:[ + handleString := aStream fileDescriptor printString + ]. + handleString := (handleString ? '') leftPaddedTo:3 + ]. + + line := (type contractTo:20) paddedTo:20. + line := line , ' ' , (((globalNameOrNil ? '') contractTo:25) paddedTo:25). + line := line , ' ' , handleString. + line := line , ' ' , (detail ? ''). + + isOpen := aStream isOpen. + +"/ line := line +"/ , ' ' +"/ , ((nm contractTo:25) paddedTo:25) +"/ , ' ' +"/ , (count printStringLeftPaddedTo:3) +"/ , ' ' +"/ , owner printString +"/ , ' ' +"/ , (waiters size printStringLeftPaddedTo:3) +"/ , ' ' +"/ , waitersNames. + + isOpen ifFalse:[ + color := Color red. + ] ifTrue:[ + color := Color blue. + ]. + line := line colorizeAllWith: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 two entries cannot be selected" + listView attributeAt:1 put:#disabled. + listView attributeAt:2 put:#disabled. + ]. + newSelection notNil ifTrue:[ + listView selectWithoutScroll:newSelection + ]. + listView flush + ]. + self installDelayedUpdate. +! ! + +!ExternalStreamMonitor methodsFor:'menu'! + +debugWaiters + "open a debugger on the selected semaphores waiting processes" + + self selectedSemaphoresDo:[:aSema | + aSema waitingProcesses do:[:aProcess | + DebugView openOn:aProcess + ] + ] + + "Modified: / 23.1.1997 / 03:12:06 / cg" + "Created: / 17.6.1998 / 14:56:55 / cg" +! + +inspectSemaphore + "open an inspector on the selected semaphores" + + self selectedSemaphoresDo:[:aSema | aSema inspect] + + "Modified: 23.1.1997 / 03:12:06 / cg" + "Created: 24.1.1997 / 23:11:50 / cg" +! + +inspectStream + "open an inspector on the selected stream(s)" + + self selectedStreamsDo:[:aSema | aSema inspect] +! + +inspectWaiters + "open an inspector on the selected semaphores waiting processes" + + self selectedSemaphoresDo:[:aSema | + aSema waitingProcesses do:[:aProcess | + aProcess inspect + ] + ] + + "Modified: / 23.1.1997 / 03:12:06 / cg" + "Created: / 17.6.1998 / 14:17:41 / cg" +! + +selectedStreamsDo:aBlock + "evaluate aBlock on all selected streams" + + self selectionIndicesDo:[:n | + |nr stream| + + nr := n - self numberOfHeadlines. + nr notNil ifTrue:[ + nr > 0 ifTrue:[ + stream := streams at:nr. + (stream notNil and:[stream ~~ 0]) ifTrue:[ + aBlock value:stream + ] + ] + ] + ]. +! + +statusMenu + "return a popUpMenu" + + + + |labels selectors m| + + labels := resources array:#( + 'Inspect' + 'Inspect Waiters' + 'Debug Waiters' + ). + selectors := #( + inspectStream + inspectWaiters + debugWaiters + ). + + updateProcess isNil ifTrue:[ + labels := (resources array:#('Update' '-')) , labels. + selectors := #(updateView nil) , selectors + ]. + + m := PopUpMenu labels:labels + selectors:selectors. + + + listView hasSelection ifFalse:[ + m disableAll:#( + inspectStream + inspectWaiters + debugWaiters + ) + ]. + ^ m + + "Modified: / 17.6.1998 / 14:17:05 / cg" +! ! + +!ExternalStreamMonitor methodsFor:'queries'! + +numberOfHeadlines + ^ 2 +! ! + +!ExternalStreamMonitor methodsFor:'user actions'! + +doubleClicked + "open an inspector on the selected semaphore" + + self inspectStream + + "Created: 23.1.1997 / 03:22:04 / cg" + "Modified: 31.1.1997 / 22:33:27 / cg" +! + +filterConnectedSocketsOnlyHolderChanged + self sensor pushUserEvent:#updateList for:self +! + +filterOpenStreamsOnlyHolderChanged + self sensor pushUserEvent:#updateList for:self +! + +filterSocketsOnlyHolderChanged + self sensor pushUserEvent:#updateList for:self +! ! + +!ExternalStreamMonitor class methodsFor:'documentation'! + +version + ^ '$Header$' +! + +version_CVS + ^ '$Header$' +! ! +