"
 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 selectedTestCases selectedClassesHolder
		selectedProtocolsHolder selectedMethodsHolder
		methodGeneratorHolder resultHolder resultInfoHolder
		resultBackgroundColorHolder runningHolder progressHolder
		infoHolder'
	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:'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 350 50)
        )
        component: 
       (SpecCollection
          collection: (
           (VerticalPanelViewSpec
              name: 'Runners'
              layout: (LayoutFrame 5 0 0 0 -5 1 0 1)
              horizontalLayout: fit
              verticalLayout: topSpaceFit
              horizontalSpace: 0
              verticalSpace: 5
              elementsChangeSize: true
              component: 
             (SpecCollection
                collection: (
                 (ViewSpec
                    name: 'Runner'
                    backgroundChannel: resultBackgroundColorAspect
                    component: 
                   (SpecCollection
                      collection: (
                       (HorizontalPanelViewSpec
                          name: 'RunnerInnerBox'
                          layout: (LayoutFrame 5 0 0 0 -5 1 0 1)
                          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)
                                      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: runningHolder
                                      backgroundChannel: resultBackgroundColorAspect
                                      component: 
                                     (SpecCollection
                                        collection: (
                                         (ProgressIndicatorSpec
                                            name: 'RunningProgress'
                                            layout: (LayoutFrame 5 0 -10 0.5 -5 1 10 0.5)
                                            model: progressHolder
                                          )
                                         )
                                       
                                      )
                                    )
                                   )
                                 
                                )
                                extent: (Point 151 30)
                              )
                             (ActionButtonSpec
                                label: 'Debug'
                                name: 'DebugButton'
                                initiallyInvisible: true
                                visibilityChannel: debugVisibleAspect
                                translateLabel: true
                                model: debug
                                extent: (Point 60 25)
                              )
                             (ActionButtonSpec
                                label: 'Run'
                                name: 'Run'
                                translateLabel: true
                                model: run
                                enableChannel: runEnabledHolder
                                extent: (Point 60 25)
                              )
                             (ActionButtonSpec
                                label: 'Run all'
                                name: 'RunAll'
                                translateLabel: true
                                model: runAll
                                enableChannel: runAllEnabledHolder
                                extent: (Point 60 25)
                              )
                             )
                           
                          )
                          postBuildCallback: postBuildRunnerPanel:
                        )
                       )
                     
                    )
                    extent: (Point 340 40)
                  )
                 )
               
              )
            )
           )
         
        )
      )

! !

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

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

    infoHolder := something.

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

