# HG changeset patch # User claus # Date 775585103 -7200 # Node ID bab0d5f83df3ac8690e8fc52df80c2362fb44f87 # Parent 2faa1f5220969dde73ab9593b105a33e70cfd285 *** empty log message *** diff -r 2faa1f522096 -r bab0d5f83df3 DevWorkst.st --- 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 the id of the last events view (internal) - lastView the last events view (internal, for faster id->view mapping) + lastId the id of the last events view (internal) + lastView the last events view (internal, for faster id->view mapping) keyboardMap mapping for keys isSlow 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 diff -r 2faa1f522096 -r bab0d5f83df3 DeviceWorkstation.st --- 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 the id of the last events view (internal) - lastView the last events view (internal, for faster id->view mapping) + lastId the id of the last events view (internal) + lastView the last events view (internal, for faster id->view mapping) keyboardMap mapping for keys isSlow 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