"
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 bitsRed
bitsGreen bitsBlue redMask greenMask blueMask redShift greenShift
blueShift 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 altModifiers metaModifiers
ctrlModifiers shiftModifiers'
classVariableNames:'ButtonTranslation MultiClickTimeDelta DeviceErrorSignal
ErrorPrinting DefaultScreen AllScreens ExitOnLastClose'
poolDictionaries:''
category:'Interface-Graphics'
!
!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.
"
!
documentation
"
this abstract class defines common protocol to all Display types.
For compatibility with ST-80, this class (actually a concrete subclass)
is also bound to the global variable Screen.
DeviceWorkstation (and its concrete subclasses) are the central classes
around windowManagement and event processing.
See the documentation in #events and #workstationDevices for more detailed
info.
[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 <SmallInteger> bits per color
ncells <SmallInteger> number of colors (i.e. colormap size; not always == 2^depth)
bitsPerRGB <SmallInteger> number of valid bits per rgb component
(actual number taken in A/D converter; not all devices report the true value)
bitsRed <SmallInteger> number of red bits (only valid for TrueColor displays)
bitsGreen <SmallInteger> number of green bits (only valid for TrueColor displays)
bitsBlue <SmallInteger> number of blue bits (only valid for TrueColor displays)
redMask <SmallInteger> shifted red mask (only useful for TrueColor displays)
greenMask <SmallInteger> shifted green mask (only useful for TrueColor displays)
blueMask <SmallInteger> shifted blue mask (only useful for TrueColor displays)
shiftRed <SmallInteger> number of bits to shift red bits (only valid for TrueColor displays)
shiftGreen <SmallInteger> number of bits to shift green bits (only valid for TrueColor displays)
shiftBlue <SmallInteger> number of bits to shift blue bits (only valid for TrueColor displays)
hasColors <Boolean> true, if display supports colors
hasGreyscales <Boolean> true, if display supports grey-scales (i.e is not b/w display)
width <SmallInteger> number of horizontal pixels
height <SmallInteger> 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.
[see also:]
GraphicsContext DeviceDrawable
WindowSensor WindowGroup WindowEvent
ProcessorScheduler
PSMedium
[author:]
Claus Gittinger
"
!
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 the 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 enabled by: 'aView enableMotionEvent'
The above is only of interest, if you write your own widget classes,
existing widgets set things as required in their #initEvents method.
"
!
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 concrete display 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.
ST/X is designed to allow the use of multiple workstation devices in parallel, if
the underlying window system supports this.
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.
This does not work with other devices (i.e. Windows).
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:
(this is now no longer needed - the first opened view will do it for you)
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).
"
! !
!DeviceWorkstation class methodsFor:'initialization'!
initialize
"create local error signals; enable errorPrinting"
DeviceErrorSignal isNil ifTrue:[
DeviceErrorSignal := (Signal new) mayProceed:true.
DeviceErrorSignal notifierString:'device error'.
].
ErrorPrinting := true.
ExitOnLastClose := false.
self initializeConstants.
"Modified: 24.4.1996 / 19:36:47 / cg"
!
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 class methodsFor:'error handling'!
errorInterrupt:errID with:aParameter
"{ Pragma: +optSpace }"
"an error in the devices low level code (typically Xlib or XtLib)
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:[
ErrorPrinting ifTrue:[msg errorPrintNL].
^ self
].
^ DeviceErrorSignal
raiseRequestWith:badResource
errorString:msg
"Modified: 24.4.1996 / 19:35:12 / cg"
!
errorPrinting
"return the `errorPrinting-is-on' flag"
ErrorPrinting isNil ifTrue:[^ false].
^ ErrorPrinting
"Modified: 24.4.1996 / 19:35:55 / cg"
!
errorPrinting:aBoolean
"set/clear the `errorPrinting-is-on' flag"
ErrorPrinting := aBoolean
"Modified: 24.4.1996 / 19:36:02 / cg"
!
lastErrorString
"return a string describing the last error"
^ self subclassResponsibility
!
resourceIdOfLastError
"return the resource id responsible for the last error"
^ self subclassResponsibility
!
resourceOfId:id
"{ Pragma: +optSpace }"
"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
"Modified: 24.4.1996 / 19:36:15 / cg"
! !
!DeviceWorkstation class methodsFor:'queries'!
allScreens
"Return a collection of active display devices.
Typically, there is only one: Display or Screen current."
^ AllScreens
"
Screen allScreens
"
"Modified: 1.9.1995 / 13:38:35 / claus"
"Modified: 24.4.1996 / 19:36:59 / cg"
!
current
"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 if a background processes
invokes this ..."
|wg tops v dev|
AllScreens isNil ifTrue:[
^ Display
].
AllScreens size == 1 ifTrue:[
^ AllScreens anElement
].
"
mhmh - multiple screens are active.
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
"
"Modified: 1.9.1995 / 13:40:05 / claus"
"Modified: 24.4.1996 / 19:37:34 / cg"
!
default
"ST-80 compatibility.
Return the default screen. This is typically the first opened
Display screen in a session. Use of the global variable Display
should vanish over time - replace it by Screen default."
^ 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."
DefaultScreen := aDevice
!
platformName
"ST-80 compatibility.
Return a string describing the display systems platform.
Returns a dummy here. This must be redefined in concrete
Workstation classes, to return somthing like 'X', 'MSWindows', 'OS/2' etc."
^ 'unknown'
! !
!DeviceWorkstation class methodsFor:'standalone setup'!
exitOnLastClose:aBoolean
"set/clear the flag which controls if the
event dispatching should stop when the last view is closed.
(standAlone applications will set it)"
ExitOnLastClose := aBoolean
"Modified: 23.4.1996 / 22:01:28 / cg"
! !
!DeviceWorkstation methodsFor:'accessing & queries'!
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))
!
dispatchProcess
^ dispatchProcess
!
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
!
id
"return the displayId"
^ displayId
!
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
!
multiClickTimeDelta
^ multiClickTimeDelta
!
multiClickTimeDelta:milliseconds
multiClickTimeDelta := milliseconds
!
rootView
"return the rootView (i.e. the background window) on the receiver screen.
It is not guaranteed, that a particular display device supports this."
rootView isNil ifTrue:[
rootView := DisplayRootView on:self
].
^ rootView
"
|v|
v := Display rootView.
v paint:Color red.
v noClipByChildren.
v fillRectangleX:10 y:10 width:100 height:100.
"
!
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|
id := self viewIdFromPoint:aPoint.
view := self viewFromId:id.
^ view
!
viewIdFromPoint:aPoint
"given a point on the screen, return the id of 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"
|id searchId foundId|
searchId := self rootWindowId.
[searchId notNil] whileTrue:[
id := self viewIdFromPoint:aPoint in:searchId.
foundId := searchId.
searchId := id
].
^ foundId
!
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
!
windowAt:aPoint
"given a point on the screen, return the ST/X topview in which that
point is.
Return nil, if its not an ST/X view or if the point is on the background.
Alias for viewFromPoint: - ST-80 compatibility"
^ self viewFromPoint:aPoint
! !
!DeviceWorkstation methodsFor:'accessing display attributes'!
bitsBlue
"return the number of valid bits in the red component."
bitsBlue isNil ifTrue:[
"/ not a truecolor display
^ bitsPerRGB
].
^ bitsBlue
"
Display bitsBlue
"
"Created: 21.10.1995 / 00:45:27 / cg"
!
bitsGreen
"return the number of valid bits in the red component."
bitsGreen isNil ifTrue:[
"/ not a truecolor display
^ bitsPerRGB
].
^ bitsGreen
"
Display bitsGreen
"
"Created: 21.10.1995 / 00:45:11 / cg"
!
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.
In the meantime, use bitsRed/bitsGreen/bitsBlue to get this information."
^ bitsPerRGB
"
Display bitsPerRGB
"
"Modified: 21.10.1995 / 00:46:27 / cg"
!
bitsRed
"return the number of valid bits in the red component."
bitsRed isNil ifTrue:[
"/ not a truecolor display
^ bitsPerRGB
].
^ bitsRed
"
Display bitsRed
"
"Created: 21.10.1995 / 00:44:55 / cg"
!
blackpixel
"return the colorId of black"
^ self subclassResponsibility
!
depth
"return the depth in pixels of the display"
^ depth
"
Display depth
"
!
hasColors
"return true, if its a color display"
^ hasColors
"
Display hasColors
"
!
hasGrayscales
"return true, if this workstation supports grayscales
(also true for color displays)"
^ hasGreyscales
"
Display hasGrayscales
"
"Created: 2.5.1996 / 11:49:07 / cg"
!
hasGreyscales
"OBSOLETE english version; please use #hasGrayScales.
Return true, if this workstation supports greyscales
(also true for color displays)"
^ hasGreyscales
"
Display hasGreyscales
"
"Modified: 2.5.1996 / 11:51:03 / cg"
!
shiftBlue
"return the count by which the blue bits are to be shifted
when forming a color index.
This only makes sense with trueColor displays; therefore,
nil is returned on all others."
^ blueShift
"
Display shiftBlue
"
"Created: 21.10.1995 / 00:45:27 / cg"
"Modified: 21.10.1995 / 00:47:58 / cg"
!
shiftGreen
"return the count by which the red bits are to be shifted
when forming a color index.
This only makes sense with trueColor displays; therefore,
nil is returned on all others."
^ greenShift
"
Display shiftGreen
"
"Created: 21.10.1995 / 00:45:27 / cg"
"Modified: 21.10.1995 / 00:48:28 / cg"
!
shiftRed
"return the count by which the red bits are to be shifted
when forming a color index.
This only makes sense with trueColor displays; therefore,
nil is returned on all others."
^ redShift
"
Display shiftRed
"
"Created: 21.10.1995 / 00:45:27 / cg"
"Modified: 21.10.1995 / 00:48:10 / cg"
!
visualType
"return a symbol representing the visual type of the display"
^ visualType
"
Display visualType
"
!
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
]
!
whitepixel
"return the colorId of white"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'accessing display capabilities'!
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
!
hasDPS
"return true, if this workstation supports postscript output into views.
Should be reimplemented in concrete classes which do support this."
^ false
"
Display hasDPS
"
!
hasExtension:extensionString
"query for an X extension. The method here is provide for XWorkstation
protocol compatibility only."
^ false
"
Display hasExtension:'XVideo'
Display hasExtension:'Input'
Display hasExtension:'GLX'
Display hasExtension:'X3D-PEX'
Display hasExtension:'XInputExtension'
Display hasExtension:'SHAPE'
Display hasExtension:'MIT-SHM'
Display hasExtension:'SGIFullScreenStereo'
"
!
hasFax
"return true, if this workstation supports decompression of fax images.
Should be reimplemented in concrete classes which do support this."
^ false
"
Display hasFax
"
!
hasGrayscales:aBoolean
"set the hasGrayscales 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
"Created: 2.5.1996 / 11:50:04 / cg"
!
hasGreyscales:aBoolean
"OBSOLETE english version - please use #hasGrayscales:
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
"Modified: 2.5.1996 / 11:50:48 / cg"
!
hasImageExtension
"return true, if this workstation supports the X Image extension"
^ false
"
Display hasImageExtension
"
!
hasInputExtension
"return true, if this workstation supports the X Input extension"
^ false
"
Display hasInputExtension
"
!
hasMultibuffer
"return true, if this workstation supports the X multibuffer extension"
^ false
"
Display hasMultibuffer
"
!
hasPEX
"return true, if this workstation supports PEX graphics.
Should be reimplemented in concrete classes which do support this."
^ false
"
Display hasPEX
"
!
hasShape
"return true, if this workstation supports non-rectangular windows.
Should be reimplemented in concrete classes which do support this."
^ false
"
Display hasShape
"
!
hasShm
"return true, if this workstation supports shared memory pixmaps.
Should be reimplemented in concrete classes which do support this."
^ false
"
Display hasShm
"
!
hasStereoExtension
"return true, if this workstation supports stereo GL drawing.
Both the server must support it, and the feature must have been
enabled in the smalltalk system, for true to be returned."
^ false
"
Display hasStereoExtension
"
!
hasXVideo
"return true, if this workstation supports the XVideo extension"
^ false
"
Display hasXVideo
"
!
iconSizes
"Get the supported icon sizes. These are typically set by the window manager.
We return nil here (as if there are no special size preferences)."
^ nil
"Created: 2.1.1996 / 15:08:16 / cg"
"Modified: 7.5.1996 / 10:43:38 / cg"
!
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
"return true, if this is a relatively slow device -
used to turn off things like popup-shadows"
^ isSlow
!
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
!
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
!
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
"
!
preferredIconSize
"Get the preferrered icon size. These are typically set by the window manager.
We return nil here (as if there are no special size preferences)."
^ nil
"Modified: 2.1.1996 / 15:09:06 / cg"
"Created: 7.5.1996 / 10:43:32 / cg"
!
supportedImageFormats
"return an array with supported image formats; each array entry
is another array, consisting of depth and bitsPerPixel values.
Here, we return a single format only; every graphics device must
support b&w single bit images."
|info|
info := IdentityDictionary new.
info at:#depth put:1.
info at:#bitsPerPixel put:1.
info at:#padding put:32.
^ Array with:info
!
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
"
Display supportsDeepIcons
"
!
supportsGLDrawing
"return true, if this device supports 3D GL drawing.
We do not depend on that being implemented."
"This method should to be reimplemented in concrete display classes."
^ false
"
Display supportsGLDrawing
"
!
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
"
Display supportsViewGravity
"
! !
!DeviceWorkstation methodsFor:'accessing display geometry'!
boundingBox
"return a rectangle representing the displays bounding box.
For Smalltalk-80 2.x compatibility"
^ self bounds
!
bounds
"return a rectangle representing the displays bounding box.
For Smalltalk-80 4.x compatibility"
^ Rectangle left:0 top:0 width:width-1 height:height-1
"
Screen default bounds
"
"/ thats the same as:
"
Display bounds
"
"Modified: 8.5.1996 / 20:58:26 / cg"
!
center
"return the centerpoint in pixels of the display"
^ (width // 2) @ (height // 2)
!
extent
"return the extent of the display (in pixels)"
^ width @ height
"
Display extent
"
!
height
"return the height of the display (in pixels)"
^ height
"Display height"
!
heightInMillimeter
"return the height in millimeter of the display"
^ heightMM
"Display heightInMillimeter"
!
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
!
horizontalPixelPerInch
"return the number of horizontal pixels per inch of the display"
^ (width / widthMM) * 25.4
!
horizontalPixelPerMillimeter
"return the number of horizontal pixels per millimeter of the display"
^ width / widthMM
!
pixelPerInch
"return the number of horizontal/vertical pixels per inch of the display as Point"
^ ((width / widthMM) @ (height / heightMM)) * 25.4
"Display pixelPerInch"
!
pixelPerMillimeter
"return the number of horizontal/vertical pixels per millimeter of the display as Point"
^ (width / widthMM) @ (height / heightMM)
"Display pixelPerMillimeter"
!
resolution
"return a point consisting of pixel-per-inch horizontally and vertically.
This is an ST-80 compatibility method"
^ self pixelPerInch
!
verticalPixelPerInch
"return the number of vertical pixels per inch of the display"
^ (height / heightMM) * 25.4
!
verticalPixelPerMillimeter
"return the number of vertical pixels per millimeter of the display"
^ height / heightMM
!
virtualExtent
"return the virtual extent of the display (in pixels).
On most systems, this is the same as the physical width;
except, if a window manager with a virtual desktop like olvwm
(simulating a bigger screen) is running."
^ width @ height
!
virtualHeight
"return the virtual height of the display (in pixels).
On most systems, this is the same as the physical height;
except, if a window manager with a virtual desktop like olvwm
(simulating a bigger screen) is running."
^ self virtualExtent y
"Display virtualHeight"
!
virtualWidth
"return the virtual width of the display (in pixels).
On most systems, this is the same as the physical width;
except, if a window manager with a virtual desktop like olvwm
(simulating a bigger screen) is running."
^ self virtualExtent x
"Display virtualWidth"
!
width
"return the width of the display (in pixels)"
^ width
"Display width"
!
widthInMillimeter
"return the width in millimeter of the display"
^ widthMM
"Display widthInMillimeter"
!
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
! !
!DeviceWorkstation methodsFor:'accessing keyboard mappings'!
buttonTranslation
^ buttonTranslation
!
buttonTranslation:anArray
buttonTranslation := anArray
!
keyboardMap
"return the keyboard map"
^ keyboardMap
!
keyboardMap:aMap
"set the keyboard map"
keyboardMap := aMap
! !
!DeviceWorkstation methodsFor:'accessing misc'!
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
"
!
glVersion
"return a string describing the GL version.
Since the generic display does not support 3D GL graphics,
a dummy is returned here."
^ 'noGL'
"
Display glVersion
"
!
platformName
"return a string describing the display systems platform.
Returns a dummy here."
^ self class platformName
"
Display platformName
"
!
protocolVersion
"return the display systems protocol version number.
Returns a dummy here"
^ 0
"
Display protocolVersion
"
!
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
"
Display vendorRelease
"
! !
!DeviceWorkstation methodsFor:'bitmap/window creation'!
createBitmapFromArray:anArray width:w height:h
^ self subclassResponsibility
!
createBitmapFromFile:aString for:aForm
^ self subclassResponsibility
!
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
!
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
!
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
!
createWindowFor:aView left:xpos top:ypos width:wwidth height:wheight
^ self subclassResponsibility
!
destroyFaxImage:aFaxImageId
^ self subclassResponsibility
!
destroyGC:aGCId
"destroy a GC"
^ self subclassResponsibility
!
destroyPixmap:aDrawableId
^ self subclassResponsibility
!
destroyView:aView withId:aWindowId
^ self subclassResponsibility
!
gcFor:aDrawableId
"create a GC for drawing into aDrawable"
^ self subclassResponsibility
!
rootWindowFor:aView
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'color stuff'!
blueComponentOfColor:colorId
"get blue component (0..100) of color in map at:index"
self getRGBFrom:colorId into:[:r :g :b | ^ b]
!
colorCell
"allocate a color - 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
!
colorRed:redVal green:greenVal blue:blueVal
"allocate a color with rgb values (0..100) - return index"
^ self subclassResponsibility
!
freeColor:colorIndex
"free a color on the display, when its no longer needed"
^ self subclassResponsibility
!
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
!
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
!
greenComponentOfColor:colorId
"get green component (0..100) of color in map at:index"
self getRGBFrom:colorId into:[:r :g :b | ^ g]
!
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')
!
redComponentOfColor:colorId
"get red component (0..100) of color in map at:index"
self getRGBFrom:colorId into:[:r :g :b | ^ r]
!
setColor:index red:redVal green:greenVal blue:blueVal
"change color in map at:index to rgb (0..100)"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'cursor stuff'!
colorCursor:aCursorId foreground:fgColor background:bgColor
"change a cursors colors"
^ self subclassResponsibility
!
createCursorShape:aShape
"create a cursor given a shape-symbol"
^ self subclassResponsibility
!
createCursorSourceForm:sourceForm maskForm:maskForm hotX:hx hotY:hy
"create a cursor given 2 bitmaps (source, mask) and a hotspot"
^ self subclassResponsibility
!
destroyCursor:aCursorId
"free a cursor"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'drawing'!
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 width:width height:height from:startAngle angle:angle
in:aDrawableId with:aGCId
"draw an arc"
^ self subclassResponsibility
"Created: 8.5.1996 / 08:44:43 / cg"
!
displayLineFromX:x0 y:y0 toX:x1 y:y1 in:aDrawableId with:aGCId
"draw a line"
"could add a bresenham line drawer here ..."
^ self subclassResponsibility
!
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
!
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
!
displayPointX:x y:y in:aDrawableId with:aGCId
"draw a point"
^ 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
!
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
!
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
!
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 x:x y:y in:aDrawableId with:aGCId opaque:opaque
"draw a string"
^ 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
!
fillArcX:x y:y width:width height:height from:startAngle angle:angle
in:aDrawableId with:aGCId
"fill an arc"
^ self subclassResponsibility
"Created: 8.5.1996 / 08:45:11 / cg"
!
fillPolygon:aPolygon in:aDrawableId with:aGCId
"fill a polygon"
^ self subclassResponsibility
!
fillRectangleX:x y:y width:width height:height in:aDrawableId with:aGCId
"fill a rectangle"
^ 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:'event forwarding'!
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
]
!
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
]
!
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
]
!
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
]
!
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
]
!
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
]
!
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
]
!
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
]
!
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:w with:h)
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
]
!
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:w with:h)
view:aView
]
!
keyPress:untranslatedKey x:x y:y view:aView
"forward a key-press event for some view"
<resource: #keyboard (#Escape)>
|xlatedKey sensor|
"/
"/ ctrl-Esc gives up focus
"/
untranslatedKey == #Escape ifTrue:[
ctrlDown ifTrue:[
self ungrabPointer.
self setInputFocusTo:nil
]
].
self modifierKeyProcessing:untranslatedKey down:true.
(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
]
]
"Modified: 7.3.1996 / 13:15:01 / cg"
!
keyRelease:untranslatedKey x:x y:y view:aView
"forward a key-release event for some view"
|xlatedKey sensor|
self modifierKeyProcessing:untranslatedKey down:false.
(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
]
]
!
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
]
!
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
]
!
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
]
!
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
]
!
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
]
!
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
]
! !
!DeviceWorkstation methodsFor:'event handling'!
checkForEndOfDispatch
"return true, if there are still any views of interest -
if not, stop dispatch.
This ends the dispatcher process when the last view is closed on that device.
We only do this for displays other that the default Display."
dispatching ifFalse:[^ self].
self == Display ifTrue:[
ExitOnLastClose ifFalse:[^ self].
].
knownViews notNil ifTrue:[
(knownViews findFirst:[:slot | slot notNil and:[slot shown]]) == 0 ifTrue:[
"/ my last view was closed
dispatching := false.
'DEVWORKST: finished dispatch (last view closed)' infoPrintCR.
]
].
"Modified: 19.9.1995 / 11:31:54 / claus"
"Modified: 20.5.1996 / 10:32:19 / cg"
!
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
!
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
].
]
!
dispatchPendingEvents
"go dispatch events as long as there is one.
This is only used with modal operation.
(i.e. when in the modal debugger)"
[self eventPending] whileTrue:[
self dispatchEventFor: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
!
disposeEvents
"dispose (i.e. forget) all events pending on this display"
[self eventPending] whileTrue:[
self getEventFor:nil withMask:nil
].
!
disposeEventsWithMask:aMask for:aWindowId
"dispose (throw away) specific events"
^ self subclassResponsibility
!
eventMaskFor:anEventSymbol
^ self subclassResponsibility
!
eventPending
"return true, if any event is pending"
^ 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
!
eventPendingWithSync:doSync
"return true, if any event is pending"
^ self subclassResponsibility
!
eventQueued
"return true, if any event is pending in some internal queue.
The fallBack here returns true if events are pending on the display connection;
only devices which use internal queues (i.e. Xlib) need to redefine this."
^ self eventPending
!
eventsPending:anEventMask for:aWindowId withSync:doSync
"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
!
setEventMask:aMask in:aWindowId
"arrange that only events from aMask are reported to a view.
Highly device specific, to be defined in concrete subclasses"
^ self subclassResponsibility
!
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.
]
"Modified: 12.12.1995 / 20:52:57 / stefan"
! !
!DeviceWorkstation methodsFor:'font stuff'!
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
!
encodingOf:aFontId
"return the characterEncoding of a font.
Here, we assume an ISO8859 (=ANSI) encoding"
^ 'ISO8859-1'
"Created: 23.2.1996 / 00:39:06 / cg"
!
facesInFamily:aFamilyName
"return a set of all available font faces in aFamily on this display"
^ self facesInFamily:aFamilyName filtering:nil
"
Display facesInFamily:'times'
Display facesInFamily:'fixed'
"
"Modified: 27.2.1996 / 01:33:47 / cg"
!
facesInFamily:aFamilyName filtering:filterBlock
"return a set of all available font faces in aFamily on this display.
But only those matching filterBlock (if nonNil)."
|fonts|
fonts := self fontsInFamily:aFamilyName filtering:filterBlock.
fonts size == 0 ifTrue:[^ nil].
^ (fonts collect:[:descr | descr face]) asSortedCollection
"
Display facesInFamily:'fixed' filtering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Created: 27.2.1996 / 01:33:25 / cg"
"Modified: 29.2.1996 / 04:29:01 / cg"
!
fontFamilies
"return a set of all available font families on this display"
^ self fontFamiliesFiltering:nil
"
Display fontFamilies
"
"Modified: 27.2.1996 / 01:31:14 / cg"
!
fontFamiliesFiltering:aFilterBlock
"return a set of all available font families on this display,
but only those matching aFilterBlock (if nonNil)."
|fonts|
fonts := self fontsFiltering:aFilterBlock.
fonts size == 0 ifTrue:[^ nil].
^ (fonts collect:[:descr | descr family]) asSortedCollection
"
Display fontFamiliesFiltering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Modified: 29.2.1996 / 04:31:51 / cg"
!
fontsFiltering:aFilterBlock
"return a set of all available font on this display,
but only those matching aFilterBlock (if nonNil)."
|allFonts fonts|
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
fonts := Set new.
allFonts do:[:fntDescr |
(aFilterBlock isNil or:[aFilterBlock value:fntDescr]) ifTrue:[
fntDescr family notNil ifTrue:[
fonts add:fntDescr
]
]
].
^ fonts
"
Display fontsFiltering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Modified: 29.2.1996 / 04:30:35 / cg"
!
fontsInFamily:aFamilyName face:aFaceName filtering:filter
"return a set of all available fonts in aFamily/aFace on this display.
But only thise matching filter (if nonNil)."
|allFonts fonts|
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
fonts := Set new.
allFonts do:[:fntDescr |
(aFamilyName = fntDescr family) ifTrue:[
(aFaceName = fntDescr face) ifTrue:[
(filter isNil or:[filter value:fntDescr]) ifTrue:[
fonts add:fntDescr
]
]
]
].
^ fonts
"
Display fontsInFamily:'fixed' face:'medium' filtering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Created: 29.2.1996 / 04:32:56 / cg"
!
fontsInFamily:aFamilyName face:aFaceName style:aStyleName filtering:filter
"return a set of all available font in aFamily/aFace/aStyle
on this display.
But only those matching filter (if nonNIl)."
|allFonts fonts|
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
fonts := Set new.
allFonts do:[:fntDescr |
(aFamilyName = fntDescr family) ifTrue:[
(aFaceName = fntDescr face) ifTrue:[
(aStyleName = fntDescr style) ifTrue:[
(filter isNil or:[filter value:fntDescr]) ifTrue:[
fonts add:fntDescr
]
]
]
]
].
^ fonts
"
Display fontsInFamily:'fixed' face:'medium' style:'roman' filtering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Created: 29.2.1996 / 04:25:30 / cg"
!
fontsInFamily:aFamilyName filtering:filterBlock
"return a set of all available font in aFamily on this display.
But only those matching filterBlock (if nonNil)."
|allFonts fonts|
allFonts := self listOfAvailableFonts.
allFonts isNil ifTrue:[^ nil].
fonts := Set new.
allFonts do:[:fntDescr |
aFamilyName = fntDescr family ifTrue:[
(filterBlock isNil or:[filterBlock value:fntDescr]) ifTrue:[
fonts add:fntDescr
]
]
].
^ fonts
"
Display fontsInFamily:'fixed' filtering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Modified: 27.2.1996 / 01:34:11 / cg"
"Created: 29.2.1996 / 04:27:49 / cg"
!
fullNameOf:aFontId
"return the full name of a font.
Here, we return nil, not knowing anything about fonts"
^ nil
"Created: 23.2.1996 / 00:43:19 / cg"
!
getDefaultFont
"return a default font id
- used when class Font cannot find anything usable"
^ self subclassResponsibility
!
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
!
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
!
maxWidthOfFont:aFontId
"return the width in pixels of the widest character a specific font"
^ self subclassResponsibility
!
minWidthOfFont:aFontId
"return the width in pixels of the smallest character a specific font"
^ self subclassResponsibility
!
releaseFont:aFontId
"free a font"
^ self subclassResponsibility
!
sizesInFamily:aFamilyName face:aFaceName style:aStyleName
"return a set of all available font sizes in aFamily/aFace/aStyle
on this display"
^ self sizesInFamily:aFamilyName face:aFaceName style:aStyleName filtering:nil
"
Display sizesInFamily:'times' face:'medium' style:'italic'
"
"Modified: 27.2.1996 / 01:38:42 / cg"
!
sizesInFamily:aFamilyName face:aFaceName style:aStyleName filtering:filter
"return a set of all available font sizes in aFamily/aFace/aStyle
on this display.
But only those matching filter (if nonNIl)."
|fonts|
fonts := self fontsInFamily:aFamilyName face:aFaceName style:aStyleName filtering:filter.
fonts size == 0 ifTrue:[^ nil].
^ fonts collect:[:descr | descr size].
"
Display sizesInFamily:'fixed' face:'medium' style:'roman' filtering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Created: 27.2.1996 / 01:37:56 / cg"
"Modified: 29.2.1996 / 04:26:52 / cg"
!
stylesInFamily:aFamilyName face:aFaceName
"return a set of all available font styles in aFamily/aFace on this display"
^ self stylesInFamily:aFamilyName face:aFaceName filtering:nil
"
Display stylesInFamily:'times' face:'medium'
Display stylesInFamily:'times' face:'bold'
"
"Modified: 27.2.1996 / 01:35:43 / cg"
!
stylesInFamily:aFamilyName face:aFaceName filtering:filter
"return a set of all available font styles in aFamily/aFace on this display.
But only thise matching filter (if nonNil)."
|fonts|
fonts := self fontsInFamily:aFamilyName face:aFaceName filtering:filter.
fonts size == 0 ifTrue:[^ nil].
^ (fonts collect:[:descr | descr style]) asSortedCollection
"
Display stylesInFamily:'fixed' face:'medium' filtering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Created: 27.2.1996 / 01:35:22 / cg"
"Modified: 29.2.1996 / 04:33:59 / cg"
!
widthOf:aString from:index1 to:index2 inFont:aFontId
"return the width in pixels of a substring in a specific font"
^ self subclassResponsibility
!
widthOf:aString inFont:aFontId
"return the width in pixels of a string in a specific font"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'grabbing '!
activeKeyboardGrab
"return the view, which currently has the keyboard grabbed,
or nil, if there is none"
^ activeKeyboardGrab
!
activePointerGrab
"return the view, which currently has the pointer grabbed,
or nil, if there is none"
^ activePointerGrab
!
grabKeyboardIn:aWindowId
"grab the keyboard - all keyboard input will be sent to the view
with id aWindowId"
^ self subclassResponsibility
!
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
!
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
!
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
!
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
!
setActivePointerGrab:aView
"DO NOT USE. private kludge - will vanish"
activePointerGrab := aView
!
ungrabKeyboard
"release the keyboard"
^ self subclassResponsibility
!
ungrabPointer
"release the pointer"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'graphic context stuff'!
noClipIn:aGCId
"disable clipping rectangle"
^ self subclassResponsibility
!
setBackground:bgColorIndex in:aGCId
"set background color to be drawn with"
^ self subclassResponsibility
!
setBitmapMask:aBitmapId in:aGCId
"set or clear the drawing mask - a bitmap mask using current fg/bg"
^ self subclassResponsibility
!
setClipByChildren:aBool in:aGCId
"enable/disable drawing into child views"
^ self subclassResponsibility
!
setClipX:clipX y:clipY width:clipWidth height:clipHeight in:aGCId
"clip to a rectangle"
^ self subclassResponsibility
!
setFont:aFontId in:aGCId
"set font to be drawn in"
^ 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
!
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
!
setForeground:fgColorIndex in:aGCId
"set foreground color to be drawn with"
^ self subclassResponsibility
!
setFunction:aFunctionSymbol in:aGCId
"set alu function to be drawn with"
^ self subclassResponsibility
!
setGraphicsExposures:aBoolean in:aGCId
"set or clear the graphics exposures flag"
^ self subclassResponsibility
!
setLineWidth:aNumber style:lineStyle cap:capStyle join:joinStyle in:aGCId
"set line attributes"
^ self subclassResponsibility
!
setMaskOriginX:orgX y:orgY in:aGCid
"set the mask origin"
^ self subclassResponsibility
!
setPixmapMask:aPixmapId in:aGCId
"set or clear the drawing mask - a pixmap mask providing full color"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'initialize / release'!
close
"close down connection to Display - usually never done"
^ self subclassResponsibility
!
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
!
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
"
!
invalidateConnection
"clear my connection handle - sent after an imageRestart to
forget about our previous life"
displayId := nil
"Modified: 24.4.1996 / 19:38:46 / cg"
!
reinitialize
"reinit after snapin"
|prevKnownViews prevMapping prevWidth prevHeight|
Font flushDeviceFontsFor:self.
displayId := nil.
dispatching := false.
dispatchProcess := nil.
prevWidth := width.
prevHeight := height.
"/ 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"
AbortSignal catch:[
aView reinitialize
]
]
].
(prevWidth ~~ width
or:[prevHeight ~~ height]) ifTrue:[
"
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.
"Modified: 6.3.1996 / 16:36:17 / cg"
! !
!DeviceWorkstation methodsFor:'interactive queries'!
originFromUser:extent
"let user specify a rectangles origin on the screen, return the rectangle.
Start with initialRectangle.
Can be used for dragging operations."
|curs origin root rect|
curs := Cursor origin on:self.
"
just in case; wait for button to be down ...
"
[self leftButtonPressed] whileFalse:[Processor yield].
root := self rootView.
"
grab and wait for leftButton being pressed
"
origin := self pointerPosition.
root noClipByChildren.
root foreground:Color black background:Color white.
root xoring:[
|left right top bottom newOrigin newCorner p|
rect := origin extent:extent.
root displayRectangle:rect.
self
grabPointerIn:root id
withCursor:curs id
pointerMode:#async
keyboardMode:#sync
confineTo:nil.
[self leftButtonPressed] whileTrue:[
newOrigin := self pointerPosition.
(newOrigin ~= origin) ifTrue:[
root displayRectangle:rect.
self
grabPointerIn:root id
withCursor:curs id
pointerMode:#async
keyboardMode:#sync
confineTo:nil.
rect := newOrigin extent:extent.
root displayRectangle:rect.
self disposeButtonEventsFor:nil.
self flush.
origin := newOrigin.
] ifFalse:[
Processor yield
]
].
root displayRectangle:rect.
self ungrabPointer.
].
self ungrabPointer.
"flush all events pending on my display"
root clipByChildren.
self flush.
self disposeButtonEventsFor:nil.
^ rect
"
Display originFromUser:200@200
"
!
pointFromUser
"let user specify a point on the screen (by pressing the left button)"
^ self pointFromUserShowing:(Cursor crossHair).
"
Display pointFromUser
"
!
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.
"
wait for leftButton ...
"
[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 pointFromUserShowing:(Cursor origin)
Display pointFromUser
"
!
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
"
!
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 origin corner root rect|
curs1 := 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:curs1 id
pointerMode:#async
keyboardMode:#sync
confineTo:nil.
"
just in case; wait for button to be down ...
"
[self leftButtonPressed] whileFalse:[Processor yield].
[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.
] ifFalse:[
Processor yield
]
].
root displayRectangle:rect.
self ungrabPointer.
].
self ungrabPointer.
"flush all events pending on my display"
root clipByChildren.
self flush.
self disposeButtonEventsFor:nil.
^ rect
"
Display rectangleFromUser:(100@100 corner:300@300)
"
!
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
"
!
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]
"
!
viewIdFromUser
"let user specify a view on the screen, return its window id.
This works even for non smalltalk views.
This returns the id of the view being clicked in,
which is not always a topView."
^ self viewIdFromPoint:(self pointFromUser)
"
Display viewIdFromUser
"
"Created: 18.9.1995 / 23:07:20 / claus"
! !
!DeviceWorkstation methodsFor:'keyboard mapping'!
altModifiers
"Return the set of keys which are treated as Alt-keys.
This set is initialized at startup from what the server thinks
are alt-keys."
^ altModifiers
"
Display altModifiers
"
"Created: 2.1.1996 / 14:57:13 / cg"
"Modified: 2.1.1996 / 15:01:54 / cg"
!
altModifiers:arrayOfAltModifierKeys
"Change the set of keys which are treated as Alt-keys."
altModifiers := arrayOfAltModifierKeys
"Created: 2.1.1996 / 14:58:24 / cg"
!
metaModifiers
"Return the set of keys which are treated as Meta-keys (i.e. Cmd-keys).
This set is initialized at startup from what the server thinks
are meta-keys."
^ metaModifiers
"
Display metaModifiers
"
"Created: 2.1.1996 / 14:57:35 / cg"
"Modified: 2.1.1996 / 15:02:00 / cg"
!
metaModifiers:arrayOfMetaModifierKeys
"Change the set of keys which are treated as Meta-keys (i.e. Cmd keys)."
metaModifiers := arrayOfMetaModifierKeys
"Created: 2.1.1996 / 14:58:41 / cg"
!
modifierKeyProcessing:key down:pressed
"internal, private method.
Called with every keyPress/keyRelease to update the xxxDown flags."
(altModifiers notNil and:[altModifiers includes:key]) ifTrue:[
altDown := pressed
] ifFalse:[
(metaModifiers notNil and:[metaModifiers includes:key]) ifTrue:[
metaDown := pressed
] ifFalse:[
(shiftModifiers notNil and:[shiftModifiers includes:key]) ifTrue:[
shiftDown := pressed
] ifFalse:[
(ctrlModifiers notNil and:[ctrlModifiers includes:key]) ifTrue:[
ctrlDown := pressed
]
]
]
]
"Modified: 2.1.1996 / 15:00:25 / cg"
!
modifierKeyTopFor:key
"reverse translation for a modifier key
(i.e. to get the keyTop from a modifier)"
|t modifiers|
key == #Alt ifTrue:[
modifiers := altModifiers
] ifFalse:[
key == #Cmd ifTrue:[
modifiers := metaModifiers
]
].
(modifiers size > 0) ifTrue:[
t := modifiers first.
(t includes:$_) ifTrue:[
t := t copyTo:(t indexOf:$_)-1
].
^ t
].
^ key
"Created: 28.2.1996 / 17:07:08 / cg"
"Modified: 20.3.1996 / 17:03:39 / cg"
!
modifierKeyTranslationFor:untranslatedKey
"map possible modifiers to a smaller set of common symbols.
Especially, left/right keys are mapped to a common one."
"should this come from a configurable variable ?"
(untranslatedKey == #Control
or:[untranslatedKey == #'Control_L'
or:[untranslatedKey == #'Control_R']]) ifTrue:[
^ #Ctrl
].
(untranslatedKey == #'Shift'
or:[untranslatedKey == #'Shift_L'
or:[untranslatedKey == #'Shift_R']]) ifTrue:[
^ #Shift
].
(untranslatedKey == #'Alt'
or:[untranslatedKey == #'Alt_L'
or:[untranslatedKey == #'Alt_R']]) ifTrue:[
^ #Alt
].
(untranslatedKey == #'Meta'
or:[untranslatedKey == #'Meta_L'
or:[untranslatedKey == #'Meta_R']]) ifTrue:[
^ #Meta
].
(untranslatedKey == #'Cmd'
or:[untranslatedKey == #'Cmd_L'
or:[untranslatedKey == #'Cmd_R']]) ifTrue:[
^ #Cmd
].
^ nil
"Created: 28.2.1996 / 16:40:46 / cg"
"Modified: 28.2.1996 / 17:11:34 / cg"
!
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 many systems, no separate Cmd (or Meta)
key exists; on those we always get AltX if the metaModifiers are not set correctly).
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 s modifier|
xlatedKey := untranslatedKey.
modifier := self modifierKeyTranslationFor:untranslatedKey.
"/
"/ only prepend, if this is not a modifier
"/
modifier isNil ifTrue:[
s := xlatedKey asString.
ctrlDown ifTrue:[
xlatedKey := 'Ctrl' , s
].
metaDown ifTrue:[
xlatedKey := 'Cmd' , s
].
altDown ifTrue:[
xlatedKey := 'Alt' , s
].
xlatedKey isCharacter ifFalse:[
xlatedKey := xlatedKey asSymbol
].
].
xlatedKey := keyboardMap valueFor:xlatedKey.
xlatedKey isCharacter ifFalse:[
xlatedKey := xlatedKey asSymbol
].
^ xlatedKey
"Modified: 28.2.1996 / 17:12:16 / cg"
! !
!DeviceWorkstation methodsFor:'keyboard queries'!
altDown
"return true, if the alt-key is currently pressed."
^ altDown
!
ctrlDown
"return true, if the control-key is currently pressed."
^ ctrlDown
!
metaDown
"return true, if the meta-key (alt-key on systems without meta)
is currently pressed."
^ metaDown
!
shiftDown
"return true, if the shift-key is currently pressed."
^ shiftDown
! !
!DeviceWorkstation methodsFor:'misc'!
beep
"output an audible beep or bell"
Stdout nextPut:(Character bell)
!
buffered
"buffer drawing - do not send it immediately to the display.
This is the default; see comment in #unBuffered."
^ self
!
compressMotionEvents:aBoolean
"turn on/off motion event compression
- compressions makes always sense except in free-hand drawing of curves"
motionEventCompression := aBoolean
!
flush
"send all buffered drawing to the display.
This used to be called #synchronizeOutput, but has been renamed
for ST-80 compatibility."
^ self
!
ringBell
"alias for beep; for ST-80 compatibility"
self beep
!
setInputFocusTo:aWindowId
^ self subclassResponsibility
!
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
!
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
! !
!DeviceWorkstation methodsFor:'pointer queries'!
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
!
leftButtonPressed
"return true, if the left button is currently pressed"
^ (self buttonStates bitAnd:self leftButtonStateMask) ~~ 0
!
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
!
middleButtonPressed
"return true, if the middle button is currently pressed"
^ (self buttonStates bitAnd:self middleButtonStateMask) ~~ 0
!
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
!
pointerPosition
"return the current pointer position in root-window coordinates.
Must be redefined by concrete subclasses."
^ self subclassResponsibility
!
rightButtonPressed
"return true, if the right button is currently pressed"
^ (self buttonStates bitAnd:self rightButtonStateMask) ~~ 0
!
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
!
rootPositionOfLastEvent
"return the position in root-window coordinates
of the last button, key or pointer event.
Must be redefined by concrete subclasses."
^ self subclassResponsibility
! !
!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:'retrieving pixels'!
getPixelX:x y:y from:aDrawableId
"return the pixel value at x/y"
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'view registration'!
addKnownView:aView withId:aWindowID
"add the View aView with id:aWindowID 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:aWindowID.
"/ dispatching ifFalse:[
"/ self startDispatch
"/ ].
"Modified: 22.12.1995 / 22:46:09 / cg"
!
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.
self checkForEndOfDispatch.
]
]
!
update:something
"this is obsolete - it will be removed"
|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.
].
]
].
]
"Modified: 24.4.1996 / 19:39:46 / cg"
!
viewFromId:aWindowID
"given an Id, return the corresponding view."
|index|
"/ ^ idToViewMapping at:aNumber ifAbsent:[nil].
index := knownIds indexOf:aWindowID.
index == 0 ifTrue:[^ nil].
^ knownViews at:index.
! !
!DeviceWorkstation methodsFor:'window stuff'!
clearRectangleX:x y:y width:width height:height in:aWindowId
"clear a rectangular area of a window to its view background"
^ self subclassResponsibility
!
clearWindow:aWindowId
"clear a windows to its view background"
^ self subclassResponsibility
!
lowerWindow:aWindowId
"lower a window"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:40:04 / cg"
!
mapView:aView id:aWindowId iconified:aBoolean atX:xPos y:yPos width:w height:h
"map a window = possibly iconified at some position"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:43:17 / cg"
!
mapWindow:aWindowId
"map a window"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:43:06 / cg"
!
moveResizeWindow:aWindowId x:x y:y width:w height:h
"move & resize a window"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:40:31 / cg"
!
moveWindow:aWindowId x:x y:y
"move a window"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:40:36 / cg"
!
raiseWindow:aWindowId
"raise a window"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:40:42 / cg"
!
resizeWindow:aWindowId width:w height:h
"resize a window"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:40:47 / cg"
!
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"
!
setBackingStore:how in:aWindowId
"turn on/off backing-store for a window"
^ self subclassResponsibility
!
setCursor:aCursorId in:aWindowId
"set a windows visible shape"
^ self subclassResponsibility
!
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"
!
setIconName:aString in:aWindowId
"set a windows icon name"
^ 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
!
setWindowBorderShape:aPixmapId in:aWindowId
"set a windows border shape"
^ self subclassResponsibility
!
setWindowBorderWidth:aNumber in:aWindowId
"set a windows border width"
^ self subclassResponsibility
!
setWindowIcon:aForm in:aWindowId
"set a windows icon"
^ self subclassResponsibility
!
setWindowIconWindow:aView in:aWindowId
"set a windows icon window"
^ self subclassResponsibility
!
setWindowName:aString in:aWindowId
"set a windows name"
^ self subclassResponsibility
!
setWindowShape:aPixmapId in:aWindowId
"set a windows visible shape"
^ self subclassResponsibility
!
unmapWindow:aWindowId
"unmap a window"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:42:39 / cg"
! !
!DeviceWorkstation class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libview/DeviceWorkstation.st,v 1.92 1996-05-28 16:27:48 cg Exp $'
! !
DeviceWorkstation initialize!