"

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

                [