"
 Copyright (c) 2007-2010 Jan Vrany, SWING Research Group, Czech Technical University in Prague
 Copyright (c) 2009-2010 eXept Software AG

 Permission is hereby granted, free of charge, to any person
 obtaining a copy of this software and associated documentation
 files (the 'Software'), to deal in the Software without
 restriction, including without limitation the rights to use,
 copy, modify, merge, publish, distribute, sublicense, and/or sell
 copies of the Software, and to permit persons to whom the
 Software is furnished to do so, subject to the following
 conditions:

 The above copyright notice and this permission notice shall be
 included in all copies or substantial portions of the Software.

 THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND,
 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
 OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
 HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
 FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
 OTHER DEALINGS IN THE SOFTWARE.
"
"{ Package: 'stx:libtool' }"

"{ NameSpace: Tools }"

AbstractTestRunner subclass:#TestRunnerEmbedded
	instanceVariableNames:'runnerPanel selectedClassesHolder selectedProtocolsHolder
		selectedMethodsHolder methodGeneratorHolder resultHolder
		resultInfoHolder resultBackgroundColorHolder runningHolder
		progressHolder progressIndicatorShownHolder infoHolder
		testProcess allTestCases'
	classVariableNames:''
	poolDictionaries:''
	category:'SUnit-UI'
!

Object subclass:#SuiteAndResult
	instanceVariableNames:'suite result'
	classVariableNames:''
	poolDictionaries:''
	privateIn:TestRunnerEmbedded
!

!TestRunnerEmbedded class methodsFor:'documentation'!

copyright
"
 Copyright (c) 2007-2010 Jan Vrany, SWING Research Group, Czech Technical University in Prague
 Copyright (c) 2009-2010 eXept Software AG

 Permission is hereby granted, free of charge, to any person
 obtaining a copy of this software and associated documentation
 files (the 'Software'), to deal in the Software without
 restriction, including without limitation the rights to use,
 copy, modify, merge, publish, distribute, sublicense, and/or sell
 copies of the Software, and to permit persons to whom the
 Software is furnished to do so, subject to the following
 conditions:

 The above copyright notice and this permission notice shall be
 included in all copies or substantial portions of the Software.

 THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND,
 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
 OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
 HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
 FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
 OTHER DEALINGS IN THE SOFTWARE.
"
!

documentation
"
    a tiny runner to be embedded in a system browser
"
! !

!TestRunnerEmbedded class methodsFor:'help specs'!

flyByHelpSpec
    "This resource specification was automatically generated
     by the UIHelpTool of ST/X."

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

    "
     UIHelpTool openOnClass:Tools::TestRunnerEmbedded    
    "

    <resource: #help>

    ^ super flyByHelpSpec addPairsFrom:#(

#debugSelected
'Run the selected test(s) with debugging enabled'

#runAll
'Run all tests'

#runFailed
'Only rerun failed tests'

#runSelected
'Run the selected test(s)'

#stopRun
'Stop the test-run'

)

    "Created: / 04-06-2012 / 19:27:47 / cg"
! !

