"{ Package: 'stx:goodies/sunit' }"

ApplicationModel subclass:#TestRunner
	instanceVariableNames:'result lastPass defect allDefects defectMenu details mode
		scriptModel script'
	classVariableNames:''
	poolDictionaries:''
	category:'SUnitUI'
!

!TestRunner class methodsFor:'interface specs'!

windowSpec
    "This resource specification was automatically generated
     by the UIPainter of ST/X."

    "Do not manually edit this!! If it is corrupted,
     the UIPainter may not be able to read the specification."

    "
     UIPainter new openOnClass:TestRunner andSelector:#windowSpec
     TestRunner new openInterface:#windowSpec
     TestRunner open
    "

    <resource: #canvas>

    ^ 
     #(#FullSpec
	#name: #windowSpec
	#window: 
       #(#WindowSpec
	  #label: 'SUnit Camp Smalltalk 2.7 TestRunner'
	  #name: 'SUnit Camp Smalltalk 2.7 TestRunner'
	  #min: #(#Point 362 122)
	  #bounds: #(#Rectangle 16 46 509 221)
	)
	#component: 
       #(#SpecCollection
	  #collection: #(
	   #(#ActionButtonSpec
	      #label: 'Refresh'
	      #name: 'Button3'
	      #layout: #(#LayoutFrame 0 0 0 0 75 0 24 0)
	      #model: #refreshSuites
	    )
	   #(#MenuButtonSpec
	      #label: 'ExampleSetTest'
	      #name: #tests
	      #layout: #(#LayoutFrame 76 0 0 0 -146 1 24 0)
	      #model: #script
	      #menu: #scriptModel
	      #useIndex: true
	    )
	   #(#ActionButtonSpec
	      #label: 'Run'
	      #name: 'Button1'
	      #layout: #(#LayoutFrame -145 1 0 0 -77 1 24 0)
	      #model: #runTests
	      #enableChannel: #enableRunButton
	    )
	   #(#ActionButtonSpec
	      #label: 'RunAll'
	      #name: 'Button2'
	      #layout: #(#LayoutFrame -76 1 0 0 0 1 24 0)
	      #model: #runAllTests
	    )
	   #(#LabelSpec
	      #label: 'N/A'
	      #name: 'mode'
	      #layout: #(#LayoutFrame 0 0 25 0 0 1 0 0.5)
	      #style: #(#FontDescription #Arial #bold #roman 14)
	      #labelChannel: #mode
	    )
	   #(#LabelSpec
	      #label: '...'
	      #name: 'details'
	      #layout: #(#LayoutFrame 0 0 0 0.5 0 1 -24 1)
	      #labelChannel: #details
	    )
	   #(#MenuButtonSpec
	      #name: #defects
	      #layout: #(#LayoutFrame 0 0 -24 1 -75 1 0 1)
	      #isOpaque: true
	      #flags: 40
	      #model: #selectionHolder
	      #initiallyDisabled: true
	      #enableChannel: #enableDefectsList
	      #menu: #defectMenu
	    )
	   #(#ActionButtonSpec
	      #label: 'Debug'
	      #name: 'Button4'
	      #layout: #(#LayoutFrame -75 1 -24 1 0 1 0 1)
	      #model: #debugSelectedFailure
	      #initiallyDisabled: true
	      #enableChannel: #enableDebugButton
	    )
	   )
         
	)
      )
! !

!TestRunner class methodsFor:'opening'!

open

	^super open!

openOnTestCase:aTestCaseSubclass
    |runner idx|

    runner := self new.
    runner open.
    runner window waitUntilVisible.
    idx := runner scriptModel value indexOf:aTestCaseSubclass name.
    runner script value:idx.

    "
     self openOnTestCase:CompilerTest
    "
! !

!TestRunner class methodsFor:'plugIn spec'!

aspectSelectors
    "This resource specification was automatically generated
     by the UIPainter of ST/X."

    "Do not manually edit this. If it is corrupted,
     the UIPainter may not be able to read the specification."

    "Return a description of exported aspects;
     these can be connected to aspects of an embedding application
     (if this app is embedded in a subCanvas)."

    ^ #(
	#script
      ).

! !

!TestRunner methodsFor:'Accessing'!

defectMenu
    "automatically generated by UIPainter ..."

    "*** the code below creates a default model when invoked."
    "*** (which may not be the one you wanted)"
    "*** Please change as required and accept it in the browser."

    ^defectMenu isNil 
	ifTrue: [defectMenu := OrderedCollection new asValue]
	ifFalse: [defectMenu]

    "Modified: / 4.4.2000 / 20:00:31 / Sames"
!

defects

	^self builder componentAt: #defects

    "Created: / 21.6.2000 / 12:19:29 / Sames"
!

details
	"This method was generated by UIDefiner.  Any edits made here
	may be lost whenever methods are automatically defined.  The
	initialization provided below may have been preempted by an
	initialize method."

	^details isNil
		ifTrue:
			[details := '...' asValue]
		ifFalse:
			[details]!

