--- a/DeviceGraphicsContext.st Wed Jul 20 17:07:38 2016 +0200
+++ b/DeviceGraphicsContext.st Wed Jul 20 18:26:01 2016 +0200
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
@@ -11,6 +9,8 @@
other person. No title to or ownership of the software is
hereby transferred.
"
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 16:39:50' !
+
"{ Package: 'stx:libview' }"
"{ NameSpace: Smalltalk }"
@@ -18,7 +18,7 @@
GraphicsContext subclass:#DeviceGraphicsContext
instanceVariableNames:'drawableId gcId deviceFont foreground background drawableType
parentId'
- classVariableNames:'CachedScaledForms CachedScales Lobby'
+ classVariableNames:'CachedScaledForms CachedScales'
poolDictionaries:''
category:'Graphics-Support'
!
@@ -94,16 +94,6 @@
"
! !
-!DeviceGraphicsContext class methodsFor:'initialization'!
-
-initialize
- Lobby isNil ifTrue:[
- Lobby := Registry new.
- ]
-
- "Modified: / 29.1.1998 / 12:56:12 / cg"
-! !
-
!DeviceGraphicsContext class methodsFor:'instance creation'!
new
@@ -176,31 +166,22 @@
parents := Array with:anId address.
[
- newChildren := Set new.
- Lobby unregisterAllForWhichHandle:[:handle |
- |parentId|
-
- handle notNil
- and:[handle device == aDevice
- and:[(parentId := handle parentId) notNil
- and:[(parents includes:parentId)
- and:[newChildren add:handle id. true]]]].
- ].
- parents := newChildren.
+ newChildren := Set new.
+ self finalizationLobby unregisterAllForWhichHandle:[:handle |
+ |parentId|
+
+ handle notNil
+ and:[handle device == aDevice
+ and:[(parentId := handle parentId) notNil
+ and:[(parents includes:parentId)
+ and:[newChildren add:handle id. true]]]].
+ ].
+ parents := newChildren.
] doWhile:[parents notEmpty].
!
lowSpaceCleanup
CachedScaledForms := CachedScales := nil
-!
-
-releaseResourcesOnDevice:aDevice
- "this is sent when a display connection is closed,
- to release all cached bitmap/window objects from that device"
-
- Lobby unregisterAllForWhich:[:aDrawable | aDrawable graphicsDevice == aDevice]
-
- "Created: 16.1.1997 / 16:43:52 / cg"
! !
!DeviceGraphicsContext methodsFor:'Compatibility-ST80'!
@@ -518,6 +499,20 @@
device:aDevice
"set the device"
+ device == aDevice ifTrue:[
+ ^ self.
+ ].
+ device notNil ifTrue:[
+ "change of device of an already existing GraphicsContext"
+ drawableId notNil ifTrue:[
+ device unregisterGraphicsContext:self.
+ ].
+ device := aDevice.
+ self recreate.
+ ^ self.
+ ].
+
+ "set device of a new GraphicsContext"
device := aDevice
!
@@ -1828,8 +1823,7 @@
the case where paint and/or bgPaint are dithered colors.
maxWidth is the maximum width of the string in pixels or nil if unknown."
- |opaque index1 index2 easy w h savedPaint fgId bgId
- fontId pX pY fontUsed fontsEncoding sz aString
+ |opaque index1 index2 easy w h savedPaint fgId bgId pX pY fontUsed fontsEncoding sz aString
nSkipLeft nChars wString wSkipLeft index2Guess|
index1 := index1Arg.
@@ -1898,18 +1892,12 @@
pY := pY rounded.
fontUsed := fontUsed onDevice:device.
- fontId := fontUsed fontId.
- fontId isNil ifTrue:[
- "this should not happen, since #onDevice tries replacement fonts"
- font isXftFont ifFalse:[
- 'STX[DeviceGraphicsContext] no font: ' errorPrint. fontUsed errorPrintCR.
+ deviceFont ~~ fontUsed ifTrue:[
+ (fontUsed installInDeviceForGCId:gcId) isNil ifTrue:[
+ "error - no such font"
^ self.
].
- ] ifFalse:[
- deviceFont ~~ fontUsed ifTrue:[
- device setFont:fontId in:gcId.
- deviceFont := fontUsed
- ].
+ deviceFont := fontUsed.
].
"
@@ -2987,8 +2975,7 @@
the case where paint and/or bgPaint are dithered colors.
No translation or scaling is done."
- |easy w h savedPaint fgId bgId allColor allBits noColor
- fontId bgForm fgForm tmpForm maskForm dx dy pX pY fontUsed aString
+ |easy w h savedPaint fgId bgId allColor allBits noColor bgForm fgForm tmpForm maskForm dx dy pX pY fontUsed aString
deviceDepth fontsEncoding ascent|
"
@@ -3005,18 +2992,12 @@
].
fontUsed := fontArg onDevice:device.
- fontId := fontUsed fontId.
- fontId isNil ifTrue:[
- "this should not happen, since #onDevice tries replacement fonts"
- font isXftFont ifFalse:[
- 'STX[DeviceGraphicsContext] no font: ' errorPrint. fontUsed errorPrintCR.
+ deviceFont ~~ fontUsed ifTrue:[
+ (fontUsed installInDeviceForGCId:gcId) isNil ifTrue:[
+ "error - no such font"
^ self.
].
- ] ifFalse:[
- deviceFont ~~ fontUsed ifTrue:[
- device setFont:fontId in:gcId.
- deviceFont := fontUsed
- ].
+ deviceFont := fontUsed.
].
aString isPlainString ifFalse:[
@@ -3055,7 +3036,6 @@
^ self
].
-
"
if bgPaint or paint is not a real Color, we have to do it the hard way ...
"
@@ -3297,7 +3277,7 @@
draw foreground-pixels only (in current paint-color), leaving background as-is.
No translation or scaling is done"
- |fontId fontUsed aString fontsEncoding|
+ |fontUsed aString fontsEncoding|
"
hook for non-strings (i.e. attributed text)
@@ -3310,9 +3290,18 @@
self initGC
].
+ fontUsed := fontArg onDevice:device.
+ deviceFont ~~ fontUsed ifTrue:[
+ (fontUsed installInDeviceForGCId:gcId) isNil ifTrue:[
+ "error - no such font"
+ ^ self.
+ ].
+ deviceFont := fontUsed.
+ ].
+
aString := aStringArg.
- fontsEncoding := fontArg encoding.
+ fontsEncoding := fontUsed encoding.
(characterEncoding ~~ fontsEncoding) ifTrue:[
[
aString := CharacterEncoder encodeString:aString from:characterEncoding into:fontsEncoding.
@@ -3322,22 +3311,6 @@
ex proceedWith:ex defaultValue.
].
].
-
- fontUsed := fontArg onDevice:device.
- fontId := fontUsed fontId.
- fontId isNil ifTrue:[
- "this should not happen, since #onDevice tries replacement fonts"
- font isXftFont ifFalse:[
- 'STX[DeviceGraphicsContext] no font: ' errorPrint. fontUsed errorPrintCR.
- ^ self.
- ].
- ] ifFalse:[
- deviceFont ~~ fontUsed ifTrue:[
- device setFont:fontId in:gcId.
- deviceFont := fontUsed
- ].
- ].
-
fontUsed isAlienFont ifTrue:[
"
hook for alien fonts
@@ -3677,13 +3650,7 @@
"answer the registry used for finalization.
DeviceGraphicContexts have their own Registry"
- ^ Lobby
-!
-
-registerChange
- "register a change with the finalizationLobby"
-
- Lobby registerChange:self.
+ ^ device graphicsContexts
! !
!DeviceGraphicsContext methodsFor:'initialization & release'!
@@ -3703,11 +3670,11 @@
This method is sent, when the first drawing happens"
drawableType == #pixmap ifTrue:[
- gcId := device gcForBitmap:drawableId.
+ gcId := device gcForBitmap:drawableId.
] ifFalse:[
- gcId := device gcFor:drawableId.
+ gcId := device gcFor:drawableId.
].
- Lobby registerChange:self.
+ device registerGraphicsContext:self. "this is a registerChange:"
"Modified: 19.3.1997 / 11:07:52 / cg"
!
@@ -3729,8 +3696,8 @@
] ifFalse:[
device destroyPixmap:id.
].
+ device unregisterGraphicsContext:self.
].
- Lobby unregister:self.
!
initGC
@@ -3857,7 +3824,7 @@
needed after snapin"
gcId := nil.
- drawableId := nil.
+ drawableId := parentId := nil.
deviceFont := nil
!
@@ -3865,21 +3832,21 @@
"sent after a snapin or a migration, reinit draw stuff for new device"
gcId := nil.
- drawableId := nil.
+ drawableId := parentId := nil.
foreground notNil ifTrue:[
- foreground := foreground onDevice:device
+ foreground := foreground onDevice:device
].
background notNil ifTrue:[
- background := background onDevice:device
+ background := background onDevice:device
].
paint notNil ifTrue:[
- paint := paint onDevice:device
+ paint := paint onDevice:device
].
bgPaint notNil ifTrue:[
- bgPaint := bgPaint onDevice:device
+ bgPaint := bgPaint onDevice:device
].
font notNil ifTrue:[
- font := font onDevice:device
+ font := deviceFont := font onDevice:device
]
"Modified: 28.10.1996 / 13:25:02 / cg"
@@ -3895,9 +3862,9 @@
id := gcId.
id notNil ifTrue:[
- gcId := nil.
- device destroyGC:id.
- Lobby registerChange:self.
+ gcId := nil.
+ device destroyGC:id.
+ device unregisterGraphicsContext:self.
].
"Created: 11.6.1996 / 22:07:30 / cg"
@@ -3909,9 +3876,9 @@
setDevice:aDevice id:aDrawbleId gcId:aGCId
"private"
- device := aDevice.
+ self device:aDevice.
+ drawableId := aDrawbleId.
gcId := aGCId.
- drawableId := aDrawbleId
!
setGCForPaint
@@ -4070,9 +4037,9 @@
createBitmapFromArray:data width:width height:height
"create a bitmap from data and set the drawableId"
+ drawableType := #pixmap.
drawableId := device createBitmapFromArray:data width:width height:height.
- drawableType := #pixmap.
- Lobby registerChange:self.
+ device registerGraphicsContext:self. "this is a registerChange:"
!
createPixmapWidth:w height:h depth:d
@@ -4080,12 +4047,12 @@
drawableId := device createPixmapWidth:w height:h depth:d.
drawableId isNil ifTrue:[
- "/ creation failed
- ('[GC] warning: pixmap creation failed: ',((OperatingSystem lastErrorString) ? 'unknown error')) erorrPrintCR.
- ^ GraphicsDevice::GraphicResourceAllocationFailure query
+ "/ creation failed
+ ('[GC] warning: pixmap creation failed: ',((OperatingSystem lastErrorString) ? 'unknown error')) erorrPrintCR.
+ ^ GraphicsDevice::GraphicResourceAllocationFailure query
].
drawableType := #pixmap.
- Lobby registerChange:self.
+ device registerGraphicsContext:self. "this is a registerChange:"
!
createRootWindowFor:aView
@@ -4099,26 +4066,26 @@
|container|
drawableId := device
- createWindowFor:aView
- type:typeSymbol
- origin:org
- extent:ext
- minExtent:minE
- maxExtent:maxE
- borderWidth:bw
- subViewOf:sv
- style:styleSymbol
- inputOnly:inp
- label:label
- owner:owner
- icon:icn
- iconMask:icnM
- iconView:icnV.
+ createWindowFor:aView
+ type:typeSymbol
+ origin:org
+ extent:ext
+ minExtent:minE
+ maxExtent:maxE
+ borderWidth:bw
+ subViewOf:sv
+ style:styleSymbol
+ inputOnly:inp
+ label:label
+ owner:owner
+ icon:icn
+ iconMask:icnM
+ iconView:icnV.
drawableType := #window.
container := aView container.
container notNil ifTrue:[ parentId := container id ].
- Lobby registerChange:self.
+ device registerGraphicsContext:self. "this is a registerChange:"
! !
!DeviceGraphicsContext methodsFor:'view properties'!
@@ -4252,35 +4219,35 @@
- release system resources"
drawableId notNil ifTrue:[
- [
- (device viewIdKnown:drawableId) ifTrue:[
+ [
+ (device viewIdKnown:drawableId) ifTrue:[
"/ 'Display [info]: recycled view (' infoPrint. v infoPrint. ') not destroyed: ' infoPrint.
"/ drawableId displayString infoPrintCR.
- drawableId := nil.
- ] ifFalse:[
- |id|
-
- (id := gcId) notNil ifTrue:[
- gcId := nil.
- device deviceIOErrorSignal handle:[:ex |
- ] do:[
- device destroyGC:id.
- ]
- ].
-
- id := drawableId.
- drawableId := nil.
- device deviceIOErrorSignal handle:[:ex |
- ] do:[
- device destroyView:nil withId:id.
- ].
-
- "When a window ist destroyed, all its subwindows are also destroyed.
- Unregister all the subwindows, to avoid destroying of reused windoeIds
- later."
- DeviceGraphicsContext cleanupLobbyForChildrenOfViewWithDevice:device id:id.
- ]
- ] valueUninterruptably.
+ drawableId := nil.
+ ] ifFalse:[
+ |id|
+
+ (id := gcId) notNil ifTrue:[
+ gcId := nil.
+ device deviceIOErrorSignal handle:[:ex |
+ ] do:[
+ device destroyGC:id.
+ ]
+ ].
+
+ id := drawableId.
+ drawableId := nil.
+ device deviceIOErrorSignal handle:[:ex |
+ ] do:[
+ device destroyView:nil withId:id.
+ ].
+
+ "When a window ist destroyed, all its subwindows are also destroyed.
+ Unregister all the subwindows, to avoid destroying of reused windowIds
+ later."
+ DeviceGraphicsContext cleanupLobbyForChildrenOfViewWithDevice:device id:id.
+ ]
+ ] valueUninterruptably.
].
"Created: / 25.9.1997 / 10:01:46 / stefan"
@@ -4308,5 +4275,3 @@
^ '$Header$'
! !
-
-DeviceGraphicsContext initialize!
--- a/DeviceWorkstation.st Wed Jul 20 17:07:38 2016 +0200
+++ b/DeviceWorkstation.st Wed Jul 20 18:26:01 2016 +0200
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
@@ -11,6 +9,8 @@
other person. No title to or ownership of the software is
hereby transferred.
"
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 14:38:04' !
+
"{ Package: 'stx:libview' }"
"{ NameSpace: Smalltalk }"
@@ -625,9 +625,9 @@
"an error in the devices low level code (typically Xlib or XtLib)
This is invoked via
- XError->errorInterrupt:#DisplayError->registeredErrorInterruptHandlers
+ XError->errorInterrupt:#DisplayError->registeredErrorInterruptHandlers
or
- XError->errorInterrupt:#DisplayIOError->registeredErrorInterruptHandlers
+ XError->errorInterrupt:#DisplayIOError->registeredErrorInterruptHandlers
looks if a signal handler for DeviceErrorSignal is present,
and - if so raises the signal.
@@ -639,20 +639,20 @@
|badResource msg theDevice theSignal p signalHolder|
errID notNil ifTrue:[
- "/
- "/ timeoutError passes the device;
- "/ the others pass the devicesID
- "/
- errID == #DisplayIOTimeoutError ifTrue:[
- theDevice := aParameter.
- "/ 'device timeout error' printCR.
- ] ifFalse:[
- AllScreens do:[:aDisplayDevice |
- aDisplayDevice id = aParameter ifTrue:[
- theDevice := aDisplayDevice.
- ]
- ]
- ]
+ "/
+ "/ timeoutError passes the device;
+ "/ the others pass the devicesID
+ "/
+ errID == #DisplayIOTimeoutError ifTrue:[
+ theDevice := aParameter.
+ "/ 'device timeout error' printCR.
+ ] ifFalse:[
+ AllScreens do:[:aDisplayDevice |
+ aDisplayDevice id = aParameter ifTrue:[
+ theDevice := aDisplayDevice.
+ ]
+ ]
+ ]
].
"/ now, we have the bad guy at hand ...
@@ -660,26 +660,26 @@
signalHolder := theDevice ? self.
errID == #DisplayIOError ifTrue:[
- "always raises an exception"
- theSignal := signalHolder deviceIOErrorSignal.
- msg := 'Display I/O Error'.
- badResource := theDevice.
+ "always raises an exception"
+ theSignal := signalHolder deviceIOErrorSignal.
+ msg := 'Display I/O Error'.
+ badResource := theDevice.
] ifFalse:[errID == #DisplayIOTimeoutError ifTrue:[
- "always raises an exception for the current process"
- theSignal := signalHolder deviceIOTimeoutErrorSignal.
- msg := 'Display I/O timeout Error'.
- badResource := theDevice.
+ "always raises an exception for the current process"
+ theSignal := signalHolder deviceIOTimeoutErrorSignal.
+ msg := 'Display I/O timeout Error'.
+ badResource := theDevice.
] ifFalse:[ "errID == #DisplayError"
- "only raises an exception if handled"
- theSignal := signalHolder deviceErrorSignal.
- theDevice notNil ifTrue:[
- "/ #resourceIdOfLastError will become instance-specific information in
- "/ the near future ...
- badResource := theDevice resourceOfId:self resourceIdOfLastError.
- ].
- msg := 'Display error: ' , self lastErrorString.
+ "only raises an exception if handled"
+ theSignal := signalHolder deviceErrorSignal.
+ theDevice notNil ifTrue:[
+ "/ #resourceIdOfLastError will become instance-specific information in
+ "/ the near future ...
+ badResource := theDevice resourceOfId:self resourceIdOfLastError.
+ ].
+ msg := 'Display error: ' , self lastErrorString.
]].
- 'DeviceWorkstation [info]: ' infoPrint. msg infoPrint. ' - ' infoPrint. badResource infoPrintCR.
+ Logger info:'%1 - %2' with:msg with:badResource.
"interrupt that displays dispatch process
@@ -689,77 +689,77 @@
that caused the timeout."
(errID ~~ #DisplayIOTimeoutError and:[theDevice notNil]) ifTrue:[
- p := theDevice dispatchProcess.
- (p notNil and:[p ~~ Processor activeProcess]) ifTrue:[
- 'DeviceWorkstation [info]: interrupting: ' infoPrint. p infoPrintCR.
- p interruptWith:[
- (errID == #DisplayError and:[theSignal isHandled not]) ifTrue:[
- "unhandled display errors are ignored"
- ErrorPrinting ifTrue:[
- ('DeviceWorkstation [error]: ' , msg) errorPrintCR
- ].
- ] ifFalse:[
- 'DeviceWorkstation [info]: raising exception ...' infoPrintCR.
- theSignal raiseSignalWith:badResource errorString:msg.
- 'DeviceWorkstation [warning]: exception returned - send brokenConnection' errorPrintCR.
- theDevice brokenConnection.
- 'DeviceWorkstation [warning]: stopping dispatch' errorPrintCR.
- theDevice stopDispatch.
- ].
- ].
- ^ self.
+ p := theDevice dispatchProcess.
+ (p notNil and:[p ~~ Processor activeProcess]) ifTrue:[
+ Logger info:'interrupting: %1' with:p.
+
+ p interruptWith:[
+ (errID == #DisplayError and:[theSignal isHandled not]) ifTrue:[
+ "unhandled display errors are ignored"
+ ErrorPrinting ifTrue:[
+ Logger error:msg.
+ ].
+ ] ifFalse:[
+ Logger info:'raising exception ...'.
+ theSignal raiseSignalWith:badResource errorString:msg.
+ Logger warning:'exception returned - send brokenConnection'.
+ theDevice brokenConnection.
+ Logger warning:'stopping dispatch'.
+ theDevice stopDispatch.
+ ].
+ ].
+ ^ self.
"/ Processor reschedule.
"/ AbortOperationRequest raise.
- ].
+ ].
].
"If we come here, this is a DiplayIOTimeoutError, we don't know
the display device or we are running on top of the dispatchProcess"
(theSignal isHandled or:[theSignal handlerBlock notNil]) ifTrue:[
- 'DeviceWorkstation [info]: raising signal in current process' infoPrintCR.
-"/ Processor activeProcess displayString infoPrintCR.
- theSignal raiseSignalWith:badResource errorString:msg.
+ Logger info:'raising signal in current process' "with:Processor activeProcess displayString".
+ theSignal raiseSignalWith:badResource errorString:msg.
].
errID == #DisplayError ifTrue:[
- "unhandled display errors are ignored"
- ^ self.
+ "unhandled display errors are ignored"
+ ^ self.
].
theDevice notNil ifTrue:[
- 'DeviceWorkstation [info]: sending #brokenConnection' infoPrintCR.
- theDevice brokenConnection.
- theDevice dispatchProcess == Processor activeProcess ifTrue:[
- "I am running in the dispatch process
- and nobody handles theSignal, so abort the dispatcher"
-
- 'DeviceWorkstation [info]: raising AbortOperationRequest' infoPrintCR.
- AbortOperationRequest raise.
- ] ifFalse:[
- "Some other process (probably not even guilty - like someone doing a draw after a change) ...
- ... see if we can unwind out of the drawing operation"
-
- |context|
+ Logger info:'sending #brokenConnection'.
+ theDevice brokenConnection.
+ theDevice dispatchProcess == Processor activeProcess ifTrue:[
+ "I am running in the dispatch process
+ and nobody handles theSignal, so abort the dispatcher"
+
+ Logger info:'raising AbortOperationRequest'.
+ AbortOperationRequest raise.
+ ] ifFalse:[
+ "Some other process (probably not even guilty - like someone doing a draw after a change) ...
+ ... see if we can unwind out of the drawing operation"
+
+ |context|
"/ thisContext fullPrintAll.
- context := thisContext.
- [
- "find the first returnable context where theDevice is the receiver"
- context := context sender.
- ] doUntil:[
- context isNil or:[context receiver == theDevice and:[context canReturn]].
- ].
- context notNil ifTrue:[
- 'DeviceWorkstation [info]: unwind the draw operation: ' infoPrint.
- context methodPrintString infoPrintCR.
+ context := thisContext.
+ [
+ "find the first returnable context where theDevice is the receiver"
+ context := context sender.
+ ] doUntil:[
+ context isNil or:[context receiver == theDevice and:[context canReturn]].
+ ].
+ context notNil ifTrue:[
+ Logger info:'unwind the draw operation: %1'
+ with:context methodPrintString.
"/ context fullPrintAll.
- context unwind.
- "not reached"
- ].
- ]
- ].
- 'DeviceWorkstation [info]: proceeding after error' infoPrintCR.
+ context unwind.
+ "not reached"
+ ].
+ ]
+ ].
+ Logger info:'proceeding after error'.
"Modified: 11.4.1997 / 11:28:27 / cg"
!
@@ -3503,15 +3503,15 @@
depthUsed mapArray|
visualType == #DirectColor ifTrue:[
- 'DeviceWorkstation [info]: directColor displays not fully supported.' infoPrintCR.
- ^ nil
+ Logger info:'directColor displays not fully supported'.
+ ^ nil
].
(visualType == #StaticGray or:[visualType == #TrueColor]) ifTrue:[
- "
- those have no colorMap - we're done
- "
- ^ nil
+ "
+ those have no colorMap - we're done
+ "
+ ^ nil
].
"
@@ -3524,12 +3524,12 @@
"/ than 8 bits ...)
depthUsed == 15 ifTrue:[
- depthUsed := 16
+ depthUsed := 16
].
depthUsed > 16 ifTrue:[
- "/ do not allocate zillions of colors ...
- self error:'unreasonably large colorMap ...'.
- ^ nil
+ "/ do not allocate zillions of colors ...
+ self error:'unreasonably large colorMap ...'.
+ ^ nil
].
mapSize := (1 bitShift:depthUsed).
@@ -3537,9 +3537,9 @@
"/ get the palette
mapArray := Array new:mapSize.
1 to:mapSize do:[:i |
- self getRGBFrom:(i-1) into:[:r :g :b |
- mapArray at:i put:(Color red:r green:g blue:b)
- ]
+ self getRGBFrom:(i-1) into:[:r :g :b |
+ mapArray at:i put:(Color red:r green:g blue:b)
+ ]
].
^ mapArray.
@@ -4773,8 +4773,7 @@
ifFalse:[
"/ my last view was closed
dispatching := false.
- 'DeviceWorkstation [info]: finished dispatch (last view closed): ' infoPrint.
- self infoPrintCR.
+ Logger info:'finished dispatch (last view closed): %1' with:self.
LastActiveScreen == self ifTrue:[
LastActiveScreen := nil.
LastActiveProcess := nil.
@@ -4829,30 +4828,30 @@
"the actual event dispatching loop."
[dispatching] whileTrue:[
- "abortAll is handled, but not asked for here!!"
- AbortAllOperationRequest handle:[:ex |
- ex return
- ] do:[
- [self eventPending] whileFalse:[
- Processor activeProcess setStateTo:#ioWait if:#active.
- eventSema wait.
- "/ a temporary hack & workaround for semaphore-bug
+ "abortAll is handled, but not asked for here!!"
+ AbortAllOperationRequest handle:[:ex |
+ ex return
+ ] do:[
+ [self eventPending] whileFalse:[
+ Processor activeProcess setStateTo:#ioWait if:#active.
+ eventSema wait.
+ "/ a temporary hack & workaround for semaphore-bug
"/ (eventSema waitWithTimeoutMs:500) isNil ifTrue:[
"/ "/ timeout
"/ eventSema wouldBlock ifFalse:[
-"/ 'DeviceWorkstation [info]: sema did not wake up' infoPrintCR
+"/ Logger info:'sema did not wake up'.
"/ ] ifTrue:[
"/ self eventPending ifTrue:[
-"/ 'DeviceWorkstation [info]: sema missed' infoPrintCR
+"/ Logger info:'sema missed'.
"/ ].
"/ ].
"/ ].
- dispatching ifFalse:[^ self].
- ].
- dispatching ifTrue:[
- self dispatchPendingEvents.
- ].
- ]
+ dispatching ifFalse:[^ self].
+ ].
+ dispatching ifTrue:[
+ self dispatchPendingEvents.
+ ].
+ ]
]
"Modified: / 09-02-2011 / 13:59:43 / cg"
@@ -5791,17 +5790,17 @@
|colorId deviceColor|
(color isOnDevice:self) ifTrue:[
- colorId := color colorId.
+ colorId := color colorId.
] ifFalse:[
- deviceColor := color onDevice:self.
- deviceColor notNil ifTrue:[
- colorId := deviceColor colorId.
- ]
+ deviceColor := color onDevice:self.
+ deviceColor notNil ifTrue:[
+ colorId := deviceColor colorId.
+ ]
].
colorId isNil ifTrue:[
- 'DeviceWorkstation [warning]: could not set bg color' infoPrintCR.
+ Logger warning:'could not set bg color'.
] ifFalse:[
- self setBackground:colorId in:aGCId.
+ self setBackground:colorId in:aGCId.
]
!
@@ -5865,17 +5864,17 @@
|colorId deviceColor|
(color isOnDevice:self) ifTrue:[
- colorId := color colorId.
+ colorId := color colorId.
] ifFalse:[
- deviceColor := color onDevice:self.
- deviceColor notNil ifTrue:[
- colorId := deviceColor colorId.
- ]
+ deviceColor := color onDevice:self.
+ deviceColor notNil ifTrue:[
+ colorId := deviceColor colorId.
+ ]
].
colorId isNil ifTrue:[
- 'DeviceWorkstation [warning]: could not set fg color' infoPrintCR.
+ Logger warning:'could not set fg color'.
] ifFalse:[
- self setForeground:colorId in:aGCId.
+ self setForeground:colorId in:aGCId.
]
!
@@ -5994,43 +5993,42 @@
"the connection to the display device was lost."
dispatching ifTrue:[
- 'DeviceWorkstation [info]: finished dispatch (broken connection): ' infoPrint.
- self infoPrintCR.
- dispatching := false.
+ Logger info:'finished dispatch (broken connection): %1' with:self.
+ dispatching := false.
].
self emergencyCloseConnection.
displayId := nil.
LastActiveScreen == self ifTrue:[
- LastActiveScreen := nil.
- LastActiveProcess := nil.
+ LastActiveScreen := nil.
+ LastActiveProcess := nil.
].
"/ tell all of my top views about this.
self allTopViews do:[:eachTopView |
- |wg sensor model|
-
- "notice: we must manually wakeup the windowGroup process here
- (it might be waiting on an event,
- and the destroy below is executed by another thread.
- Otherwise, the windowGroup process would
- not terminate itself in this case."
-
- (wg := eachTopView windowGroup) notNil ifTrue:[
- sensor := wg sensor
- ].
- eachTopView destroyed.
-
- "the #destroyed above should release the application model - but is doesn't
- yet (2006-10) - so we do it here"
- model := eachTopView model.
- model notNil ifTrue:[
- model release.
- ].
- sensor notNil ifTrue:[
- sensor eventSemaphore signal.
- ].
+ |wg sensor model|
+
+ "notice: we must manually wakeup the windowGroup process here
+ (it might be waiting on an event,
+ and the destroy below is executed by another thread.
+ Otherwise, the windowGroup process would
+ not terminate itself in this case."
+
+ (wg := eachTopView windowGroup) notNil ifTrue:[
+ sensor := wg sensor
+ ].
+ eachTopView destroyed.
+
+ "the #destroyed above should release the application model - but is doesn't
+ yet (2006-10) - so we do it here"
+ model := eachTopView model.
+ model notNil ifTrue:[
+ model release.
+ ].
+ sensor notNil ifTrue:[
+ sensor eventSemaphore signal.
+ ].
].
self releaseDeviceResources.
@@ -6044,12 +6042,11 @@
self releaseDeviceResources.
self closeConnection.
dispatching ifTrue:[
- 'DeviceWorkstation [info]: finished dispatch (close): ' infoPrint.
- self infoPrintCR.
- dispatching := false.
+ Logger info:'finished dispatch (close): %1' with:self.
+ dispatching := false.
].
dispatchProcess notNil ifTrue:[
- dispatchProcess terminate.
+ dispatchProcess terminate.
].
"Modified: 13.1.1997 / 22:13:18 / cg"
@@ -6325,20 +6322,22 @@
(i.e. be prepared to not be able to release resources regularily)"
LastActiveScreen == self ifTrue:[
- LastActiveScreen := nil.
- LastActiveProcess := nil.
+ LastActiveScreen := nil.
+ LastActiveProcess := nil.
].
Image releaseResourcesOnDevice:self.
+
"This unregisters all the finalization handles"
- DeviceGraphicsContext releaseResourcesOnDevice:self.
+ self releaseGraphicsContexts.
+
blackColor notNil ifTrue:[
- blackColor releaseFromDevice.
- blackColor := nil.
+ blackColor releaseFromDevice.
+ blackColor := nil.
].
whiteColor notNil ifTrue:[
- whiteColor releaseFromDevice.
- whiteColor := nil.
+ whiteColor releaseFromDevice.
+ whiteColor := nil.
].
self releaseDeviceColors.
self releaseDeviceCursors.
--- a/DisplaySurface.st Wed Jul 20 17:07:38 2016 +0200
+++ b/DisplaySurface.st Wed Jul 20 18:26:01 2016 +0200
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
@@ -11,6 +9,8 @@
other person. No title to or ownership of the software is
hereby transferred.
"
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 17:08:14' !
+
"{ Package: 'stx:libview' }"
"{ NameSpace: Smalltalk }"
@@ -860,6 +860,53 @@
flags := flags bitOr:GotExposeFlagMask.
! !
+!DisplaySurface methodsFor:'binary storage'!
+
+readBinaryContentsFrom: stream manager: manager
+ "tell the newly restored View to recreate itself.
+ Bug: does not work correctly yet.
+ (restored view looses its position & wg process)"
+
+ |wasRealized|
+
+ super readBinaryContentsFrom: stream manager: manager.
+
+ wasRealized := realized.
+ realized := false.
+ self recreate.
+ wasRealized ifTrue:[
+ self remap
+ ]
+
+
+ "
+ |s l|
+ s := 'storedLabel.boss' asFilename writeStream binary.
+ l := (Label label:'hello there') realize.
+ Delay waitForSeconds:1.
+ l storeBinaryOn:s.
+ s close.
+ "
+
+ "
+ |s l|
+ s := 'storedLabel.boss' asFilename writeStream binary.
+ (l := Label label:'hello there') open.
+ (Delay forSeconds:10) wait.
+ l storeBinaryOn:s.
+ s close.
+ l destroy.
+ "
+
+ "
+ |s|
+ s := 'storedLabel.boss' asFilename readStream binary.
+ (Object readBinaryFrom:s)
+ "
+
+ "Modified: 3.5.1996 / 23:59:38 / stefan"
+ "Modified: 14.2.1997 / 15:42:55 / cg"
+! !
!DisplaySurface methodsFor:'button menus'!
@@ -2332,7 +2379,6 @@
releaseDeviceResources
super destroy.
- self setDevice:nil id:nil gcId:nil.
! !
!DisplaySurface methodsFor:'keyboard commands'!
--- a/Font.st Wed Jul 20 17:07:38 2016 +0200
+++ b/Font.st Wed Jul 20 18:26:01 2016 +0200
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
@@ -11,6 +9,8 @@
other person. No title to or ownership of the software is
hereby transferred.
"
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 15:21:49' !
+
"{ Package: 'stx:libview' }"
"{ NameSpace: Smalltalk }"
@@ -307,6 +307,14 @@
"Created: 28.5.1996 / 18:39:53 / cg"
! !
+!Font methodsFor:'binary storage'!
+
+readBinaryContentsFrom: stream manager: manager
+ "tell the newly restored Font about restoration"
+
+ super readBinaryContentsFrom: stream manager: manager.
+ self restored
+! !
!Font methodsFor:'converting'!
@@ -742,6 +750,17 @@
^ device fontResolutionOf:f.
!
+installInDeviceForGCId:aGCId
+ "install the font for aGCId"
+
+ (device isNil or:[fontId isNil]) ifTrue:[
+ "this should not happen, since #onDevice tries replacement fonts"
+ Logger error:'no device font for: %1' with:self.
+ ^ nil.
+ ].
+ device setFont:fontId in:aGCId.
+!
+
releaseFromDevice
"I am no longer available on the device"
--- a/FontDescription.st Wed Jul 20 17:07:38 2016 +0200
+++ b/FontDescription.st Wed Jul 20 18:26:01 2016 +0200
@@ -9,6 +9,8 @@
other person. No title to or ownership of the software is
hereby transferred.
"
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 15:21:49' !
+
"{ Package: 'stx:libview' }"
"{ NameSpace: Smalltalk }"
@@ -1387,6 +1389,15 @@
"Created: 19.4.1997 / 18:09:25 / cg"
! !
+!FontDescription methodsFor:'private'!
+
+installInDeviceForGCId:aGCId
+ "install the font for aGCId.
+ This is a No-op. Subclasses may redefine this."
+
+ ^ self.
+! !
+
!FontDescription methodsFor:'queries'!
bold
--- a/GraphicsMedium.st Wed Jul 20 17:07:38 2016 +0200
+++ b/GraphicsMedium.st Wed Jul 20 18:26:01 2016 +0200
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -11,6 +9,8 @@
other person. No title to or ownership of the software is
hereby transferred.
"
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 17:08:14' !
+
"{ Package: 'stx:libview' }"
"{ NameSpace: Smalltalk }"
@@ -2599,11 +2599,12 @@
!
destroy
- "destroy a medium - here the fc is completely destroyed"
+ "destroy a medium - here the gc is completely destroyed"
gc notNil ifTrue:[
- gc destroy.
+ gc destroy.
].
+ device := nil.
realized := false.
!
@@ -2627,14 +2628,8 @@
"allocate a GraphicsContext for a device"
aDevice notNil ifTrue:[
- device := aDevice.
- gc := aDevice newGraphicsContextFor:self.
- ] ifFalse:[
- "should not be reached"
- GraphicsMedium superclass == DeviceGraphicsContext ifTrue:[
- gc := self.
- super device:aDevice.
- ].
+ device := aDevice.
+ gc := aDevice newGraphicsContextFor:self.
].
self initialize.
@@ -2680,6 +2675,7 @@
setDevice:aDevice id:aDrawbleId gcId:aGCId
"private"
+ device := aDevice.
gc notNil ifTrue:[
gc setDevice:aDevice id:aDrawbleId gcId:aGCId
].
--- a/HostGraphicsDevice.st Wed Jul 20 17:07:38 2016 +0200
+++ b/HostGraphicsDevice.st Wed Jul 20 18:26:01 2016 +0200
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1997 by eXept Software AG / Claus Gittinger
All Rights Reserved
@@ -11,12 +9,14 @@
other person. No title to or ownership of the software is
hereby transferred.
"
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 14:38:04' !
+
"{ Package: 'stx:libview' }"
"{ NameSpace: Smalltalk }"
GraphicsDevice subclass:#HostGraphicsDevice
- instanceVariableNames:'deviceColors deviceFonts deviceViews deviceForms deviceCursors'
+ instanceVariableNames:'graphicsContexts deviceColors deviceFonts deviceCursors'
classVariableNames:''
poolDictionaries:''
category:'Interface-Graphics'
@@ -111,18 +111,11 @@
"Modified: / 28-07-2006 / 19:48:23 / fm"
!
-deviceForms
- "return the registry keeping track of forms which were allocated
+graphicsContexts
+ "return the registry keeping track of graphics contexts which were allocated
on this device."
- ^ deviceForms
-!
-
-deviceViews
- "return the registry keeping track of views which were allocated
- on this device."
-
- ^ deviceViews
+ ^ graphicsContexts
! !
!HostGraphicsDevice methodsFor:'accessing & queries'!
@@ -142,8 +135,7 @@
!HostGraphicsDevice methodsFor:'initialization & release'!
initializeDeviceResourceTables
- deviceViews := Registry new.
- deviceForms := Registry new.
+ graphicsContexts := Registry new.
deviceColors := Registry new.
deviceCursors := Registry new.
deviceFonts := CachingRegistry new cacheSize:10.
@@ -184,6 +176,15 @@
].
deviceFonts := CachingRegistry new cacheSize:10.
].
+!
+
+releaseGraphicsContexts
+ graphicsContexts notNil ifTrue:[
+ graphicsContexts unregisterAllForWhichHandle:[:eachHandle |
+ eachHandle finalize.
+ true
+ ].
+ ]
! !
!HostGraphicsDevice methodsFor:'misc'!
@@ -224,16 +225,8 @@
"Created: 24.2.1997 / 18:29:10 / cg"
!
-registerForm:aForm
- deviceForms register:aForm.
-
- "Created: 24.2.1997 / 18:29:10 / cg"
-!
-
-registerView:aView
- deviceViews register:aView.
-
- "Created: 24.2.1997 / 18:29:10 / cg"
+registerGraphicsContext:aGC
+ graphicsContexts register:aGC
!
unregisterColor:aColor
@@ -254,16 +247,8 @@
"Created: 24.2.1997 / 18:29:14 / cg"
!
-unregisterForm:aForm
- deviceForms unregister:aForm.
-
- "Created: 24.2.1997 / 18:29:14 / cg"
-!
-
-unregisterView:aView
- deviceViews unregister:aView.
-
- "Created: 24.2.1997 / 18:29:14 / cg"
+unregisterGraphicsContext:aGC
+ graphicsContexts unregister:aGC
! !
!HostGraphicsDevice class methodsFor:'documentation'!
--- a/XWorkstation.st Wed Jul 20 17:07:38 2016 +0200
+++ b/XWorkstation.st Wed Jul 20 18:26:01 2016 +0200
@@ -11,7 +11,7 @@
other person. No title to or ownership of the software is
hereby transferred.
"
-'From Smalltalk/X, Version:7.1.0.0 on 19-07-2016 at 15:46:14' !
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 15:21:49' !
"{ Package: 'stx:libview' }"
@@ -3402,7 +3402,7 @@
if (shape == @symbol(fourWay)) RETURN ( __MKSMALLINT(XC_fleur) );
if (shape == @symbol(crossCursor)) RETURN ( __MKSMALLINT(XC_X_cursor) );
%}.
-"/ ('XWorkstation [info]: invalid cursorShape:' , shape printString) infoPrintNL.
+"/ Logger info:'invalid cursorShape: %1' with:shape.
^ nil
! !
@@ -3417,128 +3417,128 @@
(msgType := self atomIDOf:#DndProtocol) notNil ifTrue:[
- "/ DND can drop files, file, dir, links, dirLink and text
- "/ check for this.
-
- dropObjects isCollection ifFalse:[
- dropColl := Array with:dropObjects
- ] ifTrue:[
- dropColl := dropObjects
- ].
- anyFile := anyDir := anyText := anyOther := false.
- dropColl do:[:aDropObject |
- aDropObject isFileObject ifTrue:[
- aDropObject theObject isDirectory ifTrue:[
- anyDir := true
- ] ifFalse:[
- anyFile := true
- ]
- ] ifFalse:[
- aDropObject isTextObject ifTrue:[
- anyText := true
- ] ifFalse:[
- anyOther := true
- ]
- ]
- ].
-
- anyOther ifTrue:[
- "/ DND does not support this ...
- 'XWorkstation [info]: DND can only drop files or text' infoPrintCR.
- ^ false
- ].
- anyText ifTrue:[
- (anyFile or:[anyDir]) ifTrue:[
- "/ DND does not support mixed types
- 'XWorkstation [info]: DND cannot drop both files and text' infoPrintCR.
- ^ false
- ]
- ].
-
- dropCollSize := dropColl size.
- anyFile ifTrue:[
- dropType := #DndFiles.
- dropCollSize == 1 ifTrue:[
- dropType := #DndFile
- ]
- ] ifFalse:[
- anyDir ifTrue:[
- dropType := #DndFiles.
- dropCollSize == 1 ifTrue:[
- dropType := #DndDir
- ]
- ] ifFalse:[
- anyText ifTrue:[
- dropCollSize == 1 ifTrue:[
- dropType := #DndText
- ] ifFalse:[
- "/ can only drop a single text object
- 'XWorkstation [info]: DND can only drop a single text' infoPrintCR.
- ^ false
- ]
- ] ifFalse:[
- "/ mhmh ...
- 'XWorkstation [info]: DND cannot drop this' infoPrintCR.
- ^ false
- ]
- ]
- ].
-
- dropTypeCode := self dndDropTypes indexOf:dropType.
- dropTypeCode == 0 ifTrue:[
- 'XWorkstation [info]: DND cannot drop this' infoPrintCR.
- ^ false
- ].
- dropTypeCode := dropTypeCode - 1.
-
-
- "/ place the selection inTo the DndSelection property
- "/ of the rootView ...
- "/ ... need a single string, with 0-terminated parts.
-
- strings := OrderedCollection new.
- sz := 0.
- dropColl do:[:anObject |
- |s o|
-
- o := anObject theObject.
- anObject isFileObject ifTrue:[
- o := o pathName
- ].
- s := o asString.
- strings add:s.
- sz := sz + (s size) + 1.
- ].
- val := String new:sz.
- idx := 1.
- strings do:[:aString |
- |sz|
-
- sz := aString size.
- val replaceFrom:idx to:(idx + sz - 1) with:aString startingAt:1.
- idx := idx + sz.
- val at:idx put:(Character value:0).
- idx := idx + 1
- ].
-
- self
- setProperty:(self atomIDOf:#DndSelection)
- type:(self atomIDOf:#STRING)
- value:val
- for:rootId.
-
- ^ self
- sendClientEvent:msgType
- format:32
- to:destinationId
- propagate:true
- eventMask:nil
- window:destinationId
- data1:dropTypeCode
- data2:0
- data3:destinationId
- data4:nil
- data5:nil.
+ "/ DND can drop files, file, dir, links, dirLink and text
+ "/ check for this.
+
+ dropObjects isCollection ifFalse:[
+ dropColl := Array with:dropObjects
+ ] ifTrue:[
+ dropColl := dropObjects
+ ].
+ anyFile := anyDir := anyText := anyOther := false.
+ dropColl do:[:aDropObject |
+ aDropObject isFileObject ifTrue:[
+ aDropObject theObject isDirectory ifTrue:[
+ anyDir := true
+ ] ifFalse:[
+ anyFile := true
+ ]
+ ] ifFalse:[
+ aDropObject isTextObject ifTrue:[
+ anyText := true
+ ] ifFalse:[
+ anyOther := true
+ ]
+ ]
+ ].
+
+ anyOther ifTrue:[
+ "/ DND does not support this ...
+ Logger info:'DND can only drop files or text'.
+ ^ false
+ ].
+ anyText ifTrue:[
+ (anyFile or:[anyDir]) ifTrue:[
+ "/ DND does not support mixed types
+ Logger info:'DND cannot drop both files and text'.
+ ^ false
+ ]
+ ].
+
+ dropCollSize := dropColl size.
+ anyFile ifTrue:[
+ dropType := #DndFiles.
+ dropCollSize == 1 ifTrue:[
+ dropType := #DndFile
+ ]
+ ] ifFalse:[
+ anyDir ifTrue:[
+ dropType := #DndFiles.
+ dropCollSize == 1 ifTrue:[
+ dropType := #DndDir
+ ]
+ ] ifFalse:[
+ anyText ifTrue:[
+ dropCollSize == 1 ifTrue:[
+ dropType := #DndText
+ ] ifFalse:[
+ "/ can only drop a single text object
+ Logger info:'DND can only drop a single text'.
+ ^ false
+ ]
+ ] ifFalse:[
+ "/ mhmh ...
+ Logger info:'DND cannot drop this'.
+ ^ false
+ ]
+ ]
+ ].
+
+ dropTypeCode := self dndDropTypes indexOf:dropType.
+ dropTypeCode == 0 ifTrue:[
+ Logger info:'DND cannot drop this'.
+ ^ false
+ ].
+ dropTypeCode := dropTypeCode - 1.
+
+
+ "/ place the selection inTo the DndSelection property
+ "/ of the rootView ...
+ "/ ... need a single string, with 0-terminated parts.
+
+ strings := OrderedCollection new.
+ sz := 0.
+ dropColl do:[:anObject |
+ |s o|
+
+ o := anObject theObject.
+ anObject isFileObject ifTrue:[
+ o := o pathName
+ ].
+ s := o asString.
+ strings add:s.
+ sz := sz + (s size) + 1.
+ ].
+ val := String new:sz.
+ idx := 1.
+ strings do:[:aString |
+ |sz|
+
+ sz := aString size.
+ val replaceFrom:idx to:(idx + sz - 1) with:aString startingAt:1.
+ idx := idx + sz.
+ val at:idx put:(Character value:0).
+ idx := idx + 1
+ ].
+
+ self
+ setProperty:(self atomIDOf:#DndSelection)
+ type:(self atomIDOf:#STRING)
+ value:val
+ for:rootId.
+
+ ^ self
+ sendClientEvent:msgType
+ format:32
+ to:destinationId
+ propagate:true
+ eventMask:nil
+ window:destinationId
+ data1:dropTypeCode
+ data2:0
+ data3:destinationId
+ data4:nil
+ data5:nil.
].
^ false
@@ -5247,9 +5247,9 @@
dropType := (self dndDropTypes) at:dropType+1 ifAbsent:#DndNotDnd.
property := self
- getProperty:(self atomIDOf:#DndSelection)
- from:rootId
- delete:false.
+ getProperty:(self atomIDOf:#DndSelection)
+ from:rootId
+ delete:false.
propertyType := property key.
dropValue := property value.
@@ -5263,70 +5263,69 @@
"/ in the default dropMessage handling of SimpleView.
dropType == #DndFiles ifTrue:[
- "/ actually, a list of fileNames
- propertyType ~~ stringAtom ifTrue:[
- 'XWorkstation [info]: expected a string propertyValue in drop' infoPrintCR.
- ^ self
- ].
-
- names := OrderedCollection new.
- i1 := 1.
- [i1 ~~ 0] whileTrue:[
- i2 := dropValue indexOf:(Character value:0) startingAt:i1.
- i2 ~~ 0 ifTrue:[
- names add:(dropValue copyFrom:i1 to:(i2-1)).
- i1 := i2 + 1.
- ] ifFalse:[
- i1 := i2
- ].
- ].
- dropValue := names.
- dropValue := dropValue collect:[:nm | nm asFilename].
- dropType := #files.
+ "/ actually, a list of fileNames
+ propertyType ~~ stringAtom ifTrue:[
+ Logger info:'expected a string propertyValue in drop'.
+ ^ self
+ ].
+
+ names := OrderedCollection new.
+ i1 := 1.
+ [i1 ~~ 0] whileTrue:[
+ i2 := dropValue indexOf:(Character value:0) startingAt:i1.
+ i2 ~~ 0 ifTrue:[
+ names add:(dropValue copyFrom:i1 to:(i2-1)).
+ i1 := i2 + 1.
+ ] ifFalse:[
+ i1 := i2
+ ].
+ ].
+ dropValue := names.
+ dropValue := dropValue collect:[:nm | nm asFilename].
+ dropType := #files.
] ifFalse:[ (dropType == #DndFile) ifTrue:[
- propertyType ~~ stringAtom ifTrue:[
- 'XWorkstation [info]: expected a string propertyValue in drop' infoPrintCR.
- ^ self
- ].
- dropValue := dropValue asFilename.
- dropType := #file.
+ propertyType ~~ stringAtom ifTrue:[
+ Logger info:'expected a string propertyValue in drop'.
+ ^ self
+ ].
+ dropValue := dropValue asFilename.
+ dropType := #file.
] ifFalse:[ (dropType == #DndDir) ifTrue:[
- propertyType ~~ stringAtom ifTrue:[
- 'XWorkstation [info]: expected a string propertyValue in drop' infoPrintCR.
- ^ self
- ].
- dropValue := dropValue asFilename.
- dropType := #directory.
+ propertyType ~~ stringAtom ifTrue:[
+ Logger info:'expected a string propertyValue in drop'.
+ ^ self
+ ].
+ dropValue := dropValue asFilename.
+ dropType := #directory.
] ifFalse:[ (dropType == #DndText) ifTrue:[
- propertyType ~~ stringAtom ifTrue:[
- 'XWorkstation [info]: expected a string propertyValue in drop' infoPrintCR.
- ^ self
- ].
- dropType := #text.
+ propertyType ~~ stringAtom ifTrue:[
+ Logger info:'expected a string propertyValue in drop'.
+ ^ self
+ ].
+ dropType := #text.
] ifFalse:[ (dropType == #DndExe) ifTrue:[
- propertyType ~~ stringAtom ifTrue:[
- 'XWorkstation [info]: expected a string propertyValue in drop' infoPrintCR.
- ^ self
- ].
- dropType := #executable.
+ propertyType ~~ stringAtom ifTrue:[
+ Logger info:'expected a string propertyValue in drop'.
+ ^ self
+ ].
+ dropType := #executable.
] ifFalse:[ (dropType == #DndLink) ifTrue:[
- propertyType ~~ stringAtom ifTrue:[
- 'XWorkstation [info]: expected a string propertyValue in drop' infoPrintCR.
- ^ self
- ].
- dropType := #link.
+ propertyType ~~ stringAtom ifTrue:[
+ Logger info:'expected a string propertyValue in drop'.
+ ^ self
+ ].
+ dropType := #link.
] ifFalse:[ (dropType == #DndRawData) ifTrue:[
- dropType := #rawData.
+ dropType := #rawData.
] ifFalse:[
- 'XWorkstation [info]: unsupported dropType: ' infoPrint. dropType infoPrintCR.
- 'XWorkstation [info]: data: ' infoPrint. dropValue infoPrintCR.
- dropType := #unknown.
+ Logger info:'unsupported dropType: %1 data: %2 ' with:dropType with:dropValue.
+ dropType := #unknown.
]]]]]]].
sensor := targetView sensor.
"not posted, if there is no sensor ..."
sensor notNil ifTrue:[
- sensor dropMessage:dropType data:dropValue view:targetView position:nil handle:nil
+ sensor dropMessage:dropType data:dropValue view:targetView position:nil handle:nil
].
"Created: 4.4.1997 / 17:59:37 / cg"
@@ -11593,21 +11592,20 @@
buffer := self perform:bufferGetSelector.
(aTargetAtomID == (self atomIDOf:#'ST_OBJECT')) ifTrue:[
- "/ 'st-object' printCR.
- "send the selection in binaryStore format"
- "require libboss to be loaded"
- (Smalltalk isClassLibraryLoaded:'libstx_libboss') ifFalse:[
- 'XWorkstation: cannot use binary store for copy buffer (libboss missing)' errorPrintCR.
- ^ nil -> nil.
- ].
-
- [
- ^ aTargetAtomID -> (buffer binaryStoreBytes).
- ] on:Error do:[:ex|
- 'XWorkstation: error on binary store of copy buffer: ' infoPrint.
- ex description infoPrintCR.
- ^ nil -> nil.
- ].
+ "/ 'st-object' printCR.
+ "send the selection in binaryStore format"
+ "require libboss to be loaded"
+ (Smalltalk isClassLibraryLoaded:'libstx_libboss') ifFalse:[
+ Logger error:'cannot use binary store for copy buffer (libboss missing)'.
+ ^ nil -> nil.
+ ].
+
+ [
+ ^ aTargetAtomID -> (buffer binaryStoreBytes).
+ ] on:Error do:[:ex|
+ Logger info:'error on binary store of copy buffer: %1' with: ex description.
+ ^ nil -> nil.
+ ].
].
bufferAsString := self class bufferAsString:buffer.
@@ -11615,25 +11613,25 @@
(aTargetAtomID == (self atomIDOf:#STRING)
or:[aTargetAtomID == (self atomIDOf:#'text/plain')]
) ifTrue:[
- "/ 'string' printCR.
- "the other view wants the selection as string"
- ^ aTargetAtomID -> (bufferAsString asSingleByteStringReplaceInvalidWith:$#).
+ "/ 'string' printCR.
+ "the other view wants the selection as string"
+ ^ aTargetAtomID -> (bufferAsString asSingleByteStringReplaceInvalidWith:$#).
].
(aTargetAtomID == (self atomIDOf:#UTF8_STRING)
or:[aTargetAtomID == (self atomIDOf:#'text/plain;codeset=utf-8')]
) ifTrue:[
- "/ 'utf string' printCR.
- "the other view wants the selection as utf8 string"
- ^ aTargetAtomID -> (bufferAsString utf8Encoded).
+ "/ 'utf string' printCR.
+ "the other view wants the selection as utf8 string"
+ ^ aTargetAtomID -> (bufferAsString utf8Encoded).
].
aTargetAtomID == (self atomIDOf:#LENGTH) ifTrue:[
- "the other one wants to know the size of our selection.
- LENGTH is deprecated, since we do not know how the selection is
- going to be converted. The client must not rely on the length returned"
-
- ^ (self atomIDOf:#INTEGER) -> (bufferAsString size).
+ "the other one wants to know the size of our selection.
+ LENGTH is deprecated, since we do not know how the selection is
+ going to be converted. The client must not rely on the length returned"
+
+ ^ (self atomIDOf:#INTEGER) -> (bufferAsString size).
].
"we do not support the requestet target type"
@@ -14114,7 +14112,7 @@
self isPixmap ifTrue:[
pixmapDepth := depth.
].
- fontId := font getFontId.
+ fontId := font getXftFontId.
%{ /* STACK: 64000 */
#ifdef XFT
--- a/XftFontDescription.st Wed Jul 20 17:07:38 2016 +0200
+++ b/XftFontDescription.st Wed Jul 20 18:26:01 2016 +0200
@@ -1,4 +1,4 @@
-'From Smalltalk/X, Version:7.1.0.0 on 18-07-2016 at 18:55:24' !
+'From Smalltalk/X, Version:7.1.0.0 on 20-07-2016 at 15:21:49' !
"{ Package: 'stx:libview' }"
@@ -571,7 +571,7 @@
!XftFontDescription methodsFor:'accessing-private'!
-getFontId
+getXftFontId
^ fontId
"Created: / 02-01-2014 / 23:29:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
@@ -886,6 +886,16 @@
!XftFontDescription methodsFor:'getting a device font'!
+installInDeviceForGCId:aGCId
+ "install the font for aGCId"
+
+ (device isNil or:[fontId isNil]) ifTrue:[
+ Logger error:'no device font for: %1' with:self.
+ ^ nil.
+ ].
+ "nothing to install"
+!
+
onDevice:aGraphicsDevice
"Create a new XftFont representing the closes font as
myself on aDevice; if one already exists, return the one."
@@ -915,7 +925,7 @@
].
RecentlyUsedFonts keysAndValuesDo:[:index :aFont |
- ((aFont class == self class) and:[(self sameDeviceFontAs:aFont) and:[aFont getFontId notNil]]) ifTrue:[
+ ((aFont class == self class) and:[(self sameDeviceFontAs:aFont) and:[aFont getXftFontId notNil]]) ifTrue:[
"/ Transcript showCR:'hit'.
RecentlyUsedFonts
removeIndex:index;