diff -r 62799b2ab9ae -r 814282cf66c5 DeviceWorkstation.st --- 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!