mode
	"This method was generated by UIDefiner.  Any edits made here
	may be lost whenever methods are automatically defined.  The
	initialization provided below may have been preempted by an
	initialize method."

	^mode isNil
		ifTrue:
			[mode := 'N/A' asValue]
		ifFalse:
			[mode]!

script
    "automatically generated by UIPainter ..."

    "*** the code below creates a default model when invoked."
    "*** (which may not be the one you wanted)"
    "*** Please change as required and accept it in the browser."

    |holder|

    (holder := builder bindingAt:#script) isNil ifTrue:[
	holder := ValueHolder new.
	builder aspectAt:#script put:holder.
"/        holder addDependent:self.
    ].
    ^ holder.

    "Created: / 21.6.2000 / 12:04:36 / Sames"
!

script:something
    "automatically generated by UIPainter ..."

    "This method is used when I am embedded as subApplication,"
    "and the mainApp wants to connect its aspects to mine."

"/     |holder|

"/     (holder := builder bindingAt:#script) notNil ifTrue:[
"/         holder removeDependent:self.
"/     ].
    builder aspectAt:#script put:something.
"/     something notNil ifTrue:[
"/         something addDependent:self.
"/     ].
    ^ self.

    "Created: / 21.6.2000 / 12:04:36 / Sames"
!

scriptModel
    "This method was generated by UIDefiner.  Any edits made here
	may be lost whenever methods are automatically defined.  The
	initialization provided below may have been preempted by an
	initialize method."

    ^scriptModel isNil 
	ifTrue: [scriptModel := (TestCase allSubclasses collect: [:each | each name]) asValue]
	ifFalse: [scriptModel]

    "Modified: / 2.4.2000 / 14:37:51 / Sames"
!

selection

	^defect

    "Created: / 4.4.2000 / 18:50:55 / Sames"
!

selectionHolder
    "automatically generated by UIPainter ..."

    "*** the code below creates a default model when invoked."
    "*** (which may not be the one you wanted)"
    "*** Please change as required and accept it in the browser."

    |holder|

    (holder := builder bindingAt:#selectionHolder) isNil ifTrue:[
	holder := AspectAdaptor new subject:self; forAspect:#selection.
	builder aspectAt:#selectionHolder put:holder.
"/        holder addDependent:self.
    ].
    ^ holder.

    "Created: / 4.4.2000 / 18:46:08 / Sames"
    "Modified: / 4.4.2000 / 18:47:31 / Sames"
!

tests

	^self builder componentAt: #tests

    "Created: / 4.4.2000 / 19:57:37 / Sames"
! !

!TestRunner methodsFor:'Actions'!

debugSelectedFailure
	self debugTest: self selection

    "Created: / 21.6.2000 / 10:58:58 / Sames"
    "Modified: / 21.6.2000 / 12:21:05 / Sames"
!

debugTest: aTestCaseName 
    | testCase |
    defect := aTestCaseName.
    testCase := allDefects at: aTestCaseName ifAbsent: [nil].
    testCase isNil ifTrue: [^self enableDebugButton value: false].
    self enableDebugButton value: true.
    self displayMode: 'Debugging'.
    (result isFailure: testCase) 
	ifTrue: [testCase debugAsFailure]
	ifFalse: [testCase debug]

    "Modified: / 21.6.2000 / 12:12:09 / Sames"
!

