"{ Package: 'stx:libtool' }"

"{ NameSpace: Tools }"

TestRunnerMini subclass:#TestRunnerEmbedded

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'SUnit-UI'

!

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

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.

    ].

!

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:'aspects-visibility'!

pinButtonVisibleHolder

    ^ true

    "Created: / 23-09-2014 / 10:11:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

runAllButtonVisibleHolder

    ^ true

    "Created: / 23-09-2014 / 10:12:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

runFailedButtonVisibleHolder

    ^ true

    "Created: / 23-09-2014 / 10:12:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TestRunnerEmbedded methodsFor:'change & update'!

invalidateTestCases

    allTestCases := nil.

!

update:aspect with:param from: sender

    "Invoked when an object that I depend upon sends a change notification."

    sender == selectedMethodsHolder ifTrue:[

        self enqueueMessage:#updateTestCases for:self arguments:#().

        self enqueueMessage:#updateSuiteAndResult for:self arguments:#().

    ].

    sender == selectedClassesHolder ifTrue:[

        self 

            invalidateTestCases;      "/ updateTestSuite;

            invalidateSuiteAndResult; "/ updateTestSuiteAndResult;

            updateVisibility.

        self hasTestCaseSelected ifTrue:[

            self enqueueMessage:#updateTestCases for:self arguments:#().

            self enqueueMessage:#updateSuiteAndResult for:self arguments:#().

            "/ self enqueueDelayedAction:[ self updateTestCases; updateSuiteAndResult ].

        ].

         ^ self.

    ].

    self hasTestCaseSelected ifTrue:[

        (sender == selectedProtocolsHolder 

        or:[ sender == selectedMethodsHolder 

        or:[ sender == methodGeneratorHolder ]]) ifTrue:[

            self invalidateSuiteAndResult. 

            self enqueueMessage:#updateSuiteAndResult for:self arguments:#().

            ^self

        ].

        sender == Smalltalk ifTrue:[

            aspect == #lastTestRunResult ifTrue:[

                allTestCases notNil ifTrue:[

                    (allTestCases includesIdentical: param first) ifTrue:[

                        self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.

                        self enqueueMessage:#updateSuiteAndResult for:self arguments:#().

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

!

updateTestCases

    |classes|

    classes := (self selectedClassesHolder value ? #()) 

                    select:[:cls | self isTestCaseLike:cls ] as:Set.

    classes addAll:((self selectedMethodsHolder value ? #()) 

                    collect:[:mthd | mthd mclass ]

                    thenSelect:[:cls | self isTestCaseLike:cls ]).

    allTestCases := classes asArray.

    allTestCases sortBySelector:#name.

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

! !

!TestRunnerEmbedded methodsFor:'private'!

hide

    self visibility: false height: 0

    "Created: / 11-03-2010 / 09:07:24 / 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 

    | window container list h|

    window := self window.

    window isNil ifTrue:[ ^ self ].

    container := self window container.

    container isNil ifTrue:[ ^ self ].

    h := visibility ifFalse:[0] ifTrue:[ height ].

    container isVisible == visibility ifFalse:[

        container isVisible:visibility

    ].

    "/ this is the kind of dangerous access which breaks, whenever some wrapping setup

    "/ changes. Never do this!!!!!!!!

    "/ I'd rather see code which refers to the widget by name,

    "/ or if there is an explicit setter for the container, from which to steal the space.

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

    "Modified: / 22-09-2014 / 13:47:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TestRunnerEmbedded methodsFor:'utilities'!

suiteForRun

    "if methods are selected, a suite for those methods is built and returned.

     If protocols are selected, a suite for all methods in those protocols

     is built and returned.

     Otherwise, a suite for all methods in the class is built and returned"

    | testMethods protocols suite selectedClass |

    selectedClass := self theSingleTestCase.

    selectedMethodsHolder value notEmptyOrNil ifTrue:[

        testMethods := self selectedTestMethods.

        suite := TestSuite named:(self suiteNameFromMethods:testMethods).

        testMethods do:[:mthd | 

            | class  selector |

            class := selectedClass isNil ifTrue:[mthd mclass] ifFalse:[ selectedClass ].

            suite addTest:(class asTestCase selector:mthd selector)

        ].

        ^ suite

    ].

    (protocols := selectedProtocolsHolder value) notEmptyOrNil ifTrue:[

        suite := TestSuite named:(self suiteNameFromProtocols:protocols).

        (self selectedTestMethodsFromProtocols:protocols inClass:selectedClass) do:[:mthd | 

            | class  selector |

            class := selectedClass isNil ifTrue:[mthd mclass] ifFalse:[ selectedClass ].

            suite addTest:(class 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 (format): / 23-09-2014 / 10:19:34 / 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"

! !

!TestRunnerEmbedded class methodsFor:'documentation'!

version

    ^ '$Header$'

!

version_CVS

    ^ '$Header$'

! !