"
COPYRIGHT (c) 1993 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.
"
Object subclass:#DeviceWorkstation
instanceVariableNames:'displayId
visualType monitorType
depth ncells bitsPerRGB
hasColors hasGreyscales
width height widthMM heightMM resolutionHor resolutionVer
idToViewMapping knownViews knownIds knownBitmaps knownBitmapIds
dispatching
controlDown shiftDown metaDown altDown
motionEventCompression
lastId lastView
keyboardMap
isSlow activeGrab
buttonTranslation multiClickTimeDelta'
classVariableNames: 'ButtonTranslation MultiClickTimeDelta
DeviceErrorSignal'
poolDictionaries:''
category:'Interface-Graphics'
!
DeviceWorkstation comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libview/DeviceWorkstation.st,v 1.18 1994-10-10 02:29:56 claus Exp $
'!
!DeviceWorkstation class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1993 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.
"
!
version
"
$Header: /cvs/stx/stx/libview/DeviceWorkstation.st,v 1.18 1994-10-10 02:29:56 claus Exp $
"
!
documentation
"
this abstract class defines common protocol to all Display types.
instance variables:
displayId <Number> the device id of the display
visualType <Symbol> one of #StaticGray, #PseudoColor, ... #TrueColor
monitorType <Symbol> one of #monochrome, #color, #unknown
depth <Integer> bits per color
ncells <Integer> number of colors (i.e. colormap size; not always == 2^depth)
bitsPerRGB <Integer> number of valid bits per rgb component
(actual number taken in A/D converter; not all devices report the true value)
hasColors <Boolean> true, if display supports colors
hasGreyscales <Boolean> true, if display supports grey-scales (i.e is not b/w display)
width <Integer> number of horizontal pixels
height <Integer> number of vertical pixels
heightMM <Number> screen height in millimeter
widthMM <Number> screen width in millimeter
resolutionHor <Number> pixels per horizontal millimeter
resolutionVer <Number> pixels per vertical millimeter
idToViewMapping <Dictionary> maps view-ids to views
knownViews <Collection> all views known
knownIds <Collection> corresponding device-view ids
knownBitmaps <Collection> all known device bitmaps
knownBitmapIds <Collection> corresponding device-bitmap ids
dispatching <Boolean> true, if currently in dispatch loop
controlDown <Boolean> true, if control key currently pressed
shiftDown <Boolean> true, if shift key currently pressed
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)
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.
"
! !
!DeviceWorkstation class methodsFor:'initialization'!
initialize
DeviceErrorSignal isNil ifTrue:[
DeviceErrorSignal := (Signal new) mayProceed:true.
DeviceErrorSignal notifierString:'device error'.
].
!
initializeConstants
"initialize some (soft) constants"
MultiClickTimeDelta := 300. "a click within 300ms is considered a double one"
ButtonTranslation := #(1 2 3) "identity translation"
! !
!DeviceWorkstation class methodsFor:'signal access'!
deviceErrorSignal
"return the signal used for device error reporting"
^ DeviceErrorSignal
! !
!DeviceWorkstation class methodsFor:'accessing'!
buttonTranslation:anArray
"set the button translation, #(1 2 3) is no-translation,
#(3 2 1) is ok for left-handers"
ButtonTranslation := anArray
! !
!DeviceWorkstation methodsFor:'initialize / release'!
initialize
"initialize the receiver for a connection to the default display"
^ self initializeFor:nil
!
initializeFor:aDisplayOrNilForAny
"initialize the receiver for a connection to a display. If the
argument is non-nil, it should specify which workstation should be
connected to (in a device specific manner). For X displays, this is
to be the display-string i.e. hostname:displayNr.
If the argument is nil, connect to the default display."
^ self subclassResponsibility
!
close
"close down connection to Display - usually never done"
^ self subclassResponsibility
!
reinitialize
"reinit after snapin"
|prevKnownViews prevMapping|
displayId := nil.
dispatching := false.
"/ prevMapping := idToViewMapping.
"/ idToViewMapping := nil.
prevKnownViews := knownViews.
knownViews := nil.
knownIds := nil.
self initializeFor:nil.
"
first, all Forms must be recreated
(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 |
prevKnownViews do:[:aView |
aView notNil ifTrue:[
aView prepareForReinit
]
].
"
2nd round: all views should reinstall themself
on the new display
"
"/ 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 |
prevKnownViews do:[:aView |
aView notNil ifTrue:[
aView reAdjustGeometry
]
]
].
dispatching := false.
!
initializeKeyboardMap
"keystrokes from the server are translated via the keyboard map.
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 isNil ifTrue:[
keyboardMap := KeyboardMap new.
].
"
no more setup here - moved everything out into 'display.rc' file
"
! !
!DeviceWorkstation class methodsFor:'error handling'!
resourceIdOfLastError
"return the resource id responsible for the last error"
^ self subclassResponsibility
!
lastError
"return a string describing the last error"
^ self subclassResponsibility
!
errorInterrupt
"x-error interrupt"
|badId badResource msg|
badId := self resourceIdOfLastError.
badId ~~ 0 ifTrue:[
badResource := self resourceOfId:badId.
].
msg := 'Display error: ' , (self lastError).
DeviceErrorSignal isHandled ifFalse:[
msg printNL
] ifTrue:[
^ DeviceErrorSignal
raiseRequestWith:badResource errorString:msg
]
!
resourceOfId:id
"search thru all device stuff for a resource.
Needed for error handling"
Form allInstances do:[:f |
f id == id ifTrue:[^ f]
].
self allInstances do:[:aDisplay |
aDisplay allViewsDo:[:aView |
aView id == id ifTrue:[^ aView].
aView gcId == id ifTrue:[^ aView]
].
"/ |views|
"/ views := aDisplay knownViews.
"/ views notNil ifTrue:[
"/ views do:[:v |
"/ v id == id ifTrue:[^ v].
"/ v gcId == id ifTrue:[^ v]
"/ ].
"/ ].
].
Color allInstances do:[:c |
c colorId == id ifTrue:[^ c]
].
Font allInstances do:[:f |
f fontId == id ifTrue:[^ f]
].
^ nil
! !
!DeviceWorkstation methodsFor:'misc'!
metaDown
"return true, if the meta-key (alt-key on systems without meta)
is currently pressed.
WARNING: obsolete, may vanish. Use protocol in WindowSensor."
^ metaDown
!
altDown
"return true, if the alt-key is currently pressed.
WARNING: obsolete, may vanish. Use protocol in WindowSensor."
^ altDown
!
controlDown
"return true, if the control-key is currently pressed.
WARNING: obsolete, may vanish. Use protocol in WindowSensor."
^ controlDown
!
shiftDown
"return true, if the shift-key is currently pressed.
WARNING: obsolete, may vanish. Use protocol in WindowSensor."
^ shiftDown
!
unBuffered
"make all drawing be sent immediately to the display"
^ self
!
buffered
"buffer drawing - do not send it immediately to the display"
^ self
!
synchronizeOutput
"send all buffered drawing to the display"
^ self
!
compressMotionEvents:aBoolean
"turn on/off motion event compression
- compressions makes always sense except in free-hand drawing of curves"
motionEventCompression := aBoolean
!
hasColors:aBoolean
"set the hasColors flag - needed since some servers dont tell the
truth if a monochrome monitor is connected to a color server"
hasColors := aBoolean
!
hasGreyscales:aBoolean
"set the hasGreyscales flag - can be used to simulate b&w behavior"
hasGreyscales := aBoolean
!
ignoreBackingStore:aBoolean
"if the argument is true, the views backingStore setting will be ignored, and
no backing store used - this can be used on servers where backing store is
very slow (from rc-file)"
^ self
!
isSlow:aBoolean
"set/clear the slow flag"
isSlow := aBoolean
!
beep
"output an audible beep or bell"
Stdout nextPut:(Character bell)
!
setInputFocusTo:aWindowId
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'enumeration'!
allViewsDo:aBlock
"evaluate the argument, aBlock for all known 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
]
]
]
"
View defaultStyle:#iris.
Display allViewsDo:[:v | v initStyle. v redraw]
"
"
View defaultStyle:#next.
Display allViewsDo:[:v | v initStyle. v redraw]
"
"
View defaultStyle:#normal.
Display allViewsDo:[:v | v initStyle. v redraw]
"
! !
!DeviceWorkstation methodsFor:'accessing & queries'!
displayFileDescriptor
"return the file descriptor associated with the display
if any. If there is no underlying filedescriptor, return nil.
(used for event select/polling)"
^ nil
!
serverVendor
"return a string describing the server vendor
- returns a dummy here"
^ 'generic'
!
vendorRelease
"return a workstation release number
- returns a dummy here"
^ 0
!
protocolVersion
"return a protocol version number
- returns a dummy here"
^ 0
!
blackpixel
"return the colorId of black"
^ self subclassResponsibility
!
whitepixel
"return the colorId of white"
^ self subclassResponsibility
!
viewIdFromPoint:aPoint in:windowId
"given a point in rootWindow, return the viewId of the subview of windowId
hit by this coordinate. Return nil if no view was hit.
- use to find window to drop objects after a cross-view drag"
"returning nil here actually makes drag&drop impossible
- could also be reimplemented to make a search over all knownViews here.
This method has to be reimplemented in concrete display classes."
^ nil
!
translatePoint:aPoint from:windowId1 to:windowId2
"given a point in window1, return the coordinate in window2
- use to xlate points from a window to rootwindow"
"This method has to be reimplemented in concrete display classes."
^ self subclassResponsibility
!
viewFromPoint:aPoint
"given a point on the screen, return the ST/X view in which that
point is (this may be a subview). Return nil, if its not an st/X view
or if the point is on the background"
|view id searchId foundId|
searchId := RootView id.
[searchId notNil] whileTrue:[
id := self viewIdFromPoint:aPoint in:searchId.
foundId := searchId.
searchId := id
].
view := self viewFromId:foundId.
^ view
!
id
"return the displayId"
^ displayId
!
ncells
"return the number of usable color cells, the display has
- this is not always the 2 to the power of depth."
^ ncells
"Display ncells"
!
depth
"return the depth in pixels of the display"
^ depth
"Display depth"
!
bitsPerRGB
"return the number of valid bits per rgb component"
^ bitsPerRGB
"Display bitsPerRGB"
!
visualType:aSymbol
"set the visual type. The only situation, where this makes sense,
is with my plasma-display, which ignores the palette and spits out
grey scales, independent of LUT definitions.
(of which the server knows nothing).
So, this should be used from a display-specific startup file only."
visualType := aSymbol.
(visualType == #StaticGray or:[visualType == #GrayScale]) ifTrue:[
hasColors := false
] ifFalse:[
hasColors := true
]
!
visualType
"return a symbol representing the visual type of the display"
^ visualType
"Display visualType"
!
monitorType
"return a symbol representing the monitor type of the display.
It is usually set to #unknown, #color or #monochrome.
But it can be set to any value from the startup file, for later
testing from anywhere. For example the startup for plasma-displays
can set it to #plasma to later influence the colors used in widgets
(indirectly through the resource file)."
^ monitorType
"Display monitorType"
!
monitorType:aSymbol
"set the monitorType - see comment in DeviceWorkstation>>montorType"
monitorType := aSymbol
!
hasColors
"return true, if its a color display"
^ hasColors
"Display hasColors"
!
hasGreyscales
"return true, if this workstation supports greyscales
(also true for color displays)"
^ hasGreyscales
"Display hasGreyscales"
!
hasShape
"return true, if this workstation supports non-rectangular windows"
^ false
!
hasShm
"return true, if this workstation supports shared pixmaps"
^ false
!
hasFax
"return true, if this workstation supports decompression of fax images"
^ false
!
hasDPS
"return true, if this workstation supports postscript output into views"
^ false
!
isSlow
"return true, if this is a relatively slow device -
used to turn off things like popup-shadows"
^ isSlow
!
keyboardMap
"return the keyboard map"
^ keyboardMap
!
keyboardMap:aMap
"set the keyboard map"
keyboardMap := aMap
!
width
"return the width of the display (in pixels)"
^ width
"Display width"
!
height
"return the height of the display (in pixels)"
^ height
"Display height"
!
extent
"return the extent of the display (in pixels)"
^ width @ height
"Display extent"
!
boundingBox
"return a rectangle representing the displays bounding box.
For Smalltalk-80 compatibility"
^ Rectangle origin:(0 @ 0) extent:(width @ height)
!
widthInMillimeter
"return the width in millimeter of the display"
^ widthMM
"Display widthInMillimeter"
!
heightInMillimeter
"return the height in millimeter of the display"
^ heightMM
"Display heightInMillimeter"
!
widthInMillimeter:aNumber
"set the width in millimeter of the display
- needed since some displays do not tell the truth or do not know it"
widthMM := aNumber
!
heightInMillimeter:aNumber
"set the height in millimeter of the display
- needed since some displays do not tell the truth or do not know it"
heightMM := aNumber
!
pixelPerMillimeter
"return the number of horizontal/vertical pixels per millimeter of the display as Point"
^ (width / widthMM) @ (height / heightMM)
"Display pixelPerMillimeter"
!
pixelPerInch
"return the number of horizontal/vertical pixels per inch of the display as Point"
^ ((width / widthMM) @ (height / heightMM)) * 25.4
"Display pixelPerInch"
!
horizontalPixelPerMillimeter
"return the number of horizontal pixels per millimeter of the display"
^ width / widthMM
!
verticalPixelPerMillimeter
"return the number of vertical pixels per millimeter of the display"
^ height / heightMM
!
horizontalPixelPerInch
"return the number of horizontal pixels per inch of the display"
^ (width / widthMM) * 25.4
!
verticalPixelPerInch
"return the number of vertical pixels per inch of the display"
^ (height / heightMM) * 25.4
!
center
"return the centerpoint in pixels of the display"
^ (width // 2) @ (height // 2)
!
knownViews
"return a collection of all known views"
^ knownViews
!
knownViews:aCollection
"set the collection of all known views - take care,
bad use of this will create funny results; use only for snapshot support"
knownViews := aCollection
!
buttonTranslation
^ buttonTranslation
!
multiClickTimeDelta
^ multiClickTimeDelta
!
buttonTranslation:anArray
buttonTranslation := anArray
!
multiClickTimeDelta:milliseconds
multiClickTimeDelta := milliseconds
! !
!DeviceWorkstation methodsFor:'interactive queries'!
pointFromUser
"let user specify a point on the screen"
|curs p|
curs := Cursor crossHair on:self.
self ungrabPointer.
self grabPointerIn:RootView id withCursor:curs id
pointerMode:#async keyboardMode:#sync confineTo:nil.
ActiveGrab := RootView.
[self leftButtonPressed] whileFalse:[].
p := self pointerPosition.
self ungrabPointer.
ActiveGrab := nil.
"flush all events pending on myself"
self disposeEvents.
^ p
"
Display pointFromUser
"
!
rectangleFromUser
"let user specify a rectangle in the screen, return the rectangle"
|curs1 curs2 origin corner newCorner|
curs1 := Cursor origin on:self.
curs2 := Cursor corner on:self.
self ungrabPointer.
self grabPointerIn:RootView id withCursor:curs1 id
pointerMode:#async keyboardMode:#sync confineTo:nil.
ActiveGrab := RootView.
[self leftButtonPressed] whileFalse:[].
origin := self pointerPosition.
self ungrabPointer.
self grabPointerIn:RootView id withCursor:curs1 id
pointerMode:#async keyboardMode:#sync confineTo:nil.
RootView noClipByChildren.
RootView foreground:Color black.
RootView background:Color white.
RootView xoring:[
corner := origin.
RootView displayRectangle:(origin corner:corner).
[self leftButtonPressed] whileTrue:[
newCorner := self pointerPosition.
newCorner ~= corner ifTrue:[
RootView displayRectangle:(origin corner:corner).
self ungrabPointer.
self grabPointerIn:RootView id withCursor:curs2 id
pointerMode:#async keyboardMode:#sync confineTo:nil.
corner := newCorner.
RootView displayRectangle:(origin corner:corner).
self synchronizeOutput.
]
].
RootView displayRectangle:(origin corner:corner).
].
self ungrabPointer.
ActiveGrab := nil.
"flush all events pending on my display"
self disposeEvents.
RootView clipByChildren.
^ origin corner:corner
"
Display rectangleFromUser
"
!
viewFromUser
"let user specify a view on the screen; if the selected view is
not an st/x view, nil is returned.
(send topView to the returned view to get its root-top)"
^ self viewFromPoint:(self pointFromUser)
"
Display viewFromUser
"
"
|v|
v := Display viewFromUser.
v notNil ifTrue:[v topView] ifFalse:[nil]
"
!
topviewFromUser
"let user specify a view on the screen; if the selected view is
not an st/x view, nil is returned.
Otherwise, the topview is returned."
|v|
v := self viewFromUser.
v notNil ifTrue:[
v := v topView
].
^ v
"
Display topviewFromUser
"
! !
!DeviceWorkstation methodsFor:'keyboard mapping'!
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."
|xlatedKey|
xlatedKey := self translateKey:untranslatedKey.
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
]
]
!
sendKeyRelease:untranslatedKey x:x y:y to:someone
"forward a key-release event to some handler;
the key is translated via the translation table here."
|xlatedKey|
xlatedKey := self translateKey:untranslatedKey.
xlatedKey notNil ifTrue:[
someone delegate notNil ifTrue:[
someone delegate keyRelease:xlatedKey x:x y:y view:someone
] ifFalse:[
someone keyRelease: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:'view registration'!
addKnownView:aView withId:aNumber
"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."
|freeIdx newArr sz newSize id|
knownViews isNil ifTrue:[
knownViews := WeakArray new:50. "/ OrderedCollection new:50.
knownViews addDependent:self.
knownIds := Array new:50.
freeIdx := 1.
] ifFalse:[
1 to:knownViews size do:[:idx |
(knownViews at:idx) isNil ifTrue:[
id := knownIds at:idx.
id notNil ifTrue:[
"/ this one is to be destroyed ...
self destroyView:nil withId:id.
knownIds at:idx put:nil.
].
freeIdx := idx
]
].
].
freeIdx isNil ifTrue:[
sz := knownViews size.
newSize := sz * 2.
newArr := WeakArray new:newSize.
newArr replaceFrom:1 to:sz with:knownViews.
knownViews := newArr.
knownViews addDependent:self.
newArr := Array new:newSize.
newArr replaceFrom:1 to:sz with:knownIds.
knownIds := newArr.
freeIdx := sz + 1
].
knownViews at:freeIdx put:aView.
knownIds at:freeIdx put:aNumber.
!
removeKnownView:aView
"remove aView from the list of known views/id's."
|index|
aView isNil ifTrue:[^ self].
"/ idToViewMapping removeValue:aView ifAbsent:[].
"/ lastId := nil.
"/ lastView := nil
knownViews notNil ifTrue:[
index := knownViews identityIndexOf:aView.
index == 0 ifFalse:[
knownViews at:index put:nil.
knownIds at:index put:nil.
lastId := nil.
lastView := nil
]
]
!
viewFromId:aNumber
"given an Id, return the corresponding view."
|index|
"/ ^ idToViewMapping at:aNumber ifAbsent:[nil].
index := knownIds identityIndexOf:aNumber.
index == 0 ifTrue:[^ nil].
^ knownViews at:index.
!
update:something
|id|
something == knownViews ifTrue:[
"
some view was garbage-collected;
destroy it ...
"
1 to:knownViews size do:[:idx |
(knownViews at:idx) isNil ifTrue:[
id := knownIds at:idx.
id notNil ifTrue:[
"/ this one is to be destroyed ...
self destroyView:nil withId:id.
knownIds at:idx put:nil.
].
]
].
]
! !
!DeviceWorkstation methodsFor:'window stuff'!
setCursors:aCursor
"change the cursor of all views to aCursorId"
| id |
id := (aCursor on:self) id.
id notNil ifTrue:[
"/ idToViewMapping notNil ifTrue:[
"/ idToViewMapping keysAndValuesDo:[:viewId :view |
"/ self setCursor:id in:viewId
"/ ].
knownViews do:[:aView |
|vid|
(aView notNil and:[(vid := aView id) notNil]) ifTrue:[
self setCursor:id in:vid
]
].
self synchronizeOutput
"/ ]
]
"Display setCursors:Cursor wait"
"Display restoreCursors"
!
restoreCursors
"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
"/ ]
"/ ]
"/ ].
"/ self synchronizeOutput
"/ ]
knownViews notNil ifTrue:[
knownViews do:[:aView |
|c vid cid|
(aView notNil and:[(vid := aView id) notNil]) ifTrue:[
c := aView cursor.
(c notNil and:[(cid := c id) notNil]) ifTrue:[
self setCursor:cid in:vid
]
]
].
self synchronizeOutput
]
"Display setCursors:(Cursor wait)"
"Display restoreCursors"
! !
!DeviceWorkstation methodsFor:'events'!
startDispatch
"create the display dispatch process"
|inputSema fd p|
dispatching ifTrue:[^ self].
dispatching := true.
fd := self displayFileDescriptor.
ProcessorScheduler isPureEventDriven ifTrue:[
"
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.
].
dispatching ifFalse:[
Processor disableFd:fd
]
]
]
onInput:fd
] ifFalse:[
"
handle stuff as a process - sitting on a semaphore.
Tell Processor to trigger this semaphore when something arrives
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:[
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:[
Processor disableSemaphore:inputSema.
inputSema := nil
]
]
] forkAt:(Processor userInterruptPriority).
"
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:[
knownViews isEmpty ifTrue:[
dispatching := false
]
]
!
dispatchPendingEvents
Object abortSignal catch:[
[self eventPending] whileTrue:[
self dispatchEventFor:nil withMask:nil
]
]
!
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,
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.
].
self eventPending ifTrue:[
self dispatchEvent
].
]
!
dispatchEvent
"get and process next event for any view"
self dispatchEventFor:nil withMask:nil
!
eventMaskFor:anEventSymbol
^ self subclassResponsibility
!
setEventMask:aMask in:aWindowId
^ self subclassResponsibility
!
dispatchEventFor:aViewIdOrNil withMask:eventMask
"central event handling method:
get next event and send appropriate message to the view or the sensor,
if the view has one.
If the argument aViewIdOrNil is nil, events for any view are processed,
otherwise only events for the view with given id are processed
(in this case, nothing is done if no events are pending);
if the argument aMask is nonNil, only events for this eventMask are
handled;"
^ self subclassResponsibility
!
disposeEventsWithMask:aMask for:aWindowId
"dispose (throw away) specific events"
^ self subclassResponsibility
!
disposeEvents
"flush all events pending on this display"
[self eventPending] whileTrue:[
self getEventFor:nil withMask:nil
].
!
eventPending
"return true, if any event is pending"
^ self subclassResponsibility
!
eventPendingWithoutSync
"return true, if any event is pending"
^ self subclassResponsibility
!
eventsPending:anEventMask for:aWindowId
"return true, if any of the masked events is pending"
^ self subclassResponsibility
!
eventPending:anEventSymbol for:aWindowId
"return true, if a specific event is pending"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'bitmap/window creation'!
createFaxImageFromArray:data width:w height:h type:type k:k msbFirst:msbFirst
"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)
"
^ nil
!
createBitmapWidth:w height:h
"allocate a bitmap on the Xserver, the contents is undefined
(i.e. random). Return a bitmap id or nil"
^ self subclassResponsibility
!
createPixmapWidth:w height:h depth:d
"allocate a pixmap on the Xserver, the contents is undefined
(i.e. random). Return a bitmap id or nil"
^ self subclassResponsibility
!
createBitmapFromFile:aString for:aForm
^ self subclassResponsibility
!
createBitmapFromArray:anArray width:w height:h
^ self subclassResponsibility
!
destroyPixmap:aDrawableId
^ self subclassResponsibility
!
destroyFaxImage:aFaxImageId
^ self subclassResponsibility
!
rootWindowFor:aView
^ self subclassResponsibility
!
createWindowFor:aView left:xpos top:ypos width:wwidth height:wheight
^ self subclassResponsibility
!
destroyView:aView withId:aWindowId
^ self subclassResponsibility
!
destroyGC:aGCId
"destroy a GC"
^ self subclassResponsibility
!
gcFor:aDrawableId
"create a GC for drawing into aDrawable"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'font stuff'!
listOfAvailableFonts
"return a list containing all fonts on this display.
The returned list is an array of 4-element arrays, each
containing family, face, style, size and encoding."
self subclassResponsibility
!
fontFamilies
"return a set of all available font families on this display"
|allFonts families family|
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
families := Set new.
allFonts do:[:fntDescr |
"/ old:
"/ family := fntDescr at:1.
"/ new:
family := fntDescr family.
family notNil ifTrue:[
families add:family
]
].
^ families
"
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:[: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'
"
!
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:[: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'
"
!
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:[: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'
"
!
getFontWithFamily:familyString
face:faceString
style:styleString
size:sizeArg
encoding:encodingSym
"try to get the specified font, return id.
If not available, try next smaller font.
If no font fits, return nil"
^ self subclassResponsibility
!
getDefaultFont
"return a default font id
- used when class Font cannot find anything usable"
^ self subclassResponsibility
!
releaseFont:aFontId
"free a font"
^ self subclassResponsibility
!
ascentOf:aFontId
"return the number of pixels above the base line of a font"
^ self subclassResponsibility
!
descentOf:aFontId
"return the number of pixels below the base line of a font"
^ self subclassResponsibility
!
minWidthOfFont:aFontId
"return the width in pixels of the smallest character a specific font"
^ self subclassResponsibility
!
maxWidthOfFont:aFontId
"return the width in pixels of the widest character a specific font"
^ self subclassResponsibility
!
widthOf:aString inFont:aFontId
"return the width in pixels of a string in a specific font"
^ self subclassResponsibility
!
widthOf:aString from:index1 to:index2 inFont:aFontId
"return the width in pixels of a substring in a specific font"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'cursor stuff'!
destroyCursor:aCursorId
"free a cursor"
^ self subclassResponsibility
!
createCursorSourceForm:sourceForm maskForm:maskForm hotX:hx hotY:hy
"create a cursor given 2 bitmaps (source, mask) and a hotspot"
^ self subclassResponsibility
!
createCursorShape:aShape
"create a cursor given a shape-symbol"
^ self subclassResponsibility
!
colorCursor:aCursorId foreground:fgColor background:bgColor
"change a cursors colors"
^ self subclassResponsibility
!
grabKeyboardIn:aWindowId
"grab the keyboard - all keyboard input will be sent to aWindow"
^ self subclassResponsibility
!
ungrabKeyboard
"release the keyboard"
^ self subclassResponsibility
!
grabPointerIn:aWindowId
"grap the pointer"
^ self subclassResponsibility
!
ungrabPointer
"release the pointer"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'color stuff'!
listOfAvailableColors
"return a list of all available colornames;
This method should not be used, since colornames are
very X specific. However, the names defined here are pretty common"
^ #('red' 'green' 'blue' 'yellow' 'magenta' 'cyan' 'white' 'black')
!
freeColor:colorIndex
"free a color on the display, when its no longer needed"
^ self subclassResponsibility
!
colorRed:redVal green:greenVal blue:blueVal
"allocate a color with rgb values (0..100) - return index"
^ self subclassResponsibility
!
colorNamed:aString
"allocate a color with color name - return index.
Colors should not be allocated by name, since most colors
are X specific - get colors by rgb instead."
"support some of them ..."
self getRGBFromName:aString into:[:r :g :b |
^ self colorRed:r green:g blue:b
].
^ nil
!
colorCell
"allocate a color - return index"
^ self subclassResponsibility
!
setColor:index red:redVal green:greenVal blue:blueVal
"change color in map at:index to rgb (0..100)"
^ self subclassResponsibility
!
getRGBFromName:colorName into:aBlock
"get rgb components (0..100) of color named colorName,
and evaluate the 3-arg block, aBlock with them.
The method here only handles some often used colors;
getRGBFromName should not be used, since colorNames other
than those below are X specific."
|idx names triple|
names := #('red' 'green' 'blue' 'yellow' 'magenta' 'cyan' 'white' 'black').
idx := names indexOf:colorName.
idx == 0 ifTrue:[
idx := (names asLowercase) indexOf:colorName.
].
idx == 0 ifFalse:[
triple := #(
(100 0 0) "red"
( 0 100 0) "green"
( 0 0 100) "blue"
(100 100 0) "yellow"
(100 0 100) "magenta"
( 0 100 100) "cyan"
(100 100 100) "white"
( 0 0 0) "black"
) at:idx.
^ aBlock value:(triple at:1)
value:(triple at:2)
value:(triple at:3)
].
^ nil
!
getRGBFrom:index into:aBlock
"get rgb components (0..100) of color in map at:index,
and evaluate the 3-arg block, aBlock with them"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'window stuff'!
setBackingStore:how in:aWindowId
"turn on/off backing-store for a window"
^ self subclassResponsibility
!
setSaveUnder:yesOrNo in:aWindowId
"turn on/off save-under for a window"
^ self subclassResponsibility
!
setWindowBackground:aColorIndex in:aWindowId
"set a windows background color"
^ self subclassResponsibility
!
setWindowBackgroundPixmap:aPixmapId in:aWindowId
"set a windows background pattern to be a form"
^ self subclassResponsibility
!
setWindowBorderColor:aColorIndex in:aWindowId
"set a windows border color"
^ self subclassResponsibility
!
setWindowBorderPixmap:aPixmapId in:aWindowId
"set a windows border pattern"
^ self subclassResponsibility
!
setWindowBorderWidth:aNumber in:aWindowId
"set a windows border width"
^ self subclassResponsibility
!
setWindowBorderShape:aPixmapId in:aWindowId
"set a windows border shape"
^ self subclassResponsibility
!
setWindowShape:aPixmapId in:aWindowId
"set a windows visible shape"
^ self subclassResponsibility
!
setCursor:aCursorId in:aWindowId
"set a windows visible shape"
^ self subclassResponsibility
!
setWindowName:aString in:aWindowId
"set a windows name"
^ self subclassResponsibility
!
setIconName:aString in:aWindowId
"set a windows icon name"
^ self subclassResponsibility
!
setWindowIcon:aForm in:aWindowId
"set a windows icon"
^ self subclassResponsibility
!
setWindowIconWindow:aView in:aWindowId
"set a windows icon window"
^ self subclassResponsibility
!
clearWindow:aWindowId
"clear a windows to its view background"
^ self subclassResponsibility
!
clearRectangleX:x y:y width:width height:height in:aWindowId
"clear a rectangular area of a window to its view background"
^ self subclassResponsibility
!
mapView:aView id:aWindowId iconified:aBoolean atX:xPos y:yPos width:w height:h
^ self subclassResponsibility
!
mapWindow:aWindowId
^ self subclassResponsibility
!
unmapWindow:aWindowId
^ self subclassResponsibility
!
raiseWindow:aWindowId
^ self subclassResponsibility
!
lowerWindow:aWindowId
^ self subclassResponsibility
!
moveWindow:aWindowId x:x y:y
^ self subclassResponsibility
!
resizeWindow:aWindowId width:w height:h
^ self subclassResponsibility
!
moveResizeWindow:aWindowId x:x y:y width:w height:h
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'graphic context stuff'!
setForeground:fgColorIndex in:aGCId
"set foreground color to be drawn with"
^ self subclassResponsibility
!
setBackground:bgColorIndex in:aGCId
"set background color to be drawn with"
^ self subclassResponsibility
!
setForeground:fgColorIndex background:bgColorIndex in:aGCId
"set foreground and background colors to be drawn with"
^ self subclassResponsibility
!
setForeground:fgColor background:bgColor mask:aBitmapId in:aGCId
"set foreground and background colors to be drawn with using mask or
solid (if aBitmapId is nil)"
^ self subclassResponsibility
!
setLineWidth:aNumber style:lineStyle cap:capStyle join:joinStyle in:aGCId
"set line attributes"
^ self subclassResponsibility
!
setForeground:fgColor background:bgColor mask:aBitmapId lineWidth:lw in:aGCId
"set foreground and background colors to be drawn with using mask or
solid (if aBitmapId is nil); also set lineWidth"
^ self subclassResponsibility
!
setFunction:aFunctionSymbol in:aGCId
"set alu function to be drawn with"
^ self subclassResponsibility
!
setFont:aFontId in:aGCId
"set font to be drawn in"
^ self subclassResponsibility
!
setPixmapMask:aPixmapId in:aGCId
"set or clear the drawing mask - a pixmap mask providing full color"
^ self subclassResponsibility
!
setBitmapMask:aBitmapId in:aGCId
"set or clear the drawing mask - a bitmap mask using current fg/bg"
^ self subclassResponsibility
!
setMaskOriginX:orgX y:orgY in:aGCid
"set the mask origin"
^ self subclassResponsibility
!
setClipByChildren:aBool in:aGCId
"enable/disable drawing into child views"
^ self subclassResponsibility
!
noClipIn:aGCId
"disable clipping rectangle"
^ self subclassResponsibility
!
setClipX:clipX y:clipY width:clipWidth height:clipHeight in:aGCId
"clip to a rectangle"
^ self subclassResponsibility
!
setGraphicsExposures:aBoolean in:aGCId
"set or clear the graphics exposures flag"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'retrieving pixels'!
getPixelX:x y:y from:aDrawableId
"return the pixel value at x/y"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'drawing'!
displayString:aString x:x y:y in:aDrawableId with:aGCId round:round opaque:opaque
"draw a string"
^ self subclassResponsibility
!
displayString:aString from:i1 to:i2 x:x y:y in:aDrawableId with:aGCId round:round opaque:opaque
"draw part of a string"
"should be redefined to avoid creation of throw-away string"
self displayString:(aString copyFrom:i1 to:i2)
x:x
y:y
in:aDrawableId
with:aGCId
round:round
opaque:opaque
!
displayString:aString x:x y:y in:aDrawableId with:aGCId
"draw a string - draw foreground only.
If the coordinates are not integers, retry with rounded."
self displayString:aString
x:x
y:y
in:aDrawableId
with:aGCId
round:true
opaque:false
!
displayString:aString from:index1 to:index2 x:x y:y in:aDrawableId with:aGCId
"draw a sub-string - draw foreground only.
If the coordinates are not integers, retry with rounded."
self displayString:aString
from:index1
to:index2
x:x
y:y
in:aDrawableId
with:aGCId
round:true
opaque:false
!
displayOpaqueString:aString x:x y:y in:aDrawableId with:aGCId
"draw a string - draw foreground on background.
If the coordinates are not integers, retry with rounded."
self displayString:aString
x:x
y:y
in:aDrawableId
with:aGCId
round:true
opaque:true
!
displayOpaqueString:aString from:index1 to:index2 x:x y:y in:aDrawableId with:aGCId
"draw a sub-string - draw foreground on background.
If the coordinates are not integers, retry with rounded."
self displayString:aString
from:index1
to:index2
x:x
y:y
in:aDrawableId
with:aGCId
round:true
opaque:true
!
displayPointX:x y:y in:aDrawableId with:aGCId
"draw a point"
^ self subclassResponsibility
!
displayLineFromX:x0 y:y0 toX:x1 y:y1 in:aDrawableId with:aGCId
"draw a line"
"could add a bresenham line drawer here ..."
^ self subclassResponsibility
!
displayRectangleX:x y:y width:width height:height in:aDrawableId with:aGCId
"draw a rectangle"
"should draw four lines here"
^ self subclassResponsibility
!
displayPolygon:aPolygon in:aDrawableId with:aGCId
"draw a polygon"
"should draw the lines here"
^ self subclassResponsibility
!
copyFromFaxImage:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
width:w height:h with:aGCId scaleX:scaleX scaleY:scaleY
"do a bit-blt"
^ self subclassResponsibility
!
copyFromId:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
width:w height:h with:aGCId
"do a bit-blt"
^ self subclassResponsibility
!
copyPlaneFromId:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
width:w height:h with:aGCId
"do a bit-blt"
^ self subclassResponsibility
!
displayArcX:x y:y w:width h:height from:startAngle angle:angle
in:aDrawableId with:aGCId
"draw an arc"
^ self subclassResponsibility
!
fillArcX:x y:y w:width h:height from:startAngle angle:angle
in:aDrawableId with:aGCId
"fill an arc"
^ self subclassResponsibility
!
fillRectangleX:x y:y width:width height:height in:aDrawableId with:aGCId
"fill a rectangle"
^ self subclassResponsibility
!
fillPolygon:aPolygon in:aDrawableId with:aGCId
"fill a polygon"
^ self subclassResponsibility
!
drawBits:imageBits depth:imageDepth width:imageWidth height:imageHeight
x:srcx y:srcy
into:aDrawableId x:dstx y:dsty width:w height:h with:aGCId
"draw a bitimage which has depth id, width iw and height ih into
the drawable. draw a region of w/h pixels from srcx/srcy to dstx/dsty.
It has to be checked elsewhere, that server can do it with the given
depth; also it is assumed, that the colormap is setup correctly"
^ self subclassResponsibility
! !