hg/stx-libview: comparison DevWorkst.st

equal deleted inserted replaced

-:2faa1f522096
+:bab0d5f83df3
 "
 !
 version
 "
-$Header: /cvs/stx/stx/libview/Attic/DevWorkst.st,v 1.14 1994-06-03 00:52:26 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/DevWorkst.st,v 1.15 1994-07-30 16:18:23 claus Exp $
 "
 !
 documentation
 "
 metaDown        <Boolean>       true, if meta key (cmd-key) is currently pressed
 altDown         <Boolean>       true, if alt key is currently pressed
 motionEventCompression
-lastId          <Number>	    the id of the last events view (internal)
+lastId          <Number>        the id of the last events view (internal)
-lastView        <View>	    the last events view (internal, for faster id->view mapping)
+lastView        <View>          the last events view (internal, for faster id->view mapping)
 keyboardMap     <KeyBdMap>      mapping for keys
 isSlow          <Boolean>       set/cleared from startup - used to turn off
 things like popup-shadows etc.
 "
 !
 initializeConstants
 "initialize some (soft) constants"
-MultiClickTimeDelta := 300.	      "a click within 300ms is considered a double one"
+MultiClickTimeDelta := 300.       "a click within 300ms is considered a double one"
 ButtonTranslation := #(1 2 3)     "identity translation"
 ! !
 !DeviceWorkstation class methodsFor:'signal access'!
 "reinit after snapin"
 |prevKnownViews prevMapping|
 displayId := nil.
+dispatching := false.
 "/    prevMapping := idToViewMapping.
 "/    idToViewMapping := nil.
 prevKnownViews := knownViews.
 self initializeFor:nil.
 "
 first, all Forms must be recreated
