" Name: SUnitUI HideSource: false Parcel: SUnitVW30-SUnitUI SaveSource: true Date: 7:10:55 pm July 17, 2000 " 'From VisualWorks®, Release 3.0 of February 5, 1998 on July 17, 2000 at 7:10:55 pm'! (Dialog confirm: 'You are filing-in a Parcel source file!!\\While this is possible it will not have\the same effect as loading the parcel.\None of the Parcel''s prerequisites will\be loaded and none of its load actions\will be performed.\\Are you sure you want to file-in?' withCRs) ifFalse: [self error: 'Parcel file-in abandoned. Choose terminate or close.']! ApplicationModel subclass: #TestRunner instanceVariableNames: 'result lastPass defect defectMenu details mode scriptModel script ' classVariableNames: '' poolDictionaries: '' category: 'SUnitUI'! TestRunner class instanceVariableNames: ''! !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 script value sunitName! timeSinceLastPassAsString lastPass isNil ifTrue: [^'']. ^', ' , (self formatTime: (Time now subtractTime: lastPass)) , ' since last Pass'! update: anObject (anObject isKindOf: TestCase) ifTrue: [self displayDetails: anObject printString] ifFalse: [super update: anObject]! workaroundForStupidVWRefreshBug builder window refresh! ! !TestRunner methodsFor: 'Actions'! debugFailedTest defect value isNil ifFalse: [self debugTest: defect value]! debugTest self debugTest: defect value! debugTest: aTestCase aTestCase isNil ifTrue: [^self]. self displayMode: 'Debugging'. self workaroundForStupidVWRefreshBug. (result isFailure: aTestCase) ifTrue: [aTestCase debug] ifFalse: [aTestCase debug]! refreshTests scriptModel := nil. self script value: nil. self displayReset.! runAllTests self runSuite: self allTestSuite! runSuite: aTestSuite Cursor wait showWhile: [self displayRunning. aTestSuite addDependentToHierachy: self. [result := aTestSuite run] sunitEnsure: [aTestSuite removeDependentFromHierachy: self]. self updateWindow]! runTests self script value isNil ifFalse: [self runSuite: self freshTestSuite]! ! !TestRunner methodsFor: 'Updating'! displayColor: aColorValue (builder componentAt: #colorRegion) widget insideColor: aColorValue! displayDefault self displayColor: ColorValue white! displayDefects: aCollection | components | components := Array with: (self builder componentAt: #defects) with: (self builder componentAt: #debugFailedTest). defect value: nil. aCollection isEmpty ifTrue: [^components do: [:each | each disable]]. defectMenu value: (Menu labelArray: (aCollection collect: [:each | each printString]) values: aCollection). components do: [:each | each enable].! displayDetails: aString details value: aString. self workaroundForStupidVWRefreshBug! displayFail self displayRed. self displayMode: 'Fail'. self displayDetails: result printString.! displayGreen self displayColor: ColorValue green! displayMode: aString mode value: aString! displayPass self displayGreen. self displayMode: 'Pass'. self displayDetails: result runCount printString , ' run' , self timeSinceLastPassAsString. lastPass := Time now! displayRed self displayColor: ColorValue red.! displayReset self displayDefault. self displayMode: 'N/A'. self displayDetails: '...'.! displayRunning self displayYellow. self displayMode: 'running'. self displayDetails: '...'.! displayYellow self displayColor: ColorValue yellow! updateDefects self displayDefects: result defects! updateWindow result hasPassed ifTrue: [self displayPass] ifFalse: [self displayFail]. self updateDefects! ! !TestRunner methodsFor: 'Accessing'! defect "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." ^defect isNil ifTrue: [defect := nil asValue] ifFalse: [defect]! defectMenu "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." ^defectMenu isNil ifTrue: [defectMenu := List new asValue] ifFalse: [defectMenu]! 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 "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." ^script isNil ifTrue: [script := ExampleSetTest asValue] ifFalse: [script]! 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 := (Menu labelArray: ((TestCase allSubclasses asSortedCollection: [:a :b | a name < b name]) collect: [:each | each printString]) values: (TestCase allSubclasses asSortedCollection: [:a :b | a name < b name]) asOrderedCollection) asValue] ifFalse: [scriptModel]! ! !TestRunner class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'SUnit Camp Smalltalk 2.7 TestRunner' #min: #(#Point 40 20 ) #bounds: #(#Rectangle 121 193 516 341 ) ) #component: #(#SpecCollection #collection: #( #(#RegionSpec #layout: #(#LayoutFrame 0 0 24 0 0 1 -24 1 ) #name: #colorRegion ) #(#ActionButtonSpec #layout: #(#LayoutFrame -100 1 0 0 -50 1 24 0 ) #name: #runOneButton #model: #runTests #label: 'Run' #isDefault: false ) #(#ActionButtonSpec #layout: #(#LayoutFrame -50 1 0 0 0 1 24 0 ) #model: #runAllTests #label: 'RunAll' ) #(#MenuButtonSpec #layout: #(#LayoutFrame 50 0 0 0 -100 1 24 0 ) #name: #tests #model: #script #menu: #scriptModel ) #(#MenuButtonSpec #layout: #(#LayoutFrame 0 0 -24 1 -50 1 0 1 ) #name: #defects #flags: 40 #isOpaque: true #model: #defect #callbacksSpec: #(#UIEventCallbackSubSpec #valueChangeSelector: #debugTest ) #menu: #defectMenu ) #(#ActionButtonSpec #layout: #(#LayoutFrame -50 1 -24 1 0 1 0 1 ) #name: #debugFailedTest #flags: 40 #model: #debugFailedTest #label: 'Debug' #isDefault: false ) #(#ActionButtonSpec #layout: #(#Rectangle 0 0 50 24 ) #model: #refreshTests #label: 'Refresh' #isDefault: false ) #(#InputFieldSpec #layout: #(#LayoutFrame 0 0 0 0.508197 0 1 33 0.5 ) #name: #details #flags: 0 #model: #details #tabable: false #alignment: #center #style: #systemDefault #isReadOnly: true ) #(#InputFieldSpec #layout: #(#LayoutFrame 0 0 -32 0.5 0 1 0 0.5 ) #name: #mode #flags: 0 #model: #mode #tabable: false #alignment: #center #style: #large #isReadOnly: true ) ) ) )! "Imported Classes:"! self error: 'Attempting to file-in parcel imports. Choose terminate or close'! ! Model subclass: #ApplicationModel instanceVariableNames: 'builder uiSession ' classVariableNames: 'DefaultLabels DefaultVisuals ' poolDictionaries: '' category: 'UIBuilder-Framework'!