--- a/DeviceWorkstation.st Sat Dec 09 20:32:46 1995 +0100
+++ b/DeviceWorkstation.st Sun Dec 10 01:15:42 1995 +0100
@@ -11,29 +11,19 @@
"
Object subclass:#DeviceWorkstation
- instanceVariableNames:'displayId
- visualType monitorType
- depth ncells bitsPerRGB
- bitsRed bitsGreen bitsBlue
- redMask greenMask blueMask
- redShift greenShift blueShift
- hasColors hasGreyscales
- width height widthMM heightMM resolutionHor resolutionVer
- idToViewMapping knownViews knownIds knownBitmaps knownBitmapIds
- dispatching dispatchProcess
- ctrlDown shiftDown metaDown altDown
- motionEventCompression
- lastId lastView
- keyboardMap rootView
- isSlow
- activeKeyboardGrab activePointerGrab
- buttonTranslation multiClickTimeDelta
- altModifiers metaModifiers ctrlModifiers shiftModifiers'
- classVariableNames: 'ButtonTranslation MultiClickTimeDelta
- DeviceErrorSignal ErrorPrinting
- DefaultScreen AllScreens'
- poolDictionaries:''
- category:'Interface-Graphics'
+ instanceVariableNames:'displayId visualType monitorType depth ncells bitsPerRGB bitsRed
+ bitsGreen bitsBlue redMask greenMask blueMask redShift greenShift
+ blueShift hasColors hasGreyscales width height widthMM heightMM
+ resolutionHor resolutionVer idToViewMapping knownViews knownIds
+ knownBitmaps knownBitmapIds dispatching dispatchProcess ctrlDown
+ shiftDown metaDown altDown motionEventCompression lastId lastView
+ keyboardMap rootView isSlow activeKeyboardGrab activePointerGrab
+ buttonTranslation multiClickTimeDelta altModifiers metaModifiers
+ ctrlModifiers shiftModifiers'
+ classVariableNames:'ButtonTranslation MultiClickTimeDelta DeviceErrorSignal
+ ErrorPrinting DefaultScreen AllScreens'
+ poolDictionaries:''
+ category:'Interface-Graphics'
!
!DeviceWorkstation class methodsFor:'documentation'!
@@ -52,10 +42,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libview/DeviceWorkstation.st,v 1.55 1995-12-06 14:11:20 cg Exp $'
-!
-
documentation
"
this abstract class defines common protocol to all Display types.
@@ -119,6 +105,39 @@
"
!
+events
+"
+ All events are processed in a workstations dispatchEvent method.
+ There, incoming events are first sent to itself, for a first (view independent)
+ preprocessing. For example, the devices state of the shift-, alt-, control and
+ meta keys are updated there. After that, the event is forwarded either to
+ the views sensor or to the view directly (if it has no sensor).
+ (Sensorless views are a leftover from ancient times and will sooner or
+ later vanish - simplifying things a bit. Do not depend on views without
+ sensors to work correctly in future versions.)
+
+ This event processing is done by the event dispatcher process, which is
+ launched in ST/X's startup sequence (see Smalltalk>>start).
+ Event processing is done at a high priority, to allow keyboad processing
+ and CTRL-C handling to be performed even while other processes are running.
+ The code executed by thr event process is found in startDispatch.
+
+ Individual events can be enabled or disabled. The ones that are enabled
+ by default are:
+ keypress / keyRelease
+ buttonPress / buttonRelease / buttonMotion (i.e. motion with button pressed)
+ pointerEnter / pointerLeave
+
+ other events have to be enabled by sending a corresponding #enableXXXEvent
+ message to the view which shall receive those events.
+ For example, pointerMotion events (i.e. motion without button being pressed)
+ are enable by: 'aView enableMotionEvent'
+
+ The above is only of interrest, if you write your own widget classes,
+ existing widgets set things as required in their #initEvents method.
+"
+!
+
workstationDevices
"
In ST/X, all interaction with the graphics device is done through
@@ -232,39 +251,6 @@
views in this case - or set your styleSheet for the smallest common
capabilities (i.e. for b&w).
"
-!
-
-events
-"
- All events are processed in a workstations dispatchEvent method.
- There, incoming events are first sent to itself, for a first (view independent)
- preprocessing. For example, the devices state of the shift-, alt-, control and
- meta keys are updated there. After that, the event is forwarded either to
- the views sensor or to the view directly (if it has no sensor).
- (Sensorless views are a leftover from ancient times and will sooner or
- later vanish - simplifying things a bit. Do not depend on views without
- sensors to work correctly in future versions.)
-
- This event processing is done by the event dispatcher process, which is
- launched in ST/X's startup sequence (see Smalltalk>>start).
- Event processing is done at a high priority, to allow keyboad processing
- and CTRL-C handling to be performed even while other processes are running.
- The code executed by thr event process is found in startDispatch.
-
- Individual events can be enabled or disabled. The ones that are enabled
- by default are:
- keypress / keyRelease
- buttonPress / buttonRelease / buttonMotion (i.e. motion with button pressed)
- pointerEnter / pointerLeave
-
- other events have to be enabled by sending a corresponding #enableXXXEvent
- message to the view which shall receive those events.
- For example, pointerMotion events (i.e. motion without button being pressed)
- are enable by: 'aView enableMotionEvent'
-
- The above is only of interrest, if you write your own widget classes,
- existing widgets set things as required in their #initEvents method.
-"
! !
!DeviceWorkstation class methodsFor:'initialization'!
@@ -305,8 +291,2334 @@
].
! !
+!DeviceWorkstation class methodsFor:'error handling'!
+
+errorInterrupt:errID with:aParameter
+ "DisplayError interrupt.
+ This is invoked via
+ XError->errorInterrupt:#DisplayError->registeredErrorInterruptHandlers
+
+ looks if a signal handler for DeviceErrorSignal is present,
+ and - if so raises the signal. If the signal not handled, simply output a
+ message and continue.
+ This allows for non disrupted error reporting OR to catch and
+ investigate errors as required."
+
+ |badId badResource msg|
+
+ badId := self resourceIdOfLastError.
+ badId ~~ 0 ifTrue:[
+ badResource := self resourceOfId:badId.
+ ].
+ msg := 'Display error: ' , (self lastErrorString).
+
+ DeviceErrorSignal isHandled ifFalse:[
+ ErrorPrinting ifTrue:[msg errorPrintNL].
+ ^ self
+ ].
+
+ ^ DeviceErrorSignal
+ raiseRequestWith:badResource
+ errorString:msg
+!
+
+errorPrinting
+ ErrorPrinting isNil ifTrue:[^ false].
+ ^ ErrorPrinting
+!
+
+errorPrinting:aBoolean
+ ErrorPrinting := aBoolean
+!
+
+lastErrorString
+ "return a string describing the last error"
+
+ ^ self subclassResponsibility
+!
+
+resourceIdOfLastError
+ "return the resource id responsible for the last error"
+
+ ^ self subclassResponsibility
+!
+
+resourceOfId:id
+ "search thru all device stuff for a resource.
+ Needed for error handling"
+
+ Form allInstances do:[:f |
+ f id == id ifTrue:[^ f]
+ ].
+
+ self allInstances do:[:aDisplay |
+ aDisplay allViewsDo:[:aView |
+ aView id == id ifTrue:[^ aView].
+ aView gcId == id ifTrue:[^ aView]
+ ].
+
+"/ |views|
+"/ views := aDisplay knownViews.
+"/ views notNil ifTrue:[
+"/ views do:[:v |
+"/ v id == id ifTrue:[^ v].
+"/ v gcId == id ifTrue:[^ v]
+"/ ].
+"/ ].
+ ].
+
+ Color allInstances do:[:c |
+ c colorId == id ifTrue:[^ c]
+ ].
+
+ Font allInstances do:[:f |
+ f fontId == id ifTrue:[^ f]
+ ].
+ ^ nil
+! !
+
+!DeviceWorkstation class methodsFor:'queries'!
+
+allScreens
+ "EXPERIMENTAL: 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"
+!
+
+current
+ "EXPERIMENTAL: this should return the currently active screen,
+ that is, the device of the currently executing windowGroup.
+ It will be used in multi-display operation, to launch views on
+ the correct device - even if not specified explicitely.
+ This does not yet work fully satisfying ..."
+
+ |wg tops v dev|
+
+ AllScreens size == 1 ifTrue:[
+ ^ AllScreens anElement
+ ].
+
+ "
+ mhmh - multiple screens are active.
+ be careful, to not run into an error in case
+ the current windowGroup got corrupted somehow ...
+ "
+ (wg := WindowGroup activeGroup) notNil ifTrue:[
+ "
+ ok, not a background process or scheduler ...
+ "
+ (tops := wg topViews) notNil ifTrue:[
+ tops isEmpty ifFalse:[
+ (v := tops first) notNil ifTrue:[
+ "
+ ok, it has a view ...
+ "
+ (dev := v device) notNil ifTrue:[
+ ^ dev
+ ]
+ ]
+ ]
+ ]
+ ].
+ "
+ in all other cases, return the default display
+ "
+ ^ Display
+
+ "
+ Screen current
+ "
+
+ "Modified: 1.9.1995 / 13:40:05 / claus"
+!
+
+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 methodsFor:'accessing & queries'!
+
+bitsBlue
+ "return the number of valid bits in the red component."
+
+ bitsBlue isNil ifTrue:[
+ "/ not a truecolor display
+ ^ bitsPerRGB
+ ].
+ ^ bitsBlue
+
+ "
+ Display bitsBlue
+ "
+
+ "Created: 21.10.1995 / 00:45:27 / cg"
+!
+
+bitsGreen
+ "return the number of valid bits in the red component."
+
+ bitsGreen isNil ifTrue:[
+ "/ not a truecolor display
+ ^ bitsPerRGB
+ ].
+ ^ bitsGreen
+
+ "
+ Display bitsGreen
+ "
+
+ "Created: 21.10.1995 / 00:45:11 / cg"
+!
+
+bitsPerRGB
+ "return the number of valid bits per rgb component;
+ Currently, assume that r/g/b all have the same precision,
+ which is a stupid assumption (there may be some, where less
+ resolution is available in the blue component).
+ Therefore, this may be changed to return a 3-element vector.
+ In the meantime, use bitsRed/bitsGreen/bitsBlue to get this information."
+
+ ^ bitsPerRGB
+
+ "
+ Display bitsPerRGB
+ "
+
+ "Modified: 21.10.1995 / 00:46:27 / cg"
+!
+
+bitsRed
+ "return the number of valid bits in the red component."
+
+ bitsRed isNil ifTrue:[
+ "/ not a truecolor display
+ ^ bitsPerRGB
+ ].
+ ^ bitsRed
+
+ "
+ Display bitsRed
+ "
+
+ "Created: 21.10.1995 / 00:44:55 / cg"
+!
+
+blackpixel
+ "return the colorId of black"
+
+ ^ self subclassResponsibility
+!
+
+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 origin:(0 @ 0) extent:(width @ height)
+
+ "
+ Screen default bounds
+ "
+ "/ thats the same as:
+ "
+ Display bounds
+ "
+!
+
+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))
+!
+
+buttonTranslation
+ ^ buttonTranslation
+!
+
+buttonTranslation:anArray
+ buttonTranslation := anArray
+!
+
+center
+ "return the centerpoint in pixels of the display"
+
+ ^ (width // 2) @ (height // 2)
+!
+
+depth
+ "return the depth in pixels of the display"
+
+ ^ depth
+
+ "
+ Display depth
+ "
+!
+
+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
+!
+
+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
+ "
+!
+
+extent
+ "return the extent of the display (in pixels)"
+
+ ^ width @ height
+
+ "
+ Display extent
+ "
+!
+
+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
+ "
+!
+
+hasColors
+ "return true, if its a color display"
+
+ ^ hasColors
+
+ "
+ Display hasColors
+ "
+!
+
+hasDPS
+ "return true, if this workstation supports postscript output into views.
+ Should be reimplemented in concrete classes which do support this."
+
+ ^ false
+
+ "
+ Display hasDPS
+ "
+!
+
+hasExtension:extensionString
+ "query for an X extension. The method here is provide for XWorkstation
+ protocol compatibility only."
+
+ ^ false
+
+ "
+ Display hasExtension:'XVideo'
+ Display hasExtension:'Input'
+ Display hasExtension:'GLX'
+ Display hasExtension:'X3D-PEX'
+ Display hasExtension:'XInputExtension'
+ Display hasExtension:'SHAPE'
+ Display hasExtension:'MIT-SHM'
+ Display hasExtension:'SGIFullScreenStereo'
+ "
+!
+
+hasFax
+ "return true, if this workstation supports decompression of fax images.
+ Should be reimplemented in concrete classes which do support this."
+
+ ^ false
+
+ "
+ Display hasFax
+ "
+!
+
+hasGreyscales
+ "return true, if this workstation supports greyscales
+ (also true for color displays)"
+
+ ^ hasGreyscales
+
+ "
+ Display hasGreyscales
+ "
+!
+
+hasImageExtension
+ "return true, if this workstation supports the X Image extension"
+
+ ^ false
+
+ "
+ Display hasImageExtension
+ "
+!
+
+hasInputExtension
+ "return true, if this workstation supports the X Input extension"
+
+ ^ false
+
+ "
+ Display hasInputExtension
+ "
+!
+
+hasMultibuffer
+ "return true, if this workstation supports the X multibuffer extension"
+
+ ^ false
+
+ "
+ Display hasMultibuffer
+ "
+!
+
+hasPEX
+ "return true, if this workstation supports PEX graphics.
+ Should be reimplemented in concrete classes which do support this."
+
+ ^ false
+
+ "
+ Display hasPEX
+ "
+!
+
+hasShape
+ "return true, if this workstation supports non-rectangular windows.
+ Should be reimplemented in concrete classes which do support this."
+
+ ^ false
+
+ "
+ Display hasShape
+ "
+!
+
+hasShm
+ "return true, if this workstation supports shared memory pixmaps.
+ Should be reimplemented in concrete classes which do support this."
+
+ ^ false
+
+ "
+ Display hasShm
+ "
+!
+
+hasStereoExtension
+ "return true, if this workstation supports stereo GL drawing.
+ Both the server must support it, and the feature must have been
+ enabled in the smalltalk system, for true to be returned."
+
+ ^ false
+
+ "
+ Display hasStereoExtension
+ "
+!
+
+hasXVideo
+ "return true, if this workstation supports the XVideo extension"
+
+ ^ false
+
+ "
+ Display hasXVideo
+ "
+!
+
+height
+ "return the height of the display (in pixels)"
+
+ ^ height
+
+ "Display height"
+!
+
+heightInMillimeter
+ "return the height in millimeter of the display"
+
+ ^ heightMM
+
+ "Display heightInMillimeter"
+!
+
+heightInMillimeter:aNumber
+ "set the height in millimeter of the display
+ - needed since some displays do not tell the truth or do not know it"
+
+ heightMM := aNumber
+!
+
+horizontalPixelPerInch
+ "return the number of horizontal pixels per inch of the display"
+
+ ^ (width / widthMM) * 25.4
+!
+
+horizontalPixelPerMillimeter
+ "return the number of horizontal pixels per millimeter of the display"
+
+ ^ width / widthMM
+!
+
+id
+ "return the displayId"
+
+ ^ displayId
+!
+
+isSlow
+ "return true, if this is a relatively slow device -
+ used to turn off things like popup-shadows"
+
+ ^ isSlow
+!
+
+keyboardMap
+ "return the keyboard map"
+
+ ^ keyboardMap
+!
+
+keyboardMap:aMap
+ "set the keyboard map"
+
+ keyboardMap := aMap
+!
+
+knownViews
+ "return a collection of all known views"
+
+ ^ knownViews
+!
+
+knownViews:aCollection
+ "set the collection of all known views - take care,
+ bad use of this will create funny results; use only for snapshot support"
+
+ knownViews := aCollection
+!
+
+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
+!
+
+multiClickTimeDelta
+ ^ multiClickTimeDelta
+!
+
+multiClickTimeDelta:milliseconds
+ multiClickTimeDelta := milliseconds
+!
+
+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
+ "
+!
+
+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"
+!
+
+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
+ "
+!
+
+shiftBlue
+ "return the count by which the blue bits are to be shifted
+ when forming a color index.
+ This only makes sense with trueColor displays; therefore,
+ nil is returned on all others."
+
+ ^ blueShift
+
+ "
+ Display shiftBlue
+ "
+
+ "Created: 21.10.1995 / 00:45:27 / cg"
+ "Modified: 21.10.1995 / 00:47:58 / cg"
+!
+
+shiftGreen
+ "return the count by which the red bits are to be shifted
+ when forming a color index.
+ This only makes sense with trueColor displays; therefore,
+ nil is returned on all others."
+
+ ^ greenShift
+
+ "
+ Display shiftGreen
+ "
+
+ "Created: 21.10.1995 / 00:45:27 / cg"
+ "Modified: 21.10.1995 / 00:48:28 / cg"
+!
+
+shiftRed
+ "return the count by which the red bits are to be shifted
+ when forming a color index.
+ This only makes sense with trueColor displays; therefore,
+ nil is returned on all others."
+
+ ^ redShift
+
+ "
+ Display shiftRed
+ "
+
+ "Created: 21.10.1995 / 00:45:27 / cg"
+ "Modified: 21.10.1995 / 00:48:10 / cg"
+!
+
+supportedImageFormats
+ "return an array with supported image formats; each array entry
+ is another array, consisting of depth and bitsPerPixel values.
+ Here, we return a single format only; every graphics device must
+ support b&w single bit images."
+
+ |info|
+
+ info := IdentityDictionary new.
+ info at:#depth put:1.
+ info at:#bitsPerPixel put:1.
+ info at:#padding put:32.
+ ^ Array with:info
+!
+
+supportsDeepIcons
+ "return true, if this device supports non b&w (i.e. greyScale
+ or colored icons). We really dont know here."
+
+ "This method has to be reimplemented in concrete display classes."
+ ^ self subclassResponsibility
+
+ "
+ Display supportsDeepIcons
+ "
+!
+
+supportsGLDrawing
+ "return true, if this device supports 3D GL drawing.
+ We do not depend on that being implemented."
+
+ "This method should to be reimplemented in concrete display classes."
+ ^ false
+
+ "
+ Display supportsGLDrawing
+ "
+!
+
+supportsViewGravity
+ "return true, if this device supports gravity attributes.
+ We do not depend on the being implemented, but some resizing operations
+ are faster, it is is."
+
+ "This method should to be reimplemented in concrete display classes."
+ ^ false
+
+ "
+ Display supportsViewGravity
+ "
+!
+
+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.
+ "
+!
+
+vendorRelease
+ "return the display systems release number.
+ Returns a dummy here."
+
+ ^ 0
+
+ "
+ Display vendorRelease
+ "
+!
+
+verticalPixelPerInch
+ "return the number of vertical pixels per inch of the display"
+
+ ^ (height / heightMM) * 25.4
+!
+
+verticalPixelPerMillimeter
+ "return the number of vertical pixels per millimeter of the display"
+
+ ^ height / heightMM
+!
+
+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"
+
+ |view 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
+!
+
+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"
+!
+
+visualType
+ "return a symbol representing the visual type of the display"
+
+ ^ visualType
+
+ "
+ Display visualType
+ "
+!
+
+visualType:aSymbol
+ "set the visual type.
+ The only situation, where setting the visual makes sense,
+ is with my plasma-display, which ignores the palette and spits out
+ grey scales, independent of color LUT definitions.
+ (of which the server knows nothing).
+ So, this should be used from a display-specific startup file only."
+
+ visualType := aSymbol.
+ (visualType == #StaticGray or:[visualType == #GrayScale]) ifTrue:[
+ hasColors := false
+ ] ifFalse:[
+ hasColors := true
+ ]
+!
+
+whitepixel
+ "return the colorId of white"
+
+ ^ self subclassResponsibility
+!
+
+width
+ "return the width of the display (in pixels)"
+
+ ^ width
+
+ "Display width"
+!
+
+widthInMillimeter
+ "return the width in millimeter of the display"
+
+ ^ widthMM
+
+ "Display widthInMillimeter"
+!
+
+widthInMillimeter:aNumber
+ "set the width in millimeter of the display
+ - needed since some displays do not tell the truth or do not know it"
+
+ widthMM := aNumber
+!
+
+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:'bitmap/window creation'!
+
+createBitmapFromArray:anArray width:w height:h
+ ^ self subclassResponsibility
+!
+
+createBitmapFromFile:aString for:aForm
+ ^ self subclassResponsibility
+!
+
+createBitmapWidth:w height:h
+ "allocate a bitmap on the Xserver, the contents is undefined
+ (i.e. random). Return a bitmap id or nil"
+
+ ^ self subclassResponsibility
+!
+
+createFaxImageFromArray:data width:w height:h type:type k:k msbFirst:msbFirst
+ "create a new faxImage in the workstation.
+ This is a special interface to servers with the fax-image
+ extension (you won't find it in standard X-servers).
+
+ type: 0 -> uncompressed
+ 1 -> group3 1D (k is void)
+ 2 -> group3 2D
+ 3 -> group4 2D (k is void)
+ "
+
+ ^ nil
+!
+
+createPixmapWidth:w height:h depth:d
+ "allocate a pixmap on the Xserver, the contents is undefined
+ (i.e. random). Return a bitmap id or nil"
+
+ ^ self subclassResponsibility
+!
+
+createWindowFor:aView left:xpos top:ypos width:wwidth height:wheight
+ ^ self subclassResponsibility
+!
+
+destroyFaxImage:aFaxImageId
+ ^ self subclassResponsibility
+!
+
+destroyGC:aGCId
+ "destroy a GC"
+
+ ^ self subclassResponsibility
+!
+
+destroyPixmap:aDrawableId
+ ^ self subclassResponsibility
+!
+
+destroyView:aView withId:aWindowId
+ ^ self subclassResponsibility
+!
+
+gcFor:aDrawableId
+ "create a GC for drawing into aDrawable"
+
+ ^ self subclassResponsibility
+!
+
+rootWindowFor:aView
+ ^ self subclassResponsibility
+! !
+
+!DeviceWorkstation methodsFor:'color stuff'!
+
+blueComponentOfColor:colorId
+ "get blue component (0..100) of color in map at:index"
+
+ self getRGBFrom:colorId into:[:r :g :b | ^ b]
+!
+
+colorCell
+ "allocate a color - return index"
+
+ ^ self subclassResponsibility
+!
+
+colorNamed:aString
+ "allocate a color with color name - return index.
+ Colors should not be allocated by name, since most colors
+ are X specific - get colors by rgb instead."
+
+ "support some of them ..."
+
+ self getRGBFromName:aString into:[:r :g :b |
+ ^ self colorRed:r green:g blue:b
+ ].
+ ^ nil
+!
+
+colorRed:redVal green:greenVal blue:blueVal
+ "allocate a color with rgb values (0..100) - return index"
+
+ ^ self subclassResponsibility
+!
+
+freeColor:colorIndex
+ "free a color on the display, when its no longer needed"
+
+ ^ self subclassResponsibility
+!
+
+getRGBFrom:index into:aBlock
+ "get rgb components (0..100) of color in map at:index,
+ and evaluate the 3-arg block, aBlock with them"
+
+ ^ self subclassResponsibility
+!
+
+getRGBFromName:colorName into:aBlock
+ "get rgb components (0..100) of color named colorName,
+ and evaluate the 3-arg block, aBlock with them.
+ The method here only handles some often used colors;
+ getRGBFromName should not be used, since colorNames other
+ than those below are X specific."
+
+ |idx names triple|
+
+ names := #('red' 'green' 'blue' 'yellow' 'magenta' 'cyan' 'white' 'black').
+ idx := names indexOf:colorName.
+ idx == 0 ifTrue:[
+ idx := (names asLowercase) indexOf:colorName.
+ ].
+ idx == 0 ifFalse:[
+ triple := #(
+ (100 0 0) "red"
+ ( 0 100 0) "green"
+ ( 0 0 100) "blue"
+ (100 100 0) "yellow"
+ (100 0 100) "magenta"
+ ( 0 100 100) "cyan"
+ (100 100 100) "white"
+ ( 0 0 0) "black"
+ ) at:idx.
+
+ ^ aBlock value:(triple at:1)
+ value:(triple at:2)
+ value:(triple at:3)
+ ].
+ ^ nil
+!
+
+greenComponentOfColor:colorId
+ "get green component (0..100) of color in map at:index"
+
+ self getRGBFrom:colorId into:[:r :g :b | ^ g]
+!
+
+listOfAvailableColors
+ "return a list of all available colornames;
+ This method should not be used, since colornames are
+ very X specific. However, the names defined here are pretty common"
+
+ ^ #('red' 'green' 'blue' 'yellow' 'magenta' 'cyan' 'white' 'black')
+!
+
+redComponentOfColor:colorId
+ "get red component (0..100) of color in map at:index"
+
+ self getRGBFrom:colorId into:[:r :g :b | ^ r]
+!
+
+setColor:index red:redVal green:greenVal blue:blueVal
+ "change color in map at:index to rgb (0..100)"
+
+ ^ self subclassResponsibility
+! !
+
+!DeviceWorkstation methodsFor:'cursor stuff'!
+
+colorCursor:aCursorId foreground:fgColor background:bgColor
+ "change a cursors colors"
+
+ ^ self subclassResponsibility
+!
+
+createCursorShape:aShape
+ "create a cursor given a shape-symbol"
+
+ ^ self subclassResponsibility
+!
+
+createCursorSourceForm:sourceForm maskForm:maskForm hotX:hx hotY:hy
+ "create a cursor given 2 bitmaps (source, mask) and a hotspot"
+ ^ self subclassResponsibility
+!
+
+destroyCursor:aCursorId
+ "free a cursor"
+
+ ^ self subclassResponsibility
+! !
+
+!DeviceWorkstation methodsFor:'drawing'!
+
+copyFromFaxImage:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
+ width:w height:h with:aGCId scaleX:scaleX scaleY:scaleY
+ "do a bit-blt"
+
+ ^ self subclassResponsibility
+!
+
+copyFromId:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
+ width:w height:h with:aGCId
+ "do a bit-blt"
+
+ ^ self subclassResponsibility
+!
+
+copyPlaneFromId:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
+ width:w height:h with:aGCId
+ "do a bit-blt, using the low-bit plane of the source only"
+
+ ^ self subclassResponsibility
+!
+
+displayArcX:x y:y w:width h:height from:startAngle angle:angle
+ in:aDrawableId with:aGCId
+ "draw an arc"
+
+ ^ self subclassResponsibility
+!
+
+displayLineFromX:x0 y:y0 toX:x1 y:y1 in:aDrawableId with:aGCId
+ "draw a line"
+
+ "could add a bresenham line drawer here ..."
+ ^ self subclassResponsibility
+!
+
+displayOpaqueString:aString from:index1 to:index2 x:x y:y in:aDrawableId with:aGCId
+ "draw a sub-string - draw foreground on background.
+ If the coordinates are not integers, retry with rounded."
+
+ self displayString:aString
+ from:index1
+ to:index2
+ x:x
+ y:y
+ in:aDrawableId
+ with:aGCId
+ opaque:true
+!
+
+displayOpaqueString:aString x:x y:y in:aDrawableId with:aGCId
+ "draw a string - draw foreground on background.
+ If the coordinates are not integers, retry with rounded."
+
+ self displayString:aString
+ x:x
+ y:y
+ in:aDrawableId
+ with:aGCId
+ opaque:true
+!
+
+displayPointX:x y:y in:aDrawableId with:aGCId
+ "draw a point"
+
+ ^ self subclassResponsibility
+!
+
+displayPolygon:aPolygon in:aDrawableId with:aGCId
+ "draw a polygon"
+
+ "
+ should draw the lines here
+ but then, we have to reimplement all line and join styles here
+ "
+ ^ self subclassResponsibility
+!
+
+displayRectangleX:x y:y width:width height:height in:aDrawableId with:aGCId
+ "draw a rectangle"
+
+ "
+ should draw four lines here
+ but then, we have to reimplement all line and join styles here
+ "
+ ^ self subclassResponsibility
+!
+
+displayString:aString from:index1 to:index2 x:x y:y in:aDrawableId with:aGCId
+ "draw a sub-string - draw foreground only.
+ If the coordinates are not integers, retry with rounded."
+
+ self
+ displayString:aString
+ from:index1
+ to:index2
+ x:x
+ y:y
+ in:aDrawableId
+ with:aGCId
+ opaque:false
+!
+
+displayString:aString from:i1 to:i2 x:x y:y in:aDrawableId with:aGCId opaque:opaque
+ "draw part of a string"
+
+ "
+ should be redefined in concrete subclasses
+ to avoid creation of throw-away string
+ "
+ self displayString:(aString copyFrom:i1 to:i2)
+ x:x
+ y:y
+ in:aDrawableId
+ with:aGCId
+ opaque:opaque
+!
+
+displayString:aString x:x y:y in:aDrawableId with:aGCId
+ "draw a string - draw foreground only.
+ If the coordinates are not integers, retry with rounded."
+
+ self
+ displayString:aString
+ x:x
+ y:y
+ in:aDrawableId
+ with:aGCId
+ opaque:false
+!
+
+displayString:aString x:x y:y in:aDrawableId with:aGCId opaque:opaque
+ "draw a string"
+
+ ^ self subclassResponsibility
+!
+
+drawBits:imageBits depth:imageDepth width:imageWidth height:imageHeight
+ x:srcx y:srcy
+ into:aDrawableId x:dstx y:dsty width:w height:h with:aGCId
+
+ "draw a bitimage which has depth id, width iw and height ih into
+ the drawable. draw a region of w/h pixels from srcx/srcy to dstx/dsty.
+ It has to be checked elsewhere, that server can do it with the given
+ depth; also it is assumed, that the colormap is setup correctly"
+
+ ^ self subclassResponsibility
+!
+
+fillArcX:x y:y w:width h:height from:startAngle angle:angle
+ in:aDrawableId with:aGCId
+ "fill an arc"
+
+ ^ self subclassResponsibility
+!
+
+fillPolygon:aPolygon in:aDrawableId with:aGCId
+ "fill a polygon"
+
+ ^ self subclassResponsibility
+!
+
+fillRectangleX:x y:y width:width height:height in:aDrawableId with:aGCId
+ "fill a rectangle"
+
+ ^ self subclassResponsibility
+! !
+
+!DeviceWorkstation methodsFor:'enumerating'!
+
+allViewsDo:aBlock
+ "evaluate the argument, aBlock for all of my known views"
+
+"/ idToViewMapping notNil ifTrue:[
+"/ idToViewMapping keysAndValuesDo:[:id :aView |
+"/ aView notNil ifTrue:[
+"/ aBlock value:aView
+"/ ]
+"/ ]
+
+
+ knownViews notNil ifTrue:[
+ knownViews do:[:aView |
+ aView notNil ifTrue:[
+ aBlock value:aView
+ ]
+ ]
+ ]
+
+ "
+ View defaultStyle:#iris.
+ Display allViewsDo:[:v | v initStyle. v redraw]
+ "
+ "
+ View defaultStyle:#next.
+ Display allViewsDo:[:v | v initStyle. v redraw]
+ "
+ "
+ View defaultStyle:#normal.
+ Display allViewsDo:[:v | v initStyle. v redraw]
+ "
+! !
+
+!DeviceWorkstation methodsFor:'event forwarding'!
+
+buttonMotion:button x:x y:y view:aView
+ "forward a button-motion for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor buttonMotion:button x:x y:y view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#buttonMotion:x:y:
+ arguments:(Array with:button with:x with:y)
+ view:aView
+ ]
+!
+
+buttonMultiPress:button x:x y:y view:aView
+ "forward a button-multi-press event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor buttonMultiPress:button x:x y:y view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#buttonMultiPress:x:y:
+ arguments:(Array with:button with:x with:y)
+ view:aView
+ ]
+!
+
+buttonPress:button x:x y:y view:aView
+ "forward a button-press event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor buttonPress:button x:x y:y view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#buttonPress:x:y:
+ arguments:(Array with:button with:x with:y)
+ view:aView
+ ]
+!
+
+buttonRelease:button x:x y:y view:aView
+ "forward a button-release event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor buttonRelease:button x:x y:y view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#buttonRelease:x:y:
+ arguments:(Array with:button with:x with:y)
+ view:aView
+ ]
+!
+
+buttonShiftPress:button x:x y:y view:aView
+ "forward a button-shift-press event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor buttonShiftPress:button x:x y:y view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#buttonShiftPress:x:y:
+ arguments:(Array with:button with:x with:y)
+ view:aView
+ ]
+!
+
+configureX:x y:y width:w height:h view:aView
+ "forward a configure for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor configureX:x y:y width:w height:h view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ aView configureX:x y:y width:w height:h
+ ]
+!
+
+coveredBy:otherView view:aView
+ "forward a covered for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor coveredBy:otherView view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ aView coveredBy:otherView
+ ]
+!
+
+destroyedView:aView
+ "forward a destroyed event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor destroyedView:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ aView destroyed
+ ]
+!
+
+exposeX:x y:y width:w height:h view:aView
+ "forward an expose for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor exposeX:x y:y width:w height:h view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#exposeX:y:width:height:
+ arguments:(Array with:x with:y with:w with:h)
+ view:aView
+ ]
+!
+
+focusInView:aView
+ "forward a focusIn event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor focusInView:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#focusIn
+ arguments:nil
+ view:aView
+ ]
+!
+
+focusOutView:aView
+ "forward a focusOut event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor focusOutView:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#focusOut
+ arguments:nil
+ view:aView
+ ]
+!
+
+graphicExposeX:x y:y width:w height:h view:aView
+ "forward a graphic expose for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor graphicExposeX:x y:y width:w height:h view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#graphicExposeX:y:width:height:
+ arguments:(Array with:x with:y with:w with:h)
+ view:aView
+ ]
+!
+
+keyPress:untranslatedKey x:x y:y view:aView
+ "forward a key-press event for some view"
+
+ |xlatedKey sensor|
+
+ self modifierKeyProcessing:untranslatedKey down:true.
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor keyPress:untranslatedKey x:x y:y view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ xlatedKey := self translateKey:untranslatedKey.
+ xlatedKey notNil ifTrue:[
+ WindowEvent
+ sendEvent:#keyPress:x:y:
+ arguments:(Array with:xlatedKey with:x with:y)
+ view:aView
+ ]
+ ]
+!
+
+keyRelease:untranslatedKey x:x y:y view:aView
+ "forward a key-release event for some view"
+
+ |xlatedKey sensor|
+
+ self modifierKeyProcessing:untranslatedKey down:false.
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor keyRelease:untranslatedKey x:x y:y view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ xlatedKey := self translateKey:untranslatedKey.
+ xlatedKey notNil ifTrue:[
+ WindowEvent
+ sendEvent:#keyRelease:x:y:
+ arguments:(Array with:xlatedKey with:x with:y)
+ view:aView
+ ]
+ ]
+!
+
+mappedView:aView
+ "forward a mapped event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor mappedView:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ aView mapped
+ ]
+!
+
+noExposeView:aView
+ "forward a noExpose event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor noExposeView:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ aView noExpose
+ ]
+!
+
+pointerEnter:buttonState x:x y:y view:aView
+ "forward a pointer enter for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor pointerEnter:buttonState x:x y:y view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#pointerEnter:x:y:
+ arguments:(Array with:buttonState with:x with:y)
+ view:aView
+ ]
+!
+
+pointerLeave:buttonState view:aView
+ "forward a pointer leave for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor pointerLeave:buttonState view:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ WindowEvent
+ sendEvent:#pointerLeave:
+ arguments:(Array with:buttonState)
+ view:aView
+ ]
+!
+
+saveAndTerminateView:aView
+ "forward a saveAndTerminate event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor saveAndTerminateView:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ aView saveAndTerminate
+ ]
+!
+
+terminateView:aView
+ "forward a terminate event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor terminateView:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ aView terminate
+ ]
+!
+
+unmappedView:aView
+ "forward an unmapped event for some view"
+
+ |sensor|
+
+ (sensor := aView sensor) notNil ifTrue:[
+ sensor unmappedView:aView
+ ] ifFalse:[
+ "
+ if there is no sensor ...
+ "
+ aView unmapped
+ ]
+! !
+
+!DeviceWorkstation methodsFor:'event handling'!
+
+checkForEndOfDispatch
+ "return true, if there are still any views of interrest -
+ if not, stop dispatch. This ends the dispatcher process when the
+ last view is closed on that device."
+
+ knownViews notNil ifTrue:[
+ (knownViews findFirst:[:slot | slot notNil]) == 0 ifTrue:[
+ "/ my last view was closed
+ dispatching := false
+ ]
+ ]
+
+ "Modified: 19.9.1995 / 11:31:54 / claus"
+!
+
+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."
+
+ [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
+!
+
+eventPendingWithoutSync
+ "return true, if any event is pending"
+
+ ^ self subclassResponsibility
+!
+
+eventsPending:anEventMask for:aWindowId
+ "return true, if any of the masked events is pending
+ for a specific window.
+ This expects a device dependent event mask as first argument."
+
+ ^ self subclassResponsibility
+!
+
+setEventMask:aMask in:aWindowId
+ ^ self subclassResponsibility
+!
+
+startDispatch
+ "create the display dispatch process."
+
+ |inputSema fd p nm|
+
+ "
+ only allow one dispatcher process per display
+ "
+ dispatching ifTrue:[^ self].
+ dispatching := true.
+
+ AllScreens isNil ifTrue:[
+ AllScreens := Set new:1
+ ].
+ AllScreens add:self.
+
+ "
+ The code below (still) handles the situation where ST/X was built
+ without lightweight process support. Since there are many other places
+ in the system whic depend on lightweight processes to function, this
+ may be a stupid thing to do ... expect it to vanish sooner or later.
+ "
+
+ fd := self displayFileDescriptor.
+
+ ProcessorScheduler isPureEventDriven ifTrue:[
+ "
+ no threads built in;
+ handle all events by having processor call a block when something
+ arrives on my filedescriptor. Dispatch the event in that block.
+ "
+ Processor enableIOAction:[
+ dispatching ifTrue:[
+ [self eventPending] whileTrue:[
+ self dispatchPendingEvents.
+ self checkForEndOfDispatch.
+ ].
+ dispatching ifFalse:[
+ Processor disableFd:fd.
+ AllScreens remove:self.
+ ]
+ ]
+ ]
+ onInput:fd
+
+ ] ifFalse:[
+ "
+ handle stuff as a process - sitting on a semaphore.
+ Tell Processor to trigger this semaphore when something arrives
+ on my filedescriptor. Since a select alone is not enough to
+ know if events are pending (Xlib reads out event-queue while
+ doing output), we also have to install a poll-check block.
+ "
+ inputSema := Semaphore new.
+ p := [
+ [dispatching] whileTrue:[
+ AbortSignal handle:[:ex |
+ ex return
+ ] do:[
+ self eventPending ifFalse:[
+ Processor activeProcess setStateTo:#ioWait if:#active.
+ inputSema wait.
+ ].
+
+ self dispatchPendingEvents.
+ self checkForEndOfDispatch.
+ ]
+ ].
+ Processor disableSemaphore:inputSema.
+ inputSema := nil.
+ AllScreens remove:self.
+ dispatchProcess := nil
+ ] forkAt:(Processor userInterruptPriority).
+ "
+ give the process a nice name (for the processMonitor)
+ "
+ (nm := self displayName) notNil ifTrue:[
+ nm := 'event dispatcher (' , nm , ')'.
+ ] ifFalse:[
+ nm := 'event dispatcher'.
+ ].
+ p name:nm.
+ Processor signal:inputSema onInput:fd orCheck:[self eventPending].
+ dispatchProcess := p.
+ ]
+! !
+
+!DeviceWorkstation methodsFor:'font stuff'!
+
+ascentOf:aFontId
+ "return the number of pixels above the base line of a font"
+
+ ^ self subclassResponsibility
+!
+
+descentOf:aFontId
+ "return the number of pixels below the base line of a font"
+
+ ^ self subclassResponsibility
+!
+
+facesInFamily:aFamilyName
+ "return a set of all available font faces in aFamily on this display"
+
+ |allFonts faces "family face"|
+
+ allFonts := self listOfAvailableFonts.
+ allFonts isNil ifTrue:[^ nil].
+
+ faces := Set new.
+ allFonts do:[:fntDescr |
+ aFamilyName = fntDescr family ifTrue:[
+ faces add:(fntDescr face)
+ ]
+ ].
+ ^ faces asSortedCollection
+
+ "
+ Display facesInFamily:'times'
+ Display facesInFamily:'fixed'
+ "
+!
+
+fontFamilies
+ "return a set of all available font families on this display"
+
+ |allFonts families family|
+
+ allFonts := self listOfAvailableFonts.
+ allFonts isNil ifTrue:[^ nil].
+ families := Set new.
+ allFonts do:[:fntDescr |
+ family := fntDescr family.
+ family notNil ifTrue:[
+ families add:family
+ ]
+ ].
+ ^ families asSortedCollection
+
+ "
+ Display fontFamilies
+ "
+!
+
+getDefaultFont
+ "return a default font id
+ - used when class Font cannot find anything usable"
+
+ ^ self subclassResponsibility
+!
+
+getFontWithFamily:familyString
+ face:faceString
+ style:styleString
+ size:sizeArg
+ encoding:encodingSym
+
+ "try to get the specified font, return id.
+ If not available, try next smaller font.
+ If no font fits, return nil"
+
+ ^ self subclassResponsibility
+!
+
+listOfAvailableFonts
+ "return a list containing all fonts on this display.
+ The returned list is an array of 4-element arrays, each
+ containing family, face, style, size and encoding."
+
+ self subclassResponsibility
+!
+
+maxWidthOfFont:aFontId
+ "return the width in pixels of the widest character a specific font"
+
+ ^ self subclassResponsibility
+!
+
+minWidthOfFont:aFontId
+ "return the width in pixels of the smallest character a specific font"
+
+ ^ self subclassResponsibility
+!
+
+releaseFont:aFontId
+ "free a font"
+
+ ^ self subclassResponsibility
+!
+
+sizesInFamily:aFamilyName face:aFaceName style:aStyleName
+ "return a set of all available font sizes in aFamily/aFace/aStyle
+ on this display"
+
+ |allFonts sizes "family face style size"|
+
+ allFonts := self listOfAvailableFonts.
+ allFonts isNil ifTrue:[^ nil].
+
+ sizes := Set new.
+ allFonts do:[:fntDescr |
+"/ family := fntDescr at:1.
+"/ (family = aFamilyName) ifTrue:[
+"/ face := fntDescr at:2.
+"/ (face = aFaceName) ifTrue:[
+"/ style := fntDescr at:3.
+"/ (style = aStyleName) ifTrue:[
+"/ size := fntDescr at:4.
+"/ sizes add:size
+"/ ]
+"/ ]
+"/ ]
+ (aFamilyName = fntDescr family) ifTrue:[
+ (aFaceName = fntDescr face) ifTrue:[
+ (aStyleName = fntDescr style) ifTrue:[
+ sizes add:fntDescr size
+ ]
+ ]
+ ]
+ ].
+ ^ sizes
+
+ "
+ Display sizesInFamily:'times' face:'medium' style:'italic'
+ "
+!
+
+stylesInFamily:aFamilyName face:aFaceName
+ "return a set of all available font styles in aFamily/aFace on this display"
+
+ |allFonts styles "family face style"|
+
+ allFonts := self listOfAvailableFonts.
+ allFonts isNil ifTrue:[^ nil].
+
+ styles := Set new.
+ allFonts do:[:fntDescr |
+ (aFamilyName = fntDescr family) ifTrue:[
+ (aFaceName = fntDescr face) ifTrue:[
+ styles add:fntDescr style
+ ]
+ ]
+ ].
+ ^ styles asSortedCollection
+
+ "
+ Display stylesInFamily:'times' face:'medium'
+ Display stylesInFamily:'times' face:'bold'
+ "
+!
+
+widthOf:aString from:index1 to:index2 inFont:aFontId
+ "return the width in pixels of a substring in a specific font"
+
+ ^ self subclassResponsibility
+!
+
+widthOf:aString inFont:aFontId
+ "return the width in pixels of a string in a specific font"
+
+ ^ self subclassResponsibility
+! !
+
+!DeviceWorkstation methodsFor:'grabbing '!
+
+activeKeyboardGrab
+ "return the view, which currently has the keyboard grabbed,
+ or nil, if there is none"
+
+ ^ activeKeyboardGrab
+!
+
+activePointerGrab
+ "return the view, which currently has the pointer grabbed,
+ or nil, if there is none"
+
+ ^ activePointerGrab
+!
+
+grabKeyboardIn:aWindowId
+ "grab the keyboard - all keyboard input will be sent to the view
+ with id aWindowId"
+
+ ^ self subclassResponsibility
+!
+
+grabKeyboardInView:aView
+ "grab the keyboard - all keyboard input will be sent to aView.
+ Return true if ok, false if it failed for some reason."
+
+ activeKeyboardGrab notNil ifTrue:[
+ self ungrabKeyboard.
+ activeKeyboardGrab := nil
+ ].
+ (self grabKeyboardIn:(aView id)) ifTrue:[
+ activeKeyboardGrab := aView.
+ ^ true
+ ].
+ ^ false
+!
+
+grabPointerIn:aWindowId
+ "grap the pointer; all pointer events will be reported to the view
+ with id aWindowId. Return true if ok, false if it failed for some reason."
+
+ ^ self grabPointerIn:aWindowId withCursor:nil pointerMode:#async keyboardMode:#sync confineTo:nil
+!
+
+grabPointerIn:aWindowId withCursor:cursorId pointerMode:pMode keyboardMode:kMode confineTo:confineId
+ "grap the pointer - all pointer events will be reported to aWindowId. The cursor will be set to cursorId
+ for the duration of the grab. For pMode/kMode, see X documentation. The pointer is restricted to
+ confineId - if non-nil."
+
+ ^ self subclassResponsibility
+!
+
+grabPointerInView:aView
+ "grap the pointer; all pointer events will be reported to
+ aView. Return true if ok, false if it failed for some reason."
+
+ activePointerGrab notNil ifTrue:[
+ self ungrabPointer.
+ activePointerGrab := nil
+ ].
+ (self grabPointerIn:(aView id)) ifTrue:[
+ activePointerGrab := aView.
+ ^ true
+ ].
+ ^ false
+!
+
+setActivePointerGrab:aView
+ "DO NOT USE. private kludge - will vanish"
+
+ activePointerGrab := aView
+!
+
+ungrabKeyboard
+ "release the keyboard"
+
+ ^ self subclassResponsibility
+!
+
+ungrabPointer
+ "release the pointer"
+
+ ^ self subclassResponsibility
+! !
+
+!DeviceWorkstation methodsFor:'graphic context stuff'!
+
+noClipIn:aGCId
+ "disable clipping rectangle"
+
+ ^ self subclassResponsibility
+!
+
+setBackground:bgColorIndex in:aGCId
+ "set background color to be drawn with"
+
+ ^ self subclassResponsibility
+!
+
+setBitmapMask:aBitmapId in:aGCId
+ "set or clear the drawing mask - a bitmap mask using current fg/bg"
+
+ ^ self subclassResponsibility
+!
+
+setClipByChildren:aBool in:aGCId
+ "enable/disable drawing into child views"
+
+ ^ self subclassResponsibility
+!
+
+setClipX:clipX y:clipY width:clipWidth height:clipHeight in:aGCId
+ "clip to a rectangle"
+
+ ^ self subclassResponsibility
+!
+
+setFont:aFontId in:aGCId
+ "set font to be drawn in"
+
+ ^ self subclassResponsibility
+!
+
+setForeground:fgColorIndex background:bgColorIndex in:aGCId
+ "set foreground and background colors to be drawn with"
+
+ ^ self subclassResponsibility
+!
+
+setForeground:fgColor background:bgColor mask:aBitmapId in:aGCId
+ "set foreground and background colors to be drawn with using mask or
+ solid (if aBitmapId is nil)"
+
+ ^ self subclassResponsibility
+!
+
+setForeground:fgColor background:bgColor mask:aBitmapId lineWidth:lw in:aGCId
+ "set foreground and background colors to be drawn with using mask or
+ solid (if aBitmapId is nil); also set lineWidth"
+
+ ^ self subclassResponsibility
+!
+
+setForeground:fgColorIndex in:aGCId
+ "set foreground color to be drawn with"
+
+ ^ self subclassResponsibility
+!
+
+setFunction:aFunctionSymbol in:aGCId
+ "set alu function to be drawn with"
+
+ ^ self subclassResponsibility
+!
+
+setGraphicsExposures:aBoolean in:aGCId
+ "set or clear the graphics exposures flag"
+
+ ^ self subclassResponsibility
+!
+
+setLineWidth:aNumber style:lineStyle cap:capStyle join:joinStyle in:aGCId
+ "set line attributes"
+
+ ^ self subclassResponsibility
+!
+
+setMaskOriginX:orgX y:orgY in:aGCid
+ "set the mask origin"
+
+ ^ self subclassResponsibility
+!
+
+setPixmapMask:aPixmapId in:aGCId
+ "set or clear the drawing mask - a pixmap mask providing full color"
+
+ ^ self subclassResponsibility
+! !
+
!DeviceWorkstation methodsFor:'initialize / release'!
+close
+ "close down connection to Display - usually never done"
+
+ ^ self subclassResponsibility
+!
+
initialize
"initialize the receiver for a connection to the default display"
@@ -323,10 +2635,20 @@
^ self subclassResponsibility
!
-close
- "close down connection to Display - usually never done"
-
- ^ self subclassResponsibility
+initializeKeyboardMap
+ "keystrokes from the server are translated via the keyboard map.
+ Untranslated keystrokes arrive either as characters, or symbols
+ (which are the keySyms as symbol). The mapping table which is
+ setup here, is used in sendKeyPress:... later.
+ "
+
+ keyboardMap isNil ifTrue:[
+ keyboardMap := KeyboardMap new.
+ ].
+
+ "
+ no more setup here - moved everything out into 'display.rc' file
+ "
!
invalidateConnection
@@ -393,1245 +2715,99 @@
]
].
dispatching := false.
-!
-
-initializeKeyboardMap
- "keystrokes from the server are translated via the keyboard map.
- Untranslated keystrokes arrive either as characters, or symbols
- (which are the keySyms as symbol). The mapping table which is
- setup here, is used in sendKeyPress:... later.
- "
-
- keyboardMap isNil ifTrue:[
- keyboardMap := KeyboardMap new.
- ].
-
- "
- no more setup here - moved everything out into 'display.rc' file
- "
-! !
-
-!DeviceWorkstation class methodsFor:'queries'!
-
-platformName
- "ST-80 compatibility.
- Return a string describing the display systems platform.
- Returns a dummy here. This must be redefined in concrete
- Workstation classes, to return somthing like 'X', 'MSWindows', 'OS/2' etc."
-
- ^ 'unknown'
-!
-
-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
-!
-
-allScreens
- "EXPERIMENTAL: 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"
-!
-
-current
- "EXPERIMENTAL: this should return the currently active screen,
- that is, the device of the currently executing windowGroup.
- It will be used in multi-display operation, to launch views on
- the correct device - even if not specified explicitely.
- This does not yet work fully satisfying ..."
-
- |wg tops v dev|
-
- AllScreens size == 1 ifTrue:[
- ^ AllScreens anElement
- ].
-
- "
- mhmh - multiple screens are active.
- be careful, to not run into an error in case
- the current windowGroup got corrupted somehow ...
- "
- (wg := WindowGroup activeGroup) notNil ifTrue:[
- "
- ok, not a background process or scheduler ...
- "
- (tops := wg topViews) notNil ifTrue:[
- tops isEmpty ifFalse:[
- (v := tops first) notNil ifTrue:[
- "
- ok, it has a view ...
- "
- (dev := v device) notNil ifTrue:[
- ^ dev
- ]
- ]
- ]
- ]
- ].
- "
- in all other cases, return the default display
- "
- ^ Display
-
- "
- Screen current
- "
-
- "Modified: 1.9.1995 / 13:40:05 / claus"
-! !
-
-!DeviceWorkstation class methodsFor:'error handling'!
-
-errorPrinting:aBoolean
- ErrorPrinting := aBoolean
-!
-
-errorPrinting
- ErrorPrinting isNil ifTrue:[^ false].
- ^ ErrorPrinting
-!
-
-resourceIdOfLastError
- "return the resource id responsible for the last error"
-
- ^ self subclassResponsibility
-!
-
-lastErrorString
- "return a string describing the last error"
-
- ^ self subclassResponsibility
-!
-
-errorInterrupt:errID with:aParameter
- "DisplayError interrupt.
- This is invoked via
- XError->errorInterrupt:#DisplayError->registeredErrorInterruptHandlers
-
- looks if a signal handler for DeviceErrorSignal is present,
- and - if so raises the signal. If the signal not handled, simply output a
- message and continue.
- This allows for non disrupted error reporting OR to catch and
- investigate errors as required."
-
- |badId badResource msg|
-
- badId := self resourceIdOfLastError.
- badId ~~ 0 ifTrue:[
- badResource := self resourceOfId:badId.
- ].
- msg := 'Display error: ' , (self lastErrorString).
-
- DeviceErrorSignal isHandled ifFalse:[
- ErrorPrinting ifTrue:[msg errorPrintNL].
- ^ self
- ].
-
- ^ DeviceErrorSignal
- raiseRequestWith:badResource
- errorString:msg
-!
-
-resourceOfId:id
- "search thru all device stuff for a resource.
- Needed for error handling"
-
- Form allInstances do:[:f |
- f id == id ifTrue:[^ f]
- ].
-
- self allInstances do:[:aDisplay |
- aDisplay allViewsDo:[:aView |
- aView id == id ifTrue:[^ aView].
- aView gcId == id ifTrue:[^ aView]
- ].
-
-"/ |views|
-"/ views := aDisplay knownViews.
-"/ views notNil ifTrue:[
-"/ views do:[:v |
-"/ v id == id ifTrue:[^ v].
-"/ v gcId == id ifTrue:[^ v]
-"/ ].
-"/ ].
- ].
-
- Color allInstances do:[:c |
- c colorId == id ifTrue:[^ c]
- ].
-
- Font allInstances do:[:f |
- f fontId == id ifTrue:[^ f]
- ].
- ^ nil
-! !
-
-!DeviceWorkstation methodsFor:'misc'!
-
-metaDown
- "return true, if the meta-key (alt-key on systems without meta)
- is currently pressed."
-
- ^ metaDown
-!
-
-altDown
- "return true, if the alt-key is currently pressed."
-
- ^ altDown
-!
-
-ctrlDown
- "return true, if the control-key is currently pressed."
-
- ^ ctrlDown
-!
-
-shiftDown
- "return true, if the shift-key is currently pressed."
-
- ^ shiftDown
-!
-
-unBuffered
- "make all drawing be sent immediately to the display.
- This may horribly slow down your drawings, but will result
- in any errors to be delivered right after the bad operation
- (in X only). Only useful for debugging."
-
- ^ self
-!
-
-buffered
- "buffer drawing - do not send it immediately to the display.
- This is the default; see comment in #unBuffered."
-
- ^ self
-!
-
-flush
- "send all buffered drawing to the display.
- This used to be called #synchronizeOutput, but has been renamed
- for ST-80 compatibility."
-
- ^ self
-!
-
-sync
- "for ST-80 compatibility"
-
- self flush
-!
-
-synchronizeOutput
- "send all buffered drawing to the display.
- OBSOLETE: please use #flush for ST-80 compatibility."
-
- self obsoleteMethodWarning:'use #flush'.
- ^ self flush
-!
-
-compressMotionEvents:aBoolean
- "turn on/off motion event compression
- - compressions makes always sense except in free-hand drawing of curves"
-
- motionEventCompression := aBoolean
-!
-
-hasColors:aBoolean
- "set the hasColors flag - needed since some servers dont tell the
- truth if a monochrome monitor is connected to a color server.
- Clearing the hasColors flag in the rc file will force use of grey
- colors (which might make a difference, since some colors are hard to
- distinguish on a greyscale monitor)."
-
- hasColors := aBoolean
-!
-
-hasGreyscales:aBoolean
- "set the hasGreyscales flag - can be used to simulate b&w behavior
- on greyScale and color monitors.
- (You may want to check if your application looks ok if displayed on
- a b&w monitor - even if you have a color display. To do so, clear
- the hasGreyscales flag from your .rc file)"
-
- hasGreyscales := aBoolean
-!
-
-ignoreBackingStore:aBoolean
- "if the argument is true, the views backingStore setting will be ignored, and
- no backing store used - this can be used on servers where backing store is
- very slow (from rc-file)"
-
- ^ self
-!
-
-isSlow:aBoolean
- "set/clear the slow flag.
- The slow-flag has no semantic meaning by itself;
- however, it can be set via the display.rc file and tested at various
- other places to turn off some bells&whistles which might slow down
- the drawing. For example, shadows under popUps are suppressed if isSlow
- is set."
-
- isSlow := aBoolean
-!
-
-beep
- "output an audible beep or bell"
-
- Stdout nextPut:(Character bell)
-!
-
-ringBell
- "alias for beep; for ST-80 compatibility"
-
- self beep
-!
-
-setInputFocusTo:aWindowId
- ^ self subclassResponsibility
-! !
-
-!DeviceWorkstation methodsFor:'enumerating'!
-
-allViewsDo:aBlock
- "evaluate the argument, aBlock for all of my known views"
-
-"/ idToViewMapping notNil ifTrue:[
-"/ idToViewMapping keysAndValuesDo:[:id :aView |
-"/ aView notNil ifTrue:[
-"/ aBlock value:aView
-"/ ]
-"/ ]
-
-
- knownViews notNil ifTrue:[
- knownViews do:[:aView |
- aView notNil ifTrue:[
- aBlock value:aView
- ]
- ]
- ]
-
- "
- View defaultStyle:#iris.
- Display allViewsDo:[:v | v initStyle. v redraw]
- "
- "
- View defaultStyle:#next.
- Display allViewsDo:[:v | v initStyle. v redraw]
- "
- "
- View defaultStyle:#normal.
- Display allViewsDo:[:v | v initStyle. v redraw]
- "
-! !
-
-!DeviceWorkstation methodsFor:'printing & storing'!
-
-printOn:aStream
- "for your convenience, add the name of the display connection
- or 'default' to the printed representation."
-
- |name|
-
- super printOn:aStream.
-
- aStream nextPut:$(.
- (name := self displayName) isNil ifTrue:[
- name := 'defaultDisplay'
- ].
- aStream nextPutAll:name.
- aStream nextPut:$)
-! !
-
-!DeviceWorkstation methodsFor:'accessing & queries'!
-
-displayFileDescriptor
- "return the file descriptor associated with the display
- if any. If there is no underlying filedescriptor, return nil.
- (used for event select/polling)"
-
- ^ nil
-!
-
-displayName
- "return the display name - that is the name of the display connection
- or nil, for default display. For example, in X, this returns a string
- like 'hostname:0' for remote connections, and nil for a default local
- connection.
- - nothing known here, but maybe redefined in subclasses."
-
- ^ nil
-
- "
- Display displayName
- "
-!
-
-platformName
- "return a string describing the display systems platform.
- Returns a dummy here."
-
- ^ self class platformName
-
- "
- Display platformName
- "
-!
-
-serverVendor
- "return a string describing the display systems server vendor.
- Returns a dummy here"
-
- ^ 'generic'
-
- "
- Display serverVendor
- "
-!
-
-vendorRelease
- "return the display systems release number.
- Returns a dummy here."
-
- ^ 0
-
- "
- Display vendorRelease
- "
-!
-
-protocolVersion
- "return the display systems protocol version number.
- Returns a dummy here"
-
- ^ 0
-
- "
- Display protocolVersion
- "
-!
-
-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
- "
-!
-
-blackpixel
- "return the colorId of black"
-
- ^ self subclassResponsibility
-!
-
-whitepixel
- "return the colorId of white"
-
- ^ self subclassResponsibility
-!
-
-viewIdFromPoint:aPoint in:windowId
- "given a point in rootWindow, return the viewId of the subview of windowId
- hit by this coordinate. Return nil if no view was hit.
- - use to find window to drop objects after a cross-view drag"
-
- "returning nil here actually makes drag&drop impossible
- - could also be reimplemented to make a search over all knownViews here.
- This method has to be reimplemented in concrete display classes."
-
- ^ nil
-!
-
-translatePoint:aPoint from:windowId1 to:windowId2
- "given a point in window1 (defined by its id), return the coordinate of
- aPoint in window2 (defined by its id).
- Use to xlate points from a window to rootwindow, mainly for rubber-line
- drawing on the displays root window."
-
- "This method has to be reimplemented in concrete display classes."
-
- ^ self subclassResponsibility
-
- "
- |v p root|
-
- v := View new.
- v openAndWait.
-
- root := v device rootView.
-
- p := v device translatePoint:10@10 from:(v id) to:(root id).
-
- root clippedByChildren:false.
- root displayLineFrom:0@0 to:p.
- root clippedByChildren:true.
- "
- "
- |v1 v2 p1 p2 root|
-
- v1 := View new.
- v1 openAndWait.
-
- v2 := View new.
- v2 openAndWait.
-
- root := v1 device rootView.
-
- p1 := v1 device translatePoint:10@10 from:(v1 id) to:(root id).
- p2 := v1 device translatePoint:10@10 from:(v2 id) to:(root id).
-
- root clippedByChildren:false.
- root displayLineFrom:p1 to:p2.
- root clippedByChildren:true.
- "
-!
-
-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"
-
- |view id searchId foundId|
-
- searchId := self rootWindowId.
- [searchId notNil] whileTrue:[
- id := self viewIdFromPoint:aPoint in:searchId.
- foundId := searchId.
- searchId := id
- ].
- ^ foundId
-!
-
-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
-!
-
-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
-!
-
-id
- "return the displayId"
-
- ^ displayId
-!
-
-ncells
- "return the number of usable color cells, the display has
- - this is not always 2 to the power of depth
- (for example, on 6bit displays, ncells is 64 while depth is 8)"
-
- ^ ncells
-
- "
- Display ncells
- "
-!
-
-depth
- "return the depth in pixels of the display"
-
- ^ depth
-
- "
- Display depth
- "
-!
-
-bitsPerRGB
- "return the number of valid bits per rgb component;
- Currently, assume that r/g/b all have the same precision,
- which is a stupid assumption (there may be some, where less
- resolution is available in the blue component).
- Therefore, this may be changed to return a 3-element vector.
- 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"
-!
-
-bitsGreen
- "return the number of valid bits in the red component."
-
- bitsGreen isNil ifTrue:[
- "/ not a truecolor display
- ^ bitsPerRGB
- ].
- ^ bitsGreen
-
- "
- Display bitsGreen
- "
-
- "Created: 21.10.1995 / 00:45:11 / cg"
-!
-
-bitsBlue
- "return the number of valid bits in the red component."
-
- bitsBlue isNil ifTrue:[
- "/ not a truecolor display
- ^ bitsPerRGB
- ].
- ^ bitsBlue
-
- "
- Display bitsBlue
- "
-
- "Created: 21.10.1995 / 00:45:27 / cg"
-!
-
-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"
-!
-
-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"
-!
-
-shiftGreen
- "return the count by which the red bits are to be shifted
- when forming a color index.
- This only makes sense with trueColor displays; therefore,
- nil is returned on all others."
-
- ^ greenShift
-
- "
- Display shiftGreen
- "
-
- "Created: 21.10.1995 / 00:45:27 / cg"
- "Modified: 21.10.1995 / 00:48:28 / cg"
-!
-
-visualType:aSymbol
- "set the visual type.
- The only situation, where setting the visual makes sense,
- is with my plasma-display, which ignores the palette and spits out
- grey scales, independent of color LUT definitions.
- (of which the server knows nothing).
- So, this should be used from a display-specific startup file only."
-
- visualType := aSymbol.
- (visualType == #StaticGray or:[visualType == #GrayScale]) ifTrue:[
- hasColors := false
- ] ifFalse:[
- hasColors := true
- ]
-!
-
-visualType
- "return a symbol representing the visual type of the display"
-
- ^ visualType
-
- "
- Display visualType
- "
-!
-
-monitorType
- "return a symbol representing the monitor type of the display.
- It is usually set to #unknown, #color or #monochrome.
- But it can be set to any value from the startup file, for later
- testing from anywhere. For example the startup for plasma-displays
- can set it to #plasma to later influence the colors used in widgets
- (indirectly through the resource file)."
-
- ^ monitorType
-
- "
- Display monitorType
- "
-!
-
-monitorType:aSymbol
- "set the monitorType - see comment in DeviceWorkstation>>montorType"
-
- monitorType := aSymbol
-!
-
-hasColors
- "return true, if its a color display"
-
- ^ hasColors
-
- "
- Display hasColors
- "
-!
-
-hasGreyscales
- "return true, if this workstation supports greyscales
- (also true for color displays)"
-
- ^ hasGreyscales
-
- "
- Display hasGreyscales
- "
-!
-
-hasShape
- "return true, if this workstation supports non-rectangular windows.
- Should be reimplemented in concrete classes which do support this."
-
- ^ false
-
- "
- Display hasShape
- "
-!
-
-hasShm
- "return true, if this workstation supports shared memory pixmaps.
- Should be reimplemented in concrete classes which do support this."
-
- ^ false
-
- "
- Display hasShm
- "
-!
-
-hasFax
- "return true, if this workstation supports decompression of fax images.
- Should be reimplemented in concrete classes which do support this."
-
- ^ false
-
- "
- Display hasFax
- "
-!
-
-hasDPS
- "return true, if this workstation supports postscript output into views.
- Should be reimplemented in concrete classes which do support this."
-
- ^ false
-
- "
- Display hasDPS
- "
-!
-
-hasPEX
- "return true, if this workstation supports PEX graphics.
- Should be reimplemented in concrete classes which do support this."
-
- ^ false
-
- "
- Display hasPEX
- "
-!
-
-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
- "
-!
-
-hasXVideo
- "return true, if this workstation supports the XVideo extension"
-
- ^ false
-
- "
- Display hasXVideo
- "
-!
-
-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
- "
-!
-
-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'
- "
-!
-
-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
-!
-
-isSlow
- "return true, if this is a relatively slow device -
- used to turn off things like popup-shadows"
-
- ^ isSlow
-!
-
-supportsDeepIcons
- "return true, if this device supports non b&w (i.e. greyScale
- or colored icons). We really dont know here."
-
- "This method has to be reimplemented in concrete display classes."
- ^ self subclassResponsibility
-
- "
- Display supportsDeepIcons
- "
-!
-
-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
- "
-!
-
-supportsGLDrawing
- "return true, if this device supports 3D GL drawing.
- We do not depend on that being implemented."
-
- "This method should to be reimplemented in concrete display classes."
- ^ false
-
- "
- Display supportsGLDrawing
- "
-!
-
-keyboardMap
- "return the keyboard map"
-
- ^ keyboardMap
-!
-
-keyboardMap:aMap
- "set the keyboard map"
-
- keyboardMap := aMap
-!
-
-dispatchProcess
- ^ dispatchProcess
-!
-
-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
-!
-
-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"
-!
-
-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"
-!
-
-width
- "return the width of the display (in pixels)"
-
- ^ width
-
- "Display width"
-!
-
-height
- "return the height of the display (in pixels)"
-
- ^ height
-
- "Display height"
-!
-
-extent
- "return the extent of the display (in pixels)"
-
- ^ width @ height
-
- "
- Display extent
- "
-!
-
-bounds
- "return a rectangle representing the displays bounding box.
- For Smalltalk-80 4.x compatibility"
-
- ^ Rectangle origin:(0 @ 0) extent:(width @ height)
-
- "
- Screen default bounds
- "
- "/ thats the same as:
- "
- Display bounds
- "
-!
-
-boundingBox
- "return a rectangle representing the displays bounding box.
- For Smalltalk-80 2.x compatibility"
-
- ^ self bounds
-!
-
-widthInMillimeter
- "return the width in millimeter of the display"
-
- ^ widthMM
-
- "Display widthInMillimeter"
-!
-
-heightInMillimeter
- "return the height in millimeter of the display"
-
- ^ heightMM
-
- "Display heightInMillimeter"
-!
-
-widthInMillimeter:aNumber
- "set the width in millimeter of the display
- - needed since some displays do not tell the truth or do not know it"
-
- widthMM := aNumber
-!
-
-heightInMillimeter:aNumber
- "set the height in millimeter of the display
- - needed since some displays do not tell the truth or do not know it"
-
- heightMM := aNumber
-!
-
-pixelPerMillimeter
- "return the number of horizontal/vertical pixels per millimeter of the display as Point"
-
- ^ (width / widthMM) @ (height / heightMM)
-
- "Display pixelPerMillimeter"
-!
-
-pixelPerInch
- "return the number of horizontal/vertical pixels per inch of the display as Point"
-
- ^ ((width / widthMM) @ (height / heightMM)) * 25.4
-
- "Display pixelPerInch"
-!
-
-horizontalPixelPerMillimeter
- "return the number of horizontal pixels per millimeter of the display"
-
- ^ width / widthMM
-!
-
-verticalPixelPerMillimeter
- "return the number of vertical pixels per millimeter of the display"
-
- ^ height / heightMM
-!
-
-horizontalPixelPerInch
- "return the number of horizontal pixels per inch of the display"
-
- ^ (width / widthMM) * 25.4
-!
-
-verticalPixelPerInch
- "return the number of vertical pixels per inch of the display"
-
- ^ (height / heightMM) * 25.4
-!
-
-center
- "return the centerpoint in pixels of the display"
-
- ^ (width // 2) @ (height // 2)
-!
-
-knownViews
- "return a collection of all known views"
-
- ^ knownViews
-!
-
-knownViews:aCollection
- "set the collection of all known views - take care,
- bad use of this will create funny results; use only for snapshot support"
-
- knownViews := aCollection
-!
-
-buttonTranslation
- ^ buttonTranslation
-!
-
-buttonTranslation:anArray
- buttonTranslation := anArray
-!
-
-buttonMotionMask:aMask includesButton:aButton
- "given a device button mask, return true if a logical button
- (1 .. 3 for left .. right) is included."
-
- |buttonNr|
-
- "reverse buttonTranslation"
- buttonTranslation notNil ifTrue:[
- buttonNr := buttonTranslation indexOf:aButton ifAbsent:[1].
- ] ifFalse:[
- buttonNr := aButton.
- ].
- ^ (aMask bitTest:(self buttonMotionMask:buttonNr))
-!
-
-multiClickTimeDelta
- ^ multiClickTimeDelta
-!
-
-multiClickTimeDelta:milliseconds
- multiClickTimeDelta := milliseconds
-! !
-
-!DeviceWorkstation methodsFor:'pointer queries'!
-
-rootPositionOfLastEvent
- "return the position in root-window coordinates
- of the last button, key or pointer event.
- Must be redefined by concrete subclasses."
-
- ^ self subclassResponsibility
-!
-
-pointerPosition
- "return the current pointer position in root-window coordinates.
- Must be redefined by concrete subclasses."
-
- ^ self subclassResponsibility
-!
-
-buttonStates
- "return an integer representing the state of the pointer buttons;
- a one-bit represents a pressed button. The bit positions are device specific
- and to be returned by the *ButtonStateMask methods.
- Must be redefined by concrete subclasses."
-
- ^ self subclassResponsibility
-!
-
-leftButtonStateMask
- "return an integer for masking out the left button from a
- buttonStates value. This is very device specific and to
- be redefined by concrete subclasses."
-
- ^ self subclassResponsibility
-!
-
-middleButtonStateMask
- "return an integer for masking out the middle button from a
- buttonStates value. This is very device specific and to
- be redefined by concrete subclasses."
-
- ^ self subclassResponsibility
-!
-
-rightButtonStateMask
- "return an integer for masking out the right button from a
- buttonStates value. This is very device specific and to
- be redefined by concrete subclasses."
-
- ^ self subclassResponsibility
-!
-
-leftButtonPressed
- "return true, if the left button is currently pressed"
-
- ^ (self buttonStates bitAnd:self leftButtonStateMask) ~~ 0
-!
-
-middleButtonPressed
- "return true, if the middle button is currently pressed"
-
- ^ (self buttonStates bitAnd:self middleButtonStateMask) ~~ 0
-!
-
-rightButtonPressed
- "return true, if the right button is currently pressed"
-
- ^ (self buttonStates bitAnd:self rightButtonStateMask) ~~ 0
! !
!DeviceWorkstation methodsFor:'interactive queries'!
+originFromUser:extent
+ "let user specify a rectangles origin on the screen, return the rectangle.
+ Start with initialRectangle.
+ Can be used for dragging operations."
+
+ |curs origin root rect|
+
+ curs := Cursor origin on:self.
+
+ "
+ just in case; wait for button to be down ...
+ "
+ [self leftButtonPressed] whileFalse:[Processor yield].
+
+ root := self rootView.
+
+ "
+ grab and wait for leftButton being pressed
+ "
+ origin := self pointerPosition.
+
+ root noClipByChildren.
+ root foreground:Color black background:Color white.
+
+ root xoring:[
+ |left right top bottom newOrigin newCorner p|
+
+ rect := origin extent:extent.
+ root displayRectangle:rect.
+
+ self
+ grabPointerIn:root id
+ withCursor:curs id
+ pointerMode:#async
+ keyboardMode:#sync
+ confineTo:nil.
+
+ [self leftButtonPressed] whileTrue:[
+ newOrigin := self pointerPosition.
+
+ (newOrigin ~= origin) ifTrue:[
+ root displayRectangle:rect.
+
+ self
+ grabPointerIn:root id
+ withCursor:curs id
+ pointerMode:#async
+ keyboardMode:#sync
+ confineTo:nil.
+
+ rect := newOrigin extent:extent.
+ root displayRectangle:rect.
+ self disposeButtonEventsFor:nil.
+ self flush.
+ origin := newOrigin.
+ ] ifFalse:[
+ Processor yield
+ ]
+ ].
+ root displayRectangle:rect.
+ self ungrabPointer.
+ ].
+
+ self ungrabPointer.
+
+ "flush all events pending on my display"
+
+ root clipByChildren.
+
+ self flush.
+ self disposeButtonEventsFor:nil.
+
+ ^ rect
+
+ "
+ Display originFromUser:200@200
+ "
+!
+
+pointFromUser
+ "let user specify a point on the screen (by pressing the left button)"
+
+ ^ self pointFromUserShowing:(Cursor crossHair).
+
+ "
+ Display pointFromUser
+ "
+!
+
pointFromUserShowing:aCursor
"let user specify a point on the screen (by pressing leftButton).
Show aCursor while waiting."
@@ -1664,13 +2840,23 @@
"
!
-pointFromUser
- "let user specify a point on the screen (by pressing the left button)"
-
- ^ self pointFromUserShowing:(Cursor crossHair).
+rectangleFromUser
+ "let user specify a rectangle in the screen, return the rectangle"
+
+ |origin|
"
- Display pointFromUser
+ get origin
+ "
+ origin := self pointFromUserShowing:(Cursor origin on:self).
+
+ "
+ get corner
+ "
+ ^ self rectangleFromUser:(origin corner:origin).
+
+ "
+ Display rectangleFromUser
"
!
@@ -1780,118 +2966,22 @@
"
!
-rectangleFromUser
- "let user specify a rectangle in the screen, return the rectangle"
-
- |origin|
-
- "
- get origin
- "
- origin := self pointFromUserShowing:(Cursor origin on:self).
-
- "
- get corner
- "
- ^ self rectangleFromUser:(origin corner:origin).
-
- "
- Display rectangleFromUser
- "
-!
-
-originFromUser:extent
- "let user specify a rectangles origin on the screen, return the rectangle.
- Start with initialRectangle.
- Can be used for dragging operations."
-
- |curs origin root rect|
-
- curs := Cursor origin on:self.
-
- "
- just in case; wait for button to be down ...
- "
- [self leftButtonPressed] whileFalse:[Processor yield].
-
- root := self rootView.
+topviewFromUser
+ "let user specify a view on the screen; if the selected view is
+ not an ST/X view, nil is returned.
+ Otherwise, the topview is returned."
+
+ |v|
+
+ v := self viewFromUser.
+ v notNil ifTrue:[
+ v := v topView
+ ].
+ ^ v
"
- grab and wait for leftButton being pressed
+ Display topviewFromUser
"
- origin := self pointerPosition.
-
- root noClipByChildren.
- root foreground:Color black background:Color white.
-
- root xoring:[
- |left right top bottom newOrigin newCorner p|
-
- rect := origin extent:extent.
- root displayRectangle:rect.
-
- self
- grabPointerIn:root id
- withCursor:curs id
- pointerMode:#async
- keyboardMode:#sync
- confineTo:nil.
-
- [self leftButtonPressed] whileTrue:[
- newOrigin := self pointerPosition.
-
- (newOrigin ~= origin) ifTrue:[
- root displayRectangle:rect.
-
- self
- grabPointerIn:root id
- withCursor:curs id
- pointerMode:#async
- keyboardMode:#sync
- confineTo:nil.
-
- rect := newOrigin extent:extent.
- root displayRectangle:rect.
- self disposeButtonEventsFor:nil.
- self flush.
- origin := newOrigin.
- ] ifFalse:[
- Processor yield
- ]
- ].
- root displayRectangle:rect.
- self ungrabPointer.
- ].
-
- self ungrabPointer.
-
- "flush all events pending on my display"
-
- root clipByChildren.
-
- self flush.
- self disposeButtonEventsFor:nil.
-
- ^ rect
-
- "
- Display originFromUser:200@200
- "
-!
-
-viewIdFromUser
- "let user specify a view on the screen, return its window id.
- This works even for non smalltalk views.
- This returns the id of the view being clicked in,
- which is not always a topView."
-
- ^ self viewIdFromPoint:(self pointFromUser)
-
- "
- Display viewIdFromUser
- "
-
- "Created: 18.9.1995 / 23:07:20 / claus"
!
viewFromUser
@@ -1913,26 +3003,41 @@
"
!
-topviewFromUser
- "let user specify a view on the screen; if the selected view is
- not an ST/X view, nil is returned.
- Otherwise, the topview is returned."
-
- |v|
-
- v := self viewFromUser.
- v notNil ifTrue:[
- v := v topView
- ].
- ^ v
+viewIdFromUser
+ "let user specify a view on the screen, return its window id.
+ This works even for non smalltalk views.
+ This returns the id of the view being clicked in,
+ which is not always a topView."
+
+ ^ self viewIdFromPoint:(self pointFromUser)
"
- Display topviewFromUser
+ Display viewIdFromUser
"
+
+ "Created: 18.9.1995 / 23:07:20 / claus"
! !
!DeviceWorkstation methodsFor:'keyboard mapping'!
+modifierKeyProcessing:key down:pressed
+ (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
+ ]
+ ]
+ ]
+ ]
+!
+
translateKey:untranslatedKey
"Return the key translated via the translation table.
Your application program should never depend on the values returned
@@ -1994,390 +3099,227 @@
xlatedKey := xlatedKey asSymbol
].
^ xlatedKey
+! !
+
+!DeviceWorkstation methodsFor:'misc'!
+
+altDown
+ "return true, if the alt-key is currently pressed."
+
+ ^ altDown
!
-modifierKeyProcessing:key down:pressed
- (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
- ]
- ]
- ]
- ]
-! !
-
-!DeviceWorkstation methodsFor:'event forwarding'!
-
-keyPress:untranslatedKey x:x y:y view:aView
- "forward a key-press event for some view"
-
- |xlatedKey sensor|
-
- self modifierKeyProcessing:untranslatedKey down:true.
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor keyPress:untranslatedKey x:x y:y view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- xlatedKey := self translateKey:untranslatedKey.
- xlatedKey notNil ifTrue:[
- WindowEvent
- sendEvent:#keyPress:x:y:
- arguments:(Array with:xlatedKey with:x with:y)
- view:aView
- ]
- ]
+beep
+ "output an audible beep or bell"
+
+ Stdout nextPut:(Character bell)
+!
+
+buffered
+ "buffer drawing - do not send it immediately to the display.
+ This is the default; see comment in #unBuffered."
+
+ ^ self
+!
+
+compressMotionEvents:aBoolean
+ "turn on/off motion event compression
+ - compressions makes always sense except in free-hand drawing of curves"
+
+ motionEventCompression := aBoolean
!
-keyRelease:untranslatedKey x:x y:y view:aView
- "forward a key-release event for some view"
-
- |xlatedKey sensor|
-
- self modifierKeyProcessing:untranslatedKey down:false.
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor keyRelease:untranslatedKey x:x y:y view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- xlatedKey := self translateKey:untranslatedKey.
- xlatedKey notNil ifTrue:[
- WindowEvent
- sendEvent:#keyRelease:x:y:
- arguments:(Array with:xlatedKey with:x with:y)
- view:aView
- ]
- ]
+ctrlDown
+ "return true, if the control-key is currently pressed."
+
+ ^ ctrlDown
!
-buttonPress:button x:x y:y view:aView
- "forward a button-press event for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor buttonPress:button x:x y:y view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#buttonPress:x:y:
- arguments:(Array with:button with:x with:y)
- view:aView
- ]
+flush
+ "send all buffered drawing to the display.
+ This used to be called #synchronizeOutput, but has been renamed
+ for ST-80 compatibility."
+
+ ^ self
+!
+
+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
!
-buttonShiftPress:button x:x y:y view:aView
- "forward a button-shift-press event for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor buttonShiftPress:button x:x y:y view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#buttonShiftPress:x:y:
- arguments:(Array with:button with:x with:y)
- view:aView
- ]
+hasGreyscales:aBoolean
+ "set the hasGreyscales flag - can be used to simulate b&w behavior
+ on greyScale and color monitors.
+ (You may want to check if your application looks ok if displayed on
+ a b&w monitor - even if you have a color display. To do so, clear
+ the hasGreyscales flag from your .rc file)"
+
+ hasGreyscales := aBoolean
!
-buttonMultiPress:button x:x y:y view:aView
- "forward a button-multi-press event for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor buttonMultiPress:button x:x y:y view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#buttonMultiPress:x:y:
- arguments:(Array with:button with:x with:y)
- view:aView
- ]
+ignoreBackingStore:aBoolean
+ "if the argument is true, the views backingStore setting will be ignored, and
+ no backing store used - this can be used on servers where backing store is
+ very slow (from rc-file)"
+
+ ^ self
+!
+
+isSlow:aBoolean
+ "set/clear the slow flag.
+ The slow-flag has no semantic meaning by itself;
+ however, it can be set via the display.rc file and tested at various
+ other places to turn off some bells&whistles which might slow down
+ the drawing. For example, shadows under popUps are suppressed if isSlow
+ is set."
+
+ isSlow := aBoolean
!
-buttonRelease:button x:x y:y view:aView
- "forward a button-release event for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor buttonRelease:button x:x y:y view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#buttonRelease:x:y:
- arguments:(Array with:button with:x with:y)
- view:aView
- ]
+metaDown
+ "return true, if the meta-key (alt-key on systems without meta)
+ is currently pressed."
+
+ ^ metaDown
+!
+
+ringBell
+ "alias for beep; for ST-80 compatibility"
+
+ self beep
!
-buttonMotion:button x:x y:y view:aView
- "forward a button-motion for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor buttonMotion:button x:x y:y view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#buttonMotion:x:y:
- arguments:(Array with:button with:x with:y)
- view:aView
- ]
+setInputFocusTo:aWindowId
+ ^ self subclassResponsibility
!
-pointerEnter:buttonState x:x y:y view:aView
- "forward a pointer enter for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor pointerEnter:buttonState x:x y:y view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#pointerEnter:x:y:
- arguments:(Array with:buttonState with:x with:y)
- view:aView
- ]
+shiftDown
+ "return true, if the shift-key is currently pressed."
+
+ ^ shiftDown
+!
+
+sync
+ "for ST-80 compatibility"
+
+ self flush
!
-pointerLeave:buttonState view:aView
- "forward a pointer leave for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor pointerLeave:buttonState view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#pointerLeave:
- arguments:(Array with:buttonState)
- view:aView
- ]
+synchronizeOutput
+ "send all buffered drawing to the display.
+ OBSOLETE: please use #flush for ST-80 compatibility."
+
+ self obsoleteMethodWarning:'use #flush'.
+ ^ self flush
!
-focusInView:aView
- "forward a focusIn event for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor focusInView:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#focusIn
- arguments:nil
- view:aView
- ]
+unBuffered
+ "make all drawing be sent immediately to the display.
+ This may horribly slow down your drawings, but will result
+ in any errors to be delivered right after the bad operation
+ (in X only). Only useful for debugging."
+
+ ^ self
+! !
+
+!DeviceWorkstation methodsFor:'pointer queries'!
+
+buttonStates
+ "return an integer representing the state of the pointer buttons;
+ a one-bit represents a pressed button. The bit positions are device specific
+ and to be returned by the *ButtonStateMask methods.
+ Must be redefined by concrete subclasses."
+
+ ^ self subclassResponsibility
!
-focusOutView:aView
- "forward a focusOut event for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor focusOutView:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#focusOut
- arguments:nil
- view:aView
- ]
+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
!
-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
- ]
+middleButtonPressed
+ "return true, if the middle button is currently pressed"
+
+ ^ (self buttonStates bitAnd:self middleButtonStateMask) ~~ 0
!
-saveAndTerminateView:aView
- "forward a saveAndTerminate event for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor saveAndTerminateView:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- aView saveAndTerminate
- ]
-!
-
-destroyedView:aView
- "forward a destroyed event for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor destroyedView:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- aView destroyed
- ]
+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
!
-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
- ]
+pointerPosition
+ "return the current pointer position in root-window coordinates.
+ Must be redefined by concrete subclasses."
+
+ ^ self subclassResponsibility
!
-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
- ]
+rightButtonPressed
+ "return true, if the right button is currently pressed"
+
+ ^ (self buttonStates bitAnd:self rightButtonStateMask) ~~ 0
!
-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
- ]
+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
!
-configureX:x y:y width:w height:h view:aView
- "forward a configure for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor configureX:x y:y width:w height:h view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- aView configureX:x y:y width:w height:h
- ]
-!
-
-exposeX:x y:y width:w height:h view:aView
- "forward an expose for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor exposeX:x y:y width:w height:h view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#exposeX:y:width:height:
- arguments:(Array with:x with:y with:w with:h)
- view:aView
- ]
-!
-
-graphicExposeX:x y:y width:w height:h view:aView
- "forward a graphic expose for some view"
-
- |sensor|
-
- (sensor := aView sensor) notNil ifTrue:[
- sensor graphicExposeX:x y:y width:w height:h view:aView
- ] ifFalse:[
- "
- if there is no sensor ...
- "
- WindowEvent
- sendEvent:#graphicExposeX:y:width:height:
- arguments:(Array with:x with:y with:w with:h)
- view:aView
- ]
-!
-
-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
- ]
+rootPositionOfLastEvent
+ "return the position in root-window coordinates
+ of the last button, key or pointer event.
+ Must be redefined by concrete subclasses."
+
+ ^ self subclassResponsibility
+! !
+
+!DeviceWorkstation methodsFor:'printing & storing'!
+
+printOn:aStream
+ "for your convenience, add the name of the display connection
+ or 'default' to the printed representation."
+
+ |name|
+
+ super printOn:aStream.
+
+ aStream nextPut:$(.
+ (name := self displayName) isNil ifTrue:[
+ name := 'defaultDisplay'
+ ].
+ aStream nextPutAll:name.
+ aStream nextPut:$)
+! !
+
+!DeviceWorkstation methodsFor:'retrieving pixels'!
+
+getPixelX:x y:y from:aDrawableId
+ "return the pixel value at x/y"
+
+ ^ self subclassResponsibility
! !
!DeviceWorkstation methodsFor:'view registration'!
@@ -2456,18 +3398,6 @@
]
!
-viewFromId:aWindowID
- "given an Id, return the corresponding view."
-
- |index|
-
-"/ ^ idToViewMapping at:aNumber ifAbsent:[nil].
-
- index := knownIds indexOf:aWindowID.
- index == 0 ifTrue:[^ nil].
- ^ knownViews at:index.
-!
-
update:something
|id|
@@ -2488,34 +3418,60 @@
].
]
+!
+
+viewFromId:aWindowID
+ "given an Id, return the corresponding view."
+
+ |index|
+
+"/ ^ idToViewMapping at:aNumber ifAbsent:[nil].
+
+ index := knownIds indexOf:aWindowID.
+ index == 0 ifTrue:[^ nil].
+ ^ knownViews at:index.
! !
!DeviceWorkstation methodsFor:'window stuff'!
-setCursors:aCursor
- "change the cursor of all views to aCursorId"
-
- | id |
-
- id := (aCursor on:self) id.
- id notNil ifTrue:[
-"/ idToViewMapping notNil ifTrue:[
-"/ idToViewMapping keysAndValuesDo:[:viewId :view |
-"/ self setCursor:id in:viewId
-"/ ].
- knownViews do:[:aView |
- |vid|
-
- (aView notNil and:[(vid := aView id) notNil]) ifTrue:[
- self setCursor:id in:vid
- ]
- ].
- self flush
-"/ ]
- ]
-
- "Display setCursors:Cursor wait"
- "Display restoreCursors"
+clearRectangleX:x y:y width:width height:height in:aWindowId
+ "clear a rectangular area of a window to its view background"
+
+ ^ self subclassResponsibility
+!
+
+clearWindow:aWindowId
+ "clear a windows to its view background"
+
+ ^ self subclassResponsibility
+!
+
+lowerWindow:aWindowId
+ ^ self subclassResponsibility
+!
+
+mapView:aView id:aWindowId iconified:aBoolean atX:xPos y:yPos width:w height:h
+ ^ self subclassResponsibility
+!
+
+mapWindow:aWindowId
+ ^ self subclassResponsibility
+!
+
+moveResizeWindow:aWindowId x:x y:y width:w height:h
+ ^ self subclassResponsibility
+!
+
+moveWindow:aWindowId x:x y:y
+ ^ self subclassResponsibility
+!
+
+raiseWindow:aWindowId
+ ^ self subclassResponsibility
+!
+
+resizeWindow:aWindowId width:w height:h
+ ^ self subclassResponsibility
!
restoreCursors
@@ -2551,697 +3507,48 @@
"Display setCursors:(Cursor wait)"
"Display restoreCursors"
-! !
-
-!DeviceWorkstation methodsFor:'event handling'!
-
-startDispatch
- "create the display dispatch process."
-
- |inputSema fd p nm|
-
- "
- only allow one dispatcher process per display
- "
- dispatching ifTrue:[^ self].
- dispatching := true.
-
- AllScreens isNil ifTrue:[
- AllScreens := Set new:1
- ].
- AllScreens add:self.
-
- "
- The code below (still) handles the situation where ST/X was built
- without lightweight process support. Since there are many other places
- in the system whic depend on lightweight processes to function, this
- may be a stupid thing to do ... expect it to vanish sooner or later.
- "
-
- fd := self displayFileDescriptor.
-
- ProcessorScheduler isPureEventDriven ifTrue:[
- "
- no threads built in;
- handle all events by having processor call a block when something
- arrives on my filedescriptor. Dispatch the event in that block.
- "
- Processor enableIOAction:[
- dispatching ifTrue:[
- [self eventPending] whileTrue:[
- self dispatchPendingEvents.
- self checkForEndOfDispatch.
- ].
- dispatching ifFalse:[
- Processor disableFd:fd.
- AllScreens remove:self.
- ]
- ]
- ]
- onInput:fd
-
- ] ifFalse:[
- "
- handle stuff as a process - sitting on a semaphore.
- Tell Processor to trigger this semaphore when something arrives
- on my filedescriptor. Since a select alone is not enough to
- know if events are pending (Xlib reads out event-queue while
- doing output), we also have to install a poll-check block.
- "
- inputSema := Semaphore new.
- p := [
- [dispatching] whileTrue:[
- AbortSignal handle:[:ex |
- ex return
- ] do:[
- self eventPending ifFalse:[
- Processor activeProcess setStateTo:#ioWait if:#active.
- inputSema wait.
- ].
-
- self dispatchPendingEvents.
- self checkForEndOfDispatch.
- ]
- ].
- Processor disableSemaphore:inputSema.
- inputSema := nil.
- AllScreens remove:self.
- dispatchProcess := nil
- ] forkAt:(Processor userInterruptPriority).
- "
- give the process a nice name (for the processMonitor)
- "
- (nm := self displayName) notNil ifTrue:[
- nm := 'event dispatcher (' , nm , ')'.
- ] ifFalse:[
- nm := 'event dispatcher'.
- ].
- p name:nm.
- Processor signal:inputSema onInput:fd orCheck:[self eventPending].
- dispatchProcess := p.
- ]
!
-checkForEndOfDispatch
- "return true, if there are still any views of interrest -
- if not, stop dispatch. This ends the dispatcher process when the
- last view is closed on that device."
-
- knownViews notNil ifTrue:[
- (knownViews findFirst:[:slot | slot notNil]) == 0 ifTrue:[
- "/ my last view was closed
- dispatching := false
- ]
- ]
-
- "Modified: 19.9.1995 / 11:31:54 / claus"
-!
-
-dispatchPendingEvents
- "go dispatch events as long as there is one."
-
- [self eventPending] whileTrue:[
- self dispatchEventFor:nil withMask:nil
- ]
-!
-
-dispatchModalWhile:aBlock
- "get and process next event for any view as long as the
- argument-block evaluates to true.
- This is a modal loop, not switching to other processes,
- effectively polling the device in a (nice) busy loop.
- This should only be (and is only) used for emergency cases.
- (such as a graphical debugger, debugging the event-dispatcher itself)"
-
- |myFd|
-
- "
- if this display has a fileDescriptor to wait on,
- it is used; otherwise we poll (with a delay to not lock up
- the workstation)
- "
- myFd := self displayFileDescriptor.
- [aBlock value] whileTrue:[
- self eventPending ifFalse:[
- myFd isNil ifTrue:[
- OperatingSystem millisecondDelay:50
- ] ifFalse:[
- OperatingSystem selectOn:myFd withTimeOut:50.
- ].
- Processor evaluateTimeouts.
- ].
- self eventPending ifTrue:[
- self dispatchEvent
- ].
- ]
-!
-
-dispatchEvent
- "get and process the next pending event - for any view"
-
- self dispatchEventFor:nil withMask:nil
-!
-
-dispatchEventFor:aViewIdOrNil withMask:eventMask
- "central event handling method:
- get next event and send an appropriate message to the views sensor,
- or to the view directly (if the view has none).
- If the argument aViewIdOrNil is nil, events for any view are processed,
- otherwise only events for the view with given id are processed
- (in this case, nothing is done if no events are pending);
- if the argument aMask is nonNil, only events for this eventMask are
- handled. The mask is a device dependent event mask."
-
- ^ self subclassResponsibility
-!
-
-disposeEventsWithMask:aMask for:aWindowId
- "dispose (throw away) specific events"
+setBackingStore:how in:aWindowId
+ "turn on/off backing-store for a window"
^ self subclassResponsibility
!
-disposeEvents
- "dispose (i.e. forget) all events pending on this display"
-
- [self eventPending] whileTrue:[
- self getEventFor:nil withMask:nil
- ].
-!
-
-disposeButtonEventsFor:aViewIdOrNil
- "dispose (i.e. forget) all pending button events on this display"
-
- |mask|
-
- mask := self eventMaskFor:#buttonPress.
- mask := mask bitOr:(self eventMaskFor:#buttonRelease).
- mask := mask bitOr:(self eventMaskFor:#buttonMotion).
- self disposeEventsWithMask:mask for:aViewIdOrNil
-!
-
-eventPending
- "return true, if any event is pending"
-
- ^ self subclassResponsibility
-!
-
-eventPendingWithoutSync
- "return true, if any event is pending"
-
- ^ self subclassResponsibility
-!
-
-eventsPending:anEventMask for:aWindowId
- "return true, if any of the masked events is pending
- for a specific window.
- This expects a device dependent event mask as first argument."
-
- ^ self subclassResponsibility
-!
-
-eventPending:anEventSymbol for:aWindowId
- "return true, if a specific event is pending for a specific window.
- This expects device independent event symbols (such as #buttonPress,
- #buttonRelease etc.) as first argument."
-
- ^ self subclassResponsibility
-!
-
-eventMaskFor:anEventSymbol
- ^ self subclassResponsibility
-!
-
-setEventMask:aMask in:aWindowId
- ^ self subclassResponsibility
-! !
-
-!DeviceWorkstation methodsFor:'bitmap/window creation'!
-
-createFaxImageFromArray:data width:w height:h type:type k:k msbFirst:msbFirst
- "create a new faxImage in the workstation.
- This is a special interface to servers with the fax-image
- extension (you won't find it in standard X-servers).
-
- type: 0 -> uncompressed
- 1 -> group3 1D (k is void)
- 2 -> group3 2D
- 3 -> group4 2D (k is void)
- "
-
- ^ nil
-!
-
-createBitmapWidth:w height:h
- "allocate a bitmap on the Xserver, the contents is undefined
- (i.e. random). Return a bitmap id or nil"
-
- ^ self subclassResponsibility
-!
-
-createPixmapWidth:w height:h depth:d
- "allocate a pixmap on the Xserver, the contents is undefined
- (i.e. random). Return a bitmap id or nil"
-
- ^ self subclassResponsibility
-!
-
-createBitmapFromFile:aString for:aForm
- ^ self subclassResponsibility
-!
-
-createBitmapFromArray:anArray width:w height:h
- ^ self subclassResponsibility
-!
-
-destroyPixmap:aDrawableId
- ^ self subclassResponsibility
-!
-
-destroyFaxImage:aFaxImageId
- ^ self subclassResponsibility
-!
-
-rootWindowFor:aView
- ^ self subclassResponsibility
-!
-
-createWindowFor:aView left:xpos top:ypos width:wwidth height:wheight
- ^ self subclassResponsibility
-!
-
-destroyView:aView withId:aWindowId
- ^ self subclassResponsibility
-!
-
-destroyGC:aGCId
- "destroy a GC"
+setCursor:aCursorId in:aWindowId
+ "set a windows visible shape"
^ self subclassResponsibility
!
-gcFor:aDrawableId
- "create a GC for drawing into aDrawable"
-
- ^ self subclassResponsibility
-! !
-
-!DeviceWorkstation methodsFor:'font stuff'!
-
-listOfAvailableFonts
- "return a list containing all fonts on this display.
- The returned list is an array of 4-element arrays, each
- containing family, face, style, size and encoding."
-
- self subclassResponsibility
-!
-
-fontFamilies
- "return a set of all available font families on this display"
-
- |allFonts families family|
-
- allFonts := self listOfAvailableFonts.
- allFonts isNil ifTrue:[^ nil].
- families := Set new.
- allFonts do:[:fntDescr |
- family := fntDescr family.
- family notNil ifTrue:[
- families add:family
- ]
- ].
- ^ families asSortedCollection
-
- "
- Display fontFamilies
- "
-!
-
-facesInFamily:aFamilyName
- "return a set of all available font faces in aFamily on this display"
-
- |allFonts faces "family face"|
-
- allFonts := self listOfAvailableFonts.
- allFonts isNil ifTrue:[^ nil].
-
- faces := Set new.
- allFonts do:[:fntDescr |
- aFamilyName = fntDescr family ifTrue:[
- faces add:(fntDescr face)
- ]
- ].
- ^ faces asSortedCollection
-
- "
- Display facesInFamily:'times'
- Display facesInFamily:'fixed'
- "
-!
-
-stylesInFamily:aFamilyName face:aFaceName
- "return a set of all available font styles in aFamily/aFace on this display"
-
- |allFonts styles "family face style"|
-
- allFonts := self listOfAvailableFonts.
- allFonts isNil ifTrue:[^ nil].
-
- styles := Set new.
- allFonts do:[:fntDescr |
- (aFamilyName = fntDescr family) ifTrue:[
- (aFaceName = fntDescr face) ifTrue:[
- styles add:fntDescr style
- ]
- ]
- ].
- ^ styles asSortedCollection
-
- "
- Display stylesInFamily:'times' face:'medium'
- Display stylesInFamily:'times' face:'bold'
- "
-!
-
-sizesInFamily:aFamilyName face:aFaceName style:aStyleName
- "return a set of all available font sizes in aFamily/aFace/aStyle
- on this display"
-
- |allFonts sizes "family face style size"|
-
- allFonts := self listOfAvailableFonts.
- allFonts isNil ifTrue:[^ nil].
-
- sizes := Set new.
- allFonts do:[:fntDescr |
-"/ family := fntDescr at:1.
-"/ (family = aFamilyName) ifTrue:[
-"/ face := fntDescr at:2.
-"/ (face = aFaceName) ifTrue:[
-"/ style := fntDescr at:3.
-"/ (style = aStyleName) ifTrue:[
-"/ size := fntDescr at:4.
-"/ sizes add:size
-"/ ]
-"/ ]
+setCursors:aCursor
+ "change the cursor of all views to aCursorId"
+
+ | id |
+
+ id := (aCursor on:self) id.
+ id notNil ifTrue:[
+"/ idToViewMapping notNil ifTrue:[
+"/ idToViewMapping keysAndValuesDo:[:viewId :view |
+"/ self setCursor:id in:viewId
+"/ ].
+ knownViews do:[:aView |
+ |vid|
+
+ (aView notNil and:[(vid := aView id) notNil]) ifTrue:[
+ self setCursor:id in:vid
+ ]
+ ].
+ self flush
"/ ]
- (aFamilyName = fntDescr family) ifTrue:[
- (aFaceName = fntDescr face) ifTrue:[
- (aStyleName = fntDescr style) ifTrue:[
- sizes add:fntDescr size
- ]
- ]
- ]
- ].
- ^ sizes
-
- "
- Display sizesInFamily:'times' face:'medium' style:'italic'
- "
-!
-
-getFontWithFamily:familyString
- face:faceString
- style:styleString
- size:sizeArg
- encoding:encodingSym
-
- "try to get the specified font, return id.
- If not available, try next smaller font.
- If no font fits, return nil"
-
- ^ self subclassResponsibility
-!
-
-getDefaultFont
- "return a default font id
- - used when class Font cannot find anything usable"
-
- ^ self subclassResponsibility
-!
-
-releaseFont:aFontId
- "free a font"
-
- ^ self subclassResponsibility
-!
-
-ascentOf:aFontId
- "return the number of pixels above the base line of a font"
-
- ^ self subclassResponsibility
-!
-
-descentOf:aFontId
- "return the number of pixels below the base line of a font"
-
- ^ self subclassResponsibility
-!
-
-minWidthOfFont:aFontId
- "return the width in pixels of the smallest character a specific font"
-
- ^ self subclassResponsibility
-!
-
-maxWidthOfFont:aFontId
- "return the width in pixels of the widest character a specific font"
-
- ^ self subclassResponsibility
-!
-
-widthOf:aString inFont:aFontId
- "return the width in pixels of a string in a specific font"
-
- ^ self subclassResponsibility
-!
-
-widthOf:aString from:index1 to:index2 inFont:aFontId
- "return the width in pixels of a substring in a specific font"
-
- ^ self subclassResponsibility
-! !
-
-!DeviceWorkstation methodsFor:'cursor stuff'!
-
-destroyCursor:aCursorId
- "free a cursor"
-
- ^ self subclassResponsibility
-!
-
-createCursorSourceForm:sourceForm maskForm:maskForm hotX:hx hotY:hy
- "create a cursor given 2 bitmaps (source, mask) and a hotspot"
- ^ self subclassResponsibility
-!
-
-createCursorShape:aShape
- "create a cursor given a shape-symbol"
-
- ^ self subclassResponsibility
+ ]
+
+ "Display setCursors:Cursor wait"
+ "Display restoreCursors"
!
-colorCursor:aCursorId foreground:fgColor background:bgColor
- "change a cursors colors"
-
- ^ self subclassResponsibility
-! !
-
-!DeviceWorkstation methodsFor:'grabbing '!
-
-grabKeyboardInView:aView
- "grab the keyboard - all keyboard input will be sent to aView.
- Return true if ok, false if it failed for some reason."
-
- activeKeyboardGrab notNil ifTrue:[
- self ungrabKeyboard.
- activeKeyboardGrab := nil
- ].
- (self grabKeyboardIn:(aView id)) ifTrue:[
- activeKeyboardGrab := aView.
- ^ true
- ].
- ^ false
-!
-
-grabKeyboardIn:aWindowId
- "grab the keyboard - all keyboard input will be sent to the view
- with id aWindowId"
-
- ^ self subclassResponsibility
-!
-
-ungrabKeyboard
- "release the keyboard"
-
- ^ self subclassResponsibility
-!
-
-activeKeyboardGrab
- "return the view, which currently has the keyboard grabbed,
- or nil, if there is none"
-
- ^ activeKeyboardGrab
-!
-
-grabPointerInView:aView
- "grap the pointer; all pointer events will be reported to
- aView. Return true if ok, false if it failed for some reason."
-
- activePointerGrab notNil ifTrue:[
- self ungrabPointer.
- activePointerGrab := nil
- ].
- (self grabPointerIn:(aView id)) ifTrue:[
- activePointerGrab := aView.
- ^ true
- ].
- ^ false
-!
-
-grabPointerIn:aWindowId withCursor:cursorId pointerMode:pMode keyboardMode:kMode confineTo:confineId
- "grap the pointer - all pointer events will be reported to aWindowId. The cursor will be set to cursorId
- for the duration of the grab. For pMode/kMode, see X documentation. The pointer is restricted to
- confineId - if non-nil."
-
- ^ self subclassResponsibility
-!
-
-grabPointerIn:aWindowId
- "grap the pointer; all pointer events will be reported to the view
- with id aWindowId. Return true if ok, false if it failed for some reason."
-
- ^ self grabPointerIn:aWindowId withCursor:nil pointerMode:#async keyboardMode:#sync confineTo:nil
-!
-
-ungrabPointer
- "release the pointer"
-
- ^ self subclassResponsibility
-!
-
-activePointerGrab
- "return the view, which currently has the pointer grabbed,
- or nil, if there is none"
-
- ^ activePointerGrab
-!
-
-setActivePointerGrab:aView
- "DO NOT USE. private kludge - will vanish"
-
- activePointerGrab := aView
-! !
-
-!DeviceWorkstation methodsFor:'color stuff'!
-
-listOfAvailableColors
- "return a list of all available colornames;
- This method should not be used, since colornames are
- very X specific. However, the names defined here are pretty common"
-
- ^ #('red' 'green' 'blue' 'yellow' 'magenta' 'cyan' 'white' 'black')
-!
-
-freeColor:colorIndex
- "free a color on the display, when its no longer needed"
-
- ^ self subclassResponsibility
-!
-
-colorRed:redVal green:greenVal blue:blueVal
- "allocate a color with rgb values (0..100) - return index"
-
- ^ self subclassResponsibility
-!
-
-colorNamed:aString
- "allocate a color with color name - return index.
- Colors should not be allocated by name, since most colors
- are X specific - get colors by rgb instead."
-
- "support some of them ..."
-
- self getRGBFromName:aString into:[:r :g :b |
- ^ self colorRed:r green:g blue:b
- ].
- ^ nil
-!
-
-colorCell
- "allocate a color - return index"
-
- ^ self subclassResponsibility
-!
-
-setColor:index red:redVal green:greenVal blue:blueVal
- "change color in map at:index to rgb (0..100)"
-
- ^ self subclassResponsibility
-!
-
-redComponentOfColor:colorId
- "get red component (0..100) of color in map at:index"
-
- self getRGBFrom:colorId into:[:r :g :b | ^ r]
-!
-
-greenComponentOfColor:colorId
- "get green component (0..100) of color in map at:index"
-
- self getRGBFrom:colorId into:[:r :g :b | ^ g]
-!
-
-blueComponentOfColor:colorId
- "get blue component (0..100) of color in map at:index"
-
- self getRGBFrom:colorId into:[:r :g :b | ^ b]
-!
-
-getRGBFromName:colorName into:aBlock
- "get rgb components (0..100) of color named colorName,
- and evaluate the 3-arg block, aBlock with them.
- The method here only handles some often used colors;
- getRGBFromName should not be used, since colorNames other
- than those below are X specific."
-
- |idx names triple|
-
- names := #('red' 'green' 'blue' 'yellow' 'magenta' 'cyan' 'white' 'black').
- idx := names indexOf:colorName.
- idx == 0 ifTrue:[
- idx := (names asLowercase) indexOf:colorName.
- ].
- idx == 0 ifFalse:[
- triple := #(
- (100 0 0) "red"
- ( 0 100 0) "green"
- ( 0 0 100) "blue"
- (100 100 0) "yellow"
- (100 0 100) "magenta"
- ( 0 100 100) "cyan"
- (100 100 100) "white"
- ( 0 0 0) "black"
- ) at:idx.
-
- ^ aBlock value:(triple at:1)
- value:(triple at:2)
- value:(triple at:3)
- ].
- ^ nil
-!
-
-getRGBFrom:index into:aBlock
- "get rgb components (0..100) of color in map at:index,
- and evaluate the 3-arg block, aBlock with them"
-
- ^ self subclassResponsibility
-! !
-
-!DeviceWorkstation methodsFor:'window stuff'!
-
-setBackingStore:how in:aWindowId
- "turn on/off backing-store for a window"
+setIconName:aString in:aWindowId
+ "set a windows icon name"
^ self subclassResponsibility
!
@@ -3276,38 +3583,14 @@
^ self subclassResponsibility
!
-setWindowBorderWidth:aNumber in:aWindowId
- "set a windows border width"
-
- ^ self subclassResponsibility
-!
-
setWindowBorderShape:aPixmapId in:aWindowId
"set a windows border shape"
^ self subclassResponsibility
!
-setWindowShape:aPixmapId in:aWindowId
- "set a windows visible shape"
-
- ^ self subclassResponsibility
-!
-
-setCursor:aCursorId in:aWindowId
- "set a windows visible shape"
-
- ^ self subclassResponsibility
-!
-
-setWindowName:aString in:aWindowId
- "set a windows name"
-
- ^ self subclassResponsibility
-!
-
-setIconName:aString in:aWindowId
- "set a windows icon name"
+setWindowBorderWidth:aNumber in:aWindowId
+ "set a windows border width"
^ self subclassResponsibility
!
@@ -3324,317 +3607,25 @@
^ self subclassResponsibility
!
-clearWindow:aWindowId
- "clear a windows to its view background"
+setWindowName:aString in:aWindowId
+ "set a windows name"
^ self subclassResponsibility
!
-clearRectangleX:x y:y width:width height:height in:aWindowId
- "clear a rectangular area of a window to its view background"
-
- ^ self subclassResponsibility
-!
-
-mapView:aView id:aWindowId iconified:aBoolean atX:xPos y:yPos width:w height:h
- ^ self subclassResponsibility
-!
-
-mapWindow:aWindowId
+setWindowShape:aPixmapId in:aWindowId
+ "set a windows visible shape"
+
^ self subclassResponsibility
!
unmapWindow:aWindowId
^ self subclassResponsibility
-!
-
-raiseWindow:aWindowId
- ^ self subclassResponsibility
-!
-
-lowerWindow:aWindowId
- ^ self subclassResponsibility
-!
-
-moveWindow:aWindowId x:x y:y
- ^ self subclassResponsibility
-!
-
-resizeWindow:aWindowId width:w height:h
- ^ self subclassResponsibility
-!
-
-moveResizeWindow:aWindowId x:x y:y width:w height:h
- ^ self subclassResponsibility
-! !
-
-!DeviceWorkstation methodsFor:'graphic context stuff'!
-
-setForeground:fgColorIndex in:aGCId
- "set foreground color to be drawn with"
-
- ^ self subclassResponsibility
-!
-
-setBackground:bgColorIndex in:aGCId
- "set background color to be drawn with"
-
- ^ self subclassResponsibility
-!
-
-setForeground:fgColorIndex background:bgColorIndex in:aGCId
- "set foreground and background colors to be drawn with"
-
- ^ self subclassResponsibility
-!
-
-setForeground:fgColor background:bgColor mask:aBitmapId in:aGCId
- "set foreground and background colors to be drawn with using mask or
- solid (if aBitmapId is nil)"
-
- ^ self subclassResponsibility
-!
-
-setLineWidth:aNumber style:lineStyle cap:capStyle join:joinStyle in:aGCId
- "set line attributes"
-
- ^ self subclassResponsibility
-!
-
-setForeground:fgColor background:bgColor mask:aBitmapId lineWidth:lw in:aGCId
- "set foreground and background colors to be drawn with using mask or
- solid (if aBitmapId is nil); also set lineWidth"
-
- ^ self subclassResponsibility
-!
-
-setFunction:aFunctionSymbol in:aGCId
- "set alu function to be drawn with"
-
- ^ self subclassResponsibility
-!
-
-setFont:aFontId in:aGCId
- "set font to be drawn in"
-
- ^ self subclassResponsibility
-!
-
-setPixmapMask:aPixmapId in:aGCId
- "set or clear the drawing mask - a pixmap mask providing full color"
-
- ^ self subclassResponsibility
-!
-
-setBitmapMask:aBitmapId in:aGCId
- "set or clear the drawing mask - a bitmap mask using current fg/bg"
-
- ^ self subclassResponsibility
-!
-
-setMaskOriginX:orgX y:orgY in:aGCid
- "set the mask origin"
-
- ^ self subclassResponsibility
-!
-
-setClipByChildren:aBool in:aGCId
- "enable/disable drawing into child views"
-
- ^ self subclassResponsibility
-!
-
-noClipIn:aGCId
- "disable clipping rectangle"
-
- ^ self subclassResponsibility
-!
-
-setClipX:clipX y:clipY width:clipWidth height:clipHeight in:aGCId
- "clip to a rectangle"
-
- ^ self subclassResponsibility
-!
-
-setGraphicsExposures:aBoolean in:aGCId
- "set or clear the graphics exposures flag"
-
- ^ self subclassResponsibility
-! !
-
-!DeviceWorkstation methodsFor:'retrieving pixels'!
-
-getPixelX:x y:y from:aDrawableId
- "return the pixel value at x/y"
-
- ^ self subclassResponsibility
! !
-!DeviceWorkstation methodsFor:'drawing'!
-
-displayString:aString x:x y:y in:aDrawableId with:aGCId opaque:opaque
- "draw a string"
-
- ^ self subclassResponsibility
-!
-
-displayString:aString from:i1 to:i2 x:x y:y in:aDrawableId with:aGCId opaque:opaque
- "draw part of a string"
-
- "
- should be redefined in concrete subclasses
- to avoid creation of throw-away string
- "
- self displayString:(aString copyFrom:i1 to:i2)
- x:x
- y:y
- in:aDrawableId
- with:aGCId
- opaque:opaque
-!
-
-displayString:aString x:x y:y in:aDrawableId with:aGCId
- "draw a string - draw foreground only.
- If the coordinates are not integers, retry with rounded."
-
- self
- displayString:aString
- x:x
- y:y
- in:aDrawableId
- with:aGCId
- opaque:false
-!
-
-displayString:aString from:index1 to:index2 x:x y:y in:aDrawableId with:aGCId
- "draw a sub-string - draw foreground only.
- If the coordinates are not integers, retry with rounded."
-
- self
- displayString:aString
- from:index1
- to:index2
- x:x
- y:y
- in:aDrawableId
- with:aGCId
- opaque:false
-!
-
-displayOpaqueString:aString x:x y:y in:aDrawableId with:aGCId
- "draw a string - draw foreground on background.
- If the coordinates are not integers, retry with rounded."
-
- self displayString:aString
- x:x
- y:y
- in:aDrawableId
- with:aGCId
- opaque:true
-!
-
-displayOpaqueString:aString from:index1 to:index2 x:x y:y in:aDrawableId with:aGCId
- "draw a sub-string - draw foreground on background.
- If the coordinates are not integers, retry with rounded."
-
- self displayString:aString
- from:index1
- to:index2
- x:x
- y:y
- in:aDrawableId
- with:aGCId
- opaque:true
-!
-
-displayPointX:x y:y in:aDrawableId with:aGCId
- "draw a point"
-
- ^ self subclassResponsibility
-!
-
-displayLineFromX:x0 y:y0 toX:x1 y:y1 in:aDrawableId with:aGCId
- "draw a line"
-
- "could add a bresenham line drawer here ..."
- ^ self subclassResponsibility
-!
-
-displayRectangleX:x y:y width:width height:height in:aDrawableId with:aGCId
- "draw a rectangle"
-
- "
- should draw four lines here
- but then, we have to reimplement all line and join styles here
- "
- ^ self subclassResponsibility
-!
-
-displayPolygon:aPolygon in:aDrawableId with:aGCId
- "draw a polygon"
-
- "
- should draw the lines here
- but then, we have to reimplement all line and join styles here
- "
- ^ self subclassResponsibility
-!
-
-copyFromFaxImage:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
- width:w height:h with:aGCId scaleX:scaleX scaleY:scaleY
- "do a bit-blt"
-
- ^ self subclassResponsibility
-!
-
-copyFromId:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
- width:w height:h with:aGCId
- "do a bit-blt"
-
- ^ self subclassResponsibility
-!
-
-copyPlaneFromId:sourceId x:srcX y:srcY to:destId x:dstX y:dstY
- width:w height:h with:aGCId
- "do a bit-blt, using the low-bit plane of the source only"
-
- ^ self subclassResponsibility
-!
-
-displayArcX:x y:y w:width h:height from:startAngle angle:angle
- in:aDrawableId with:aGCId
- "draw an arc"
-
- ^ self subclassResponsibility
-!
-
-fillArcX:x y:y w:width h:height from:startAngle angle:angle
- in:aDrawableId with:aGCId
- "fill an arc"
-
- ^ self subclassResponsibility
-!
-
-fillRectangleX:x y:y width:width height:height in:aDrawableId with:aGCId
- "fill a rectangle"
-
- ^ self subclassResponsibility
-!
-
-fillPolygon:aPolygon in:aDrawableId with:aGCId
- "fill a polygon"
-
- ^ self subclassResponsibility
-!
-
-drawBits:imageBits depth:imageDepth width:imageWidth height:imageHeight
- x:srcx y:srcy
- into:aDrawableId x:dstx y:dsty width:w height:h with:aGCId
-
- "draw a bitimage which has depth id, width iw and height ih into
- the drawable. draw a region of w/h pixels from srcx/srcy to dstx/dsty.
- It has to be checked elsewhere, that server can do it with the given
- depth; also it is assumed, that the colormap is setup correctly"
-
- ^ self subclassResponsibility
+!DeviceWorkstation class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libview/DeviceWorkstation.st,v 1.56 1995-12-10 00:15:42 cg Exp $'
! !
+DeviceWorkstation initialize!