!TestRunnerEmbedded 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:Tools::TestRunnerEmbedded andSelector:#windowSpec
     Tools::TestRunnerEmbedded new openInterface:#windowSpec
     Tools::TestRunnerEmbedded open
    "

    <resource: #canvas>

    ^ 
     #(FullSpec
        name: windowSpec
        window: 
       (WindowSpec
          label: 'Test Runner Embedded'
          name: 'Test Runner Embedded'
          min: (Point 10 10)
          bounds: (Rectangle 0 0 595 50)
        )
        component: 
       (SpecCollection
          collection: (
           (ViewSpec
              name: 'Runner'
              layout: (LayoutFrame 5 0 0 0 -5 1 0 1)
              backgroundChannel: resultBackgroundColorAspect
              component: 
             (SpecCollection
                collection: (
                 (HorizontalPanelViewSpec
                    name: 'RunnerInnerBox'
                    layout: (LayoutFrame 5 0 0 0 -5 1 0 1)
                    backgroundChannel: resultBackgroundColorAspect
                    horizontalLayout: rightSpaceFit
                    verticalLayout: center
                    horizontalSpace: 0
                    elementsChangeSize: true
                    component: 
                   (SpecCollection
                      collection: (
                       (ViewSpec
                          name: 'RunnerInfoBox'
                          backgroundChannel: resultBackgroundColorAspect
                          component: 
                         (SpecCollection
                            collection: (
                             (LabelSpec
                                label: 'Run tests first!!'
                                name: 'ResultName'
                                layout: (LayoutFrame 0 0 0 0 0 1 -10 1)
                                backgroundChannel: resultBackgroundColorAspect
                                foregroundColor: (Color 100.0 100.0 100.0)
                                translateLabel: true
                                labelChannel: resultNameAspect
                                adjust: left
                              )
                             (LabelSpec
                                name: 'ResultInfo'
                                layout: (LayoutFrame 0 0 -10 1 0 1 0 1)
                                style: (FontDescription helvetica medium roman 8 #'iso10646-1')
                                backgroundChannel: resultBackgroundColorAspect
                                foregroundColor: (Color 100.0 100.0 100.0)
                                translateLabel: true
                                labelChannel: resultInfoAspect
                                adjust: left
                              )
                             (ViewSpec
                                name: 'ProgressPanel'
                                layout: (LayoutFrame 0 0 0 0 0 1 0 1)
                                visibilityChannel: progressIndicatorShownHolder
                                backgroundChannel: resultBackgroundColorAspect
                                component: 
                               (SpecCollection
                                  collection: (
                                   (ProgressIndicatorSpec
                                      name: 'RunningProgress'
                                      layout: (LayoutFrame 5 0 -10 0.5 -5 1 10 0.5)
                                      model: progressHolder
                                    )
                                   )
                                 
                                )
                              )
                             )
                           
                          )
                          extent: (Point 276 30)
                        )
                       (ActionButtonSpec
                          label: 'Debug'
                          name: 'DebugButton'
                          activeHelpKey: debugSelected
                          translateLabel: true
                          model: debug
                          enableChannel: runEnabledHolder
                          extent: (Point 60 25)
                        )
                       (ActionButtonSpec
                          label: 'Stop'
                          name: 'Button2'
                          activeHelpKey: stopRun
                          visibilityChannel: runningHolder
                          translateLabel: true
                          model: stop
                          extent: (Point 60 25)
                        )
                       (ActionButtonSpec
                          label: 'Run'
                          name: 'Run'
                          activeHelpKey: runSelected
                          visibilityChannel: notRunningHolder
                          translateLabel: true
                          model: run
                          enableChannel: runEnabledHolder
                          extent: (Point 60 25)
                        )
                       (ActionButtonSpec
                          label: 'Run Failed'
                          name: 'Button1'
                          activeHelpKey: runFailed
                          translateLabel: true
                          model: runFailed
                          enableChannel: runFailedEnabledHolder
                          extent: (Point 60 25)
                        )
                       (ActionButtonSpec
                          label: 'Run all'
                          name: 'RunAll'
                          activeHelpKey: runAll
                          translateLabel: true
                          model: runAll
                          enableChannel: runAllEnabledHolder
                          extent: (Point 60 25)
                        )
                       )
                     
                    )
                    postBuildCallback: postBuildRunnerPanel:
                  )
                 )
               
              )
            )
           )
         
        )
      )

! !

!TestRunnerEmbedded 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)."

    ^ #(
        #methodGeneratorHolder
        #selectedClassesHolder
        #selectedMethodsHolder
        #selectedProtocolsHolder
      ).

! !

!TestRunnerEmbedded methodsFor:'accessing'!

allTestCases
    allTestCases isNil ifTrue:[
        self updateTestCases
    ].
    ^ allTestCases
!

infoHolder:something
    "to show something in the browsers info area (near the bottom"

    infoHolder := something.

    "Created: / 05-07-2011 / 16:22:24 / cg"
!

invalidateAllTestCases
    allTestCases := nil
!

