"{ Encoding: utf8 }"

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

"{ NameSpace: Smalltalk }"

ApplicationModel subclass:#TestRunner

	instanceVariableNames:'result lastTestCase lastPass defect allDefects defectMenu details

		mode scriptModel script numberOfTestsToRun testsWhichFailed

		testsWhichPassed categoryModel category'

	classVariableNames:''

	poolDictionaries:''

	category:'SUnit-UI'

!

!TestRunner class methodsFor:'documentation'!

documentation

"

    Obsolete now; see the enhanced test runner: Tools::TestRunner2

    This GUI is based on SUnit2.7 and

    was ported to ST/X by Samuel S. Schuster (as 2.7)  (thanks, indeed)

    It was slightly enhanced by adding a rerun-defects, browse and

    a category selector (to minor revision 2.7d, in the meantime)

"

! !

!TestRunner class methodsFor:'defaults'!

colorForFailedTests

    ^ Color red

!

colorForPassedTests

    ^ Color darkGreen

    "Modified: / 13-03-2019 / 21:13:13 / Claus Gittinger"

!

defaultIcon

    <resource: #programImage>

    "/ kept there to prevent me from being autoloaded for the icon

    ^ ToolbarIconLibrary sUnit24x24Icon

! !

!TestRunner class methodsFor:'interface specs'!

helpSpec

    <resource: #help>

    ^super helpSpec addPairsFrom:#(

#refreshSuitesButton

'Refresh List of Tests'

#suitesCategoryList

'Test Categories'

#suiteSelection

'Selected Test'

#runButton

'Run selected Test'

#rerunDefectsButton

'ReRun Defects Only'

#runAllButton

'Run all Tests from Category'

#defectsList

'Failures'

#browseButton

'Browse Test'

#debugButton

'Debug Failed Test'

)

!

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 3.1/STX TestRunner'

	  name: 'SUnit Camp Smalltalk 3.1/STX TestRunner'

	  min: (Point 362 122)

	  bounds: (Rectangle 0 0 493 175)

	  icon: defaultIcon

	)

	component:

       (SpecCollection

	  collection: (

	   (ActionButtonSpec

	      label: 'Refresh'

	      name: 'RefreshButton'

	      layout: (LayoutFrame 0 0 0 0 75 0 48 0)

	      activeHelpKey: refreshSuitesButton

	      tabable: true

	      model: refreshSuites

	    )

	   (MenuButtonSpec

	      name: 'category'

	      layout: (LayoutFrame 76 0 0 0 -216 1 24 0)

	      activeHelpKey: suitesCategoryList

	      tabable: true

	      model: category

	      menu: categoryList

	    )

	   (MenuButtonSpec

	      name: tests

	      layout: (LayoutFrame 76 0 24 0 -216 1 48 0)

	      activeHelpKey: suiteSelection

	      tabable: true

	      model: script

	      menu: scriptModel

	      useIndex: true

	    )

	   (ActionButtonSpec

	      label: 'Run'

	      name: 'RunButton'

	      layout: (LayoutFrame -215 1 0 0 -160 1 48 0)

	      activeHelpKey: runButton

	      tabable: true

	      model: runTests

	      enableChannel: enableRunButton

	    )

	   (ActionButtonSpec

	      label: 'ReRun Defects'

	      name: 'ReRunButton'

	      layout: (LayoutFrame -159 1 0 0 -57 1 48 0)

	      activeHelpKey: rerunDefectsButton

	      tabable: true

	      model: runDefects

	      enableChannel: enableDefects

	    )

	   (ActionButtonSpec

	      label: 'Run All'

	      name: 'RunAllButton'

	      layout: (LayoutFrame -56 1 0 0 0 1 48 0)

	      activeHelpKey: runAllButton

	      tabable: true

	      model: runAllTests

	    )

	   (ProgressIndicatorSpec

	      name: 'ProgressIndicator1'

	      layout: (LayoutFrame 0 0.0 49 0 0 1.0 60 0)

	      visibilityChannel: percentageIndicatorVisible

	      model: percentageDone

	      foregroundColor: (Color 32.999160753796 32.999160753796 0.0)

	      backgroundColor: (Color 66.999313344015 66.999313344015 0.0)

	      showPercentage: false

	    )

	   (LabelSpec

	      label: '...'

	      name: 'details'

	      layout: (LayoutFrame 0 0 21 0.5 0 1 -25 1)

	      labelChannel: details

	    )

	   (LabelSpec

	      label: 'N/A'

	      name: 'mode'

	      layout: (LayoutFrame 0 0 49 0 0 1 35 0.5)

	      style: (FontDescription Arial bold roman 14)

	      labelChannel: mode

	    )

	   (MenuButtonSpec

	      name: defects

	      layout: (LayoutFrame 0 0 -24 1 -152 1 0 1)

	      isOpaque: true

	      flags: 40

	      activeHelpKey: defectsList

	      tabable: true

	      model: selectionHolder

	      initiallyDisabled: true

	      enableChannel: enableDefects

	      menu: defectMenu

	      ignoreReselect: false

	    )

	   (ActionButtonSpec

	      label: 'Browse'

	      name: 'BrowseButton'

	      layout: (LayoutFrame -151 1 -24 1 -76 1 0 1)

	      activeHelpKey: browseButton

	      tabable: true

	      model: browseSelectedTestCase

	      initiallyDisabled: true

	      enableChannel: enableRunButton

	    )

	   (ActionButtonSpec

	      label: 'Debug'

	      name: 'DebugButton'

	      layout: (LayoutFrame -75 1 -24 1 0 1 0 1)

	      activeHelpKey: debugButton

	      tabable: true

	      model: debugSelectedFailure

	      initiallyDisabled: true

	      enableChannel: enableDebugButton

	    )

	   )

	)

      )

