"

 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:#TestRunnerMini

	instanceVariableNames:'runnerPanel selectedClassesHolder selectedProtocolsHolder

		selectedMethodsHolder methodGeneratorHolder resultHolder

		resultInfoHolder resultBackgroundColorHolder runningHolder

		progressHolder progressIndicatorShownHolder infoHolder

		testProcess allTestCases progressIndicator'

	classVariableNames:''

	poolDictionaries:''

	category:'SUnit-UI'

!

Object subclass:#SuiteAndResult

	instanceVariableNames:'suite result'

	classVariableNames:''

	poolDictionaries:''

	privateIn:TestRunnerMini

!

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

"

! !

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

! !

!TestRunnerMini class methodsFor:'image specs'!

pinIcon

    "This resource specification was automatically generated

     by the ImageEditor of ST/X."

    "Do not manually edit this!! If it is corrupted,

     the ImageEditor may not be able to read the specification."

    "

     self pinIcon inspect

     ImageEditor openOnClass:self andSelector:#pinIcon

     Icon flushCachedIcons

    "

    <resource: #image>

    ^Icon

        constantNamed:'Tools::TestRunnerEmbedded pinIcon'

        ifAbsentPut:[(Depth8Image new) width:14; height:13; bits:(ByteArray fromPackedString:'

NC 8NC 8NC 8NB8/L# 8NC 8NC 8NC 8J3@1L# 8NC 8NC 8NB80J3@/APXDB@8OB3L+L3L0KB8RD1TVE1$ZJ2<0L2,8N@TGA@$JD@00KR<-M3 8M04MCP4M

CPD0KSL7NC 7CRD\HRDAHRD!!HS\8NCXMH!!4"H!!4TGQ4#M# 8M@4[IRP^IQ8XIRT5NC *CRX_I!!<_I!!<QG2$8N@LMI2 ''HB\ HB\ @# 8@@@@@@@@@@@@@@@@

NC b') ; colorMapFromArray:#[136 149 174 23 50 93 145 154 169 144 154 168 48 116 186 68 118 170 70 119 171 70 120 171 62 133 196 62 132 195 93 155 206 170 202 228 171 202 228 197 223 244 93 156 206 132 180 218 132 181 218 205 228 246 90 156 204 111 182 226 179 216 240 88 182 232 115 196 236 153 212 241 186 225 246 189 226 245 217 238 249 242 251 255 235 249 255 238 250 255 241 251 255 245 252 255 248 253 255 235 250 255 238 251 255 239 251 255 241 252 255 242 252 255 245 253 255 248 254 255 247 254 255 157 161 160 157 162 160 0 114 54 0 97 46 0 82 39 0 149 62 53 155 88 114 182 73 125 181 81 163 202 129 159 167 110 170 170 151 171 169 151 183 177 142 191 182 136 255 255 255]; mask:((Depth1Image new) width:14; height:13; bits:(ByteArray fromPackedString:'@C @O@A<??3?<O?0??C?<O?0??C?<O?0??@b') ; yourself); yourself]

! !

!TestRunnerMini 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::TestRunnerMini andSelector:#windowSpec

     Tools::TestRunnerMini new openInterface:#windowSpec

     Tools::TestRunnerMini open

    "

    <resource: #canvas>

    ^ 

    #(FullSpec

       name: windowSpec

       window: 

      (WindowSpec

         label: 'Test Runner Embedded'

         name: 'Test Runner Embedded'

         min: (Point 10 10)

         bounds: (Rectangle 0 0 600 50)

       )

       component: 

      (SpecCollection

         collection: (

          (HorizontalPanelViewSpec

             name: 'RunnerInnerBox'

             layout: (LayoutFrame 0 0 0 0 0 1 0 1)

             backgroundChannel: resultBackgroundColorAspect

             horizontalLayout: rightSpaceFit

             verticalLayout: center

             horizontalSpace: 0

             elementsChangeSize: true

             component: 

            (SpecCollection

               collection: (

                (ViewSpec

                   name: 'RunnerInfoBox'

                   backgroundChannel: resultBackgroundColorAspect

                   component: 

                  (SpecCollection

                     collection: (

                      (ViewSpec

                         name: 'ProgressPanel'

                         layout: (LayoutFrame 0 0 0 0 0 1 0 1)

                         initiallyInvisible: true

                         visibilityChannel: progressIndicatorShownHolder

                         backgroundChannel: resultBackgroundColorAspect

                         component: 

                        (SpecCollection

                           collection: (

                            (ProgressIndicatorSpec

                               name: 'RunningProgress'

                               layout: (LayoutFrame 5 0 -10 0.5 -5 1 10 0.5)

                               model: progressHolder

                               postBuildCallback: postBuildProgressIndicator:

                             )

                            )

                         )

                       )

                      (LabelSpec

                         label: 'Run tests first!!'

                         name: 'ResultName'

                         layout: (LayoutFrame 22 0 0 0 0 1 -10 1)

                         backgroundChannel: resultBackgroundColorAspect

                         foregroundColor: (Color 100.0 100.0 100.0)

                         translateLabel: true

                         labelChannel: resultNameAspect

                         adjust: left

                       )

                      (ActionButtonSpec

                         name: 'Button3'

                         layout: (LayoutFrame 5 0 3 0 21 0 17 0)

                         level: 0

                         visibilityChannel: pinButtonVisibleHolder

                         backgroundChannel: resultBackgroundColorAspect

                         hasCharacterOrientedLabel: false

                         translateLabel: true

                         foregroundChannel: resultBackgroundColorAspect

                         labelChannel: pinIcon

                         model: pin

                       )

                      (LabelSpec

                         name: 'ResultInfo'

                         layout: (LayoutFrame 22 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

                       )

                      )

                   )

                   extent: (Point 296 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: ' Failed'

                   name: 'Button1'

                   activeHelpKey: runFailed

                   visibilityChannel: runFailedButtonVisibleHolder

                   translateLabel: true

                   model: runFailed

                   enableChannel: runFailedEnabledHolder

                   extent: (Point 60 25)

                 )

                (ActionButtonSpec

                   label: 'Run all'

                   name: 'RunAll'

                   activeHelpKey: runAll

                   visibilityChannel: runAllButtonVisibleHolder

                   translateLabel: true

                   model: runAll

                   enableChannel: runAllEnabledHolder

                   extent: (Point 60 25)

                 )

                (ViewSpec

                   name: 'Spacer'

                   backgroundChannel: resultBackgroundColorAspect

                   extent: (Point 5 50)

                 )

                )

             )

             postBuildCallback: postBuildRunnerPanel:

           )

          )

       )

     )

! !

!TestRunnerMini class methodsFor:'queries'!

shouldRememberLastExtent

    "to be redefined by concrete applications:

     if true is answered, the application's extent is remembered on close

     and used as a default when opened the next time"

    ^ false

    "Created: / 22-09-2014 / 14:02:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

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

! !

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

    result := TestResult defaultResultClass new.

    suiteAndResult := SuiteAndResult suite: suite result: result.

    self stop.

    "/ debug run is synchronous

    [

        self runningHolder value:true.

        suite tests do:[:test |

            [

                test debug. 

            ] ifCurtailed:[

                result failureOutcomes add: test.

                self resultHolder value:suiteAndResult; changed.    

            ].

            (test class testSelectorPassed:test selector) ifTrue:[

                "/ result := TestResult defaultResultClass new.

                "/ result passed add: test.

                "/ suiteAndResult := SuiteAndResult suite: suite result: result.

                result passedOutcomes add: test.

                self resultHolder value:suiteAndResult; changed.    

            ] ifFalse:[

                (test class testSelectorFailed:test selector) ifTrue:[

                    "/ result := TestResult defaultResultClass new.

                    "/ result failures add: test.

                    "/ suiteAndResult := SuiteAndResult suite: suite result: result.       

                    result failureOutcomes add: test.

                    self resultHolder value:suiteAndResult; changed.    

                ]

            ]

        ].

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

!

pin

    | runner screen |

    runner := TestRunnerMini new.

    runner selectedMethodsHolder: self selectedMethodsHolder copy asValue.

    runner selectedProtocolsHolder: self selectedProtocolsHolder copy asValue.

    runner selectedClassesHolder: self selectedClassesHolder copy asValue.

    runner allButOpen.

    screen := Screen current.

    (screen notNil and:[ screen platformName == #X11 ]) ifTrue:[ 

        "/ Use EWMH hint to tell the WM that the window is

        "/ a sort of floating tool so WM can decorate it according to

        "/ DE standards.

        runner window id isNil ifTrue:[ 

            runner window create.

        ].

        screen setWindowType:#'_NET_WM_WINDOW_TYPE_UTILITY' in:runner window id.      

    ].        

    runner open.

    "Modified: / 23-09-2014 / 10:13:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

run

    |suite|

    resultHolder value isNil ifTrue:[

        suite := self suiteForRun