selectedTestMethods

    | selectedClass |
    selectedClass := self theSingleTestCase.

    ^ (self selectedMethodsHolder value ? #()) select:
            [:mthd | | cls |
            (cls := selectedClass) isNil ifTrue:[cls := mthd mclass].
            (self isTestCaseLike:selectedClass) 
                and:[ selectedClass isTestSelector:mthd selector ] ]

    "Created: / 15-03-2010 / 13:21:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 22-07-2011 / 15:46:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 02-08-2011 / 17:46:38 / cg"
!

selectedTestMethodsFromProtocols:protocols 

    |methods generator selectedClass|

    methods := Set new.
    generator := self methodGeneratorHolder value.
    selectedClass := self theSingleTestCase.

    generator notNil ifTrue:[ 
        generator do: [:cls :cat :sel :mthd | 
            (mthd notNil 
                and:[ (self isTestCaseLike:(selectedClass ? cls)) 
                and:[ (selectedClass ? cls) isTestSelector:sel ] ]) 
            ifTrue:[ methods add:mthd ] 
        ] 
    ] ifFalse:[
        allTestCases do: [:cls | 
            cls methodsDo: [:mthd | 
                ((protocols includes:mthd category) and:[ cls isTestSelector:mthd selector ]) 
                ifTrue:[ 
                    methods add:mthd 
                ] 
            ] 
        ] 
    ].
    ^ methods

    "Created: / 15-03-2010 / 19:50:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 22-07-2011 / 15:53:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified (format): / 04-06-2012 / 19:05:32 / cg"
!

selectedTestMethodsFromProtocols:protocols inClass:aTestClass

    |methods generator|

    methods := Set new.
    generator := self methodGeneratorHolder value.

    generator notNil ifTrue:[ 
        generator do: [:cls :cat :sel :mthd | 
            (mthd notNil 
                and:[ (self isTestCaseLike:(aTestClass ? cls)) 
                and:[ (aTestClass ? cls) isTestSelector:sel ] ]) 
            ifTrue:[ methods add:mthd ] 
        ] 
    ] ifFalse:[
        self allTestCases do: [:cls | 
            cls methodsDo: [:mthd | 
                ((protocols includes:mthd category) and:[ cls isTestSelector:mthd selector ]) 
                ifTrue:[ 
                    methods add:mthd 
                ] 
            ] 
        ] 
    ].
    ^ methods

    "Created: / 15-03-2010 / 19:50:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 22-07-2011 / 15:53:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified (format): / 04-06-2012 / 19:05:32 / cg"
!

selectedTestMethodsInClass:testClass
    ^ (self selectedMethodsHolder value ? #()) select:
            [:mthd | | cls |
            (cls := testClass) isNil ifTrue:[cls := mthd mclass].
            (self isTestCaseLike:testClass) 
                and:[ testClass isTestSelector:mthd selector ] ]

    "Created: / 15-03-2010 / 13:21:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 22-07-2011 / 15:46:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 02-08-2011 / 17:46:38 / cg"
!

theSingleTestCase

    self allTestCases isEmptyOrNil ifTrue:[^nil].
    allTestCases size > 1 ifTrue:[^nil].

    ^allTestCases anyOne.

    "Created: / 22-07-2011 / 15:44:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestRunnerEmbedded methodsFor:'actions'!

debug
    | suiteAndResult suite result | 

    suiteAndResult := self resultHolder value.
    suite := suiteAndResult suiteForRun.
    "/ suite tests size ~= 1 ifTrue:[^self breakPoint: #jv].
    "/ test := suiteAndResult suite tests anyOne.

    self stop.

    "/ debug run is synchronous
    [
        self runningHolder value:true.

        suite tests do:[:test |
            [
                test debug. 
            ] on: AbortAllOperationRequest do:[:ex|].
            (test class testSelectorPassed:test selector) ifTrue:[
                result := TestResult defaultResultClass new.
                result passed add: test.
                suiteAndResult := SuiteAndResult suite: suite result: result.       
                self resultHolder value:suiteAndResult.    
            ].
        ].
    ] ensure:[
        self runningHolder value:false.
    ].

    "Created: / 15-03-2010 / 15:43:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 07-07-2011 / 11:33:48 / Jan Vrany <jan.vrant@fit.cvut,cz>"
    "Modified: / 04-06-2012 / 19:46:38 / cg"
    "Modified: / 03-12-2012 / 14:02:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

run
    |suite|

    resultHolder value isNil ifTrue:[
        suite := self suiteForRun
    ] ifFalse:[
        suite := resultHolder value suiteForRun
    ].
    self run:suite

    "Created: / 10-03-2010 / 19:42:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 22-08-2011 / 09:58:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 09-10-2011 / 10:56:39 / cg"
!

run:suite 
    ^self run: suite debug: false

    "Created: / 11-03-2010 / 10:22:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 09-06-2012 / 20:23:58 / cg"
    "Modified: / 03-12-2012 / 13:59:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

run:suite debug: debug 
    |suiteAndResult numTests|

    numTests := suite tests size.
    numTests == 0 ifTrue:[
        ^ self
    ].

    self stop.

    testProcess := [
                |result incr run|

                result := debug ifFalse:[TestResult new] ifTrue:[TestResultForRunWithDebug].
                [
                    self runningHolder value:true.
                    self progressIndicatorShownHolder value:(numTests > 1).
                    self progressHolder value:0.
                    incr := 100 / numTests.
                    run := 0.
                    result := suite 
                                run: result
                                beforeEachDo:[:test :result |
                                    infoHolder notNil ifTrue:[
                                        infoHolder value:('Running "%1-%2"...' 
                                                        bindWith:test name
                                                        with:test getTestName allBold)
                                    ]
                                ]
                                afterEachDo:[:test :result | 
                                    run := run + 1.
                                    self progressHolder value:(incr * run) truncated "rounded".
                                    infoHolder notNil ifTrue:[
                                        infoHolder value:('Done.')
                                    ]
                                ]
                                debug: debug.
                    suiteAndResult := SuiteAndResult suite:suite result:result.
                ] ensure:[
                    self progressIndicatorShownHolder value:false.
                    self resultHolder value:suiteAndResult.
                    self runningHolder value:false.
                ]
            ] newProcess.

    testProcess priority:(Processor userBackgroundPriority).
    testProcess resume.

    "Created: / 03-12-2012 / 13:59:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

runAll

    self run: (self suiteForRunAll).

    "Created: / 10-03-2010 / 19:42:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 13:12:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 19:00:14 / cg"
!

runFailed
    self run: self suiteForRunFailed.

    "Created: / 04-06-2012 / 18:32:19 / cg"
!

runWithDebug
    "/ cg: I really do not want to run them twice to get a debugger 
    "/ - I want to run them either with a debugger coming right away, or not.

    | suiteAndResult suite|

    suiteAndResult := self resultHolder value.
    suiteAndResult isNil ifTrue:[
        suite := self suiteForRun.
    ] ifFalse:[
        suite := suiteAndResult suiteForRun.
    ].

    self run: suite debug: true



    "/ suiteAndResult suite tests size ~= 1 ifTrue:[^self breakPoint: #jv].
    "/ [suiteAndResult suite tests anyOne debug] fork

    "Created: / 05-07-2011 / 18:45:43 / cg"
    "Modified: / 09-10-2011 / 10:55:46 / cg"
    "Modified: / 03-12-2012 / 13:59:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

stop
    |p|

    (p := testProcess) notNil ifTrue:[
        testProcess := nil.
        p terminate
    ].

    "Created: / 04-06-2012 / 18:34:07 / cg"
! !

!TestRunnerEmbedded methodsFor:'aspects'!

debugVisibleAspect
    ^ BlockValue 
        with:[:model | 
            model notNil
            and:[ model testCount == 1 
            and:[ model hasFailuresOrErrors ]]
        ]
        argument:self resultHolder

    "Created: / 15-03-2010 / 15:40:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 02-08-2011 / 18:19:14 / cg"
!

methodGeneratorHolder
    "return/create the 'methodGeneratorHolder' value holder (automatically generated)"

    methodGeneratorHolder isNil ifTrue:[
        methodGeneratorHolder := ValueHolder new.
        methodGeneratorHolder addDependent:self.
    ].
    ^ methodGeneratorHolder
!

methodGeneratorHolder:something
    "set the 'methodGeneratorHolder' value holder (automatically generated)"

    |oldValue newValue|

    methodGeneratorHolder notNil ifTrue:[
        oldValue := methodGeneratorHolder value.
        methodGeneratorHolder removeDependent:self.
    ].
    methodGeneratorHolder := something.
    methodGeneratorHolder notNil ifTrue:[
        methodGeneratorHolder addDependent:self.
    ].
    newValue := methodGeneratorHolder value.
    oldValue ~~ newValue ifTrue:[
        self update:#value with:newValue from:methodGeneratorHolder.
    ].
!

notRunningHolder
    ^ BlockValue forLogicalNot:(self runningHolder)

    "Created: / 04-06-2012 / 18:38:48 / cg"
!

progressHolder
    "return/create the 'progressHolder' value holder (automatically generated)"

    progressHolder isNil ifTrue:[
        progressHolder := ValueHolder new.
    ].
    ^ progressHolder
!

progressIndicatorShownHolder
    progressIndicatorShownHolder isNil ifTrue:[
        progressIndicatorShownHolder := ValueHolder with: false.
    ].
    ^ progressIndicatorShownHolder

    "Modified: / 15-03-2010 / 20:29:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified (comment): / 04-06-2012 / 18:38:52 / cg"
    "Created: / 04-06-2012 / 19:42:59 / cg"
!

resultBackgroundColorAspect
    <resource: #uiAspect>
    resultBackgroundColorHolder isNil ifTrue:[
        resultBackgroundColorHolder := BlockValue 
                    with:[:result :running | 
                        running ifTrue:[
                            self class currentlyRunningColor "/ View defaultBackgroundColor
                        ] ifFalse:[
                            result ifNil:[ self class notRunColor ] ifNotNil:[ result color ]
                        ].
                    ]
                    argument:self resultHolder
                    argument:self runningHolder.
        resultBackgroundColorHolder 
            onChangeEvaluate:[
                runnerPanel 
                    ifNotNil:[ runnerPanel backgroundColor:resultBackgroundColorHolder value ]
            ].
    ].
    ^ resultBackgroundColorHolder.

    "Created: / 15-03-2010 / 15:22:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 21:02:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 19:40:11 / cg"
!

resultHolder
    "return/create the 'resultHolder' value holder (automatically generated)"

    resultHolder isNil ifTrue:[
        resultHolder := ValueHolder new.
    ].
    ^ resultHolder
!

resultInfoAspect
    ^ BlockValue 
        with:[:model | model isNil ifTrue:[ '' ] ifFalse:[ model info ] ]
        argument:self resultHolder

    "Created: / 15-03-2010 / 20:22:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 02-08-2011 / 18:20:26 / cg"
!

resultNameAspect
    ^ BlockValue 
        with:[:model | model isNil ifTrue:[ 'Run the tests!!' ] ifFalse:[ model name ] ]
        argument:self resultHolder

    "Created: / 15-03-2010 / 14:57:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 20:17:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 02-08-2011 / 18:20:38 / cg"
!

runAllEnabledHolder

    ^ self notRunningHolder

    "Created: / 07-09-2010 / 09:15:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 18:40:46 / cg"
!

runEnabledHolder
    ^BlockValue
        with:
            [:result :running | 

            running not
            and:[ result notNil 
            and:[ result testCount > 0 ]]
        ]
        argument: self resultHolder
        argument: self runningHolder

    "Created: / 07-09-2010 / 09:15:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 18:52:41 / cg"
!

runFailedEnabledHolder
    ^BlockValue
        with:
            [:running | 

            |result|

            running not
            and:[ TestResult notNil 
            and:[ TestResult isLoaded
            and:[ result := self resultForSuite:self suiteForRunAll. result notNil 
            and:[ result hasFailuresOrErrors ]]]]
        ]
        "/ argument: self resultHolder
        argument: self runningHolder

    "Created: / 07-09-2010 / 09:15:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Created: / 04-06-2012 / 18:28:12 / cg"
    "Modified: / 18-07-2012 / 09:55:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

runningHolder
    runningHolder isNil ifTrue:[
        runningHolder := ValueHolder with: false.
    ].
    ^ runningHolder

    "Modified: / 15-03-2010 / 20:29:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified (comment): / 04-06-2012 / 18:38:52 / cg"
!

selectedClassesHolder
    "return/create the 'selectedClassesHolder' value holder (automatically generated)"

    selectedClassesHolder isNil ifTrue:[
        selectedClassesHolder := ValueHolder new.
        selectedClassesHolder addDependent:self.
    ].
    ^ selectedClassesHolder
!

selectedClassesHolder:something
    "set the 'selectedClassesHolder' value holder (automatically generated)"

    |oldValue newValue|

    selectedClassesHolder notNil ifTrue:[
        oldValue := selectedClassesHolder value.
        selectedClassesHolder removeDependent:self.
    ].
    selectedClassesHolder := something.
    selectedClassesHolder notNil ifTrue:[
        selectedClassesHolder addDependent:self.
    ].
    newValue := selectedClassesHolder value.
    oldValue ~~ newValue ifTrue:[
        self update:#value with:newValue from:selectedClassesHolder.
    ].
!

selectedMethodsHolder
    "return/create the 'selectedMethodsHolder' value holder (automatically generated)"

    selectedMethodsHolder isNil ifTrue:[
        selectedMethodsHolder := ValueHolder new.
        selectedMethodsHolder addDependent:self.
    ].
    ^ selectedMethodsHolder
!

selectedMethodsHolder:something
    "set the 'selectedMethodsHolder' value holder (automatically generated)"

    |oldValue newValue|

    selectedMethodsHolder notNil ifTrue:[
        oldValue := selectedMethodsHolder value.
        selectedMethodsHolder removeDependent:self.
    ].
    selectedMethodsHolder := something.
    selectedMethodsHolder notNil ifTrue:[
        selectedMethodsHolder addDependent:self.
    ].
    newValue := selectedMethodsHolder value.
    oldValue ~~ newValue ifTrue:[
        self update:#value with:newValue from:selectedMethodsHolder.
    ].
!

selectedProtocolsHolder
    "return/create the 'selectedProtocolsHolder' value holder (automatically generated)"

    selectedProtocolsHolder isNil ifTrue:[
        selectedProtocolsHolder := ValueHolder new.
        selectedProtocolsHolder addDependent:self.
    ].
    ^ selectedProtocolsHolder
!

selectedProtocolsHolder:something
    "set the 'selectedProtocolsHolder' value holder (automatically generated)"

    |oldValue newValue|

    selectedProtocolsHolder notNil ifTrue:[
        oldValue := selectedProtocolsHolder value.
        selectedProtocolsHolder removeDependent:self.
    ].
    selectedProtocolsHolder := something.
    selectedProtocolsHolder notNil ifTrue:[
        selectedProtocolsHolder addDependent:self.
    ].
    newValue := selectedProtocolsHolder value.
    oldValue ~~ newValue ifTrue:[
        self update:#value with:newValue from:selectedProtocolsHolder.
    ].
!

stopEnabledHolder
    ^ self runningHolder

    "Created: / 04-06-2012 / 18:29:01 / cg"
! !

!TestRunnerEmbedded methodsFor:'change & update'!

invalidateSuiteAndResult
    self resultHolder value:nil.
!

invalidateTestCases
    allTestCases := nil.
!

update:aspect with:param from: sender
    "Invoked when an object that I depend upon sends a change notification."

    sender == selectedClassesHolder ifTrue:[
        self 
            invalidateTestCases;      "/ updateTestSuite;
            invalidateSuiteAndResult; "/ updateTestSuiteAndResult;
            updateVisibility.
        self enqueueDelayedAction:[ self updateTestCases; updateSuiteAndResult ].
         ^ self.
    ].
    sender == selectedProtocolsHolder ifTrue:[
        self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.
        self enqueueDelayedAction:[ self updateSuiteAndResult ].
        ^self
    ].

    sender == selectedMethodsHolder ifTrue:[
        self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.
        self enqueueDelayedAction:[ self updateSuiteAndResult ].
        ^self
    ].
    sender == methodGeneratorHolder ifTrue:[
        self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.
        self enqueueDelayedAction:[ self updateSuiteAndResult ].
        ^self
    ].

    sender == Smalltalk ifTrue:[
        aspect == #lastTestRunResult ifTrue:[
            allTestCases notNil ifTrue:[
                (allTestCases includesIdentical: param first) ifTrue:[
                    self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.
                    self enqueueDelayedAction:[ self updateSuiteAndResult ].
                    ^self        
                ]
            ].
        ]        
    ].



    super update:aspect with:param from: sender

    "Modified: / 20-11-2011 / 12:40:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 19:03:34 / cg"
!

updateSuiteAndResult
    | suite suiteAndResult |

    self runningHolder value ifTrue:[^self].
    self allTestCases isEmptyOrNil ifTrue:[^self].

    suiteAndResult := SuiteAndResult
                        suite:  (suite := self suiteForRun)
                        result: (self resultForSuite: suite).
    self resultHolder value: suiteAndResult.

    "Created: / 15-03-2010 / 19:41:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 20:55:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 19:03:15 / cg"
!

updateTestCases
    allTestCases := ((self selectedClassesHolder value ? #()) 
                select:[:cls | self isTestCaseLike:cls ]).
    allTestCases := allTestCases asArray

    "Created: / 11-03-2010 / 10:31:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 24-01-2012 / 22:09:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 19:02:52 / cg"
!

updateTestSuiteAndResult

    | suite suiteAndResult |
    self runningHolder value ifTrue:[^self].
    allTestCases isEmptyOrNil ifTrue:[^self].
    suiteAndResult := SuiteAndResult
                        suite:  (suite := self suiteForRun)
                        result: (self resultForSuite: suite).
    self resultHolder value: suiteAndResult.

    "Created: / 15-03-2010 / 19:41:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 20:55:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 19:03:15 / cg"
!

updateVisibility

    self hasTestCaseSelected 
        ifTrue:[self show]
        ifFalse:[self hide]

    "Created: / 11-03-2010 / 09:02:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestRunnerEmbedded methodsFor:'hooks'!

commonPostOpen

    Smalltalk addDependent: self.

    "Created: / 17-11-2011 / 20:59:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

postBuildRunnerPanel: aView

    runnerPanel := aView.
    runnerPanel backgroundColor: self resultBackgroundColorAspect value

    "Created: / 15-03-2010 / 14:26:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

releaseAsSubCanvas

    Smalltalk removeDependent: self.

    "Created: / 17-11-2011 / 21:03:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestRunnerEmbedded methodsFor:'private'!

hide

    self visibility: false height: 0

    "Created: / 11-03-2010 / 09:07:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

isTestCaseLike:cls 

    ^(super isTestCaseLike: cls) and:
        [(cls askFor: #isAbstract) not]

    "Modified: / 04-03-2011 / 06:54:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

show

    self visibility: true height: 50

    "Created: / 11-03-2010 / 09:07:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visibility:visibility height:height 
    |container list h|

    (container := self window container) ifNil:[ ^ self ].
    h := visibility ifFalse:[0] ifTrue:[ height ].
    container isVisible == visibility ifFalse:[
        container isVisible:visibility
    ].
    list := container container subViews first.
    (list layout bottomOffset ~= height negated) ifTrue:[
        list layout:((list layout)
                    bottomOffset:height negated;
                    yourself)
    ].

    "Created: / 11-03-2010 / 09:51:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestRunnerEmbedded methodsFor:'queries'!

hasTestCaseSelected

    ^self allTestCases notEmptyOrNil

    "Created: / 11-03-2010 / 09:06:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 20:54:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-08-2011 / 20:42:10 / cg"
! !

!TestRunnerEmbedded methodsFor:'utilities'!

resultForSuite:suite 
    |result|

    result := TestResult defaultResultClass new.
    suite tests do:[:test |
        | sel cls |

        sel := test selector.
        cls := test class.
        (cls testSelectorPassed:sel) ifTrue:[
            result passedOutcomes add: (cls rememberedOutcomeFor: sel)
        ] ifFalse:[
            (cls testSelectorError:sel) ifTrue:[
                result errorOutcomes add:(cls rememberedOutcomeFor: sel)
            ] ifFalse:[
                (cls testSelectorFailed:sel) ifTrue:[
                    result failureOutcomes add:(cls rememberedOutcomeFor: sel)
                ]
            ]
        ]
    ].
    ^ result

    "Created: / 15-03-2010 / 19:46:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 02-08-2011 / 18:20:00 / cg"
    "Modified: / 20-08-2011 / 14:30:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

suiteForRun
    | methods testMethods protocols suite selectedClass |

    selectedClass := self theSingleTestCase.

    (methods := selectedMethodsHolder value) notEmptyOrNil ifTrue:[
        testMethods := self selectedTestMethods.
        suite := TestSuite named: (self suiteNameFromMethods: testMethods).
        testMethods do:[:mthd| 
            | class selector |
            class := selectedClass ifNil:[mthd mclass].
            suite addTest: (class asTestCase selector: mthd selector)
        ].
        ^suite
    ].
    
    (protocols := selectedProtocolsHolder value) isEmptyOrNil ifFalse:[
        suite := TestSuite named: (self suiteNameFromProtocols: protocols).
        (self selectedTestMethodsFromProtocols: protocols inClass:selectedClass) do:[:mthd| 
            | class selector |
            class := selectedClass ifNil:[mthd mclass].           
            suite addTest: (mthd mclass asTestCase selector: mthd selector)
        ].
        ^suite
    ].

    ^self suiteForRunAll

    "Created: / 15-03-2010 / 13:13:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-08-2011 / 19:06:42 / cg"
    "Modified: / 02-11-2012 / 11:17:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

suiteForRunAll
    |suite|

    allTestCases isNil ifTrue:[
        self updateTestCases.
    ].
    suite := TestSuite named:(self suiteNameFromClasses: self allTestCases).

    allTestCases do:[:testCase | 
        suite addTests:(self buildSuiteFromClass:testCase) tests
    ].
    ^suite

    "Modified: / 04-03-2011 / 06:57:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2012 / 19:01:48 / cg"
!

suiteForRunFailed
    |suite|

    suite := TestSuite named:(self suiteNameFromClasses: self allTestCases).
    self allTestCases do:[:testCase |
        (self buildSuiteFromClass:testCase) tests do:[:eachTest |
            | sel cls |

            sel := eachTest selector.
            cls := eachTest class.
            (cls testSelectorPassed:sel) ifFalse:[
                suite addTest:eachTest
            ]
        ]
    ].
    ^suite

    "Modified: / 04-03-2011 / 06:57:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Created: / 04-06-2012 / 18:32:40 / cg"
! !

!TestRunnerEmbedded::SuiteAndResult class methodsFor:'instance creation'!

suite: suite result: result

    ^self new
        suite: suite;
        result: result.

    "Modified: / 15-03-2010 / 15:27:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestRunnerEmbedded::SuiteAndResult methodsFor:'accessing'!

color

    self testCount == 0 ifTrue:
        [^TestRunnerEmbedded notRunColor].

    result ifNil:[^TestRunnerEmbedded notRunColor].
    self hasErrors ifTrue:[^TestRunnerEmbedded errorColor].
    self hasFailures ifTrue:[^TestRunnerEmbedded failedColor].
    self hasPassed ifTrue:[^TestRunnerEmbedded passedColor].
    ^TestRunnerEmbedded notRunColor

    "Created: / 15-03-2010 / 15:24:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 07-09-2010 / 08:25:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

info

    result ifNil:[^''].
    (result passedCount + result failureCount + result errorCount) = 1 ifTrue:[^''].
    ^'%1 tests, %2 passed, %3 failed, %4 errors'
        bindWith: suite tests size
            with: result passedCount        
            with: result failureCount 
            with: result errorCount

    "Created: / 15-03-2010 / 20:23:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

name

    ^suite name

    "Created: / 15-03-2010 / 15:12:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

result
    ^ result
!

result:aTestResult
    result := aTestResult.
!

suite
    ^ suite
!

suite:aTestSuite
    suite := aTestSuite.
!

suiteForRun

    | suiteForRun |
    suiteForRun := suite class named: suite name.
    suiteForRun addTests:
        (suite tests collect:[:testCase|testCase class selector: testCase selector]).
    ^suiteForRun

    "Created: / 22-08-2011 / 09:56:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

testCount

    ^suite tests size

    "Created: / 15-03-2010 / 15:44:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestRunnerEmbedded::SuiteAndResult methodsFor:'queries'!

hasErrors

    ^result errorCount > 0

    "Created: / 15-03-2010 / 15:21:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

hasFailures

    ^result failureCount > 0

    "Created: / 15-03-2010 / 15:21:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

hasFailuresOrErrors

    ^self hasErrors or:[self hasFailures]

    "Created: / 15-03-2010 / 15:45:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

hasPassed

    ^result passedCount > 0

    "Created: / 15-03-2010 / 22:06:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestRunnerEmbedded class methodsFor:'documentation'!

version
    ^ '$Id: Tools__TestRunnerEmbedded.st 8076 2012-12-03 16:22:00Z vranyj1 $'
!

version_CVS
    ^ '§Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.32 2012/11/08 00:05:16 cg Exp §'
!

version_SVN
    ^ '$Id: Tools__TestRunnerEmbedded.st 8076 2012-12-03 16:22:00Z vranyj1 $'
! !