-(since they bay be needed for view recreation as
+(since they may be needed for view recreation as
 background or icons)
 "
 Form reinitializeAllOn:self.
 "/    prevMapping notNil ifTrue:[
 prevKnownViews notNil ifTrue:[
 "
 first round: flush all device specific stuff
 "
-"/	prevMapping keysAndValuesDo:[:anId :aView |
+"/      prevMapping keysAndValuesDo:[:anId :aView |
 prevKnownViews do:[:aView |
 aView notNil ifTrue:[
 aView prepareForReinit
 ]
 ].
 "
 2nd round: all views should reinstall themself
 on the new display
 "
-"/	prevMapping keysAndValuesDo:[:anId :aView |
+"/      prevMapping keysAndValuesDo:[:anId :aView |
 prevKnownViews do:[:aView |
 aView notNil ifTrue:[
 "have to re-create the view"
 aView reinitialize
 ]
 ].
 "
 3rd round: all views get a chance to handle
 changed environment (colors, font sizes etc)
 "
-"/	prevMapping keysAndValuesDo:[:anId :aView |
+"/      prevMapping keysAndValuesDo:[:anId :aView |
 prevKnownViews do:[:aView |
 aView notNil ifTrue:[
 aView reAdjustGeometry
 ]
 ]
 Untranslated keystrokes arrive either as characters, or symbols
 (which are the keySyms as symbol). The mapping table which is
 setup here, is used in sendKeyPress:... later.
 "
-keyboardMap := KeyboardMap new.
+keyboardMap isNil ifTrue:[
+keyboardMap := KeyboardMap new.
+].
 "
 no more setup here - moved everything out into 'display.rc' file
 "
 ! !
 Form allInstances do:[:f |
 f id == id ifTrue:[^ f]
 ].
 self allInstances do:[:aDisplay |
-	aDisplay allViewsDo:[:aView |
+aDisplay allViewsDo:[:aView |
 aView id == id ifTrue:[^ aView].
 aView gcId == id ifTrue:[^ aView]
 ].
 "/        |views|
 "/    idToViewMapping notNil ifTrue:[
 "/        idToViewMapping keysAndValuesDo:[:id :aView |
 "/            aView notNil ifTrue:[
 "/                aBlock value:aView
 "/            ]
-"/	]
+"/      ]
 knownViews notNil ifTrue:[
 knownViews do:[:aView |
 aView notNil ifTrue:[
 aBlock value:aView
 ]
 sendKeyPress:untranslatedKey x:x y:y to:someone
 "forward a key-press event to some handler;
 the key is translated via the translation table here."
-|key xlatedKey|
+|xlatedKey|
-key := untranslatedKey.
+xlatedKey := self translateKey:untranslatedKey.
-controlDown ifTrue:[
-(key size == 1) ifTrue:[   "a single character"
-key := ('Ctrl' , untranslatedKey asString) asSymbol
-]
-].
-metaDown ifTrue:[
-(untranslatedKey isMemberOf:Character) ifTrue:[
-key := ('Cmd' , untranslatedKey asString) asSymbol
-]
-].
-altDown ifTrue:[
-(untranslatedKey isMemberOf:Character) ifTrue:[
-key := ('Alt' , untranslatedKey asString) asSymbol
-]
-].
-xlatedKey := keyboardMap valueFor:key.
 xlatedKey notNil ifTrue:[
 someone delegate notNil ifTrue:[
 someone delegate keyPress:xlatedKey x:x y:y view:someone
 ] ifFalse:[
 someone keyPress:xlatedKey x:x y:y
 ]
 ]
+!
+translateKey:untranslatedKey
+"Return the key translated via the translation table.
+First, the modifier is prepended, making character X into
+AltX, CtrlX or CmdX (on most systems, no separate Cmd (or Meta)
+key exists; on those we always get AltX).
+Then the result is used as a key into the translation keyboardMap
+to get the final return value."
+|xlatedKey|
+xlatedKey := untranslatedKey.
+controlDown ifTrue:[
+(xlatedKey size == 1) ifTrue:[   "a single character"
+xlatedKey := ('Ctrl' , untranslatedKey asString) asSymbol
+].
+].
+metaDown ifTrue:[
+(untranslatedKey isMemberOf:Character) ifTrue:[
+xlatedKey := ('Cmd' , untranslatedKey asString) asSymbol
+]
+].
+altDown ifTrue:[
+(untranslatedKey isMemberOf:Character) ifTrue:[
+xlatedKey := ('Alt' , untranslatedKey asString) asSymbol
+]
+].
+xlatedKey := keyboardMap valueFor:xlatedKey.
+^ xlatedKey
 ! !
 !DeviceWorkstation methodsFor:'private'!
 addKnownView:aView withId:aNumber
-"add the View aView with Id:aNumber to the list of known views/id's"
+"add the View aView with Id:aNumber to the list of known views/id's.
+This map is needed later (on event arrival) to get the view from
+the views id (which is passed along with the devices event) quickly."
 "/    idToViewMapping isNil ifTrue:[
-"/	idToViewMapping := IdentityDictionary new.
+"/      idToViewMapping := IdentityDictionary new.
 "/    ].
 "/    idToViewMapping at:aNumber put:aView.
 knownViews isNil ifTrue:[
-knownViews := OrderedCollection new "(VariableArray new:100) grow:0".
+knownViews := OrderedCollection new:50.
-knownIds := OrderedCollection new "(VariableArray new:100) grow:0"
+knownIds := OrderedCollection new:50.
 ].
 knownViews add:aView.
 knownIds add:aNumber.
 lastView := aView.
 lastId := aNumber
 !
 removeKnownView:aView
-"remove aView from the list of known views/id's"
+"remove aView from the list of known views/id's."
 "/    idToViewMapping removeValue:aView ifAbsent:[].
 "/    lastId := nil.
 "/    lastView := nil
 ]
 ]
 !
 viewFromId:aNumber
-"given an Id, return the corresponding view"
+"given an Id, return the corresponding view."
 |index|
 (aNumber == lastId) ifTrue:[
 ^ lastView
 | id |
 id := (aCursor on:self) id.
 id notNil ifTrue:[
 "/        idToViewMapping notNil ifTrue:[
-"/	    idToViewMapping keysAndValuesDo:[:viewId :view |
+"/          idToViewMapping keysAndValuesDo:[:viewId :view |
-"/	        self setCursor:id in:viewId
+"/              self setCursor:id in:viewId
-"/	    ].
+"/          ].
 knownViews do:[:aView |
 aView id notNil ifTrue:[
 self setCursor:id in:(aView id)
 ]
 ].
 restoreCursors
 "restore the cursors of all views to their current cursor"
 "/    idToViewMapping notNil ifTrue:[
-"/	idToViewMapping keysAndValuesDo:[:viewId :view |
+"/      idToViewMapping keysAndValuesDo:[:viewId :view |
-"/	    |curs cid|
+"/          |curs cid|
-"/	    curs := view cursor.
+"/          curs := view cursor.
-"/	    curs notNil ifTrue:[
+"/          curs notNil ifTrue:[
-"/	        cid := curs id.
+"/              cid := curs id.
-"/		cid notNil ifTrue:[
+"/              cid notNil ifTrue:[
-"/	           self setCursor:cid in:viewId
+"/                 self setCursor:cid in:viewId
-"/		]
+"/              ]
-"/	    ]
+"/          ]
-"/ 	 ].
+"/       ].
 "/       self synchronizeOutput
 "/  ]
 knownViews notNil ifTrue:[
 knownViews do:[:aView |
 !DeviceWorkstation methodsFor:'events'!
 startDispatch
 "create the display dispatch process"
-|sema fd p|
+|inputSema fd p|
 dispatching ifTrue:[^ self].
 dispatching := true.
 fd := self displayFileDescriptor.
 ProcessorScheduler isPureEventDriven ifTrue:[
-"handle all events by having preocessor call a block when something
+"
-arrives on my filedescriptor"
+no threads built in;
+handle all events by having processor call a block when something
+arrives on my filedescriptor
+"
 Processor enableIOAction:[
 dispatching ifTrue:[
 [self eventPending] whileTrue:[
 self dispatchPendingEvents.
 self checkForEndOfDispatch.
 ]
 ]
 on:fd
 ] ifFalse:[
-"handle stuff as a process - sitting on a semaphore.
+"
+handle stuff as a process - sitting on a semaphore.
 Tell Processor to trigger this semaphore when something arrives
-on my filedescriptor"
+on my filedescriptor. Since a select alone is not enough to
+know if events are pending (Xlib reads out event-queue while
-sema := Semaphore new.
+doing output), we also have to install a poll-check block.
+"
+inputSema := Semaphore new.
 p := [
 [dispatching] whileTrue:[
 self eventPending ifFalse:[
-Processor enableSemaphore:sema onInput:fd check:[self eventPending].
+inputSema wait.
-sema wait.
-Processor disableSemaphore:sema
 ].
+"
+in case of an error in the dispatch (i.e. WSensor
+is broken) AND user presses abort in the debugger,
+we want to continue here.
+"
+Object abortSignal catch:[
+self dispatchPendingEvents.
+].
 self dispatchPendingEvents.
 self checkForEndOfDispatch.
 dispatching ifFalse:[
-sema := nil
+Processor disableSemaphore:inputSema.
+inputSema := nil
 ]
 ]
-] forkAt:(Processor userSchedulingPriority).
+] forkAt:(Processor userInterruptPriority).
-p name:'event dispatcher'
+"
+give the process a nice name
+"
+p name:'event dispatcher'.
+Processor signal:inputSema onInput:fd orCheck:[self eventPending].
 ]
 !
 checkForEndOfDispatch
 "return true, if there are still any views of interrest -
 if not, stop dispatch"
 self == Display ifTrue:[
-"/	idToViewMapping isEmpty ifTrue:[
+"/      idToViewMapping isEmpty ifTrue:[
 knownViews isEmpty ifTrue:[
 dispatching := false
 ]
 ]
 !
 !
 dispatchModalWhile:aBlock
 "get and process next event for any view as long as the
 argument-block evaluates to true.
-This is a modal loop, not switching to other processes."
+This is a modal loop, not switching to other processes,
+effectively polling the device in a (nice) busy loop.
+This should only be used for emergency cases.
+(such as a graphical debugger, debugging the event-dispatcher itself)"
+|myFd|
+"
+if this display has a fileDescriptor to wait on,
+it is used; otherwise we poll (with a delay to not lock up
+the workstation)
+"
+myFd := self displayFileDescriptor.
 [aBlock value] whileTrue:[
 self eventPending ifFalse:[
+myFd isNil ifTrue:[
+OperatingSystem millisecondDelay:50
+] ifFalse:[
+OperatingSystem selectOn:myFd withTimeOut:50.
+].
 Processor evaluateTimeouts.
-OperatingSystem millisecondDelay:50.
 ].
-self dispatchEvent
+self eventPending ifTrue:[
-].
+self dispatchEvent
+].
+]
 !
 dispatchEvent
 "get and process next event for any view"
 ! !
 !DeviceWorkstation methodsFor:'bitmap/window creation'!
 createFaxImageFromArray:data width:w height:h type:type k:k msbFirst:msbFirst
-"create a new faxImage in the workstation
+"create a new faxImage in the workstation.
+This is a special interface to servers with the fax-image
+extension (you won't find it in standard X-servers).
 type: 0 -> uncompressed
 1 -> group3 1D (k is void)
 2 -> group3 2D
-3 -> group4 2D (k is void)"
+3 -> group4 2D (k is void)
+"
 ^ nil
 !
 createBitmapWidth:w height:h
 |allFonts families family|
 allFonts := self listOfAvailableFonts.
 allFonts isNil ifTrue:[^ nil].
 families := Set new.
-allFonts do:[:arr |
+allFonts do:[:fntDescr |
-family := arr at:1.
+"/ old:
+"/        family := fntDescr at:1.
+"/ new:
+family := fntDescr family.
 family notNil ifTrue:[
 families add:family
 ]
 ].
 ^ families
-"Display fontFamilies"
+"
+Display fontFamilies
+"
 !
 facesInFamily:aFamilyName
 "return a set of all available font faces in aFamily on this display"
 |allFonts faces family face|
 allFonts := self listOfAvailableFonts.
 allFonts isNil ifTrue:[^ nil].
 faces := Set new.
-allFonts do:[:arr |
+allFonts do:[:fntDescr |
-family := arr at:1.
+"/ old:
-(family = aFamilyName) ifTrue:[
+"/        family := fntDescr at:1.
-face := arr at:2.
+"/        (family = aFamilyName) ifTrue:[
-faces add:face
+"/            face := fntDescr at:2.
+"/            faces add:face
+"/        ]
+"/ new:
+fntDescr family = aFamilyName ifTrue:[
+faces add:(fntDescr face)
 ]
 ].
 ^ faces
-"Display facesInFamily:'times'"
+"
-"Display facesInFamily:'fixed'"
+Display facesInFamily:'times'
+Display facesInFamily:'fixed'
+"
 !
 stylesInFamily:aFamilyName face:aFaceName
 "return a set of all available font styles in aFamily/aFace on this display"
 |allFonts styles family face style|
 allFonts := self listOfAvailableFonts.
 allFonts isNil ifTrue:[^ nil].
 styles := Set new.
-allFonts do:[:arr |
+allFonts do:[:fntDescr |
-family := arr at:1.
+"/ old:
-(family = aFamilyName) ifTrue:[
+"/        family := fntDescr at:1.
-face := arr at:2.
+"/        (family = aFamilyName) ifTrue:[
-(face = aFaceName) ifTrue:[
+"/            face := fntDescr at:2.
-style := arr at:3.
+"/            (face = aFaceName) ifTrue:[
-styles add:style
+"/                style := fntDescr at:3.
+"/                styles add:style
+"/            ]
+"/        ]
+(fntDescr family = aFamilyName) ifTrue:[
+(fntDescr face = aFaceName) ifTrue:[
+styles add:fntDescr style
 ]
 ]
 ].
 ^ styles
-"Display stylesInFamily:'times' face:'medium'"
+"
-"Display stylesInFamily:'times' face:'bold'"
+Display stylesInFamily:'times' face:'medium'
+Display stylesInFamily:'times' face:'bold'
+"
 !
 sizesInFamily:aFamilyName face:aFaceName style:aStyleName
 "return a set of all available font sizes in aFamily/aFace/aStyle
 on this display"
 |allFonts sizes family face style size|
 allFonts := self listOfAvailableFonts.
 allFonts isNil ifTrue:[^ nil].
 sizes := Set new.
-allFonts do:[:arr |
+allFonts do:[:fntDescr |
-family := arr at:1.
+"/        family := fntDescr at:1.
-(family = aFamilyName) ifTrue:[
+"/        (family = aFamilyName) ifTrue:[
-face := arr at:2.
+"/            face := fntDescr at:2.
-(face = aFaceName) ifTrue:[
+"/            (face = aFaceName) ifTrue:[
-style := arr at:3.
+"/                style := fntDescr at:3.
-(style = aStyleName) ifTrue:[
+"/                (style = aStyleName) ifTrue:[
-size := arr at:4.
+"/                    size := fntDescr at:4.
-sizes add:size
+"/                    sizes add:size
+"/                ]
+"/            ]
+"/        ]
+(fntDescr family = aFamilyName) ifTrue:[
+(fntDescr face = aFaceName) ifTrue:[
+(fntDescr style = aStyleName) ifTrue:[
+sizes add:fntDescr size
 ]
 ]
 ]
 ].
 ^ sizes
-"Display sizesInFamily:'times' face:'medium' style:'italic'"
+"
+Display sizesInFamily:'times' face:'medium' style:'italic'
+"
 !
 getFontWithFamily:familyString
 face:faceString
 style:styleString

changeset 51	bab0d5f83df3
parent 46	7b331e9012fd
child 54	29a6b2f8e042