"
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.
"
HostGraphicsDevice subclass:#DeviceWorkstation
instanceVariableNames:'visualType monitorType depth ncells bitsPerRGB bitsRed bitsGreen
bitsBlue redMask greenMask blueMask redShift greenShift blueShift
hasColors hasGreyscales width height widthMM heightMM
resolutionHor resolutionVer idToTableIndexMapping knownViews
knownIds knownBitmaps knownBitmapIds dispatching dispatchProcess
exitOnLastClose ctrlDown shiftDown metaDown altDown
motionEventCompression lastId lastView keyboardMap rootView
isSlow activeKeyboardGrab activePointerGrab buttonTranslation
multiClickTimeDelta altModifiers metaModifiers ctrlModifiers
shiftModifiers supportsDeepIcons preferredIconSize ditherColors
fixColors numFixRed numFixGreen numFixBlue fixGrayColors
copyBuffer lastCopyBuffer blackColor whiteColor focusMode
activeView clipBoardEncoding focusView deviceErrorSignal
deviceIOErrorSignal'
classVariableNames:'ButtonTranslation MultiClickTimeDelta DeviceErrorSignal
DeviceIOErrorSignal DeviceIOTimeoutErrorSignal ErrorPrinting
DefaultScreen AllScreens CurrentScreenQuerySignal
LastActiveScreen LastActiveProcess NoBeep
WindowsRightButtonBehavior 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
idToTableIndexMapping <Dictionary> maps view-ids to views
knownViews <WeakArray> all of my known views
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
exitDispatchOnLastWindowClose
<Boolean> if true, dispatch is finished when the last
window closes (default:true).
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.
focusMode <Symbol> nil, #pointer or #activeWindow
activeWindow <View> WINDOWS only: the currently active (foreground) view
clipBoardEncoding
<Symbol> encoding of pasted clipBoard text;
nil means: iso8859.
set this to #shiftJis, if pasting
SJIS text (for example, from netscape)
Some systems pass encoding information
in the clipBoard - there, this is not
needed.
[class variables:]
MultiClickTimeDelta in ms; controls how long of a delay is
required between two clicks, to NOT take
it as a multi-click.
ErrorPrinting controls low-level (X-) error message printing
AllScreens a collectin of known screens
[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 twoconcrete display classes (released to the public):
XWorkstation - a plain X window interface
GLXWorkstation - an X window interface with a GL(tm) (3D graphic library)
extension; either simulated (VGL) or a real GL
(real GL is only available on SGI machines)
the following are coming soon:
OpenGLWorkstation
- an X window interface with a openGL(tm) (3D graphic library)
extension; either simulated (MESA) or a real openGL
(real openGL is only available on SGI/NT machines)
WinWorkstation - what will that be ?
An experimental version for a NeXTStep interface exists, but is currently
no longer maintained and not released.
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 subclassResponsibility-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.
Multiple display operation 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).
or:
Smalltalk at:#Display2 put:(GLXWorkstation new).
- have it connect to the display (i.e. the xServer):
(replace 'localhost' below with the name of your display)
Display2 := Display2 initializeFor:'localhost: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
does not work with Launcher, since its an ApplicationModel (not a view)
use:
Launcher openOnDevice:Display2
instead.
However, as mentioned above, there may be a few places, where the default
display 'Display' is still hard-coded - especially, in contributed and
Public domain code, you may find those.
Beside this (little bug ;-), remote display operation works pretty well.
If you write your application to work around those, multi-display applications are
possible in the current release (and actually being used in a concrete application,
where up to 6 x-terminals are connected to a single linux PC).
To make your application ready for multi-display operation, replace all
references to 'Display' by: 'Screen current', which evaluates to the currently
active display. I.e. each view gets its actual display via this expression.
Since ST/X views already use this, new views opened by remote views should
come up on the remote display.
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'.
Finally, your application should care for I/O errors (i.e. lost connection when
a remote display is switched off).
The framework provides per-display signals, which are raised in the corresponding
event dispatchers context.
For a save environment, you should add static exception handler blocks on those
signals; i.e. the setup for remote displays should look somewhat like:
|newDpy|
newDpy := GLXWorkstation new.
newDpy := newDpy initializeFor:'localhost:0.0'.
newDpy isNil ifTrue:[
self warn:'cannot connect ...'.
] ifFalse:[
newDpy deviceIOErrorSignal handlerBlock:[:ex |
Transcript beep.
Transcript showCR:'Display (' , newDpy displayName , '): connection broken.'.
AbortSignal raise.
].
newDpy startDispatch.
Launcher openOnDevice:newDpy.
].
There may 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).
This may be fixed in a future version ...
"
! !
!DeviceWorkstation class methodsFor:'initialization'!
initialize
"create local error signals; enable errorPrinting"
DeviceErrorSignal isNil ifTrue:[
DeviceErrorSignal := (Signal new) mayProceed:true.
DeviceErrorSignal notifierString:'device error'.
DeviceErrorSignal nameClass:self message:#deviceErrorSignal.
DeviceIOErrorSignal := (Signal new) mayProceed:false.
DeviceIOErrorSignal notifierString:'device IO error'.
DeviceIOErrorSignal nameClass:self message:#deviceIOErrorSignal.
DeviceIOTimeoutErrorSignal := DeviceIOErrorSignal newSignalMayProceed:false.
DeviceIOTimeoutErrorSignal notifierString:'device IO timeout error'.
DeviceIOTimeoutErrorSignal nameClass:self message:#deviceIOTimeoutErrorSignal.
CurrentScreenQuerySignal := QuerySignal new.
CurrentScreenQuerySignal nameClass:self message:#currentScreenQuerySignal.
CurrentScreenQuerySignal notifierString:'asking for current screen'.
].
ErrorPrinting := true.
self initializeConstants.
"Modified: 3.8.1997 / 18:14:58 / cg"
!
initializeConstants
"initialize some (soft) constants"
MultiClickTimeDelta := 300. "a click within 300ms is considered a double one"
ButtonTranslation := #(1 2 3) "identity translation"
!
nativeWindows:aBoolean
"enable / disable use of native windows - dummy here."
! !
!DeviceWorkstation class methodsFor:'Signal constants'!
currentScreenQuerySignal
"return the signal which can be used to provide a current
screen (if background processes ask for one)"
^ CurrentScreenQuerySignal
"Created: 15.2.1997 / 15:07:20 / cg"
!
deviceErrorSignal
"return the signal used for device error reporting.
In multi-display configurations, this is the parent of
all per-instance deviceErrorSignals."
^ DeviceErrorSignal
!
deviceIOErrorSignal
"return the signal used for device I/O error reporting.
In multi-display configurations, this is the parent of
all per-instance deviceIOErrorSignals."
^ DeviceIOErrorSignal
!
deviceIOTimeoutErrorSignal
"return the signal used for device I/O timeout error reporting.
In multi-display configurations, this is the parent of
all per-instance deviceIOTimeoutErrorSignals."
^ DeviceIOTimeoutErrorSignal
! !
!DeviceWorkstation class methodsFor:'accessing'!
activateOnClick:aBoolean
"now obsolete - it became an instance message"
Display isNil ifTrue:[ ^ false].
^ Display activateOnClick:aBoolean
!
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
or
XError->errorInterrupt:#DisplayIOError->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.
However, io-errors are always delivered as a signal raise."
|badId badResource msg theDevice theSignal p|
'DevWorkst [info]: errorInterrupt: ' infoPrint. errID infoPrintCR.
errID notNil ifTrue:[
"/
"/ timeoutError passes the device;
"/ the others pass the devicesID
"/
errID == #DisplayIOTimeoutError ifTrue:[
theDevice := aParameter.
"/ 'device tiomeout error' printCR.
] ifFalse:[
AllScreens do:[:aDisplayDevice |
aDisplayDevice id = aParameter ifTrue:[
theDevice := aDisplayDevice.
]
]
]
].
"/ now, we have the bad guy at hand ...
"/ get a per-instance signal.
theDevice isNil ifTrue:[
errID == #DisplayIOError ifTrue:[
theSignal := self deviceIOErrorSignal.
] ifFalse:[
errID == #DisplayIOTimeoutError ifTrue:[
theSignal := self deviceIOTimeoutErrorSignal
] ifFalse:[
theSignal := self deviceErrorSignal
]
]
] ifFalse:[
errID == #DisplayIOError ifTrue:[
theSignal := theDevice deviceIOErrorSignal.
] ifFalse:[
errID == #DisplayIOTimeoutError ifTrue:[
theSignal := theDevice deviceIOTimeoutErrorSignal
] ifFalse:[
theSignal := theDevice deviceErrorSignal
]
]
].
errID == #DisplayIOError ifTrue:[
"/ always raises an exception
msg := 'Display I/O Error'.
badResource := theDevice.
] ifFalse:[
errID == #DisplayIOTimeoutError ifTrue:[
"/ always raises an exception for the current process
msg := 'Display I/O timeout Error'.
badResource := theDevice.
] ifFalse:[
"/ only raises an exception if handled
"/ that will become instance-specific information in
"/ the near future ...
badId := self resourceIdOfLastError.
badId ~~ 0 ifTrue:[
badResource := self resourceOfId:badId.
].
msg := 'Display error: ' , (self lastErrorString).
theSignal isHandled ifFalse:[
ErrorPrinting ifTrue:[
('DeviceWorkstation [error]: ' , msg) errorPrintCR
].
^ self
]
].
].
"/ interrupt that displays dispatch process
"/ and force it to shutdown
theDevice notNil ifTrue:[
errID ~~ #DisplayIOTimeoutError ifTrue:[
p := theDevice dispatchProcess.
(p notNil and:[p ~~ Processor activeProcess]) ifTrue:[
'DeviceWorkstation [info]: interrupting: ' infoPrint. p displayString infoPrintCR.
p interruptWith:[
'broken connection' infoPrintCR.
theDevice brokenConnection.
theSignal raiseRequestWith:badResource errorString:msg.
p terminateWithAllSubprocesses.
p terminateNoSignal. "/ just in case
].
Processor reschedule.
AbortSignal raise.
].
].
"/ 'broken connection' printCR.
theDevice brokenConnection.
].
'DeviceWorkstation [info]: interrupting current process: ' infoPrint.
Processor activeProcess displayString infoPrintCR.
theSignal
raiseRequestWith:badResource
errorString:msg.
AbortSignal raise.
"Modified: 11.4.1997 / 11:28:27 / 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 allInstancesDo:[:f |
f id == id ifTrue:[^ f]
].
self allInstancesDo:[: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 allInstancesDo:[:c |
c colorId == id ifTrue:[^ c]
].
Font allInstancesDo:[: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: 18.8.1997 / 18:43:42 / 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 ... the default display is returned in this case."
|wg dev thisProcess|
"/
"/ if there is only one screen,
"/ take that ... it ought to be display
"/
AllScreens size <= 1 ifTrue:[
^ Display
].
"/
"/ someone willing to tell me ?
"/
(dev := CurrentScreenQuerySignal query) notNil ifTrue:[
^ dev
].
thisProcess := Processor activeProcess.
LastActiveScreen notNil ifTrue:[
LastActiveProcess == thisProcess ifTrue:[
^ LastActiveScreen
]
].
"/
"/ mhmh - multiple screens are active;
"/ look for the active windowGroups screen.
"/ 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 ...
"/
(dev := wg graphicsDevice) notNil ifTrue:[
LastActiveScreen := dev.
LastActiveProcess := thisProcess.
^ dev
].
].
"/
"/ in all other cases, return the default display
"/
'DevWorkstation [info]: cannot figure out current screen - use default' infoPrintCR.
^ Display
"
Screen current
"
"Modified: / 1.9.1995 / 13:40:05 / claus"
"Modified: / 7.2.1997 / 16:16:58 / cg"
"Modified: / 18.3.1999 / 18:20:39 / stefan"
!
currentWindow
"Return the currently active window,
that is, the topView of the currently executing windowGroup"
|wg|
wg := WindowGroup activeGroup.
wg notNil ifTrue:[^ wg topViews first].
^ nil
"
Screen currentWindow
"
"Modified: / 1.9.1995 / 13:40:05 / claus"
"Modified: / 7.2.1997 / 16:16:58 / cg"
"Created: / 14.11.1997 / 21:52:24 / 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
on the (main) Display connection.
(standAlone applications will set it)"
"/ here, a separate class variable is used, since this may have
"/ to be set at init-time, when no display instance exists yet.
"/ For all other (non-main-Display) connections, an instVar is used.
ExitOnLastClose := aBoolean
"Modified: 23.4.1996 / 22:01:28 / cg"
! !
!DeviceWorkstation methodsFor:'ST-80 compatibility'!
colorDepth
"alias for depth - for ST-80 compatibility"
^ self depth
!
zoom:startRect to:endRect
"animate a rubber-rectangle from startRect to endRect.
Can be used by buttons, which open some dialog for nicer user feedback.
Notice: since the displays window manager typically allows a topWindow
to be placed by the user, this should not be used for modeless
topViews.
"
^ self
zoom:startRect to:endRect duration:0.3
"
Screen current zoom:(10@10 corner:20@20) to:(20@20 corner:1000@1000)
Screen current zoom:(20@20 corner:1000@1000) to:(10@10 corner:20@20)
"
"Modified: 27.1.1997 / 18:20:11 / cg"
!
zoom:startRect to:endRect duration:milliseconds
"animate a rubber-rectangle from startRect to endRect.
Can be used by buttons, which open some dialog for nicer user feedback.
Notice: since the displays window manager typically allows a topWindow
to be placed by the user, this should not be used for modeless
topViews.
"
|steps dExt dOrg org ext root|
root := self rootView.
steps := 10.
dExt := (endRect extent - startRect extent) / steps.
dOrg := (endRect origin - startRect origin) / steps.
0 to:steps do:[:step |
org := (startRect origin + (dOrg * step)) rounded.
ext := (startRect extent + (dExt * step)) rounded.
rootView clippedByChildren:false.
rootView xoring:[
rootView displayRectangleX:org x y:org y width:ext x height:ext y
].
Delay waitForMilliseconds:(milliseconds // steps).
rootView xoring:[
rootView displayRectangleX:org x y:org y width:ext x height:ext y
].
].
rootView clippedByChildren:true.
"
Screen current zoom:(10@10 corner:20@20) to:(20@20 corner:1000@1000) duration:1000
Screen current zoom:(20@20 corner:1000@1000) to:(10@10 corner:20@20) duration:1000
"
"Created: 27.1.1997 / 18:19:35 / cg"
!
zoom:startRect to:endRect speed:pixelsPerSecond
"animate a rubber-rectangle from startRect to endRect.
Can be used by buttons, which open some dialog for nicer user feedback.
The speed is computed for the longest edge to run at the given speed.
Notice: since the displays window manager typically allows a topWindow
to be placed by the user, this should not be used for modeless
topViews.
"
|maxDistance|
maxDistance := (endRect origin - startRect origin).
maxDistance := maxDistance max:(endRect topRight - startRect topRight).
maxDistance := maxDistance max:(endRect bottomLeft - startRect bottomLeft).
maxDistance := maxDistance max:(endRect corner - startRect corner).
maxDistance := maxDistance x max:(maxDistance y).
^ self
zoom:startRect to:endRect duration:(maxDistance / pixelsPerSecond * 1000)
"
Screen current zoom:(10@10 corner:20@20) to:(20@20 corner:1000@1000) speed:1000
Screen current zoom:(20@20 corner:1000@1000) to:(10@10 corner:20@20) speed:2000
"
"Created: 27.1.1997 / 18:19:35 / cg"
"Modified: 27.1.1997 / 18:24:58 / cg"
! !
!DeviceWorkstation methodsFor:'Signal constants'!
deviceErrorSignal
"return the per-device signal, which is used for error reporting.
The default here is the global DeviceErrorSignal
(which is the parent of any per-instance error signals)."
deviceErrorSignal notNil ifTrue:[^ deviceErrorSignal].
^ self class deviceErrorSignal
!
deviceIOErrorSignal
"return the signal used for device I/O error reporting.
The default here is the global DeviceIOErrorSignal
(which is the parent of any per-instance I/O error signals)."
deviceIOErrorSignal notNil ifTrue:[^ deviceIOErrorSignal].
^ self class deviceIOErrorSignal
!
deviceIOTimeoutErrorSignal
"return the signal used for device I/O timeout error reporting.
The default here is the global DeviceIOTimeoutErrorSignal
(which is the parent of any per-instance I/O timeout signals)."
^ self class deviceIOTimeoutErrorSignal
! !
!DeviceWorkstation methodsFor:'Squeak compatibility'!
border:aRectangle width:bw
"draw a rectangular border on the display with black.
Added to allow for some squeak examples to be evaluated ..."
|r|
rootView clippedByChildren:false.
rootView paint:Color black.
r := aRectangle.
0 to:bw-1 do:[:i |
rootView displayRectangle:r.
r := r insetBy:1.
].
rootView clippedByChildren:true.
"
Display restoreAfter:[
Display border:(10@10 corner:100@100) width:2.
]
"
"Modified: 15.10.1997 / 19:23:28 / cg"
!
cursorPoint
^ self pointerPosition
!
displayOpaqueString:s x:x y:y
"draw a string on the display with black.
Added to allow for some squeak examples to be evaluated ..."
rootView clippedByChildren:false.
rootView paint:Color black.
rootView displayOpaqueString:s x:x y:y.
rootView clippedByChildren:true.
"
Display restoreAfter:[
Display displayOpaqueString:'hello' x:10 y:10.
]
"
"Created: 15.10.1997 / 19:25:09 / cg"
"Modified: 15.10.1997 / 19:29:05 / cg"
!
displayString:s x:x y:y
"draw a string on the display with black.
Added to allow for some squeak examples to be evaluated ..."
rootView clippedByChildren:false.
rootView paint:Color black.
rootView displayString:s x:x y:y.
rootView clippedByChildren:true.
"
Display restoreAfter:[
Display displayString:'hello' x:10 y:10.
]
"
"Modified: 15.10.1997 / 19:29:10 / cg"
!
fillWhite:aRectangle
"fill a rectangular area on the display with white.
Added to allow for some squeak examples to be evaluated ..."
|oldPaint|
oldPaint := rootView paint.
rootView clippedByChildren:false.
rootView paint:Color white.
rootView fillRectangle:aRectangle.
rootView clippedByChildren:true.
rootView paint:oldPaint.
"
Display restoreAfter:[
Display fillWhite:(10@10 corner:100@100)
]
"
"Modified: 15.10.1997 / 19:28:17 / cg"
!
restoreAfter:aBlock
"evaluate aBlock, wait for a buttonPress, then restore the display.
Added to allow for some squeak examples to be evaluated ..."
aBlock value.
[self anyButtonPressed] whileFalse:[].
self restoreWindows.
"
Display restoreAfter:[Display fillWhite:(10@10 corner:100@100)]
"
"Modified: 15.10.1997 / 19:43:08 / cg"
!
supportsDisplayDepth:givenDepth
"return true, if the given depth is supported by the display.
(Actually, some displays support multiple depths (i.e. visuals),
but for now, we want the displays native depth here."
^ depth == givenDepth
! !
!DeviceWorkstation methodsFor:'accessing & queries'!
activateOnClick:aBoolean
"enable/disable raise&activate on click;
return the previous setting.
This may be left unimplemented by a device."
^ false
"Created: / 2.10.1998 / 01:07:51 / cg"
!
activeView
^ activeView
!
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
!
isOpen
"return true, if there is a valid connection to the display.
Added for ST-80 compatibility."
^ displayId notNil
"Created: 27.1.1997 / 18:28:30 / cg"
!
knownViews
"return a (non-weak) collection of all known views"
|views|
knownViews size == 0 ifTrue:[^ #()].
views := IdentitySet new.
knownViews validElementsDo:[:v | views add:v].
^ views
"Modified: 23.1.1997 / 21:25:51 / cg"
!
knownViews:aCollection
"set the collection of all known views - take care,
bad use of this will create funny results; use only for snapshot support"
idToTableIndexMapping := nil.
knownViews := aCollection.
!
mayOpenDebugger
"return true, if a debugger may open on this workstation;
if false, the debugger opens on the main display.
This should be made a variable ..."
^ true
!
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 onDevice:self
].
^ rootView
"
|v|
v := Display rootView.
v paint:Color red.
v clippedByChildren:false.
v fillRectangleX:10 y:10 width:100 height:100.
"
!
suppressShadowViews
"return true, if this device wants to suppress shadow views
(i.e. shadows under popups and modalBoxes).
Some (slow) devices may want to return true here"
^ false
!
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 blue component."
bitsBlue isNil ifTrue:[
"/ not a truecolor display
^ bitsPerRGB
].
^ bitsBlue
"
Display bitsBlue
"
"Created: 21.10.1995 / 00:45:27 / cg"
"Modified: 16.4.1997 / 15:00:53 / cg"
!
bitsGreen
"return the number of valid bits in the green component."
bitsGreen isNil ifTrue:[
"/ not a truecolor display
^ bitsPerRGB
].
^ bitsGreen
"
Display bitsGreen
"
"Created: 21.10.1995 / 00:45:11 / cg"
"Modified: 16.4.1997 / 15:01:02 / 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"
!
blackColor
"return the black color on this device.
This is the same as 'Color black on:device', but much faster."
^ blackColor
"Created: 13.1.1997 / 22:37:05 / cg"
"Modified: 13.1.1997 / 22:43:19 / cg"
!
blackpixel
"return the colorId of black"
visualType == #TrueColor ifTrue:[^ 0].
^ self subclassResponsibility
!
blueMask
"return a mask, which extracts the blueBits from a color id.
This only makes sense with trueColor displays;
therefore, 0 is returned on all others."
^ blueMask
"
Display blueMask
"
"Modified: 21.10.1995 / 00:47:58 / cg"
"Created: 24.7.1996 / 13:25:21 / cg"
!
depth
"return the depth in pixels of the display"
^ depth
"
Display depth
"
!
focusMode
^ focusMode
!
greenMask
"return a mask, which extracts the greenBits from a color id.
This only makes sense with trueColor displays;
therefore, 0 is returned on all others."
^ greenMask
"
Display greenMask
"
"Modified: 21.10.1995 / 00:47:58 / cg"
"Created: 24.7.1996 / 13:25:15 / cg"
!
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"
!
redMask
"return a mask, which extracts the redBits from a color id.
This only makes sense with trueColor displays;
therefore, 0 is returned on all others."
^ redMask
"
Display redMask
"
"Created: 21.10.1995 / 00:45:27 / cg"
"Modified: 24.7.1996 / 13:25:08 / 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 green 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: 16.4.1997 / 15:02:37 / 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
]
!
whiteColor
"return the white color on this device.
This is the same as 'Color white on:device', but much faster."
^ whiteColor
"Created: 13.1.1997 / 22:37:10 / cg"
"Modified: 13.1.1997 / 22:43:04 / cg"
!
whitepixel
"return the colorId of white"
visualType == #TrueColor ifTrue:[^ (1 bitShift:depth)-1].
^ 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'
"
!
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 arbitrary shaped windows.
This is obsolete - use #supportsArbitraryShapedViews."
^ self supportsArbitraryShapedViews
"
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)."
|sizes spec sz sz2|
preferredIconSize isNil ifTrue:[
sizes := self iconSizes.
sizes notNil ifTrue:[
spec := sizes first.
"/ we prefer square icons ...
sz := (spec at:#maxWidth) min: (spec at:#maxHeight).
sz > 64 ifTrue:[
sz2 := (spec at:#minWidth) max: (spec at:#minHeight).
sz2 <= 48 ifTrue:[
sz := 48
]
].
preferredIconSize := sz @ sz
].
preferredIconSize isNil ifTrue:[
preferredIconSize := 48@48
].
].
^ preferredIconSize
"
Display preferredIconSize
Display preferredIconSize:32@32
Display preferredIconSize:nil
"
"Modified: 10.6.1996 / 22:10:58 / cg"
!
preferredIconSize:anExtentPoint
"set the preferrered icon size.
By default, the preferredIconSize is queried from the display,
however, some windowManagers return stupid values.
This methods allows overriding thngs from a startup file"
preferredIconSize := anExtentPoint
"
Display preferredIconSize
Display preferredIconSize:32@32
Display preferredIconSize:48@48
"
"Modified: 10.6.1996 / 21:01:50 / cg"
!
scrollsAsynchronous
"return true, if this display asynchronously sends expose events after a
scroll operation. False otherwise. Asynchronous expose events are an X
speciality, which affects a few methods outside of the display class (sorry)"
^ false
!
supportedImageFormatForDepth:aDepth
"given a depth, return the devices image format info,
which provides padding info. If the given depth is not
supported, return nil."
self supportedImageFormats do:[:fmt |
(fmt at:#depth) == aDepth ifTrue:[
^fmt
]
].
^ nil
!
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
!
supportsAnyViewBackgroundPixmaps
"return true, if the device allows any pixmap as
viewBackground. False returned here - redefined in some
device classes."
^ false
"Created: / 4.5.1999 / 18:41:01 / cg"
!
supportsArbitraryShapedViews
"return true, if this workstation supports arbitrary shaped
windows.
Should be reimplemented in concrete classes which do support this."
^ false
"
Display supportsArbitraryShapedViews
"
!
supportsDeepIcons
"return true, if this device supports non b&w (i.e. greyScale
or colored icons). Many Xservers (and/or windowManagers) crash,
if you pass them a deep form as icon; therefore, the default is false.
It may be a good idea to check for the server vendor/release and
return true sometimes.
This flag can be set with #supportsDeepIcons:"
^ supportsDeepIcons
"
Display supportsDeepIcons:true
|v|
v := StandardSystemView new.
v icon:((Image fromFile:'bitmaps/claus.gif') magnifiedTo:68@68).
v open.
"
"Modified: 10.6.1996 / 20:11:48 / cg"
!
supportsDeepIcons:yesOrNo
"set/clear the supportsDeepIcons flag.
Many Xservers (and/or windowManagers) crash,
if you pass them a deep form as icon; therefore, the default is false."
supportsDeepIcons := yesOrNo
"
Display supportsDeepIcons
"
"Created: 10.6.1996 / 19:36:19 / cg"
!
supportsGLDrawing
"return true, if this device supports 3D GL drawing.
We do not depend on that being implemented."
"This method should be reimplemented in concrete display classes."
^ false
"
Display supportsGLDrawing
"
!
supportsIconMasks
"return true, if this device supports masked icons.
Assume true here - to be redefined in concrete classes."
^ true
"
Display supportsIconMasks
"
"Modified: / 28.4.1999 / 19:58:12 / cg"
!
supportsIconViews
"return true, if this device supports views as icons.
Only Xservers (currently) support this."
^ false
"
Display supportsIconViews
"
"Modified: 10.6.1996 / 21:08:04 / cg"
!
supportsMaskedDrawingWith:aForm
"return true, if the device allows the given form pixmap
to be used as paint color.
False returned here, which forces higher level code to
perform the filling manually (by copying the form)
- redefined in most device classes."
^ false
"Created: / 4.5.1999 / 12:16:18 / cg"
"Modified: / 4.5.1999 / 12:58:04 / cg"
!
supportsRoundShapedViews
"return true, if this workstation supports round shaped
(elliptical & circular) windows.
Should be reimplemented in concrete classes which do support this."
^ false
"
Display supportsRoundShapedViews
"
!
supportsViewBackgroundPixmap:aForm
"return true, if the device allows the given pixmap as
viewBackground. If false is returned,
drawing is done by (possibly) slower smalltalk code.
False returned here - redefined in some concrete device classes."
^ false
"Created: / 4.5.1999 / 18:40:25 / cg"
"Modified: / 4.5.1999 / 18:44:41 / cg"
!
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"
!
captionHeight
"return the height in pixels of the caption
(i.e. title bar) of topWindows.
Fallback of 0 (i.e. unknown) is returned here.
Applications should not depend on that returned value
to be exact - on some systems (windowManagers),
its value cannot be retrieved"
^ 0
!
center
"return the centerpoint in pixels of the display"
^ (width // 2) @ (height // 2)
!
drawingResolution
"return a point consisting of the actual drawing resolution
in pixel-per-inch horizontally and vertically.
On screen devices, this is the same as resolution; on postscript
devices, this is usually higher than the coordinate systems unit.
This method is provided for compatibility with postscript media,
to query the device if sub-pixel-coordinate drawing is possible.
(there are a few situations, in which resolution-independ drawing
leads to ugly looking output ... knowing about subPixel resolution
may help there.)"
^ self resolution
"Created: 4.6.1996 / 15:20:43 / cg"
"Modified: 4.6.1996 / 17:56:26 / cg"
!
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"
aNumber > 0 ifTrue:[
heightMM := aNumber.
resolutionVer := nil.
]
"Modified: 10.9.1996 / 14:25:39 / cg"
!
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"
resolutionHor notNil ifTrue:[
^ resolutionHor
].
resolutionHor := (width / widthMM) asFloat.
^ resolutionHor
!
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
!
usableExtent
"return the usable extent of the display (in pixels).
Normally, the same as extent, but may be smaller, in
case some menu space is taken up by the window manager (windows)"
^ width @ height
"
Display extent
Display usableExtent
"
"Modified: 4.8.1997 / 01:40:14 / cg"
!
usableHeight
"returns the usable height of the display (in pixels)
Normally, the same as height, but may be smaller, in
case some menu space is taken up by the window manager (windows)"
^ self usableExtent y
!
usableWidth
"returns the usable width of the display (in pixels)
Normally, the same as width, but may be smaller, in
case some menu space is taken up by the window manager (windows)"
^ self usableExtent x
!
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"
resolutionVer notNil ifTrue:[
^ resolutionVer
].
resolutionVer := (height / heightMM) asFloat.
^ resolutionVer
!
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"
aNumber > 0 ifTrue:[
widthMM := aNumber.
resolutionHor := nil.
].
"Modified: 10.9.1996 / 14:25:27 / cg"
! !
!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
^ 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
!
createWindowFor:aView type:typeSymbol origin:org extent:ext minExtent:minE maxExtent:maxE borderWidth:bw subViewOf:sv style:styleSymbol inputOnly:inp label:label cursor:curs icon:icn iconMask:icnM iconView:icnV
"must be implemented by a concrete class"
^ self subclassResponsibility
!
createWindowFor:aView type:typeSymbol origin:org extent:ext
minExtent:minE maxExtent:maxE borderWidth:bw subViewOf:sv
style:styleSymbol inputOnly:inp
label:label owner:owner
icon:icn iconMask:icnM iconView:icnV
"must be implemented by a concrete class"
^ 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
!
gcForBitmap:aDrawableId
"create a GC for drawing into a bitmap drawable"
^ self subclassResponsibility
!
realRootWindowId
"return the id of the real root window.
This may or may not be the view you see as background,
since some window managers install a virtual root window on top
of the real one. In this case, this method returns the id of the
covered real-root
(in contrast, rootWindowId returns the id of the visible one).
With most window systems, the realRoot is the same as the root window.
The real root is only seldom of any interest."
^ self rootWindowId
"Modified: 14.10.1996 / 22:25:03 / stefan"
!
rootWindowFor:aView
|id|
id := self rootWindowId.
self addKnownView:aView withId:id.
^ id
!
rootWindowId
"return the id of the root window.
This is the window you see as background,
however, it may or may not be the real physical root window,
since some window managers install a virtual root window on top
of the real one. If this is the case, that views id is returned here."
^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'color stuff'!
availableDitherColors
"return the table of preallocated emergency ditherColors
plus possibly available fixColors."
|s|
s := IdentitySet new.
fixColors notNil ifTrue:[
s addAll:fixColors.
].
fixGrayColors notNil ifTrue:[
s addAll:fixGrayColors.
].
ditherColors notNil ifTrue:[
s addAll:ditherColors.
].
^ s asArray
"Created: 11.7.1996 / 18:13:30 / cg"
"Modified: 24.6.1997 / 16:23:50 / cg"
!
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 or nil, if no color cell
can be allocated (out of colors or trueColor device)"
^ nil
!
colorMap
"return my displays colormap, or nil, if the display is not colorMap based
(i.e. not PseudoColor)"
|mapSize "{ Class: SmallInteger }"
depthUsed mapArray|
visualType == #DirectColor ifTrue:[
'DeviceWorkstation [info]: directColor displays not fully supported.' infoPrintCR.
^ nil
].
(visualType == #StaticGray or:[visualType == #TrueColor]) ifTrue:[
"
those have no colorMap - we're done
"
^ nil
].
"
get some attributes of the display device
"
depthUsed := depth.
"/ kludge for 15bit XFree server
"/ (but: I have never encountered a PseudoColor display with more
"/ than 8 bits ...)
depthUsed == 15 ifTrue:[
depthUsed := 16
].
depthUsed > 16 ifTrue:[
"/ do not allocate zillions of colors ...
self error:'unreasonably large colorMap ...'.
^ nil
].
mapSize := (1 bitShift:depthUsed).
"/ get the palette
mapArray := Array new:mapSize.
1 to:mapSize do:[:i |
self getRGBFrom:(i-1) into:[:r :g :b |
mapArray at:i put:(Color red:r green:g blue:b)
]
].
^ mapArray.
"
Display colorMap
"
"Created: 11.7.1996 / 10:53:38 / cg"
"Modified: 10.1.1997 / 15:40:10 / cg"
!
colorRed:redVal green:greenVal blue:blueVal
"allocate a color with rgb values (0..100) - return index"
^ self subclassResponsibility
!
colorScaledRed:red scaledGreen:green scaledBlue:blue
visualType == #TrueColor ifTrue:[
^ (((red bitShift:-8) bitShift:redShift)
bitOr:((green bitShift:-8) bitShift:greenShift))
bitOr:((blue bitShift:-8) bitShift:blueShift)
].
self subclassResponsibility
!
ditherColors
"return the table of preallocated emergency ditherColors"
^ ditherColors
"Modified: 11.7.1996 / 18:13:37 / cg"
!
fixColors
"return the table of preallocated fix colors (a colorCube),
or nil if no fix colors were preallocated."
^ fixColors
"Created: 11.7.1996 / 17:49:24 / cg"
!
fixGrayColors
"return the table of preallocated fix grayScale colors,
or nil if no fix gray colors were preallocated."
^ fixGrayColors
"Created: 11.7.1996 / 17:49:24 / cg"
!
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 r g b|
(colorName startsWith:$#) ifTrue:[
"/ color in r/g/b hex notation
r := Integer readFrom:(colorName copyFrom:2 to:3) radix:16.
g := Integer readFrom:(colorName copyFrom:4 to:5) radix:16.
b := Integer readFrom:(colorName copyFrom:6 to:7) radix:16.
^ aBlock value:(r * 100 / 255)
value:(g * 100 / 255)
value:(b * 100 / 255)
].
names := #(
'red'
'green'
'blue'
'yellow'
'magenta'
'cyan'
'white'
'black'
'olive'
'teal'
'silver'
'lime'
'fuchsia'
'aqua'
).
idx := names indexOf:colorName.
idx == 0 ifTrue:[
idx := names indexOf:colorName asLowercase.
].
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"
( 50 50 0) "olive"
( 0 50 50) "teal"
( 40 40 40) "silver"
( 20 100 0) "lime"
( 60 3 100) "fuchsia"
( 10 100 100) "aqua"
) at:idx.
^ aBlock value:(triple at:1)
value:(triple at:2)
value:(triple at:3)
].
^ nil
"Modified: 18.9.1996 / 12:27:11 / cg"
"Modified: 28.4.1997 / 22:35:55 / dq"
!
getScaledRGBFromName:colorName into:aBlock
"get rgb components (0..16rFFFF) of color named colorName,
and evaluate the 3-arg block, aBlock with them"
self getRGBFromName:colorName into:[:r :g :b |
|sr sg sb|
sr := self percentToDeviceColorValue:r.
sg := self percentToDeviceColorValue:g.
sb := self percentToDeviceColorValue:b.
^ aBlock value:sr value:sg value:sb
]
!
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')
!
numFixBlue
"return the number of blue shades in the
preallocated fix color cube (or 0 if there is none)"
^ numFixBlue
"Created: 11.7.1996 / 17:49:58 / cg"
!
numFixGreen
"return the number of green shades in the
preallocated fix color cube (or 0 if there is none)"
^ numFixGreen
"Created: 11.7.1996 / 17:50:12 / cg"
!
numFixRed
"return the number of red shades in the
preallocated fix color cube (or 0 if there is none)"
^ numFixRed
"Created: 11.7.1996 / 17:50:20 / cg"
!
percentToDeviceColorValue:percent
^ self subclassResponsibility
!
redComponentOfColor:colorId
"get red component (0..100) of color in map at:index"
self getRGBFrom:colorId into:[:r :g :b | ^ r]
!
releaseFixColors
"release the fix colorMap"
fixColors := nil.
numFixRed := numFixGreen := numFixBlue := 0.
"
Display releaseFixColors
"
"Created: 11.7.1996 / 18:00:42 / cg"
"Modified: 23.6.1997 / 15:32:04 / cg"
!
releaseFixGrayColors
"release the fix colorMap"
fixGrayColors := nil.
"
Display releaseFixGrayColors
"
"Created: 23.6.1997 / 15:32:00 / cg"
!
setColor:index red:redVal green:greenVal blue:blueVal
"change color in map at:index to rgb (0..100).
This is a no-op on TrueColor systems."
^ self
!
setDitherColors:colors
"set the table of preallocated emergency dither fix colors
These preallocated colors
(white, black, red, green, blue and a few grayScales) prevent
running out of colors later, when images have to be dithered or
pen colors must be approximated.
((Although, with such a small number of colors, the result will
definitely look poor))"
ditherColors := colors.
"Created: 11.7.1996 / 18:11:45 / cg"
!
setFixColors:colors numRed:nR numGreen:nG numBlue:nB
"set the table of preallocated fix colors (a colorCube),
and the number of r/g/b entries in each dimension."
fixColors := colors.
numFixRed := nR.
numFixGreen := nG.
numFixBlue := nB.
"Created: 11.7.1996 / 17:56:18 / cg"
"Modified: 11.7.1996 / 17:57:10 / cg"
!
setFixGrayColors:colors
"set the table of preallocated fix gray colors"
fixGrayColors := colors.
! !
!DeviceWorkstation methodsFor:'cursor stuff'!
builtInCursorShapes
"return a collection of standard cursor names.
Hre none is assumed - so all cursors are created as user cursors
(see Cursor>>initializeNewCursors)"
"/ if you add something here, also add to #shapeNumberFromCursor ...
^ #()
"Created: 8.4.1997 / 10:32:31 / cg"
!
colorCursor:aCursorId foreground:fgColor background:bgColor
"change a cursors colors.
Ignored on systems which do not support colored cursors."
^ self
!
createCursorShape:aShapeSymbol
"create a cursor given a shape-symbol; return a cursorID or nil.
This only works for a few standard cursors, and returns nil
if no such cursor exists.
Always care for a fallBack, in case of a nil return."
^ nil
!
createCursorSourceForm:sourceForm maskForm:maskForm hotX:hx hotY:hy width:w height:h
"create a cursor given 2 bitmaps (source, mask) and a hotspot.
Returns nil, if no cursor can be created (for any reason)"
^ self subclassResponsibility
!
destroyCursor:aCursorId
"free a cursor"
^ self subclassResponsibility
!
needDeviceFormsForCursor
"return true, if this device requires device-forms as opposed
to a simple bitmap-byteArray for creation.
Redefined in X- and Win- Workstation classes."
^ self subclassResponsibility
!
shapeNumberFromSymbol:shape
"given a shape-symbol, return the corresponding cursor-number,
or nil if no such standard cursor exists."
^ nil
! !
!DeviceWorkstation methodsFor:'drag & drop'!
drop:aCollectionOfDropObjects inWindowID:destinationId position:destinationPoint rootPosition:rootPoint
"device specific drop here"
"/ self subclassResponsibility
"Created: 4.4.1997 / 18:33:44 / cg"
"Modified: 11.4.1997 / 12:43:23 / cg"
! !
!DeviceWorkstation methodsFor:'drawing'!
copyFromId:sourceId x:srcX y:srcY gc:srcGCId to:destId x:dstX y:dstY gc:dstGCId width:w height:h
"do a bit-blt"
^ self subclassResponsibility
!
copyFromPixmapId:sourceId x:srcX y:srcY gc:srcGCId to:destId x:dstX y:dstY gc:dstGCId width:w height:h
"do a bit-blt from a pix- or bitmap.
Here, fall back into copyFromId:, which should also work.
Subclasses may redefine this for more performance or if required"
^ self copyFromId:sourceId x:srcX y:srcY gc:srcGCId to:destId x:dstX y:dstY gc:dstGCId width:w height:h
!
copyPlaneFromId:sourceId x:srcX y:srcY gc:srcGCId to:destId x:dstX y:dstY gc:dstGCId width:w height:h
"do a bit-blt, using the low-bit plane of the source only"
^ self subclassResponsibility
!
copyPlaneFromPixmapId:sourceId x:srcX y:srcY gc:srcGCId to:destId x:dstX y:dstY gc:dstGCId width:w height:h
"do a bit-blt from a pix- or bitmap, using the low-bit plane of the source only.
Here, fall back into copyPlaneFromId:, which should also work.
Subclasses may redefine this for more performance or if required"
^ self copyPlaneFromId:sourceId x:srcX y:srcY gc:srcGCId to:destId x:dstX y:dstY gc:dstGCId width:w height:h
!
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"
"/ could use
"/ self displayLineFromX:x y:y toX:x y:y in:aDrawableId with:aGCId.
"/ but then, we had to care for lineWidth & style ...
^ self subclassResponsibility
"Modified: / 3.5.1999 / 14:26:32 / cg"
!
displayPolygon:aPolygon in:aDrawableId with:aGCId
"draw a polygon"
"
could draw the lines here
but then, we have to reimplement all line and join styles here
"
^ self subclassResponsibility
!
displayPolylines:arrayOfPoints in:aDrawableId with:aGCId
"draw a bunch of lines"
|startPoint p|
1 to:arrayOfPoints size by:2 do:[:idx |
p := arrayOfPoints at:idx.
idx odd ifTrue:[
startPoint := p
] ifFalse:[
self
displayLineFromX:startPoint x
y:startPoint y
toX:p x
y:p y
in:aDrawableId
with:aGCId
]
]
!
displayRectangleX:x y:y width:width height:height in:aDrawableId with:aGCId
"draw a rectangle"
"
could 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"
^ self subclassResponsibility
!
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 displayString:aString
from:1
to:aString size
x:x
y:y
in:aDrawableId
with:aGCId
opaque:opaque
!
drawBits:imageBits bitsPerPixel:bitsPerPixel depth:imageDepth padding:pad
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.
The actual bits per pixel may be different from the depth (for example,
on a depth-15 device, 16 bits/pixel may be used; also, many depth-24
systems actually use 32 bits/pixel)"
^ self subclassResponsibility
!
drawBits:imageBits bitsPerPixel:bitsPerPixel 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.
The actual bits per pixel may be different from the depth (for example,
on a depth-15 device, 16 bits/pixel may be used; also, many depth-24
systems actually use 32 bits/pixel).
This assumes a padding of 8-bits (i.e. byte-boundary),
which is the natural padding within ST/X."
^ self
drawBits:imageBits
bitsPerPixel:bitsPerPixel
depth:imageDepth
padding:8
width:imageWidth height:imageHeight
x:srcx y:srcy
into:aDrawableId
x:dstx y:dsty
width:w height:h
with:aGCId
"Created: / 16.4.1997 / 14:55:57 / cg"
"Modified: / 21.1.1998 / 13:27:58 / cg"
!
drawBits:imageBits depth:imageDepth padding:pad 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
drawBits:imageBits
bitsPerPixel:imageDepth
depth:imageDepth
padding:pad
width:imageWidth height:imageHeight
x:srcx y:srcy
into:aDrawableId
x:dstx y:dsty
width:w height:h
with:aGCId
!
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.
This assumes a padding of 8-bits (i.e. byte-boundary),
which is the natural padding within ST/X."
^ self
drawBits:imageBits
bitsPerPixel:imageDepth
depth:imageDepth
width:imageWidth height:imageHeight
x:srcx y:srcy
into:aDrawableId
x:dstx y:dsty
width:w height:h
with:aGCId
"Modified: / 21.1.1998 / 13:28:34 / cg"
!
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'!
allViews
"return a collection of all my known views"
|setOfViews|
knownViews notNil ifTrue:[
setOfViews := IdentitySet new.
knownViews validElementsDo:[:v | setOfViews add:v].
].
^ setOfViews
"Created: 14.2.1997 / 14:29:43 / cg"
"Modified: 23.1.1997 / 21:27:03 / cg"
!
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 validElementsDo:aBlock
]
"
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]
"
"Modified: 16.7.1997 / 09:56:58 / cg"
! !
!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:[
aView shown ifTrue:[ "/ could be a late event arrival
"
if there is no sensor ...
"
aView
dispatchEvent:#buttonMotion:x:y:
arguments:(Array with:button with:x with:y)
"/ WindowEvent
"/ sendEvent:#buttonMotion:x:y:
"/ arguments:(Array with:button with:x with:y)
"/ view:aView
]
]
"Modified: / 20.5.1998 / 22:50:32 / cg"
!
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:[
aView shown ifTrue:[ "/ could be a late event arrival
"
if there is no sensor ...
"
aView
dispatchEvent:#buttonMultiPress:x:y:
arguments:(Array with:button with:x with:y)
"/ WindowEvent
"/ sendEvent:#buttonMultiPress:x:y:
"/ arguments:(Array with:button with:x with:y)
"/ view:aView
]
]
"Modified: / 20.5.1998 / 22:50:49 / cg"
!
buttonPress:button x:x y:y view:aView
"forward a button-press event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
WindowsRightButtonBehavior == true ifTrue:[
button >= 2 ifTrue:[
sensor buttonPress:1 x:x y:y view:aView.
^ self.
]
].
sensor buttonPress:button x:x y:y view:aView
] ifFalse:[
aView shown ifTrue:[ "/ could be a late event arrival
"
if there is no sensor ...
"
aView
dispatchEvent:#buttonPress:x:y:
arguments:(Array with:button with:x with:y)
"/ WindowEvent
"/ sendEvent:#buttonPress:x:y:
"/ arguments:(Array with:button with:x with:y)
"/ view:aView
]
]
"Modified: / 20.5.1998 / 22:51:02 / cg"
!
buttonRelease:button x:x y:y view:aView
"forward a button-release event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
WindowsRightButtonBehavior == true ifTrue:[
button >= 2 ifTrue:[
sensor buttonRelease:1 x:x y:y view:aView.
sensor buttonPress:button x:x y:y view:aView.
sensor buttonRelease:button x:x y:y view:aView.
^ self.
].
].
sensor buttonRelease:button x:x y:y view:aView
] ifFalse:[
aView shown ifTrue:[ "/ could be a late event arrival
"
if there is no sensor ...
"
aView
dispatchEvent:#buttonRelease:x:y:
arguments:(Array with:button with:x with:y)
"/ WindowEvent
"/ sendEvent:#buttonRelease:x:y:
"/ arguments:(Array with:button with:x with:y)
"/ view:aView
]
]
"Modified: / 20.5.1998 / 22:51:13 / cg"
!
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
"/ ]
"Modified: / 8.2.1999 / 15:24:52 / cg"
!
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 ...
"
aView
dispatchEvent:#exposeX:y:width:height:
arguments:(Array with:x with:y with:w with:h)
"/ WindowEvent
"/ sendEvent:#exposeX:y:width:height:
"/ arguments:(Array with:x with:y with:w with:h)
"/ view:aView
]
"Modified: / 20.5.1998 / 22:51:31 / cg"
!
focusInView:aView
"forward a focusIn event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor focusInView:aView
] ifFalse:[
"
if there is no sensor ...
"
aView
dispatchEvent:#focusIn
arguments:nil
"/ WindowEvent
"/ sendEvent:#focusIn
"/ arguments:nil
"/ view:aView
]
"Modified: / 20.5.1998 / 22:51:48 / cg"
!
focusOutView:aView
"forward a focusOut event for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor focusOutView:aView
] ifFalse:[
"
if there is no sensor ...
"
aView
dispatchEvent:#focusOut
arguments:nil
"/ WindowEvent
"/ sendEvent:#focusOut
"/ arguments:nil
"/ view:aView
]
"Modified: / 20.5.1998 / 22:51:58 / cg"
!
graphicsExposeX:x y:y width:w height:h final:final view:aView
"forward a graphic expose for some view"
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor graphicsExposeX:x y:y width:w height:h final:final view:aView
] ifFalse:[
"
if there is no sensor ...
"
aView
dispatchEvent:#graphicsExposeX:y:width:height:final:
arguments:(Array with:x with:y with:w with:h with:final)
"/ WindowEvent
"/ sendEvent:#graphicsExposeX:y:width:height:final:
"/ arguments:(Array with:x with:y with:w with:h with:final)
"/ view:aView
]
"Modified: / 20.5.1998 / 22:52:16 / cg"
!
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:[
aView shown ifTrue:[ "/ could be a late event arrival
"
if there is no sensor ...
"
xlatedKey := self translateKey:untranslatedKey forView:aView.
xlatedKey notNil ifTrue:[
aView
dispatchEvent:#keyPress:x:y:
arguments:(Array with:xlatedKey with:x with:y)
"/ WindowEvent
"/ sendEvent:#keyPress:x:y:
"/ arguments:(Array with:xlatedKey with:x with:y)
"/ view:aView
]
]
]
"Modified: / 20.5.1998 / 22:52:36 / 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:[
aView shown ifTrue:[ "/ could be a late event arrival
"
if there is no sensor ...
"
xlatedKey := self translateKey:untranslatedKey forView:aView.
xlatedKey notNil ifTrue:[
aView
dispatchEvent:#keyRelease:x:y:
arguments:(Array with:xlatedKey with:x with:y)
"/ WindowEvent
"/ sendEvent:#keyRelease:x:y:
"/ arguments:(Array with:xlatedKey with:x with:y)
"/ view:aView
]
]
]
"Modified: / 20.5.1998 / 22:52:52 / cg"
!
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
]
!
mouseWheelMotion:buttonState x:x y:y amount:amount deltaTime:dTime view:aView
"the mousewheel was moved by some amount (signed).
This event is sent to the current pointer view (like keyPress/release)."
|sensor|
(sensor := aView sensor) notNil ifTrue:[
sensor mouseWheelMotion:buttonState x:x y:y amount:amount deltaTime:dTime view:aView
] ifFalse:[
aView shown ifTrue:[ "/ could be a late event arrival
"
if there is no sensor ...
"
aView
dispatchEvent:#mouseWheelMotion:x:y:amount:deltaTime:
arguments:(Array with:buttonState with:x with:y with:amount with:dTime )
]
]
"Modified: / 21.5.1999 / 13:05:53 / cg"
!
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 ...
"
aView
dispatchEvent:#pointerEnter:x:y:
arguments:(Array with:buttonState with:x with:y)
"/ WindowEvent
"/ sendEvent:#pointerEnter:x:y:
"/ arguments:(Array with:buttonState with:x with:y)
"/ view:aView
]
"Modified: / 20.5.1998 / 22:53:13 / cg"
!
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 ...
"
aView
dispatchEvent:#pointerLeave:
arguments:(Array with:buttonState)
"/ WindowEvent
"/ sendEvent:#pointerLeave:
"/ arguments:(Array with:buttonState)
"/ view:aView
]
"Modified: / 20.5.1998 / 22:53:29 / cg"
!
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 == true ifFalse:[^ self].
].
exitOnLastClose == true ifFalse:[^ self].
knownViews notNil ifTrue:[
(knownViews findFirst:[:slot |
slot notNil
and:[slot ~~ 0
and:[slot isRootView not
and:[slot superView isNil
and:[slot realized]]]]]) == 0 ifTrue:[
"/ my last view was closed
dispatching := false.
'DeviceWorkstation [info]: finished dispatch (last view closed)' infoPrintCR.
]
].
"Modified: 19.9.1995 / 11:31:54 / claus"
"Modified: 18.3.1997 / 10:42:11 / 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)"
Object osSignalInterruptSignal handle:[:ex |
ex return
] do:[
[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
!
eventQueuedAlready
"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 & start the display event dispatch process."
|inputSema fd p nm|
"/
"/ only allow one dispatcher process per display
"/
dispatching ifTrue:[^ self].
dispatching := true.
AllScreens isNil ifTrue:[
AllScreens := IdentitySet new:1
].
AllScreens add:self.
fd := self displayFileDescriptor.
"/ handle all incoming events from the device, sitting on a semaphore.
"/ Tell Processor to trigger this semaphore when some event arrives
"/ for me. Since a select alone may not be enough to know if events are pending
"/ (Xlib reads out event-queue while doing output), we also install a poll-check block.
"/ The poll check is also req'd for systems where we cannot do a select
"/ on the eventQ (i.e. windows).
inputSema := Semaphore new name:'display inputSema'.
p := [
self initializeDeviceResources.
[dispatching] whileTrue:[
AbortSignal handle:[:ex |
ex return
] do:[
self eventPending ifFalse:[
Processor activeProcess setStateTo:#ioWait if:#active.
inputSema wait.
].
self dispatchPendingEvents.
]
].
inputSema notNil ifTrue:[
Processor disableSemaphore:inputSema.
inputSema := nil.
].
dispatchProcess := nil.
self close.
] newProcess.
"/
"/ 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.
p priority:(Processor userInterruptPriority).
dispatchProcess := p.
p resume.
"/ finally, arrange for the processor to signal that semaphore when input
"/ is available or #eventPending returns true
"/ fd isNil ifTrue:[
"/ fd := -1 "/ has no fileDescriptor (i.e. Windows) - will poll
"/ ].
Processor signal:inputSema onInput:fd orCheck:[self eventPending].
"Modified: / 12.12.1995 / 20:52:57 / stefan"
"Modified: / 24.8.1998 / 18:36:29 / cg"
! !
!DeviceWorkstation methodsFor:'event sending'!
sendKeyOrButtonEvent:typeSymbol x:xPos y:yPos keyOrButton:keySymCodeOrButtonNr state:stateMask toViewId:targetId
"send a keyPress/Release or buttonPress/Release event to some (possibly alien) view.
TypeSymbol must be one of: #keyPress, #keyRelease, #buttonPress , #buttonRelease.
For buttonEvents, the keySymCodeOrButtonNr must be the buttons number (1, 2 ...);
for key events, it can be either a symbol (as listen in X's keySyms)
or a numeric keysym code. If state is nil, the modifier bits (shift & control)
are computed from the keyboardMap - if non-nil, these are passed as modifierbits.
The non-nil case is the lowlevel entry, where state must include any shift/ctrl information
(not very user friendly)"
self subclassResponsibility
!
simulateKeyboardInput:aCharacterOrString inViewId:viewId
"send input to some other view, by simulating keyPress/keyRelease
events.
Only a few control characters are supported.
Notice: not all alien views allow this kind of synthetic input;
some simply ignore it."
|control code state|
aCharacterOrString isString ifTrue:[
aCharacterOrString do:[:char |
self simulateKeyboardInput:char inViewId:viewId
].
^ self
].
control := false.
code := aCharacterOrString asciiValue.
(aCharacterOrString == Character cr) ifTrue:[
code := #Return
] ifFalse:[
(aCharacterOrString == Character tab) ifTrue:[
code := #Tab
] ifFalse:[
(aCharacterOrString == Character esc) ifTrue:[
code := #Escape
]
]
].
control ifTrue:[
state := self controlMask
].
"/ the stuff below should not be needed
"/ (sendKeyOrButtonevent should be able to figure out things itself)
"/ however, on some linux systems it seems to not work correctly.
"/ Hopefully, this is correct ...
code isNumber ifTrue:[
code >= $A asciiValue ifTrue:[
code <= $Z asciiValue ifTrue:[
state := self shiftMask
]
]
].
self sendKeyOrButtonEvent:#keyPress x:0 y:0 keyOrButton:code state:state toViewId:viewId.
self sendKeyOrButtonEvent:#keyRelease x:0 y:0 keyOrButton:code state:state toViewId:viewId
"
sending input to some (possibly alien) view:
|point id|
point := Display pointFromUser.
id := Display viewIdFromPoint:point.
Display simulateKeyboardInput:'Hello_world' inViewId:id
"
"Modified: 11.6.1996 / 10:59:42 / cg"
! !
!DeviceWorkstation methodsFor:'font helpers'!
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"
!
maxAscentOf:aFontId
"return the number of pixels above the base line of the tallest character
in a font"
^ self subclassResponsibility
!
maxDescentOf:aFontId
"return the number of pixels below the base line of the tallest character
in a font"
^ 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
! !
!DeviceWorkstation methodsFor:'font stuff'!
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"
!
flushListOfAvailableFonts
"flush any cached font information - dummy here,
but should be implemented in subclasses, which keep
a list of available device fonts.
This should be flushed, to allow update whenever new fonts
are installed or the system-font-path changes."
"Created: / 4.8.1998 / 16:52:13 / 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"
!
fontMetricsOf:fontId into:aBlock
"evaluate aBlock, passing a fonts metrics as arguments"
|encoding avgAscent avgDescent
maxAscent maxDescent minWidth maxWidth avgWidth|
encoding := self encodingOf:fontId.
avgAscent := self ascentOf:fontId.
avgDescent := self descentOf:fontId.
maxAscent := self maxAscentOf:fontId.
maxDescent := self maxDescentOf:fontId.
minWidth := self minWidthOfFont:fontId.
maxWidth := self maxWidthOfFont:fontId.
avgWidth := self widthOf:' ' inFont:fontId.
aBlock value:encoding
value:avgAscent
value:avgDescent
value:maxAscent
value:maxDescent
value:minWidth
value:maxWidth
value:avgWidth
!
fontResolutionOf:fontId
"return the resolution (as dpiX @ dpiY) of the font - this is usually the displays resolution,
but due to errors in some XServer installations, some use 75dpi fonts on higher
resolution displays and vice/versa."
^ self resolution
!
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 match:fntDescr family) ifTrue:[
(aFaceName match: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"
"Modified: 30.6.1997 / 11:07:21 / 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 match:fntDescr family) ifTrue:[
(aFaceName match:fntDescr face) ifTrue:[
(aStyleName match: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']]
"
"
Display fontsInFamily:'fixed' face:'*' style:'roman' filtering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Created: 29.2.1996 / 04:25:30 / cg"
"Modified: 30.6.1997 / 11:07:08 / 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 match: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']]
"
"
Display fontsInFamily:'*' filtering:[:f |
f encoding notNil and:[f encoding startsWith:'jis']]
"
"Created: 29.2.1996 / 04:27:49 / cg"
"Modified: 30.6.1997 / 11:06:36 / 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
!
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 widthOf:aString from:1 to:(aString size) inFont:aFontId
! !
!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:aCursorIdOrNil
"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:aCursorIdOrNil 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:aDrawableId gc: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:aDrawableID gc:aGCId
"enable/disable drawing into child views"
^ self subclassResponsibility
!
setClipX:clipX y:clipY width:clipWidth height:clipHeight in:drawableId gc:aGCId
"clip to a rectangle"
^ self subclassResponsibility
!
setDashes:dashList dashOffset:offset in:aGCId
"set dash attributes.
Ignored here - it may be left unimplemented by some devices."
^ self subclassResponsibility
"Created: 4.6.1996 / 18:50:38 / cg"
"Modified: 4.6.1996 / 19:05:22 / cg"
!
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: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'!
brokenConnection
"the connection to the display device was lost."
displayId := nil.
dispatching := false.
"/ tell all of my views about this.
"/ first, all topViews get a notification ...
self allViewsDo:[:aView |
aView isTopView ifTrue:[
aView destroyed
]
].
self releaseDeviceResources.
"Modified: 11.4.1997 / 10:44:33 / cg"
!
close
"close down connection to Display - usually never done"
self releaseDeviceResources.
self closeConnection.
"Modified: 13.1.1997 / 22:13:18 / cg"
!
closeConnection
"close down connection to Display - usually never done"
^ self subclassResponsibility
"Created: 13.1.1997 / 22:10:07 / cg"
!
exitOnLastClose:aBoolean
"set/clear the flag which controls if the
event dispatching should stop when the last view is closed."
self == Display ifTrue:[
ExitOnLastClose := aBoolean
].
exitOnLastClose := aBoolean
"Modified: 23.4.1996 / 22:01:28 / cg"
!
initialize
"initialize the receiver for a connection to the default display"
idToTableIndexMapping notNil ifTrue:[
"/ assume, I am already initialized ...
^ self.
].
idToTableIndexMapping := Dictionary new:100.
^ self initializeFor:nil
"Modified: / 27.1.1998 / 20:17:27 / cg"
!
initializeDefaultValues
isSlow := false.
motionEventCompression := true.
buttonTranslation := ButtonTranslation.
multiClickTimeDelta := MultiClickTimeDelta.
shiftDown := false.
ctrlDown := false.
metaDown := false.
altDown := false.
self initializeModifierMappings
!
initializeDeviceResources
"initialize heavily used device resources - to avoid looking them up later"
blackColor isNil ifTrue:[
blackColor := Color black onDevice:self.
whiteColor := Color white onDevice:self.
Color getPrimaryColorsOn:self.
]
"Modified: 24.2.1997 / 22:07:50 / cg"
!
initializeDeviceSignals
deviceErrorSignal := DeviceErrorSignal newSignalMayProceed:false.
deviceErrorSignal nameClass:self message:#deviceErrorSignal.
deviceIOErrorSignal := DeviceIOErrorSignal newSignalMayProceed:false.
deviceIOErrorSignal nameClass:self message:#deviceIOErrorSignal.
!
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.
Here, an empty (no-translation) keyboard map is setup initially;
this is usually filled via the keyboard.rc startup file.
"
keyboardMap isNil ifTrue:[
keyboardMap := KeyboardMap new.
].
"
no more setup here - moved everything out into 'display.rc' file
"
!
initializeModifierMappings
shiftModifiers := ctrlModifiers := altModifiers := metaModifiers := nil.
shiftModifiers := #(Shift_L Shift_R Shift).
ctrlModifiers := #(Control_L Control_R Control).
metaModifiers := #(Alt_L Meta_L Meta_R Meta).
altModifiers := #(Alt_R Alt).
!
initializeScreenProperties
"setup screen specific properties."
supportsDeepIcons isNil ifTrue:[
supportsDeepIcons := false.
].
fixColors := fixGrayColors := ditherColors := nil.
numFixRed := numFixGreen := numFixBlue := 0.
"Modified: 21.4.1997 / 12:04:37 / cg"
!
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|
self releaseDeviceFonts.
self releaseDeviceCursors.
self releaseDeviceColors.
"/ Color flushDeviceColorsFor:self.
displayId := nil.
dispatching := false.
dispatchProcess := nil.
prevWidth := width.
prevHeight := height.
"/ prevMapping := idToViewMapping.
"/ idToViewMapping := nil.
prevKnownViews := knownViews.
idToTableIndexMapping := nil.
knownViews := nil.
knownIds := nil.
lastId := nil.
lastView := nil.
self initializeFor:nil.
displayId isNil ifTrue:[
'DevWorkstation [error]: could not connect to display' errorPrintCR.
Smalltalk exit.
^ self
].
"
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 and:[aView ~~ 0]) ifTrue:[
aView prepareForReinit
]
].
"
2nd round: all views should reinstall themself
on the new display
"
"/ prevMapping keysAndValuesDo:[:anId :aView |
prevKnownViews do:[:aView |
(aView notNil and:[aView ~~ 0]) ifTrue:[
"have to re-create the view"
UserInterruptSignal catch:[
AbortSignal catch:[
GraphicsContext drawingOnClosedDrawableSignal handle:[:ex |
'DeviceWorkstation [warning]: drawing attempt on closed drawable during reinit' errorPrintCR.
ex return
] do:[
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 and:[aView ~~ 0]) ifTrue:[
aView reAdjustGeometry
]
].
]
].
dispatching := false.
"Modified: / 7.6.1998 / 02:45:13 / cg"
!
releaseDeviceResources
"release any cached device resources.
This is invoked when closed or when the display connection is broken
(i.e. be prepared to not be able to release resources regularily)"
"/ blackColor notNil ifTrue:[
"/ blackColor on:nil.
"/ ].
"/ whiteColor notNil ifTrue:[
"/ whiteColor on:nil.
"/ ].
blackColor := whiteColor := nil.
Image releaseResourcesOnDevice:self.
self releaseDeviceColors.
self releaseDeviceCursors.
self releaseDeviceFonts.
DeviceGraphicsContext releaseResourcesOnDevice:self.
focusView := activeView := rootView := lastView := nil.
activeKeyboardGrab := activePointerGrab := nil.
LastActiveScreen == self ifTrue:[
LastActiveScreen := nil
].
AllScreens remove:self ifAbsent:nil.
"Modified: 16.1.1997 / 19:34:11 / cg"
! !
!DeviceWorkstation methodsFor:'interactive queries'!
colorFromUser
"{ Pragma: +optSpace }"
"let user specify a point on the screen (by pressing the left button),
return the color of that pixel."
|p|
p := self pointFromUser.
^ self rootView colorAt:p
"
Display colorFromUser
"
"Modified: 1.8.1997 / 20:00:41 / cg"
!
originFromUser:extent
"{ Pragma: +optSpace }"
"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 onDevice:self.
"
just in case; wait for button to be down ...
"
[self leftButtonPressed] whileFalse:[Delay waitForSeconds:0.05].
root := self rootView.
"
grab and wait for leftButton being pressed
"
origin := self pointerPosition.
root clippedByChildren:false.
root foreground:blackColor background:whiteColor.
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:[
Delay waitForSeconds:0.05
]
].
root displayRectangle:rect.
self ungrabPointer.
].
self ungrabPointer.
"flush all events pending on my display"
root clippedByChildren:true.
self flush.
self disposeButtonEventsFor:nil.
^ rect
"
Display originFromUser:200@200
"
"Modified: / 18.8.1998 / 15:00:14 / cg"
!
pointFromUser
"{ Pragma: +optSpace }"
"let user specify a point on the screen (by pressing the left button)"
^ self pointFromUserShowing:(Cursor crossHair).
"
Display pointFromUser
"
"Modified: 13.1.1997 / 22:53:05 / cg"
!
pointFromUserShowing:aCursor
"{ Pragma: +optSpace }"
"let user specify a point on the screen (by pressing leftButton).
Show aCursor while waiting."
|p|
self ungrabPointer.
self grabPointerIn:(self rootWindowId) withCursor:((aCursor onDevice:self) id)
pointerMode:#async keyboardMode:#sync confineTo:nil.
activePointerGrab := rootView.
"
wait for leftButton ...
"
[self leftButtonPressed] whileFalse:[Delay waitForSeconds:0.05].
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
"
"Modified: / 18.8.1998 / 15:00:19 / cg"
!
rectangleFromUser
"{ Pragma: +optSpace }"
"let user specify a rectangle in the screen, return the rectangle"
|origin|
"
get origin
"
origin := self pointFromUserShowing:(Cursor origin onDevice:self).
"
get corner
"
^ self rectangleFromUser:(origin corner:origin).
"
Display rectangleFromUser
"
"Modified: 28.3.1997 / 16:14:44 / cg"
!
rectangleFromUser:initialRectangle
"{ Pragma: +optSpace }"
"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."
^ self rectangleFromUser:initialRectangle keepExtent:false
"
Display rectangleFromUser:(100@100 corner:300@300)
"
"Modified: 24.7.1997 / 16:04:54 / cg"
!
rectangleFromUser:initialRectangle keepExtent:keepExtent
"{ Pragma: +optSpace }"
"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 doRegrab|
"/ regrabbing leads to horrible flicker and
"/ events being sent to applications under the mouse.
"/ on windows displays.
doRegrab := self class ~~ WinWorkstation.
keepExtent ifTrue:[
curs1 := Cursor origin
] ifFalse:[
curs1 := Cursor corner
].
curs1 := curs1 onDevice:self.
root := self rootView.
"
grab and wait for leftButton being pressed
"
origin := initialRectangle origin.
root clippedByChildren:false.
root foreground:blackColor background:whiteColor.
root xoring:[
|left right top bottom newOrigin newCorner p curs|
keepExtent ifFalse:[
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:[Delay waitForSeconds:0.05].
keepExtent ifTrue:[
p := self pointerPosition.
origin := p.
corner := origin + initialRectangle extent.
rect := origin corner:corner.
root displayRectangle:rect.
].
[self leftButtonPressed] whileTrue:[
left := initialRectangle origin x.
top := initialRectangle origin y.
right := initialRectangle corner x.
bottom := initialRectangle corner y.
p := self pointerPosition.
keepExtent ifTrue:[
newOrigin := p.
newCorner := newOrigin + initialRectangle extent.
curs := curs1.
] ifFalse:[
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.
doRegrab ifTrue:[
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:[
Delay waitForSeconds:0.05
]
].
root displayRectangle:rect.
self ungrabPointer.
].
self ungrabPointer.
"flush all events pending on my display"
root clippedByChildren:true.
self flush.
self disposeButtonEventsFor:nil.
^ rect
"
Display rectangleFromUser
Display rectangleFromUser:(100@100 corner:300@300)
Display rectangleFromUser:(100@100 corner:300@300) keepExtent:true
"
"Created: / 24.7.1997 / 15:26:47 / cg"
"Modified: / 10.9.1998 / 17:38:41 / cg"
!
topviewFromUser
"{ Pragma: +optSpace }"
"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
"
"Modified: 13.1.1997 / 22:53:15 / cg"
!
viewFromUser
"{ Pragma: +optSpace }"
"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]
"
"Modified: 13.1.1997 / 22:53:17 / cg"
!
viewIdFromUser
"{ Pragma: +optSpace }"
"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"
"Modified: 13.1.1997 / 22:53:20 / cg"
! !
!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
]
].
"/ temporary kludge ...
(modifiers size > 0) ifTrue:[
(modifiers includes:'Num_Lock') ifTrue:[
modifiers := modifiers copy.
modifiers remove:'Num_Lock'
]
].
(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: / 7.2.1998 / 16:18:17 / 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 ?"
"/ the next statement will vanish ....
(untranslatedKey == #Control
or:[untranslatedKey == #'Control_L'
or:[untranslatedKey == #'Control_R']]) ifTrue:[
^ #Ctrl
].
(untranslatedKey == #Ctrl
or:[untranslatedKey == #'Ctrl_L'
or:[untranslatedKey == #'Ctrl_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 forView:aView
"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 := aView 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
!
leftShiftDown
"return true, if the left shift-key is currently pressed.
Here, we dont differentiate between left and right shift keys."
^ shiftDown
"Created: 9.11.1996 / 19:06:48 / cg"
!
metaDown
"return true, if the meta-key (alt-key on systems without meta)
is currently pressed."
^ metaDown
!
rightShiftDown
"return true, if the right shift-key is currently pressed.
Here, we dont differentiate between left and right shift keys."
^ shiftDown
"Created: 9.11.1996 / 19:06:56 / cg"
!
shiftDown
"return true, if the shift-key is currently pressed."
^ shiftDown
! !
!DeviceWorkstation methodsFor:'misc'!
beep
"{ Pragma: +optSpace }"
"output an audible beep or bell"
NoBeep ~~ true ifTrue:[
Stdout nextPut:(Character bell)
]
"Modified: 13.1.1997 / 22:56:13 / cg"
!
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
!
focusView
^ focusView
!
focusView:aView
focusView := aView
!
repadBits:givenBits width:imageWidth height:imageHeight depth:imageDepth from:givenPadding to:wantedPadding
"repadding support - required for some devices when drawing images"
|newBits bytesPerLineGiven bytesPerLineWanted
dstIndex "{ Class: SmallInteger }"
srcIndex "{ Class: SmallInteger }"|
bytesPerLineGiven := ((width * imageDepth) + givenPadding - 1) // 8.
bytesPerLineWanted := ((width * imageDepth) + wantedPadding - 1) // 8.
bytesPerLineGiven == bytesPerLineWanted ifTrue:[^ givenBits].
newBits := ByteArray new:(bytesPerLineWanted * height).
srcIndex := dstIndex := 1.
1 to:height do:[:row |
newBits
replaceFrom:dstIndex
to:(dstIndex + bytesPerLineWanted - 1)
with:givenBits
startingAt:srcIndex.
dstIndex := dstIndex + bytesPerLineWanted.
srcIndex := srcIndex + bytesPerLineGiven.
].
^ newBits.
!
restoreWindows
"restore the display.
Here, a view is popped over all of the screen temporarily"
|v|
v := PopUpView onDevice:self.
v origin:0@0 corner:(self bounds corner).
v map.
v unmap.
"
Display restoreWindows
"
"Modified: 15.10.1997 / 19:06:26 / cg"
!
ringBell
"{ Pragma: +optSpace }"
"alias for beep; for ST-80 compatibility"
self beep
"Modified: 13.1.1997 / 22:56:02 / cg"
!
setInputFocusTo:aWindowId
^ self subclassResponsibility
!
sync
"{ Pragma: +optSpace }"
"send all buffered drawing to the display and wait until its processed/drawn.
See also #flush, which does not wait.
ST-80 seems to only support flush."
self flush
"Modified: 13.1.1997 / 22:55:44 / cg"
!
synchronizeOutput
"{ Pragma: +optSpace }"
"send all buffered drawing to the display.
OBSOLETE: please use #flush for ST-80 compatibility."
self obsoleteMethodWarning:'use #flush'.
^ self flush
"Modified: 13.1.1997 / 22:53:44 / cg"
!
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 stuff'!
anyButtonMotionMask
"return an integer for masking out any button from a motion
buttonStates value. This is very device specific and to
be redefined by concrete subclasses."
^ self subclassResponsibility
"Created: 15.10.1997 / 19:17:00 / cg"
!
anyButtonPressed
"return true, if the any button is currently pressed"
^ (self buttonStates bitAnd:self anyButtonStateMask) ~~ 0
"Created: 15.10.1997 / 19:16:32 / cg"
!
anyButtonStateMask
"return an integer for masking out any button from a
buttonStates value. This is very device specific and to
be redefined by concrete subclasses."
^ self subclassResponsibility
"Created: 15.10.1997 / 19:17:00 / cg"
!
button1MotionMask
"return an integer for masking out the left button from a
motion buttonStates value. This is very device specific and to
be redefined by concrete subclasses."
^ self subclassResponsibility
!
button2MotionMask
"return an integer for masking out the middle button from a
motion buttonStates value. This is very device specific and to
be redefined by concrete subclasses."
^ self subclassResponsibility
!
button3MotionMask
"return an integer for masking out the right button from a
motion buttonStates value. This is very device specific and to
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
!
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
!
setPointerPosition:newPosition
"change the pointer position in root-window coordinates."
self setPointerPosition:newPosition in:rootView id
"
Display setPointerPosition:10@30
"
!
setPointerPosition:newPosition in:aWindowID
"change the pointer position relative to some views origin.
Must be redefined by concrete subclasses."
^ self subclassResponsibility
"
Display setPointerPosition:10@30
"
! !
!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'!
getBitsFromId:aDrawableId x:srcx y:srcy width:w height:h into:imageBits
"get bits from a view drawable into the imageBits. The storage for the bits
must be big enough for the data to fit. If ok, returns an array with some
info and the bits in imageBits. The info contains the depth, bitOrder and
number of bytes per scanline. The number of bytes per scanline is not known
in advance, since the X-server is free to return whatever it thinks is a good padding."
self subclassResponsibility
"Created: 19.3.1997 / 13:41:21 / cg"
!
getBitsFromPixmapId:aDrawableId x:srcx y:srcy width:w height:h into:imageBits
"get bits from a drawable into the imageBits. The storage for the bits
must be big enough for the data to fit. If ok, returns an array with some
info and the bits in imageBits. The info contains the depth, bitOrder and
number of bytes per scanline. The number of bytes per scanline is not known
in advance, since the X-server is free to return whatever it thinks is a good padding."
^ self
getBitsFromId:aDrawableId
x:srcx
y:srcy
width:w
height:h
into:imageBits
"Created: 19.3.1997 / 13:43:04 / cg"
"Modified: 19.3.1997 / 13:43:38 / cg"
!
getBitsFromViewId:aDrawableId x:srcx y:srcy width:w height:h into:imageBits
"get bits from a drawable into the imageBits. The storage for the bits
must be big enough for the data to fit. If ok, returns an array with some
info and the bits in imageBits. The info contains the depth, bitOrder and
number of bytes per scanline. The number of bytes per scanline is not known
in advance, since the X-server is free to return whatever it thinks is a good padding."
^ self
getBitsFromId:aDrawableId
x:srcx
y:srcy
width:w
height:h
into:imageBits
"Created: 19.3.1997 / 13:43:04 / cg"
"Modified: 19.3.1997 / 13:43:42 / cg"
!
getPixelX:x y:y from:aDrawableId with:gcId
"return the pixel value at x/y"
^ self subclassResponsibility
"Created: / 22.5.1999 / 01:40:42 / cg"
! !
!DeviceWorkstation methodsFor:'selections'!
clipBoardEncoding
"return the assumed default clibBoards encoding
if a raw string (i.e. without encoding information) is pasted.
Useful on XWindows, if a sjis or euc string is pasted from a netscape
or other program."
^ clipBoardEncoding
"
Screen current clipBoardEncoding
"
"Created: 28.6.1997 / 13:46:02 / cg"
"Modified: 28.6.1997 / 17:28:08 / cg"
!
clipBoardEncoding:aSymbol
"set the assumed default clibBoards encoding
if a raw string (i.e. without encoding information) is pasted.
Useful on XWindows, if a sjis or euc string is pasted from a netscape
or other program."
clipBoardEncoding := aSymbol
"
Screen current clipBoardEncoding:#sjis
Screen current clipBoardEncoding:#euc
Screen current clipBoardEncoding:nil
"
"Created: 28.6.1997 / 13:46:12 / cg"
"Modified: 28.6.1997 / 17:28:02 / cg"
!
getCopyBuffer
"return the copyBuffers contents.
This is an ST/X internal buffer (i.e. its not visible to alien views)."
^ copyBuffer
"Modified: 11.12.1996 / 12:55:42 / cg"
"Created: 11.12.1996 / 13:34:34 / cg"
!
getLastCopyBuffer
"return the last copyBuffers contents.
This is an ST/X internal buffer (i.e. its not visible to alien views)."
^ lastCopyBuffer
"Modified: 11.12.1996 / 12:55:47 / cg"
"Created: 11.12.1996 / 13:34:43 / cg"
!
getTextSelectionFor:aDrawableId
"Retrieve the common per-display selection text.
For clipBoard mechanisms to work (into ST/X),
this must be redefined in a concrete subclass"
^ nil
"Modified: 11.12.1996 / 12:56:57 / cg"
!
selectionAsString
"return my current selection as a string"
|o s|
o := self getCopyBuffer.
s := o.
o isString ifFalse:[
o isNil ifTrue:[
s := ''
] ifFalse:[
(o isStringCollection) ifTrue:[
s := o asStringWithCRsFrom:1 to:(o size) compressTabs:false withCR:false.
s := s string.
] ifFalse:[
s := o storeString
]
]
].
^ s
"Created: / 13.2.1997 / 13:10:30 / cg"
"Modified: / 20.1.1998 / 14:11:01 / stefan"
!
setCopyBuffer:something
"set the copyBuffers contents.
This is an ST/X internal buffer (i.e. its not visible to alien views)."
copyBuffer := something.
"Created: 11.12.1996 / 12:54:23 / cg"
"Modified: 11.12.1996 / 12:55:53 / cg"
!
setLastCopyBuffer:something
"set the last copyBuffers contents.
This is an ST/X internal buffer (i.e. its not visible to alien views)."
lastCopyBuffer := something.
"Created: 11.12.1996 / 12:54:32 / cg"
"Modified: 11.12.1996 / 12:55:59 / cg"
!
setSelection:anObject owner:aWindowId
"set the common per-display object selection.
This can be used by other Smalltalk(X) applications only.
For clipBoard mechanisms to work (out of ST/X),
this must be redefined in a concrete subclass"
^ nil
!
setTextSelection:aString owner:aWindowId
"Set the common per-display selection text.
For clipBoard mechanisms to work (out of ST/X),
this must be redefined in a concrete subclass"
^ nil
"Modified: 11.12.1996 / 12:56:36 / cg"
! !
!DeviceWorkstation methodsFor:'style defaults'!
defaultStyleValueFor:aKey
"return a default style value, given a key.
These defaults are used if nothing is specified
in the style sheet
This allows for empty values in style sheets, and defaults
being provided by the display (which makes sense with Windows,
where the systemDefaults are used ..."
<resource: #style (#viewSpacing
#borderColor #borderWidth
#viewBackgroundColor #shadowColor #lightColor
)>
aKey == #viewSpacing ifTrue:[
^ self verticalPixelPerMillimeter rounded "/ 1 millimeter
].
aKey == #borderColor ifTrue:[
^ Color black
].
aKey == #borderWidth ifTrue:[
^ 1
].
aKey == #shadowColor ifTrue:[
^ Color black
].
aKey == #lightColor ifTrue:[
^ Color white
].
aKey == #viewBackgroundColor ifTrue:[
^ Color white
].
aKey == #scrollerViewBackgroundColor ifTrue:[
^ Color white
].
aKey == #textForegroundColor ifTrue:[
^ Color black.
].
aKey == #textBackgroundColor ifTrue:[
^ Color white.
].
aKey == #selectionForegroundColor ifTrue:[
^ Color white.
].
aKey == #selectionBackgroundColor ifTrue:[
^ Color black.
].
^ nil.
"Modified: 29.4.1997 / 11:16:57 / dq"
"Modified: 29.4.1997 / 17:17:15 / cg"
! !
!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 wasBlocked|
wasBlocked := OperatingSystem blockInterrupts.
knownViews isNil ifTrue:[
knownViews := WeakArray new:50.
knownIds := Array new:50.
freeIdx := 1.
] ifFalse:[
freeIdx := knownViews identityIndexOf:nil.
freeIdx == 0 ifTrue:[
freeIdx := knownViews identityIndexOf:0.
[freeIdx ~~ 0
and:[(knownIds at:freeIdx) notNil]] whileTrue:[
"/ mhmh - the view is already clear in the weakArray
"/ but the id is not.
"/ (i.e. its collected, but not yet finalized)
"/ skip this entry.
"/ 'XXX ' print. (knownIds at:freeIdx) displayString printCR.
freeIdx := knownViews identityIndexOf:0 startingAt:(freeIdx + 1).
].
].
].
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.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
idToTableIndexMapping notNil ifTrue:[
idToTableIndexMapping at:aWindowID put:freeIdx.
].
"/ dispatching ifFalse:[
"/ self startDispatch
"/ ].
"Modified: 2.4.1997 / 19:15:46 / cg"
!
initializeTopViewHookFor:aView
"callBack from topViews initialize method.
empty here, but may be useful ..."
!
realizedTopViewHookFor:aView
"callBack from topViews realize method.
empty here, but may be useful ..."
!
removeKnownView:aView withId:aViewId
"remove aView from the list of known views/id's."
|index wasBlocked nV nI n dstIdx v id newSize|
lastId := nil.
lastView := nil.
focusView == aView ifTrue:[
focusView := nil
].
knownViews notNil ifTrue:[
wasBlocked := OperatingSystem blockInterrupts.
index := 0.
aViewId notNil ifTrue:[
idToTableIndexMapping notNil ifTrue:[
index := idToTableIndexMapping at:aViewId ifAbsent:0.
]
].
index == 0 ifTrue:[
aView notNil ifTrue:[
index := knownViews identityIndexOf:aView.
].
].
index ~~ 0 ifTrue:[
idToTableIndexMapping notNil ifTrue:[
aViewId notNil ifTrue:[
idToTableIndexMapping removeKey:aViewId ifAbsent:nil
] ifFalse:[
id := knownIds at:index.
id notNil ifTrue:[
idToTableIndexMapping removeKey:id ifAbsent:nil.
]
]
].
knownViews at:index put:nil.
knownIds at:index put:nil.
lastId := nil.
lastView := nil.
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
aView notNil ifTrue:[
aView isTopView ifTrue:[
"/ check for sparsely filled knownViews - array
wasBlocked := OperatingSystem blockInterrupts.
n := 0.
knownViews do:[:v |
(v notNil and:[v ~~ 0]) ifTrue:[
n := n + 1
].
].
n < (knownViews size * 2 // 3) ifTrue:[
newSize := n * 3 // 2.
newSize > 50 ifTrue:[
nV := WeakArray new:newSize.
nI := Array new:newSize.
dstIdx := 1.
1 to:knownViews size do:[:srcIdx |
v := knownViews at:srcIdx.
(v notNil and:[v ~~ 0]) ifTrue:[
nV at:dstIdx put:v.
nI at:dstIdx put:(knownIds at:srcIdx).
dstIdx := dstIdx + 1.
].
].
idToTableIndexMapping := nil.
knownViews := nV.
knownIds := nI.
idToTableIndexMapping := Dictionary new.
knownIds keysAndValuesDo:[:idx :id |
id notNil ifTrue:[
idToTableIndexMapping at:id put:idx
]
].
].
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
].
].
self checkForEndOfDispatch.
]
"Created: 22.3.1997 / 14:56:20 / cg"
"Modified: 27.3.1997 / 17:13:28 / cg"
!
viewFromId:aWindowID
"given an Id, return the corresponding view."
|index v idx|
aWindowID = lastId ifTrue:[
lastView notNil ifTrue:[
^ lastView
]
].
idToTableIndexMapping notNil ifTrue:[
idx := idToTableIndexMapping at:aWindowID ifAbsent:nil.
idx notNil ifTrue:[
v := knownViews at:idx.
(v notNil and:[v ~~ 0]) ifTrue:[
lastView := v.
lastId := aWindowID.
^ v
].
]
].
knownIds isNil ifTrue:[
^ nil
].
index := knownIds indexOf:aWindowID.
index == 0 ifTrue:[
^ nil
].
v := knownViews at:index.
v == 0 ifTrue:[
knownViews at:index put:nil.
knownIds at:index put:nil.
^ nil
].
lastId := aWindowID.
lastView := v.
^ v
"Modified: 22.3.1997 / 17:19:59 / cg"
!
viewIdKnown:aWindowID
"return true, if I still consider a windowId as being valid"
|index v|
aWindowID = lastId ifTrue:[
lastView notNil ifTrue:[
^ true
]
].
idToTableIndexMapping notNil ifTrue:[
index := idToTableIndexMapping at:aWindowID ifAbsent:nil.
].
index isNil ifTrue:[
index := knownIds indexOf:aWindowID.
].
index ~~ 0 ifTrue:[
v := knownViews at:index.
^ (v notNil and:[v ~~ 0])
].
^ false.
"Created: 4.4.1997 / 11:01:07 / cg"
"Modified: 4.4.1997 / 19:07:55 / cg"
! !
!DeviceWorkstation methodsFor:'window stuff'!
activateWindow:aWindowId
"make a window active.
Noop here"
"Created: / 5.6.1999 / 22:07:08 / cg"
!
clearRectangleX:x y:y width:width height:height in:aWindowId
"clear a rectangular area of a window to its view background"
"/ mhmh - should not be needed
^ self subclassResponsibility
!
clearWindow:aWindowId
"clear a windows to its view background"
"/ mhmh - should not be needed
^ 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 - either as icon or as a real view - needed for restart"
"/ OBSOLETE interface - this looses the minExtent/maxExtent properties
"/ use mapView:...minWidth:minHeight:maxWidth:maxHeight:
^ self
mapView:aView id:aWindowId iconified:aBoolean atX:xPos y:yPos
width:w height:h minExtent:nil maxExtent:nil
!
mapView:aView id:aWindowId iconified:aBoolean atX:xPos y:yPos
width:w height:h minExtent:minExt maxExtent:maxExt
"make a window visible - either as icon or as a real view - needed for restart"
^ 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"
"/ fallBack: move & resize as two individual operations
self moveWindow:aWindowId x:x y:y.
self resizeWindow:aWindowId width:w height:h.
!
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"
!
reparentWindow:windowId to:newParentWindowId
"change a windows parent (an optional interface).
Returns true if successfull."
^ false
!
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.
This undoes the effect of #setCursors:"
knownViews notNil ifTrue:[
knownViews validElementsDo:[:aView |
|c vid cid|
(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).
Delay waitForSeconds:5.
Display restoreCursors
"
"Modified: 20.3.1997 / 16:28:25 / cg"
!
setBackingStore:how in:aWindowId
"turn on/off backing-store for a window.
A view with backingStore will redraw automatically
from the backing pixmap (without sending expose events).
An implementation may ignore this request."
"/ default here is to ignore the request
!
setBitGravity:how in:aWindowId
"set bit gravity for a window"
"/ default here is to ignore the request
!
setCursor:aCursorId in:aWindowId
"set a windows cursor"
"/ mhmh - could be ignored
^ self subclassResponsibility
!
setCursors:aCursor
"change the cursor of all views on the receiver device
to aCursorId, without affecting the views idea of what
the cursor is (so that it can be restored from the views
cursor instance variable later).
Use of this is not recommended - its better to change
the cursor of a windowGroup alone."
|id|
id := (aCursor onDevice:self) id.
id notNil ifTrue:[
knownViews validElementsDo:[:aView |
|vid|
(vid := aView id) notNil ifTrue:[
self setCursor:id in:vid
]
].
self flush
]
"
Display setCursors:(Cursor wait).
Delay waitForSeconds:5.
Display restoreCursors.
"
"Modified: 28.3.1997 / 16:14:59 / cg"
!
setIconName:aString in:aWindowId
"set a windows icon name"
"/ default here is to ignore the request
!
setSaveUnder:yesOrNo in:aWindowId
"turn on/off save-under for a window.
A view with saveUnder will save the pixels of the
area covered by itself and repair from those when
unmapped (therefore, no expose events are generated later).
It is especially useful for popUp menus.
An implementation may ignore this request."
"/ default here is to ignore the request
!
setTransient:aWindowId for:aMainWindowId
"set aWindowId to be a transient of aMainWindow.
This informs the windowManager that those are to
be handled as a group w.r.t. iconification and deiconification.
An implementation may ignore this
(being somewhat inconvenient to the user, though)"
"/ default here is to ignore the request
"Created: 20.8.1997 / 20:38:32 / cg"
!
setWindowBackground:aColorIndex in:aWindowId
"set a windows background color"
^ self subclassResponsibility
!
setWindowBackgroundPixmap:aPixmapId in:aWindowId
"set a windows background pattern to be a form.
No need to be implemented in concrete workstation;
if not implemented, its done by (slower) smalltalk code
(must return false from #supportsViewBackgroundPixmap query)"
^ self
"Modified: / 4.5.1999 / 19:06:13 / cg"
!
setWindowBorderColor:aColorIndex in:aWindowId
"set a windows border color"
"/ default here is to ignore the request
^ self
!
setWindowBorderPixmap:aPixmapId in:aWindowId
"set a windows border pattern"
"/ default here is to ignore the request
^ self
!
setWindowBorderShape:aPixmapId in:aWindowId
"set a windows border shape"
"/ default here is to ignore the request
^ self
!
setWindowBorderWidth:aNumber in:aWindowId
"set a windows border width"
^ self subclassResponsibility
!
setWindowClass:wClass name:wName in:aWindowId
"define class and name of a window.
This may be used by the window manager to
select client specific resources."
"/ default here is to ignore the request
"Created: 14.6.1996 / 17:23:34 / stefan"
!
setWindowGravity:how in:aWindowId
"set window gravity for a window"
"/ default here is to ignore the request
!
setWindowIcon:aForm in:aWindowId
"define a bitmap to be used as icon"
self
setWindowIcon:aForm
mask:nil
in:aWindowId
!
setWindowIcon:aForm mask:aMaskForm in:aWindowId
"set a windows icon & iconMask"
"/ default here is to ignore the request
!
setWindowIconWindow:aView in:aWindowId
"set a windows icon window"
"/ default here is to ignore the request
!
setWindowMinExtent:newMinExtent maxExtent:newMaxExtent in:aWindowId
"set a windows minimum & max extents.
nil arguments are ignored."
^ self subclassResponsibility
!
setWindowName:aString in:aWindowId
"define a windows name (i.e. windowTitle)"
^ self subclassResponsibility
!
setWindowShape:aPixmapId in:aWindowId
"set a windows visible shape"
"/ default here is to ignore the request
!
unmapWindow:aWindowId
"unmap a window"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:42:39 / cg"
!
windowIsIconified:aWindowId
"return true, if a window is iconified"
^ self subclassResponsibility
"Modified: 24.4.1996 / 19:42:39 / cg"
"Created: 4.4.1997 / 14:45:26 / cg"
! !
!DeviceWorkstation class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libview/DeviceWorkstation.st,v 1.328 1999-08-31 19:38:47 cg Exp $'
! !
DeviceWorkstation initialize!