"

 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 := self resultHolder value.

    [

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

!

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 ]

                        ]