enableDebugButton
    "automatically generated by UIPainter ..."
    "*** the code below creates a default model when invoked."
    "*** (which may not be the one you wanted)"
    "*** Please change as required and accept it in the browser."

    | holder |
    (holder := builder bindingAt: #enableDebugButton) isNil 
	ifTrue: 
	    [holder := true asValue.
	    builder aspectAt: #enableDebugButton put: holder
	    "        holder addDependent:self."].
    ^holder

    "Created: / 21.6.2000 / 10:47:34 / Sames"
    "Modified: / 21.6.2000 / 10:51:07 / Sames"
!

enableDefectsList
    "automatically generated by UIPainter ..."

    "*** the code below creates a default model when invoked."
    "*** (which may not be the one you wanted)"
    "*** Please change as required and accept it in the browser."

    |holder|

    (holder := builder bindingAt:#enableDefectsList) isNil ifTrue:[
	holder := true asValue.
	builder aspectAt:#enableDefectsList put:holder.
"/        holder addDependent:self.
    ].
    ^ holder.

    "Created: / 21.6.2000 / 10:47:34 / Sames"
!

enableRunButton
    "automatically generated by UIPainter ..."

    "*** the code below creates a default model when invoked."
    "*** (which may not be the one you wanted)"
    "*** Please change as required and accept it in the browser."

    |holder|

    (holder := builder bindingAt:#enableRunButton) isNil ifTrue:[
	holder := true asValue.
	builder aspectAt:#enableRunButton put:holder.
"/        holder addDependent:self.
    ].
    ^ holder.

    "Created: / 21.6.2000 / 10:47:34 / Sames"
!

refreshSuites
	self scriptModel value: (TestCase allSubclasses collect: [:each | each name]).
	self tests selection: 0.
	self defects selection: 0.
	result := TestResult new.
	self displayRefresh

    "Created: / 21.6.2000 / 10:58:34 / Sames"
    "Modified: / 21.6.2000 / 12:19:54 / Sames"
!

runAllTests
	self runSuite: self allTestSuite!

runSuite: aTestSuite 
	Cursor wait
		showWhile: 
			[self displayRunning.
			aTestSuite addDependentToHierachy: self.
			[result := aTestSuite run]
				ensure: [aTestSuite removeDependentFromHierachy: self].
			self updateWindow]!

runTests
	| testSuite |
	(testSuite := self freshTestSuite) notNil ifTrue:
		[self runSuite: testSuite]

    "Modified: / 2.4.2000 / 14:16:10 / Sames"
!

selection: aValue

	self debugTest: aValue

    "Created: / 4.4.2000 / 18:54:09 / Sames"
    "Modified: / 4.4.2000 / 19:01:33 / Sames"
!

suiteSelectionChanged
	self enableRunButton value: self freshTestSuite notNil

    "Created: / 21.6.2000 / 11:31:25 / Sames"
    "Modified: / 21.6.2000 / 11:32:54 / Sames"
! !

!TestRunner methodsFor:'Private'!

allTestSuite
	| tokens stream |
	tokens := (TestCase subclasses collect: [:each | each name , '* '])
				copyWithout: 'SUnitTest* '.
	stream := WriteStream on: String new.
	tokens do: [:each | stream nextPutAll: each].
	^TestSuitesScripter run: stream contents!

formatTime: aTime 
	aTime hours > 0 ifTrue: [^aTime hours printString , 'h'].
	aTime minutes > 0 ifTrue: [^aTime minutes printString , 'min'].
	^aTime seconds printString , ' sec'!

freshTestSuite

	^TestSuitesScripter run: self tests contents

    "Modified: / 4.4.2000 / 20:13:41 / Sames"
!

postOpenWith: aBuilder 
    "automatically generated by UIPainter ..."

    super postOpenWith: aBuilder.
    self tests defaultLabel: ''.
    self tests selection: 'ExampleSetTest'.
    self enableDebugButton value: false.
    self enableDefectsList value: false.
    self script onChangeSend: #suiteSelectionChanged to: self

    "Created: / 2.4.2000 / 14:44:32 / Sames"
    "Modified: / 21.6.2000 / 12:06:30 / Sames"
!

timeSinceLastPassAsString
	lastPass isNil ifTrue: [^''].
	^', ' , (self formatTime: (Time now subtractTime: lastPass getSeconds)) , ' since last Pass'

    "Modified: / 3.4.2000 / 19:17:11 / Sames"
! !

!TestRunner methodsFor:'Updating'!

displayColor: aColorValue

	(builder componentAt: #mode) widget insideColor: aColorValue.
	(builder componentAt: #details) widget insideColor: aColorValue.

    "Modified: / 2.4.2000 / 14:21:42 / Sames"
!

displayDefault
	self displayColor: self tests backgroundColor

    "Created: / 21.6.2000 / 12:28:06 / Sames"
    "Modified: / 21.6.2000 / 12:35:09 / Sames"
!

displayDefects: aCollection 
    | menuButton |
    menuButton := self builder componentAt: #defects.
    aCollection isEmpty ifTrue: [^menuButton disable].
    allDefects := Dictionary new.
    aCollection do: [:each | allDefects at: each printString put: each].
    self defectMenu value: allDefects keys asOrderedCollection.
    menuButton enable

    "Modified: / 4.4.2000 / 20:11:06 / Sames"
!

displayDetails: aString 
	self details value: aString.

    "Modified: / 21.6.2000 / 11:10:14 / Sames"
!

displayFail
	self displayRed.
	self displayMode: 'Fail'.
	self displayDetails: result printString.!

displayGreen
	self displayColor: ColorValue green!

displayMode: aString 
	self mode value: aString

    "Modified: / 21.6.2000 / 11:14:19 / Sames"
!

displayPass
    self displayMode: 'Pass'.
    self displayDetails: result runCount printString , ' run' , self timeSinceLastPassAsString.
    self displayGreen.
    lastPass := Time now

    "Modified: / 21.6.2000 / 12:14:52 / Sames"
!

displayRed
	self displayColor: ColorValue red.!

displayRefresh
    self displayMode: 'N/A'.
    self displayDetails:'...'.
    self updateDefects.
    self enableRunButton value: false.
    self enableDebugButton value: false.
    self displayDefault

    "Created: / 21.6.2000 / 12:14:11 / Sames"
    "Modified: / 21.6.2000 / 12:28:24 / Sames"
!

displayRunning
	self displayYellow.
	self displayMode: 'running'. 
	self displayDetails: '...'.!

displayYellow
	self displayColor: ColorValue yellow!

update: anObject 
	(anObject isKindOf: TestCase)
		ifTrue: [self displayDetails: anObject printString]
		ifFalse: [super update: anObject]!

updateDefects
	self displayDefects: result defects!

updateWindow
	result hasPassed
		ifTrue: [self displayPass]
		ifFalse: [self displayFail].
	self updateDefects! !