! !

!TestRunner class methodsFor:'opening'!

open

	^super open

!

openOnTestCase:aTestCaseSubclass

    "open the testrunner,let it switch to and execute a testcase"

    |runner|

    runner := self new.

    runner openAndWaitUntilVisible.

    "/ idx := runner scriptModel value indexOf:aTestCaseSubclass name.

    runner selectScriptNamed:aTestCaseSubclass name.

    "/ the test should be executed by the TestRunner process (not the caller)

    "/ in oder for CTRL-C and busyCursor to work correctly.

    "/ Therefore, push event instead of executing the test here.

    "/runner runTests

    runner enqueueMessage:#runTests.

    "

     self openOnTestCase:CompilerTest

     self openOnTestCase:ConstraintTests

    "

    "Modified: / 16-03-2019 / 14:20:22 / Claus Gittinger"

! !

!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'!

category

    |holder|

    (holder := builder bindingAt:#category) isNil ifTrue:[

	holder := '* all *' asValue.

	builder aspectAt:#category put:holder.

	holder onChangeSend:#categorySelectionChanged to:self.

    ].

    ^ holder.

!

categoryList

    ^categoryModel isNil

	ifTrue: [categoryModel := ValueHolder new. self updateCategoryList. categoryModel]

	ifFalse: [categoryModel]

!

defectMenu

    ^ 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]

!

percentageDone

    ^ builder valueAspectFor:#percentageDone initialValue:0

!

percentageIndicatorVisible

    ^ builder valueAspectFor:#percentageIndicatorVisible initialValue:false

!

script

    "automatically generated by UIPainter ..."

    <resource: #uiAspect>

    script isNil ifTrue:[

        script := ValueHolder new.

        script onChangeSend:#suiteSelectionChanged to:self.

    ].

    ^ script.

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

!

script:something

    builder aspectAt:#script put:something.

    "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 := ValueHolder new. self updateSuitesList. scriptModel]

	ifFalse: [scriptModel]

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

!

selection

	^defect

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

!

selectionHolder

    |holder|

    (holder := builder bindingAt:#selectionHolder) isNil ifTrue:[

	holder := AspectAdaptor new subject:self; forAspect:#selection.

	builder aspectAt:#selectionHolder put:holder.

    ].

    ^ 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'!

browseSelectedTestCase

    |testCaseName testCase browser defect singleCase|

    testCaseName := self selectedScript.

    testCaseName isNil ifTrue:[

        testCaseName := self tests contents.

        testCaseName notNil ifTrue:[

            testCaseName := testCaseName string

        ]

    ].

    testCaseName notNil ifTrue:[

        testCase := Smalltalk at:testCaseName asSymbol.

        testCase notNil ifTrue:[

            browser := testCase browserClass openInClass:testCase.

            MessageNotUnderstood

                handle:[:ex | ]

                do:[

                    (defect := self selection) notNil ifTrue:[

                        singleCase := allDefects at:defect ifAbsent: [nil].

                    ].

                    singleCase notNil ifTrue:[

                        browser switchToSelector:singleCase selector

                    ] ifFalse:[

                        browser selectProtocolsMatching:'test*'

                    ]

                ]

        ]

    ]

!

categorySelectionChanged

    |selectedScriptIndex selectedScript oldSuitesList newSuitesList

     newScriptSelectionIndex|

    selectedScriptIndex := self script value.

    oldSuitesList := self scriptModel value.

    (selectedScriptIndex notNil and:[selectedScriptIndex ~~0]) ifTrue:[

	selectedScript := (oldSuitesList at:selectedScriptIndex) string

    ].

    self updateSuitesList.

    newSuitesList := self scriptModel value.

    newScriptSelectionIndex := newSuitesList indexOf:selectedScript.

    self script value:(newScriptSelectionIndex == 0

			    ifTrue:[nil]

			    ifFalse:[newScriptSelectionIndex]).

!

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'.

    "/ defect := nil.

    self withWaitCursorDo:[

	((result isFailure: testCase) "or:[(result isError: testCase)]")

	    ifTrue: [testCase debugAsFailure]

	    ifFalse: [testCase debug].

    ].

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

!

enableDebugButton

    ^ builder valueAspectFor:#enableDebugButton initialValue:false

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

    "Modified: / 21.6.2000 / 10:51:07 / Sames"

!