Tools__TestRunnerMini.st
changeset 18865 33f91c4c68ba
parent 18843 ace2c3514658
child 18942 aa9077775955
--- a/Tools__TestRunnerMini.st	Tue Jul 02 21:56:45 2019 +0200
+++ b/Tools__TestRunnerMini.st	Sun Jul 07 15:00:50 2019 +0200
@@ -759,20 +759,58 @@
      tests. Requires that the testcase returns a non-empty collection
      from the coveredClasses query"
 
-    |testedClasses suite instrumentPackage|
+    |testedClasses suite instrumentPackage suiteClasses suiteClass
+     answer coveredClassNamesString coveredClassNames coveredClasses|
 
     suite := self suiteForRunAll.
 
     instrumentPackage := false.
-    testedClasses := self allCoveredClasses.
+    testedClasses := suite allCoveredClasses.
     testedClasses isEmpty ifTrue:[
-        self suiteForRunAll tests isEmpty ifTrue:[
+        suite tests isEmpty ifTrue:[
             Dialog warn:(resources stringWithCRs:'The test suite is empty - nothing covered, I assume.').
             ^ self.
-        ].   
-        (Dialog confirm:(resources stringWithCRs:'The test cases do not define any covered class.\(missing #coveredClassNames or #coveredPackageNames method on the TestCase''s class side)\\Run without coverage ?'))
-        ifFalse:[^ self].
-    ] ifFalse:[
+        ].
+        suiteClasses := suite tests collect:#class.
+        suiteClasses size == 1 ifTrue:[
+            suiteClass := suiteClasses first
+        ].
+        suiteClass notNil ifTrue:[
+            answer := Dialog 
+                confirmWithCancel:(resources stringWithCRs:'The test cases do not define any covered class.\(missing #coveredClassNames or #coveredPackageNames method on the TestCase''s class side)\\Define covered classes now?\(click on "No" to run without coverage)')
+                labels:(resources array:#('Cancel' 'No' 'Yes')).
+            answer isNil ifTrue:[^ self].
+
+            answer == true ifTrue:[
+                coveredClassNamesString := Dialog request:'Name(s) of class(es) covered by test\(separate by blanks)'.
+                coveredClassNamesString isEmptyOrNil ifTrue:[^ self].
+                coveredClassNames := (coveredClassNamesString splitBy:' ') collect:#withoutSeparators. 
+                coveredClasses := coveredClassNames 
+                            collect:[:nm | 
+                                |cls|
+
+                                (cls := Smalltalk classNamed:nm) isNil ifTrue:[
+                                    Dialog warn:'No class named "%1" found' with:nm
+                                ].
+                                cls]
+                            thenSelect:[:cls | cls notNil].
+
+                (suiteClass theMetaclass includesSelector:#coveredClassNames) ifFalse:[
+                    suiteClass theMetaclass 
+                        compile:('coveredClassNames
+    "These classes will be instrumented for coverage analysis,
+     before running the suite to provide coverage analysis/report"
+
+    ^ %1
+' bindWith:(coveredClasses collect:#name as:Array) storeString) 
+                        classified:'queries'.
+                    testedClasses := suite allCoveredClasses.
+                ].
+            ].
+        ].
+    ].
+
+    testedClasses notEmptyOrNil ifTrue:[
         self withWaitCursorDo:[
             infoHolder notNil ifTrue:[
                 infoHolder value:('Instrumenting...')
@@ -1185,15 +1223,7 @@
      tests. Requires that the testcase returns a non-empty collection
      from the coveredClasses query"
 
-    |testedClasses suite|
-
-    testedClasses := Set new.
-
-    suite := self suiteForRunAll.
-    suite tests do:[:eachTest |
-        testedClasses addAll:(eachTest class coveredClasses).
-    ].
-    ^ testedClasses
+    ^ self suiteForRunAll allCoveredClasses.
 !
 
 hasTestCaseSelected