'From Cuis 1.0 of 6 March 2009 [latest update: #5989] on 24 March 2009 at 10:30:04 pm'!
!classDefinition: #OldWorldTest category: #'Morphic-Tests'!
TestCase subclass: #OldWorldTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Tests'!
!classDefinition: #TimedOut category: #'System-Exceptions Kernel'!
Notification subclass: #TimedOut
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!

!BlockContext methodsFor: 'evaluating' stamp: 'ar 3/24/2009 22:29'!
valueWithin: aDuration onTimeout: timeoutBlock
	"Evaluate the receiver.
	If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead"

	| theProcess delay watchdog |

	aDuration <= Duration zero ifTrue: [^ timeoutBlock value ].

	"the block will be executed in the current process"
	theProcess _ Processor activeProcess.
	delay _ aDuration asDelay.

	"make a watchdog process"
	watchdog _ [
		delay wait. 	"wait for timeout or completion"
		theProcess ifNotNil: [ theProcess signalException: TimedOut ] 
	] newProcess.

	"Watchdog needs to run at high priority to do its job (but not at timing priority)"
	watchdog priority: Processor timingPriority-1.

	"catch the timeout signal"
	^ [	watchdog resume.				"start up the watchdog"
		self ensure:[						"evaluate the receiver"
			theProcess _ nil.				"it has completed, so ..."
			delay delaySemaphore signal.	"arrange for the watchdog to exit"
		]] on: TimedOut do: [ :e | timeoutBlock value ].
! !


!Delay methodsFor: 'public' stamp: 'ar 3/24/2009 22:28'!
delaySemaphore

	^ delaySemaphore! !


!OldWorldState methodsFor: 'stepping' stamp: 'ar 3/24/2009 22:18'!
runStepMethodsIn: aWorld
	"Perform periodic activity inbetween event cycles"
	| queue msg |

	queue _ self class deferredUIMessages.
	[ (msg _ queue nextOrNil) isNil ] whileFalse: [
		msg value
	].
	self runLocalStepMethodsIn: aWorld.

	"we are using a normal #step for these now"
	"aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]."
! !


!OldWorldTest methodsFor: 'as yet unclassified' stamp: 'ar 3/24/2009 22:21'!
testDoOneCycleWorksWithDeferredQueue
        "Ensure that nested doOneCycles don't break deferred UI messages"
        | finished |
        [
                OldWorldState addDeferredUIMessage: [ World doOneCycleNow ].
                OldWorldState addDeferredUIMessage: [ "whatever" ].
                World doOneCycleNow.
                finished _ true.
        ] valueWithin: 1 second onTimeout: [finished _ false ].
        self assert: finished! !