selectedTestMethods
    ^ (self selectedMethodsHolder value ? #()) select:
            [:mthd | 
            (self isTestCaseLike:mthd mclass) 
                and:[ mthd mclass isTestSelector:mthd selector ] ]

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

selectedTestMethodsFromProtocols:protocols 
    |methods generator|

    methods := Set new.
    generator := self methodGeneratorHolder value.
    generator ifNotNil:
            [ generator do:
                    [:cls :cat :sel :mthd | 
                    (mthd notNil 
                        and:[ (self isTestCaseLike:cls) and:[ cls isTestSelector:sel ] ]) 
                            ifTrue:[ methods add:mthd ] ] ]
        ifNil:
            [ selectedTestCases 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: / 07-09-2010 / 08:29:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestRunnerEmbedded methodsFor:'actions'!

debug

    | suiteAndResult suite test result | 
    suiteAndResult := self resultHolder value.
    suite := suiteAndResult suite.
    suite tests size ~= 1 ifTrue:[^self breakPoint: #jv].
    test := suiteAndResult suite tests anyOne.
    [
         test debug.
         (test class testSelectorPassed:test selector) ifTrue:[
            result := TestResult new.
            result passed add: test.
            suiteAndResult := SuiteAndResult suite: suite result: result.       
            self resultHolder value:suiteAndResult.    
         ].            
    ] fork

    "Created: / 15-03-2010 / 15:43:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 20:09:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 05-07-2011 / 19:05:31 / cg"
    "Modified: / 07-07-2011 / 11:33:48 / Jan Vrany <jan.vrant@fit.cvut,cz>"
!

run

    self run:  resultHolder value suite

    "Created: / 10-03-2010 / 19:42:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 20:00:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

run:suite 
    |process suiteAndResult numTests|

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

    process := [
                |result incr run|

                [
                    self progressHolder value:0.
                    self runningHolder value:true.
                    incr := 100 / numTests.
                    run := 0.
                    result := suite 
                                runBeforeEachDo:[: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.')
                                    ]
                                ].
                    suiteAndResult := SuiteAndResult suite:suite result:result.
                ] ensure:[
                    self resultHolder value:suiteAndResult.
                    self runningHolder value:false.
                ]
            ] newProcess.
    process resume.

    "Created: / 11-03-2010 / 10:22:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-09-2010 / 21:48:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-07-2011 / 14:28:02 / cg"
!

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

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 result|

    suiteAndResult := self resultHolder value.
    suite := suiteAndResult suite.
    result := suiteAndResult result.

    suite tests do:[:each | 
        |errorHappened failureHappened cls|

        errorHappened := failureHappened := false.
        GenericException 
            handle:[:ex | 
                (HaltInterrupt accepts:ex signal) ifFalse:[
                    ex signal == NoHandlerError ifFalse:[
                        (TestFailure accepts:ex signal) ifTrue:[
                            failureHappened := true
                        ] ifFalse:[
                            errorHappened := true.
                        ].
                    ]
                ].
                ex reject.
            ]
            do:[ 
                infoHolder notNil ifTrue:[
                    infoHolder value:('Running "%1-%2"...' 
                                    bindWith:each name
                                    with:each getTestName allBold)
                ].
                each debug. 
                infoHolder notNil ifTrue:[
                    infoHolder value:('Done.')
                ]
            ].

        result failures remove:each ifAbsent:[].
        result passed remove:each ifAbsent:[].
        result errors remove:each ifAbsent:[].

        failureHappened ifTrue:[
            each class rememberErrorTest:each selector.
            result errors add:each.
        ] ifFalse:[
            errorHappened ifTrue:[
                each class rememberFailedTest:each selector.
                result failures add:each.
            ] ifFalse:[
                each class rememberPassedTest:each selector.
                result passed add:each.
            ]
        ]
    ]

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

    "Modified: / 15-03-2010 / 20:09:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Created: / 05-07-2011 / 18:45:43 / cg"
! !

!TestRunnerEmbedded methodsFor:'aspects'!

debugVisibleAspect

    ^BlockValue
        with: 
            [:model|
            model 
                ifNil:[false]
                ifNotNil:[model testCount == 1 and:[model hasFailuresOrErrors]]]
        argument:
            self resultHolder

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

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.
    ].
!

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

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

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 (comment): / 05-07-2011 / 14:13:30 / cg"
!

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

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

resultInfoAspect

    ^BlockValue
        with: 
            [:model|
            model 
                ifNil:['']
                ifNotNil:[model info]]
        argument:
            self resultHolder

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

resultNameAspect

    ^BlockValue
        with: 
            [:model|
            model 
                ifNil:['Run the tests!!']
                ifNotNil:[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>"
!

runAllEnabledHolder

    ^true

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

runEnabledHolder

    ^BlockValue
        with:
            [:resultHolder | | result | 
            (result := resultHolder value) notNil and:[result testCount > 0 ]]
        argument: self resultHolder

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

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

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

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

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.
    ].
! !

!TestRunnerEmbedded methodsFor:'change & update'!

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

    sender == selectedClassesHolder ifTrue:[
        self 
            updateTestCases;
            updateTestSuiteAndResult;
            updateVisibility.
         ^ self.
    ].
    sender == selectedProtocolsHolder ifTrue:[
        self updateTestSuiteAndResult.
        ^self
    ].

    sender == selectedMethodsHolder ifTrue:[
        self updateTestSuiteAndResult.
        ^self
    ].
    sender == methodGeneratorHolder ifTrue:[
        self updateTestSuiteAndResult.
        ^self
    ].



    super update:aspect with:param from: sender

    "Modified: / 07-09-2010 / 08:18:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

updateTestCases
    selectedTestCases := (self selectedClassesHolder value 
                select:[:cls | self isTestCaseLike:cls ]).
    selectedTestCases := selectedTestCases isEmpty 
                ifTrue:[ nil ]
                ifFalse:[ selectedTestCases asArray ]

    "Created: / 11-03-2010 / 10:31:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-03-2010 / 20:53:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

updateTestSuiteAndResult

    | suite suiteAndResult |
    self runningHolder value ifTrue:[^self].
    selectedTestCases ifNil:[^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>"
!

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

postBuildRunnerPanel: aView

    runnerPanel := aView.
    runnerPanel backgroundColor: self resultBackgroundColorAspect value

    "Created: / 15-03-2010 / 14:26:15 / 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

    ^selectedTestCases isNilOrEmptyCollection not

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

!TestRunnerEmbedded methodsFor:'utilities'!

resultForSuite: suite

    | result |
    result := TestResult new.
    suite tests do:
        [:test|
        (test class testSelectorPassed: test selector)
            ifTrue:
                [result passed add: test]
            ifFalse:
                [(test class testSelectorError: test selector)
                    ifTrue:
                        [result errors add: test]
                    ifFalse:
                        [(test class testSelectorFailed: test selector)
                            ifTrue:
                                [result failures add: test]]]].
    ^result

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

suiteForRun
    | methods protocols suite |                                            
    (methods := selectedMethodsHolder value) isNilOrEmptyCollection ifFalse:
        [suite := TestSuite named: (self suiteNameFromMethods: methods).
        self selectedTestMethods do:
            [:mthd| | selector |
            suite addTest: (mthd mclass asTestCase selector: mthd selector)].
        ^suite].
    
    (protocols := selectedProtocolsHolder value) isNilOrEmptyCollection ifFalse:
        [suite := TestSuite named: (self suiteNameFromProtocols: protocols).
        (self selectedTestMethodsFromProtocols: protocols) do:
            [:mthd| | selector |
            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-03-2011 / 08:24:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

suiteForRunAll
    |suite|
    suite := TestSuite named:(self suiteNameFromClasses: selectedTestCases).
    selectedTestCases 
        do:[:testCase | suite addTests:(self buildSuiteFromClass:testCase) tests].
    ^suite

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

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

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_CVS
    ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.9 2011-07-07 10:40:45 vrany Exp $'
!

version_SVN
    ^ '§Id: Tools__TestRunnerEmbedded.st 7681 2011-03-04 11:30:02Z vranyj1 §'
! !