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

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

"

    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 green darkened

!

defaultIcon

    <resource: #programImage>

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

    ^ ToolbarIconLibrary sUnit28x28Icon

! !

!TestRunner class methodsFor:'interface specs'!

flyByHelpSpec

    <resource: #help>

    ^super flyByHelpSpec 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 for:runner arguments:nil.

    "

     self openOnTestCase:CompilerTest

     self openOnTestCase:ConstraintTests

    "

! !

!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

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

!

percentageDone

!

percentageIndicatorVisible

!

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

    script isNil ifTrue:[

        script := ValueHolder new.

        script onChangeSend:#suiteSelectionChanged to:self.

    ].

    ^ script.

    "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 := 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 := UserPreferences current systemBrowserClass 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 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].

    ].