--- a/DevWorkst.st Tue Jul 19 18:09:13 1994 +0200
+++ b/DevWorkst.st Sat Jul 30 18:18:23 1994 +0200
@@ -52,7 +52,7 @@
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 $
"
!
@@ -94,8 +94,8 @@
motionEventCompression
- lastId <Number> the id of the last events view (internal)
- lastView <View> the last events view (internal, for faster id->view mapping)
+ lastId <Number> the id of the last events view (internal)
+ 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
@@ -115,7 +115,7 @@
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"
! !
@@ -166,6 +166,7 @@
|prevKnownViews prevMapping|
displayId := nil.
+ dispatching := false.
"/ prevMapping := idToViewMapping.
"/ idToViewMapping := nil.
@@ -178,7 +179,7 @@
"
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.
@@ -188,7 +189,7 @@
"
first round: flush all device specific stuff
"
-"/ prevMapping keysAndValuesDo:[:anId :aView |
+"/ prevMapping keysAndValuesDo:[:anId :aView |
prevKnownViews do:[:aView |
aView notNil ifTrue:[
aView prepareForReinit
@@ -199,7 +200,7 @@
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"
@@ -210,7 +211,7 @@
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
@@ -227,7 +228,9 @@
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
@@ -271,7 +274,7 @@
].
self allInstances do:[:aDisplay |
- aDisplay allViewsDo:[:aView |
+ aDisplay allViewsDo:[:aView |
aView id == id ifTrue:[^ aView].
aView gcId == id ifTrue:[^ aView]
].
@@ -399,9 +402,9 @@
"/ aView notNil ifTrue:[
"/ aBlock value:aView
"/ ]
-"/ ]
-
-
+"/ ]
+
+
knownViews notNil ifTrue:[
knownViews do:[:aView |
aView notNil ifTrue:[
@@ -853,27 +856,9 @@
"forward a key-press event to some handler;
the key is translated via the translation table here."
- |key xlatedKey|
+ |xlatedKey|
- key := 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 := self translateKey:untranslatedKey.
xlatedKey notNil ifTrue:[
someone delegate notNil ifTrue:[
someone delegate keyPress:xlatedKey x:x y:y view:someone
@@ -881,21 +866,55 @@
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".
- knownIds := OrderedCollection new "(VariableArray new:100) grow:0"
+ knownViews := OrderedCollection new:50.
+ knownIds := OrderedCollection new:50.
].
knownViews add:aView.
knownIds add:aNumber.
@@ -905,7 +924,7 @@
!
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.
@@ -925,7 +944,7 @@
!
viewFromId:aNumber
- "given an Id, return the corresponding view"
+ "given an Id, return the corresponding view."
|index|
@@ -951,9 +970,9 @@
id := (aCursor on:self) id.
id notNil ifTrue:[
"/ idToViewMapping notNil ifTrue:[
-"/ idToViewMapping keysAndValuesDo:[:viewId :view |
-"/ self setCursor:id in:viewId
-"/ ].
+"/ idToViewMapping keysAndValuesDo:[:viewId :view |
+"/ self setCursor:id in:viewId
+"/ ].
knownViews do:[:aView |
aView id notNil ifTrue:[
self setCursor:id in:(aView id)
@@ -971,16 +990,16 @@
"restore the cursors of all views to their current cursor"
"/ idToViewMapping notNil ifTrue:[
-"/ idToViewMapping keysAndValuesDo:[:viewId :view |
-"/ |curs cid|
-"/ curs := view cursor.
-"/ curs notNil ifTrue:[
-"/ cid := curs id.
-"/ cid notNil ifTrue:[
-"/ self setCursor:cid in:viewId
-"/ ]
-"/ ]
-"/ ].
+"/ idToViewMapping keysAndValuesDo:[:viewId :view |
+"/ |curs cid|
+"/ curs := view cursor.
+"/ curs notNil ifTrue:[
+"/ cid := curs id.
+"/ cid notNil ifTrue:[
+"/ self setCursor:cid in:viewId
+"/ ]
+"/ ]
+"/ ].
"/ self synchronizeOutput
"/ ]
@@ -1006,7 +1025,7 @@
startDispatch
"create the display dispatch process"
- |sema fd p|
+ |inputSema fd p|
dispatching ifTrue:[^ self].
dispatching := true.
@@ -1014,9 +1033,11 @@
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:[
@@ -1031,28 +1052,42 @@
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"
-
- sema := Semaphore new.
+ on my filedescriptor. Since a select alone is not enough to
+ know if events are pending (Xlib reads out event-queue while
+ 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].
- sema wait.
- Processor disableSemaphore:sema
+ inputSema wait.
].
+ "
+ 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).
- p name:'event dispatcher'
+ ] forkAt:(Processor userInterruptPriority).
+ "
+ give the process a nice name
+ "
+ p name:'event dispatcher'.
+ Processor signal:inputSema onInput:fd orCheck:[self eventPending].
]
!
@@ -1061,7 +1096,7 @@
if not, stop dispatch"
self == Display ifTrue:[
-"/ idToViewMapping isEmpty ifTrue:[
+"/ idToViewMapping isEmpty ifTrue:[
knownViews isEmpty ifTrue:[
dispatching := false
]
@@ -1079,15 +1114,32 @@
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
@@ -1158,11 +1210,15 @@
!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
!
@@ -1239,15 +1295,20 @@
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
families := Set new.
- allFonts do:[:arr |
- family := arr at:1.
+ allFonts do:[:fntDescr |
+"/ old:
+"/ family := fntDescr at:1.
+"/ new:
+ family := fntDescr family.
family notNil ifTrue:[
families add:family
]
].
^ families
- "Display fontFamilies"
+ "
+ Display fontFamilies
+ "
!
facesInFamily:aFamilyName
@@ -1257,18 +1318,26 @@
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
+
faces := Set new.
- allFonts do:[:arr |
- family := arr at:1.
- (family = aFamilyName) ifTrue:[
- face := arr at:2.
- faces add:face
+ allFonts do:[:fntDescr |
+"/ old:
+"/ family := fntDescr at:1.
+"/ (family = aFamilyName) ifTrue:[
+"/ 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
@@ -1278,21 +1347,30 @@
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
+
styles := Set new.
- allFonts do:[:arr |
- family := arr at:1.
- (family = aFamilyName) ifTrue:[
- face := arr at:2.
- (face = aFaceName) ifTrue:[
- style := arr at:3.
- styles add:style
+ allFonts do:[:fntDescr |
+"/ old:
+"/ family := fntDescr at:1.
+"/ (family = aFamilyName) ifTrue:[
+"/ face := fntDescr at:2.
+"/ (face = aFaceName) ifTrue:[
+"/ 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
@@ -1303,23 +1381,33 @@
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
+
sizes := Set new.
- allFonts do:[:arr |
- family := arr at:1.
- (family = aFamilyName) ifTrue:[
- face := arr at:2.
- (face = aFaceName) ifTrue:[
- style := arr at:3.
- (style = aStyleName) ifTrue:[
- size := arr at:4.
- sizes add:size
+ allFonts do:[:fntDescr |
+"/ family := fntDescr at:1.
+"/ (family = aFamilyName) ifTrue:[
+"/ face := fntDescr at:2.
+"/ (face = aFaceName) ifTrue:[
+"/ style := fntDescr at:3.
+"/ (style = aStyleName) ifTrue:[
+"/ size := fntDescr at:4.
+"/ 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
--- a/DeviceWorkstation.st Tue Jul 19 18:09:13 1994 +0200
+++ b/DeviceWorkstation.st Sat Jul 30 18:18:23 1994 +0200
@@ -52,7 +52,7 @@
version
"
-$Header: /cvs/stx/stx/libview/DeviceWorkstation.st,v 1.14 1994-06-03 00:52:26 claus Exp $
+$Header: /cvs/stx/stx/libview/DeviceWorkstation.st,v 1.15 1994-07-30 16:18:23 claus Exp $
"
!
@@ -94,8 +94,8 @@
motionEventCompression
- lastId <Number> the id of the last events view (internal)
- lastView <View> the last events view (internal, for faster id->view mapping)
+ lastId <Number> the id of the last events view (internal)
+ 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
@@ -115,7 +115,7 @@
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"
! !
@@ -166,6 +166,7 @@
|prevKnownViews prevMapping|
displayId := nil.
+ dispatching := false.
"/ prevMapping := idToViewMapping.
"/ idToViewMapping := nil.
@@ -178,7 +179,7 @@
"
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.
@@ -188,7 +189,7 @@
"
first round: flush all device specific stuff
"
-"/ prevMapping keysAndValuesDo:[:anId :aView |
+"/ prevMapping keysAndValuesDo:[:anId :aView |
prevKnownViews do:[:aView |
aView notNil ifTrue:[
aView prepareForReinit
@@ -199,7 +200,7 @@
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"
@@ -210,7 +211,7 @@
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
@@ -227,7 +228,9 @@
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
@@ -271,7 +274,7 @@
].
self allInstances do:[:aDisplay |
- aDisplay allViewsDo:[:aView |
+ aDisplay allViewsDo:[:aView |
aView id == id ifTrue:[^ aView].
aView gcId == id ifTrue:[^ aView]
].
@@ -399,9 +402,9 @@
"/ aView notNil ifTrue:[
"/ aBlock value:aView
"/ ]
-"/ ]
-
-
+"/ ]
+
+
knownViews notNil ifTrue:[
knownViews do:[:aView |
aView notNil ifTrue:[
@@ -853,27 +856,9 @@
"forward a key-press event to some handler;
the key is translated via the translation table here."
- |key xlatedKey|
+ |xlatedKey|
- key := 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 := self translateKey:untranslatedKey.
xlatedKey notNil ifTrue:[
someone delegate notNil ifTrue:[
someone delegate keyPress:xlatedKey x:x y:y view:someone
@@ -881,21 +866,55 @@
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".
- knownIds := OrderedCollection new "(VariableArray new:100) grow:0"
+ knownViews := OrderedCollection new:50.
+ knownIds := OrderedCollection new:50.
].
knownViews add:aView.
knownIds add:aNumber.
@@ -905,7 +924,7 @@
!
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.
@@ -925,7 +944,7 @@
!
viewFromId:aNumber
- "given an Id, return the corresponding view"
+ "given an Id, return the corresponding view."
|index|
@@ -951,9 +970,9 @@
id := (aCursor on:self) id.
id notNil ifTrue:[
"/ idToViewMapping notNil ifTrue:[
-"/ idToViewMapping keysAndValuesDo:[:viewId :view |
-"/ self setCursor:id in:viewId
-"/ ].
+"/ idToViewMapping keysAndValuesDo:[:viewId :view |
+"/ self setCursor:id in:viewId
+"/ ].
knownViews do:[:aView |
aView id notNil ifTrue:[
self setCursor:id in:(aView id)
@@ -971,16 +990,16 @@
"restore the cursors of all views to their current cursor"
"/ idToViewMapping notNil ifTrue:[
-"/ idToViewMapping keysAndValuesDo:[:viewId :view |
-"/ |curs cid|
-"/ curs := view cursor.
-"/ curs notNil ifTrue:[
-"/ cid := curs id.
-"/ cid notNil ifTrue:[
-"/ self setCursor:cid in:viewId
-"/ ]
-"/ ]
-"/ ].
+"/ idToViewMapping keysAndValuesDo:[:viewId :view |
+"/ |curs cid|
+"/ curs := view cursor.
+"/ curs notNil ifTrue:[
+"/ cid := curs id.
+"/ cid notNil ifTrue:[
+"/ self setCursor:cid in:viewId
+"/ ]
+"/ ]
+"/ ].
"/ self synchronizeOutput
"/ ]
@@ -1006,7 +1025,7 @@
startDispatch
"create the display dispatch process"
- |sema fd p|
+ |inputSema fd p|
dispatching ifTrue:[^ self].
dispatching := true.
@@ -1014,9 +1033,11 @@
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:[
@@ -1031,28 +1052,42 @@
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"
-
- sema := Semaphore new.
+ on my filedescriptor. Since a select alone is not enough to
+ know if events are pending (Xlib reads out event-queue while
+ 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].
- sema wait.
- Processor disableSemaphore:sema
+ inputSema wait.
].
+ "
+ 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).
- p name:'event dispatcher'
+ ] forkAt:(Processor userInterruptPriority).
+ "
+ give the process a nice name
+ "
+ p name:'event dispatcher'.
+ Processor signal:inputSema onInput:fd orCheck:[self eventPending].
]
!
@@ -1061,7 +1096,7 @@
if not, stop dispatch"
self == Display ifTrue:[
-"/ idToViewMapping isEmpty ifTrue:[
+"/ idToViewMapping isEmpty ifTrue:[
knownViews isEmpty ifTrue:[
dispatching := false
]
@@ -1079,15 +1114,32 @@
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
@@ -1158,11 +1210,15 @@
!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
!
@@ -1239,15 +1295,20 @@
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
families := Set new.
- allFonts do:[:arr |
- family := arr at:1.
+ allFonts do:[:fntDescr |
+"/ old:
+"/ family := fntDescr at:1.
+"/ new:
+ family := fntDescr family.
family notNil ifTrue:[
families add:family
]
].
^ families
- "Display fontFamilies"
+ "
+ Display fontFamilies
+ "
!
facesInFamily:aFamilyName
@@ -1257,18 +1318,26 @@
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
+
faces := Set new.
- allFonts do:[:arr |
- family := arr at:1.
- (family = aFamilyName) ifTrue:[
- face := arr at:2.
- faces add:face
+ allFonts do:[:fntDescr |
+"/ old:
+"/ family := fntDescr at:1.
+"/ (family = aFamilyName) ifTrue:[
+"/ 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
@@ -1278,21 +1347,30 @@
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
+
styles := Set new.
- allFonts do:[:arr |
- family := arr at:1.
- (family = aFamilyName) ifTrue:[
- face := arr at:2.
- (face = aFaceName) ifTrue:[
- style := arr at:3.
- styles add:style
+ allFonts do:[:fntDescr |
+"/ old:
+"/ family := fntDescr at:1.
+"/ (family = aFamilyName) ifTrue:[
+"/ face := fntDescr at:2.
+"/ (face = aFaceName) ifTrue:[
+"/ 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
@@ -1303,23 +1381,33 @@
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
+
sizes := Set new.
- allFonts do:[:arr |
- family := arr at:1.
- (family = aFamilyName) ifTrue:[
- face := arr at:2.
- (face = aFaceName) ifTrue:[
- style := arr at:3.
- (style = aStyleName) ifTrue:[
- size := arr at:4.
- sizes add:size
+ allFonts do:[:fntDescr |
+"/ family := fntDescr at:1.
+"/ (family = aFamilyName) ifTrue:[
+"/ face := fntDescr at:2.
+"/ (face = aFaceName) ifTrue:[
+"/ style := fntDescr at:3.
+"/ (style = aStyleName) ifTrue:[
+"/ size := fntDescr at:4.
+"/ 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