.
"
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 dispatchProcess
ctrlDown shiftDown metaDown altDown
motionEventCompression
lastId lastView
keyboardMap rootView
isSlow
activeKeyboardGrab activePointerGrab
buttonTranslation multiClickTimeDelta'
classVariableNames: 'ButtonTranslation MultiClickTimeDelta
DeviceErrorSignal
DefaultScreen AllScreens'
poolDictionaries:''
category:'Interface-Graphics'
!
DeviceWorkstation comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libview/Attic/DevWorkst.st,v 1.38 1995-06-06 04:06:28 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/Attic/DevWorkst.st,v 1.38 1995-06-06 04:06:28 claus Exp $
"
!
documentation
"
this abstract class defines common protocol to all Display types.
For compatibility with ST-80, this class (or a subclass) is also
bound to the global Screen.
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
ctrlDown <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
<Boolean> if true motion events are compressed
(obsolete: now done in sensor)
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
rootView <DisplayRootView> this displays root window
isSlow <Boolean> set/cleared from startup - used to turn off
things like popup-shadows etc.
"
!
workstationDevices
"
In ST/X, all interaction with the graphics device is done through
an instance of (a subclass) of DeviceWorkstation.
Every view has a reference to the device it has been created on in
its device instance variable.
One particular device instance is bound to the global variable Display:
this is the default graphics display, on which new views are created
(however, provisions exist for multi-display operation)
Currently, there is are only two classes (released to the public):
XWorkstation - a plain X window interface
GLXWorkstation - an X window interface with a GL (3D graphic library)
extension; either simulated (VGL) or a real GL
(real GL is only available on SGI machines)
An experimental version for a NeXTStep interface exists, but is currently
no longer maintained and not released.
Also, interfaces for other graphic systems (i.e. OS/2 and Windows) are
planned for and will be available (hopefully) in late 95.
DeviceWorkstation itself is an abstract class; the methods as defined
here perform things which are common to all graphic devices or block
methods and raise a subclassResponsibilty error condition.
To create a new graphic interface, at least the subclassResponsibilty-methods
have to be reimplemented in a concrete subclass.
In theory, ST/X is designed to allow the use of multiple workstation
devices in parallel; for example, in X, it is possible to create another
instance of XWorkstation, start a dispatch process for it, and to create and
open views on this display. However, (currently) some mechanisms are badly
implemented and therefore, things do not work fully satisfying.
(for example, popUpMenus are currently opened on the workstation which is
bound to the global variable 'Display' - independent of the active
windowgroups display.)
These bugs will be fixed and fully working multi-display operation can be
expected for one of the next releases.
If you want to experiment with multi-display applications,
you have to:
- create a new instance of XWorkstation:
Smalltalk at:#Display2 put:(XWorkstation new).
- have it connect to the display (i.e. the xServer):
(replace 'porty' below with the name of your display)
Display2 := Display2 initializeFor:'porty:0.0'
returns nil, if connection is refused
- leaving you with Display2==nil in this case.
- start an event dispatcher process for it:
Display2 startDispatch
- optionally set its keyboard map
(since this is usually done for Display in the startup-file,
the new display does not have all your added key bindings)
Display2 keyboardMap:(Display keyboardMap)
- create a view for it:
(FileBrowser onDevice:Display2) open
(Workspace onDevice:Display2) open
(Launcher onDevice:Display2) open
NewLauncher openOnDevice:Display2
--> does not work, since ApplicationModel is not prepared
to open views on other devices. (and may never be, since
it was written for ST-80 compatibility, which seems not to
support this.)
To do the above, try:
Smalltalk at:#OldDisplay put:Display.
Display := Display2.
NewLauncher open.
Display := OldDisplay.
Consider this is an ugly kludge ...
However, as mentioned above, there are a few places, where the default
display 'Display' is still hard-coded. But, beside from this (little bug ;-),
remote display operation works pretty well. If you write your application to
work around those (to-be-fixed) bugs, multi-display applications are
even possible in the current release. (avoid popUps and use simple buttons
only).
Things are being changed to introduce the concept of a 'current' display,
which is the device on which the current windowGroup has its topView.
All places in the system whit explicit accesses to Display will be changed
to use 'Screen current' instead. Especially, this will create popups and
modalBoxes on the display of the active windowGroup.
There is no easy solution for things like Notifiers, WarnBoxes or
Debuggers when opened from some background or non-view process.
These will come up one the default Display, as returned by 'Screen default'.
Late note: the above has been mostly fixed, multidisplay applications
work pretty well. However, there are still some problems to be expected,
if the screens have different display capabilities (b&w vs. greyscale vs.
color display). The current styleSheet approach keeps default values
only once (it should do so per display ...) For now, expect ugly looking
views in this case - or set your styleSheet for the smallest common
capabilities (i.e. for b&w).
"
!
events
"
All events are processed in a workstations dispatchEvent method.
There, incoming events are first sent to itself, for a first (view independent)
preprocessing. For example, the devices state of the shift-, alt-, control and
meta keys are updated there. After that, the event is forwarded either to
the views sensor or to the view directly (if it has no sensor).
(Sensorless views are a leftover from ancient times and will sooner or
later vanish - simplifying things a bit. Do not depend on views without
sensors to work correctly in future versions.)
This event processing is done by the event dispatcher process, which is
launched in ST/X's startup sequence (see Smalltalk>>start).
Event processing is done at a high priority, to allow keyboad processing
and CTRL-C handling to be performed even while other processes are running.
The code executed by thr event process is found in startDispatch.
Individual events can be enabled or disabled. The ones that are enabled
by default are:
keypress / keyRelease
buttonPress / buttonRelease / buttonMotion (i.e. motion with button pressed)
pointerEnter / pointerLeave
other events have to be enabled by sending a corresponding #enableXXXEvent
message to the view which shall receive those events.
For example, pointerMotion events (i.e. motion without button being pressed)
are enable by: 'aView enableMotionEvent'
The above is only of interrest, if you write your own widget classes,
existing widgets set things as required in their #initEvents method.
"
! !
!DeviceWorkstation class methodsFor:'initialization'!
initialize
DeviceErrorSignal isNil ifTrue:[
DeviceErrorSignal := (Signal new) mayProceed:true.
DeviceErrorSignal notifierString:'device error'.
].
self initializeConstants.
!
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 constants'!
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.
Display notNil ifTrue:[
Display 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.
dispatchProcess := nil.
"/ 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:'queries'!
platformName
"ST-80 compatibility.
Return a string describing the display systems platform.
Returns a dummy here. This method is redefined in concrete classes."
^ 'unknown'
!
default
"ST-80 compatibility.
Return the default screen"
^ DefaultScreen
"
Screen default
"
!
default:aDevice
"Set the default screen. This is sent very early during startup,
and assigns the first opened screenDevice to both Display and the default
screen. Use of the global Display should vanish over time."
DefaultScreen := aDevice
!
current
"EXPERIMENTAL: this should return the currently active screen,
that is, the device of the currently executing windowGroup.
It will be used in multi-display operation, to launch views on
the correct device - even if not specified explicitely.
This does not yet work fully satisfying ..."
|wg tops v dev|
"
be careful, to not run into an error in case
the current windowGroup got corrupted somehow ...
"
(wg := WindowGroup activeGroup) notNil ifTrue:[
"
ok, not a background process or scheduler ...
"
(tops := wg topViews) notNil ifTrue:[
tops isEmpty ifFalse:[
(v := tops first) notNil ifTrue:[
"
ok, it has a view ...
"
(dev := v device) notNil ifTrue:[
^ dev
]
]
]
]
].
"
in all other cases, return the default display
"
^ Display
"
Screen current
"
! !
!DeviceWorkstation class methodsFor:'error handling'!
resourceIdOfLastError
"return the resource id responsible for the last error"
^ self subclassResponsibility
!
lastErrorString
"return a string describing the last error"
^ self subclassResponsibility
!
errorInterrupt:errID
"DisplayError interrupt.
This is invoked via
XError->errorInterrupt:#DisplayError->registeredErrorInterruptHandlers
looks if a signal handler for DeviceErrorSignal is present,
and - if so raises the signal. If the signal not handled, simply output a
message and continue.
This allows for non disrupted error reporting OR to catch and
investigate errors as required."
|badId badResource msg|
badId := self resourceIdOfLastError.
badId ~~ 0 ifTrue:[
badResource := self resourceOfId:badId.
].
msg := 'Display error: ' , (self lastErrorString).
DeviceErrorSignal isHandled ifFalse:[
msg errorPrintNL.
^ self
].
^ 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."
^ metaDown
!
altDown
"return true, if the alt-key is currently pressed."
^ altDown
!
ctrlDown
"return true, if the control-key is currently pressed."
^ ctrlDown
!
shiftDown
"return true, if the shift-key is currently pressed."
^ shiftDown
!
unBuffered
"make all drawing be sent immediately to the display.
This may horribly slow down your drawings, but will result
in any errors to be delivered right after the bad operation
(in X only). Only useful for debugging."
^ self
!
buffered
"buffer drawing - do not send it immediately to the display.
This is the default; see comment in #unBuffered."
^ self
!
flush
"send all buffered drawing to the display.
This used to be called #synchronizeOutput, but has been renamed
for ST-80 compatibility."
^ self
!
sync
"for ST-80 compatibility"
self flush
!
synchronizeOutput
"send all buffered drawing to the display.
OBSOLETE: please use #flush for ST-80 compatibility."
self obsoleteMethodWarning:'use #flush'.
^ self flush
!
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.
Clearing the hasColors flag in the rc file will force use of grey
colors (which might make a difference, since some colors are hard to
distinguish on a greyscale monitor)."
hasColors := aBoolean
!
hasGreyscales:aBoolean
"set the hasGreyscales flag - can be used to simulate b&w behavior
on greyScale and color monitors.
(You may want to check if your application looks ok if displayed on
a b&w monitor - even if you have a color display. To do so, clear
the hasGreyscales flag from your .rc file)"
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.
The slow-flag has no semantic meaning by itself;
however, it can be set via the display.rc file and tested at various
other places to turn off some bells&whistles which might slow down
the drawing. For example, shadows under popUps are suppressed if isSlow
is set."
isSlow := aBoolean
!
beep
"output an audible beep or bell"
Stdout nextPut:(Character bell)
!
ringBell
"alias for beep; for ST-80 compatibility"
self beep
!
setInputFocusTo:aWindowId
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'enumerating'!
allViewsDo:aBlock
"evaluate the argument, aBlock for all of my 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:'printing & storing'!
printOn:aStream
"for your convenience, add the name of the display connection
or 'default' to the printed representation."
|name|
super printOn:aStream.
aStream nextPut:$(.
(name := self displayName) isNil ifTrue:[
name := 'defaultDisplay'
].
aStream nextPutAll:name.
aStream nextPut:$)
! !
!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
!
displayName
"return the display name - that is the name of the display connection
or nil, for default display. For example, in X, this returns a string
like 'hostname:0' for remote connections, and nil for a default local
connection.
- nothing known here, but maybe redefined in subclasses."
^ nil
"
Display displayName
"
!
platformName
"return a string describing the display systems platform.
Returns a dummy here."
^ self class platformName
"
Display platformName
"
!
serverVendor
"return a string describing the display systems server vendor.
Returns a dummy here"
^ 'generic'
"
Display serverVendor
"
!
vendorRelease
"return the display systems release number.
Returns a dummy here."
^ 0
!
protocolVersion
"return the display systems 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 (defined by its id), return the coordinate of
aPoint in window2 (defined by its id).
Use to xlate points from a window to rootwindow, mainly for rubber-line
drawing on the displays root window."
"This method has to be reimplemented in concrete display classes."
^ self subclassResponsibility
"
|v p root|
v := View new.
v openAndWait.
root := v device rootView.
p := v device translatePoint:10@10 from:(v id) to:(root id).
root clippedByChildren:false.
root displayLineFrom:0@0 to:p.
root clippedByChildren:true.
"
"
|v1 v2 p1 p2 root|
v1 := View new.
v1 openAndWait.
v2 := View new.
v2 openAndWait.
root := v1 device rootView.
p1 := v1 device translatePoint:10@10 from:(v1 id) to:(root id).
p2 := v1 device translatePoint:10@10 from:(v2 id) to:(root id).
root clippedByChildren:false.
root displayLineFrom:p1 to:p2.
root clippedByChildren:true.
"
!
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 := self rootWindowId.
[searchId notNil] whileTrue:[
id := self viewIdFromPoint:aPoint in:searchId.
foundId := searchId.
searchId := id
].
view := self viewFromId:foundId.
^ view
!
windowAt:aPoint
"alias for viewFromPoint: - ST-80 compatibility"
^ self viewFromPoint:aPoint
!
id
"return the displayId"
^ displayId
!
ncells
"return the number of usable color cells, the display has
- this is not always 2 to the power of depth
(for example, on 6bit displays, ncells is 64 while depth is 8)"
^ 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.
Currently, assume that r/g/b all have the same precision,
which is a stupid assumption (there may be some, where less
resolution is available in the blue component).
Therefore, this may be changed to return a 3-element vector."
^ bitsPerRGB
"
Display bitsPerRGB
"
!
visualType:aSymbol
"set the visual type.
The only situation, where setting the visual makes sense,
is with my plasma-display, which ignores the palette and spits out
grey scales, independent of color 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
!
supportsDeepIcons
"return true, if this device supports non b&w (i.e. greyScale
or colored icons). We really dont know here."
"This method has to be reimplemented in concrete display classes."
^ self subclassResponsibility
!
supportsViewGravity
"return true, if this device supports gravity attributes.
We do not depend on the being implemented, but some resizing operations
are faster, it is is."
"This method should to be reimplemented in concrete display classes."
^ false
!
keyboardMap
"return the keyboard map"
^ keyboardMap
!
keyboardMap:aMap
"set the keyboard map"
keyboardMap := aMap
!
dispatchProcess
^ dispatchProcess
!
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
"
!
bounds
"return a rectangle representing the displays bounding box.
For Smalltalk-80 4.x compatibility"
^ Rectangle origin:(0 @ 0) extent:(width @ height)
"
Screen default bounds
"
"/ thats the same as:
"
Display bounds
"
!
boundingBox
"return a rectangle representing the displays bounding box.
For Smalltalk-80 2.x compatibility"
^ self bounds
!
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
!
buttonTranslation:anArray
buttonTranslation := anArray
!
buttonMotionMask:aMask includesButton:aButton
"given a device button mask, return true if a logical button
(1 .. 3 for left .. right) is included."
|buttonNr|
"reverse buttonTranslation"
buttonTranslation notNil ifTrue:[
buttonNr := buttonTranslation indexOf:aButton ifAbsent:[1].
] ifFalse:[
buttonNr := aButton.
].
^ (aMask bitTest:(self buttonMotionMask:buttonNr))
!
multiClickTimeDelta
^ multiClickTimeDelta
!
multiClickTimeDelta:milliseconds
multiClickTimeDelta := milliseconds
! !
!DeviceWorkstation methodsFor:'pointer queries'!
rootPositionOfLastEvent
"return the position in root-window coordinates
of the last button, key or pointer event.
Must be redefined by concrete subclasses."
^ self subclassResponsibility
!
pointerPosition
"return the current pointer position in root-window coordinates.
Must be redefined by concrete subclasses."
^ self subclassResponsibility
!
buttonStates
"return an integer representing the state of the pointer buttons;
a one-bit represents a pressed button. The bit positions are device specific
and to be returned by the *ButtonStateMask methods.
Must be redefined by concrete subclasses."
^ self subclassResponsibility
!
leftButtonStateMask
"return an integer for masking out the left button from a
buttonStates value. This is very device specific and to
be redefined by concrete subclasses."
^ self subclassResponsibility
!
middleButtonStateMask
"return an integer for masking out the middle button from a
buttonStates value. This is very device specific and to
be redefined by concrete subclasses."
^ self subclassResponsibility
!
rightButtonStateMask
"return an integer for masking out the right button from a
buttonStates value. This is very device specific and to
be redefined by concrete subclasses."
^ self subclassResponsibility
!
leftButtonPressed
"return true, if the left button is currently pressed"
^ (self buttonStates bitAnd:self leftButtonStateMask) ~~ 0
!
middleButtonPressed
"return true, if the middle button is currently pressed"
^ (self buttonStates bitAnd:self middleButtonStateMask) ~~ 0
!
rightButtonPressed
"return true, if the right button is currently pressed"
^ (self buttonStates bitAnd:self rightButtonStateMask) ~~ 0
! !
!DeviceWorkstation methodsFor:'interactive queries'!
pointFromUserShowing:aCursor
"let user specify a point on the screen (by pressing leftButton).
Show aCursor while waiting."
|p|
self ungrabPointer.
self grabPointerIn:(self rootWindowId) withCursor:((aCursor on:self) id)
pointerMode:#async keyboardMode:#sync confineTo:nil.
activePointerGrab := rootView.
[self leftButtonPressed] whileFalse:[Processor yield].
p := self pointerPosition.
self ungrabPointer.
"flush all events pending on myself"
self disposeButtonEventsFor:nil.
^ p
"
Display pointFromUserShowing:(Cursor stop)
Display pointFromUserShowing:(Cursor crossHair)
Display pointFromUser
"
!
pointFromUser
"let user specify a point on the screen (by pressing the left button)"
^ self pointFromUserShowing:(Cursor crossHair).
"
Display pointFromUser
"
!
rectangleFromUser:initialRectangle
"let user specify a rectangle on the screen, return the rectangle.
Start with initialRectangle.
A helper for rectangleFromUser; can also be used for resizing operations."
|curs1 curs2 origin corner root rect|
curs1 := Cursor origin on:self.
curs2 := Cursor corner on:self.
root := self rootView.
"
grab and wait for leftButton being pressed
"
origin := initialRectangle origin.
root noClipByChildren.
root foreground:Color black background:Color white.
root xoring:[
|left right top bottom newOrigin newCorner p curs|
corner := origin.
rect := origin corner:corner.
root displayRectangle:rect.
self grabPointerIn:root id withCursor:curs2 id
pointerMode:#async keyboardMode:#sync confineTo:nil.
[self leftButtonPressed] whileTrue:[
left := initialRectangle origin x.
top := initialRectangle origin y.
right := initialRectangle corner x.
bottom := initialRectangle corner y.
p := self pointerPosition.
p x < initialRectangle left ifTrue:[
p y < initialRectangle top ifTrue:[
curs := Cursor topLeft.
left := p x.
top := p y.
] ifFalse:[
curs := Cursor bottomLeft.
left := p x.
bottom := p y
]
] ifFalse:[
p y < initialRectangle top ifTrue:[
curs := Cursor topRight.
right := p x.
top := p y
] ifFalse:[
curs := Cursor bottomRight.
right := p x.
bottom := p y
]
].
newOrigin := left @ top.
newCorner := right @ bottom.
((newOrigin ~= origin) or:[newCorner ~= corner]) ifTrue:[
root displayRectangle:rect.
self grabPointerIn:root id withCursor:curs id
pointerMode:#async keyboardMode:#sync confineTo:nil.
origin := newOrigin.
corner := newCorner.
rect := origin corner:corner.
root displayRectangle:rect.
self disposeButtonEventsFor:nil.
self flush.
]
].
root displayRectangle:rect.
self ungrabPointer.
].
self ungrabPointer.
"flush all events pending on my display"
root clipByChildren.
self flush.
self disposeButtonEventsFor:nil.
^ rect
!
rectangleFromUser
"let user specify a rectangle in the screen, return the rectangle"
|origin|
"
get origin
"
origin := self pointFromUserShowing:(Cursor origin on:self).
"
get corner
"
^ self rectangleFromUser:(origin corner:origin).
"
Display rectangleFromUser
"
!
viewFromUser
"let user specify a view on the screen; if the selected view is
not an ST/X view, nil is returned.
This returns the view being clicked in, which is not always a topView.
(send topView to the returned view or use topviewFromUser,
to get the topview)"
^ 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'!
translateKey:untranslatedKey
"Return the key translated via the translation table.
Your application program should never depend on the values returned
by this method, but instead use symbolic keys (such as #FindNext).
Doing so allows easier reconfiguration by changing the translation map
in the 'smalltalk.rc' or 'display.rc' startup files.
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).
If multiple modifiers are active, the symbol becoms the concatenation
as in AltCtrlq (for control-alt-q). Shift will affect the last component,
thus the above with shift becoms: AltCtrlQ instead.
Some keyboards offer both Alt and Meta keys - on those, the first has a
prefix of Alt, the second has Cmd as prefix. Keyboards with only an Alt
key will will create prefix codes of Cmd for that.
For symbolic keys (i.e.Tab, Backspace etc, shift is ignored).
Then the result is used as a key into the translation keyboardMap
to get the final return value."
|xlatedKey dontTranslate|
xlatedKey := untranslatedKey.
"should this come from a configurable variable ?"
dontTranslate := (untranslatedKey == #Control
or:[untranslatedKey == #'Control_L'
or:[untranslatedKey == #'Control_R'
or:[untranslatedKey == #'Shift'
or:[untranslatedKey == #'Shift_L'
or:[untranslatedKey == #'Shift_R'
or:[untranslatedKey == #'Alt'
or:[untranslatedKey == #'Alt_L'
or:[untranslatedKey == #'Alt_R'
or:[untranslatedKey == #'Meta'
or:[untranslatedKey == #'Meta_L'
or:[untranslatedKey == #'Meta_R'
or:[untranslatedKey == #'Cmd'
or:[untranslatedKey == #'Cmd_L'
or:[untranslatedKey == #'Cmd_R']]]]]]]]]]]]]]).
ctrlDown ifTrue:[
dontTranslate ifFalse:[
xlatedKey := ('Ctrl' , xlatedKey asString) asSymbol
]
].
metaDown ifTrue:[
dontTranslate ifFalse:[
xlatedKey := ('Cmd' , xlatedKey asString) asSymbol
]
].
altDown ifTrue:[
dontTranslate ifFalse:[
xlatedKey := ('Alt' , xlatedKey asString) asSymbol
]
].
xlatedKey := keyboardMap valueFor:xlatedKey.
^ xlatedKey
! !
!DeviceWorkstation methodsFor:'event forwarding'!
keyPress:untranslatedKey x:x y:y view:aView
"forward a key-press event for some view"
|xlatedKey sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor keyPress:untranslatedKey x:x y:y view:aView
] ifFalse:[
"
if there is no sensor ...
"
xlatedKey := self translateKey:untranslatedKey.
xlatedKey notNil ifTrue:[
WindowEvent
sendEvent:#keyPress:x:y:
arguments:(Array with:xlatedKey with:x with:y)
view:aView
]
]
!
keyRelease:untranslatedKey x:x y:y view:aView
"forward a key-release event for some view"
|xlatedKey sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor keyRelease:untranslatedKey x:x y:y view:aView
] ifFalse:[
"
if there is no sensor ...
"
xlatedKey := self translateKey:untranslatedKey.
xlatedKey notNil ifTrue:[
WindowEvent
sendEvent:#keyRelease:x:y:
arguments:(Array with:xlatedKey with:x with:y)
view:aView
]
]
!
buttonPress:button x:x y:y view:aView
"forward a button-press event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor buttonPress:button x:x y:y view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#buttonPress:x:y:
arguments:(Array with:button with:x with:y)
view:aView
]
!
buttonShiftPress:button x:x y:y view:aView
"forward a button-shift-press event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor buttonShiftPress:button x:x y:y view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#buttonShiftPress:x:y:
arguments:(Array with:button with:x with:y)
view:aView
]
!
buttonMultiPress:button x:x y:y view:aView
"forward a button-multi-press event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor buttonMultiPress:button x:x y:y view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#buttonMultiPress:x:y:
arguments:(Array with:button with:x with:y)
view:aView
]
!
buttonRelease:button x:x y:y view:aView
"forward a button-release event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor buttonRelease:button x:x y:y view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#buttonRelease:x:y:
arguments:(Array with:button with:x with:y)
view:aView
]
!
buttonMotion:button x:x y:y view:aView
"forward a button-motion for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor buttonMotion:button x:x y:y view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#buttonMotion:x:y:
arguments:(Array with:button with:x with:y)
view:aView
]
!
pointerEnter:buttonState x:x y:y view:aView
"forward a pointer enter for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor pointerEnter:buttonState x:x y:y view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#pointerEnter:x:y:
arguments:(Array with:buttonState with:x with:y)
view:aView
]
!
pointerLeave:buttonState view:aView
"forward a pointer leave for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor pointerLeave:buttonState view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#pointerLeave:
arguments:(Array with:buttonState)
view:aView
]
!
focusInView:aView
"forward a focusIn event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor focusInView:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#focusIn
arguments:nil
view:aView
]
!
focusOutView:aView
"forward a focusOut event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor focusOutView:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#focusOut
arguments:nil
view:aView
]
!
terminateView:aView
"forward a terminate event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor terminateView:aView
] ifFalse:[
"
if there is no sensor ...
"
aView terminate
]
!
saveAndTerminateView:aView
"forward a saveAndTerminate event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor saveAndTerminateView:aView
] ifFalse:[
"
if there is no sensor ...
"
aView saveAndTerminate
]
!
destroyedView:aView
"forward a destroyed event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor destroyedView:aView
] ifFalse:[
"
if there is no sensor ...
"
aView destroyed
]
!
unmappedView:aView
"forward an unmapped event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor unmappedView:aView
] ifFalse:[
"
if there is no sensor ...
"
aView unmapped
]
!
mappedView:aView
"forward a mapped event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor mappedView:aView
] ifFalse:[
"
if there is no sensor ...
"
aView mapped
]
!
coveredBy:otherView view:aView
"forward a covered for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor coveredBy:otherView view:aView
] ifFalse:[
"
if there is no sensor ...
"
aView coveredBy:otherView
]
!
configureX:x y:y width:w height:h view:aView
"forward a configure for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor configureX:x y:y width:w height:h view:aView
] ifFalse:[
"
if there is no sensor ...
"
aView configureX:x y:y width:w height:h
]
!
exposeX:x y:y width:w height:h view:aView
"forward an expose for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor exposeX:x y:y width:w height:h view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#exposeX:y:width:height:
arguments:(Array with:x with:y with:width with:height)
view:aView
]
!
graphicExposeX:x y:y width:w height:h view:aView
"forward a graphic expose for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor graphicExposeX:x y:y width:w height:h view:aView
] ifFalse:[
"
if there is no sensor ...
"
WindowEvent
sendEvent:#graphicExposeX:y:width:height:
arguments:(Array with:x with:y with:width with:height)
view:aView
]
!
noExposeView:aView
"forward a noExpose event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor noExposeView:aView
] ifFalse:[
"
if there is no sensor ...
"
aView noExpose
]
! !
!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|
knownViews isNil ifTrue:[
knownViews := WeakArray new:50.
knownIds := Array new:50.
freeIdx := 1.
] ifFalse:[
freeIdx := knownViews identityIndexOf:nil.
"/ 1 to:knownViews size do:[:idx |
"/ |id|
"/ (knownViews at:idx) isNil ifTrue:[
"/ freeIdx := idx
"/ id := knownIds at:idx.
"/ id notNil ifTrue:[
"/ "/ this one is no longer valid ...
"/ knownIds at:idx put:nil.
"/ ].
"/ ]
"/ ].
].
freeIdx == 0 ifTrue:[
sz := knownViews size.
newSize := sz * 2.
newArr := WeakArray new:newSize.
newArr replaceFrom:1 to:sz with:knownViews.
knownViews := newArr.
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|
"/ no longer called for ...
"/
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:[
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 flush
"/ ]
]
"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 flush
"/ ]
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 flush
]
"Display setCursors:(Cursor wait)"
"Display restoreCursors"
! !
!DeviceWorkstation methodsFor:'event handling'!
startDispatch
"create the display dispatch process."
|inputSema fd p nm|
"
only allow one dispatcher process per display
"
dispatching ifTrue:[^ self].
dispatching := true.
AllScreens isNil ifTrue:[
AllScreens := Set new:1
].
AllScreens add:self.
"
The code below (still) handles the situation where ST/X was built
without lightweight process support. Since there are many other places
in the system whic depend on lightweight processes to function, this
may be a stupid thing to do ... expect it to vanish sooner or later.
"
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. Dispatch the event in that block.
"
Processor enableIOAction:[
dispatching ifTrue:[
[self eventPending] whileTrue:[
self dispatchPendingEvents.
self checkForEndOfDispatch.
].
dispatching ifFalse:[
Processor disableFd:fd.
AllScreens remove:self.
]
]
]
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:[
AbortSignal handle:[:ex |
ex return
] do:[
self eventPending ifFalse:[
Processor activeProcess setStateTo:#ioWait if:#active.
inputSema wait.
].
self dispatchPendingEvents.
self checkForEndOfDispatch.
]
].
Processor disableSemaphore:inputSema.
inputSema := nil.
AllScreens remove:self.
dispatchProcess := nil
] forkAt:(Processor userInterruptPriority).
"
give the process a nice name (for the processMonitor)
"
(nm := self displayName) notNil ifTrue:[
nm := 'event dispatcher (' , nm , ')'.
] ifFalse:[
nm := 'event dispatcher'.
].
p name:nm.
Processor signal:inputSema onInput:fd orCheck:[self eventPending].
dispatchProcess := p.
]
!
checkForEndOfDispatch
"return true, if there are still any views of interrest -
if not, stop dispatch. This ends the dispatcher process when the
last view is closed on that device."
self == Display ifTrue:[
"/ idToViewMapping isEmpty ifTrue:[
knownViews isEmpty ifTrue:[
dispatching := false
]
]
!
dispatchPendingEvents
"go dispatch events as long as there is one."
[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 (and is only) 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 the next pending event - for any view"
self dispatchEventFor:nil withMask:nil
!
dispatchEventFor:aViewIdOrNil withMask:eventMask
"central event handling method:
get next event and send an appropriate message to the views sensor,
or to the view directly (if the view has none).
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. The mask is a device dependent event mask."
^ self subclassResponsibility
!
disposeEventsWithMask:aMask for:aWindowId
"dispose (throw away) specific events"
^ self subclassResponsibility
!
disposeEvents
"dispose (i.e. forget) all events pending on this display"
[self eventPending] whileTrue:[
self getEventFor:nil withMask:nil
].
!
disposeButtonEventsFor:aViewIdOrNil
"dispose (i.e. forget) all pending button events on this display"
|mask|
mask := self eventMaskFor:#buttonPress.
mask := mask bitOr:(self eventMaskFor:#buttonRelease).
mask := mask bitOr:(self eventMaskFor:#buttonMotion).
self disposeEventsWithMask:mask for:aViewIdOrNil
!
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
for a specific window.
This expects a device dependent event mask as first argument."
^ self subclassResponsibility
!
eventPending:anEventSymbol for:aWindowId
"return true, if a specific event is pending for a specific window.
This expects device independent event symbols (such as #buttonPress,
#buttonRelease etc.) as first argument."
^ self subclassResponsibility
!
eventMaskFor:anEventSymbol
^ self subclassResponsibility
!
setEventMask:aMask in:aWindowId
^ 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 |
family := fntDescr family.
family notNil ifTrue:[
families add:family
]
].
^ families asSortedCollection
"
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 |
aFamilyName = fntDescr family ifTrue:[
faces add:(fntDescr face)
]
].
^ faces asSortedCollection
"
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 |
(aFamilyName = fntDescr family) ifTrue:[
(aFaceName = fntDescr face) ifTrue:[
styles add:fntDescr style
]
]
].
^ styles asSortedCollection
"
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
"/ ]
"/ ]
"/ ]
(aFamilyName = fntDescr family) ifTrue:[
(aFaceName = fntDescr face) ifTrue:[
(aStyleName = fntDescr style) 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
! !
!DeviceWorkstation methodsFor:'grabbing '!
grabKeyboardInView:aView
"grab the keyboard - all keyboard input will be sent to aView.
Return true if ok, false if it failed for some reason."
activeKeyboardGrab notNil ifTrue:[
self ungrabKeyboard.
activeKeyboardGrab := nil
].
(self grabKeyboardIn:(aView id)) ifTrue:[
activeKeyboardGrab := aView.
^ true
].
^ false
!
grabKeyboardIn:aWindowId
"grab the keyboard - all keyboard input will be sent to the view
with id aWindowId"
^ self subclassResponsibility
!
ungrabKeyboard
"release the keyboard"
^ self subclassResponsibility
!
activeKeyboardGrab
"return the view, which currently has the keyboard grabbed,
or nil, if there is none"
^ activeKeyboardGrab
!
grabPointerInView:aView
"grap the pointer; all pointer events will be reported to
aView. Return true if ok, false if it failed for some reason."
activePointerGrab notNil ifTrue:[
self ungrabPointer.
activePointerGrab := nil
].
(self grabPointerIn:(aView id)) ifTrue:[
activePointerGrab := aView.
^ true
].
^ false
!
grabPointerIn:aWindowId withCursor:cursorId pointerMode:pMode keyboardMode:kMode confineTo:confineId
"grap the pointer - all pointer events will be reported to aWindowId. The cursor will be set to cursorId
for the duration of the grab. For pMode/kMode, see X documentation. The pointer is restricted to
confineId - if non-nil."
^ self subclassResponsibility
!
grabPointerIn:aWindowId
"grap the pointer; all pointer events will be reported to the view
with id aWindowId. Return true if ok, false if it failed for some reason."
^ self grabPointerIn:aWindowId withCursor:nil pointerMode:#async keyboardMode:#sync confineTo:nil
!
ungrabPointer
"release the pointer"
^ self subclassResponsibility
!
activePointerGrab
"return the view, which currently has the pointer grabbed,
or nil, if there is none"
^ activePointerGrab
!
setActivePointerGrab:aView
"DO NOT USE. private kludge - will vanish"
activePointerGrab := aView
! !
!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
!
redComponentOfColor:colorId
"get red component (0..100) of color in map at:index"
self getRGBFrom:colorId into:[:r :g :b | ^ r]
!
greenComponentOfColor:colorId
"get green component (0..100) of color in map at:index"
self getRGBFrom:colorId into:[:r :g :b | ^ g]
!
blueComponentOfColor:colorId
"get blue component (0..100) of color in map at:index"
self getRGBFrom:colorId into:[:r :g :b | ^ b]
!
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 opaque:opaque
"draw a string"
^ self subclassResponsibility
!
displayString:aString from:i1 to:i2 x:x y:y in:aDrawableId with:aGCId opaque:opaque
"draw part of a string"
"
should be redefined in concrete subclasses
to avoid creation of throw-away string
"
self displayString:(aString copyFrom:i1 to:i2)
x:x
y:y
in:aDrawableId
with:aGCId
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
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
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
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
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
but then, we have to reimplement all line and join styles here
"
^ self subclassResponsibility
!
displayPolygon:aPolygon in:aDrawableId with:aGCId
"draw a polygon"
"
should draw the lines here
but then, we have to reimplement all line and join styles 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, using the low-bit plane of the source only"
^ 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
! !