diff --git a/src/BaselineOfDrTests/BaselineOfDrTests.class.st b/src/BaselineOfDrTests/BaselineOfDrTests.class.st new file mode 100644 index 00000000..94033fa2 --- /dev/null +++ b/src/BaselineOfDrTests/BaselineOfDrTests.class.st @@ -0,0 +1,45 @@ +Class { + #name : 'BaselineOfDrTests', + #superclass : 'BaselineOf', + #category : 'BaselineOfDrTests', + #package : 'BaselineOfDrTests' +} + +{ #category : 'baselines' } +BaselineOfDrTests >> baseline: spec [ + + spec + for: #common + do: [ + spec + package: 'DrTests'; + package: 'Coverage'; + package: 'DrTests-TestsRunner' with: [ spec requires: #('DrTests') ]; + package: 'DrTests-TestCoverage' with: [ spec requires: #('DrTests' 'Coverage') ]; + package: 'DrTests-TestsProfiling' with: [ spec requires: #('DrTests') ]; + package: 'DrTests-Tests' with: [ spec requires: #('DrTests' 'DrTests-TestsRunner' 'DrTests-TestCoverage-Tests-Mocks') ]; + package: 'DrTests-TestCoverage-Tests' with: [ spec requires: #('DrTests-TestCoverage' 'DrTests-TestCoverage-Tests-Mocks') ]; + package: 'DrTests-TestsProfiling-Tests' with: [ spec requires: #('DrTests-TestsProfiling') ]; + package: 'DrTests-TestCoverage-Tests-Mocks' with: [ spec requires: #('DrTests-TestCoverage') ]; + package: 'DrTests-CommentsToTests' with: [ spec requires: #('DrTests' 'DrTests-TestsRunner') ]; + package: 'DrTests-CommentsToTests-Tests' with: [ spec requires: #('DrTests-CommentsToTests') ]. + self rottenTestsFinder: spec. + spec package: 'DrTests-RottenGreenTestsFinder' with: [ spec requires: #('rotten-tests-finder') ]. ] +] + +{ #category : 'actions' } +BaselineOfDrTests >> postload: loader package: packageSpec [ + + self tools register: DrTests as: #testRunner +] + +{ #category : 'baselines' } +BaselineOfDrTests >> rottenTestsFinder: spec [ + + spec + package: 'RottenTestsFinder'; + package: 'RottenTestsFinder-FakeTests' with: [ spec requires: #('RottenTestsFinder') ]; + package: 'RottenTestsFinder-Tests' with: [ spec requires: #('RottenTestsFinder') ]; + group: 'rotten-tests-finder' with: #('RottenTestsFinder' 'RottenTestsFinder-FakeTests' 'RottenTestsFinder-Tests'). + +] diff --git a/src/BaselineOfDrTests/package.st b/src/BaselineOfDrTests/package.st new file mode 100644 index 00000000..8b076cdc --- /dev/null +++ b/src/BaselineOfDrTests/package.st @@ -0,0 +1 @@ +Package { #name : 'BaselineOfDrTests' } diff --git a/src/DrTests-CommentsToTests-Tests/CommentsToTestsTest.class.st b/src/DrTests-CommentsToTests-Tests/CommentsToTestsTest.class.st new file mode 100644 index 00000000..d8c6ed56 --- /dev/null +++ b/src/DrTests-CommentsToTests-Tests/CommentsToTestsTest.class.st @@ -0,0 +1,61 @@ +" +A DrTestsUITest is a test class for testing the behavior of DrTests-CommentsToTestsTest +" +Class { + #name : 'CommentsToTestsTest', + #superclass : 'TestCase', + #category : 'DrTests-CommentsToTests-Tests-Base', + #package : 'DrTests-CommentsToTests-Tests', + #tag : 'Base' +} + +{ #category : 'tests' } +CommentsToTestsTest >> testCommentWithFailure [ + "(1+3)>>>5" + + | docComment commentTestCase | + + docComment := thisContext method ast pharoDocCommentNodes first. + commentTestCase := CommentTestCase for: docComment. + + self should: [commentTestCase testIt] raise: TestFailure +] + +{ #category : 'tests' } +CommentsToTestsTest >> testCommentWithSyntaxError [ + "(1+)>>>5" + + | docComment commentTestCase | + + docComment := thisContext method ast pharoDocCommentNodes first. + commentTestCase := CommentTestCase for: docComment. + + self should: [commentTestCase testIt] raise: OCCodeError +] + +{ #category : 'tests' } +CommentsToTestsTest >> testErrorComment [ + "(1+3)+6/0>>>4" + + | docComment commentTestCase | + + docComment := thisContext method ast pharoDocCommentNodes first. + commentTestCase := CommentTestCase for: docComment. + + self should: [commentTestCase testIt] raise: Error +] + +{ #category : 'tests' } +CommentsToTestsTest >> testSimpleComment [ + "(1+3)>>>4" + + | docComment commentTestCase value | + + docComment := thisContext method ast pharoDocCommentNodes first. + commentTestCase := CommentTestCase for: docComment. + value := commentTestCase evaluate. + + self + assert: value key + equals: value value +] diff --git a/src/DrTests-CommentsToTests-Tests/package.st b/src/DrTests-CommentsToTests-Tests/package.st new file mode 100644 index 00000000..11caaba2 --- /dev/null +++ b/src/DrTests-CommentsToTests-Tests/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-CommentsToTests-Tests' } diff --git a/src/DrTests-CommentsToTests/DTCommentTestConfiguration.class.st b/src/DrTests-CommentsToTests/DTCommentTestConfiguration.class.st new file mode 100644 index 00000000..211a3427 --- /dev/null +++ b/src/DrTests-CommentsToTests/DTCommentTestConfiguration.class.st @@ -0,0 +1,25 @@ +" +I know the items to create a testSuite that will be analysed by a DrTestsPlugin. +" +Class { + #name : 'DTCommentTestConfiguration', + #superclass : 'DTPluginConfiguration', + #category : 'DrTests-CommentsToTests-Base', + #package : 'DrTests-CommentsToTests', + #tag : 'Base' +} + +{ #category : 'converting' } +DTCommentTestConfiguration >> asTestSuite [ + + | suite classes methods | + suite := TestSuite named: 'Test Generated From Comments'. + classes := self items addAll: (self items collect: [ :each | each class ]); yourself. + methods := classes flatCollect: [ :each | each methods ]. + "keep only methods defined in a selected package or methods whose classes are defined in a selected package." + methods := methods select: [ :m | (packagesSelected includes: m package) or: [ packagesSelected includes: m origin package ] ]. + methods do: [ :method | + method pharoDocCommentNodes do: [ :docComment | + suite addTest: (CommentTestCase for: docComment) ] ]. + ^ suite +] diff --git a/src/DrTests-CommentsToTests/DTCommentToTestPlugin.class.st b/src/DrTests-CommentsToTests/DTCommentToTestPlugin.class.st new file mode 100644 index 00000000..c8f4e549 --- /dev/null +++ b/src/DrTests-CommentsToTests/DTCommentToTestPlugin.class.st @@ -0,0 +1,108 @@ +" +I am a DrTestPlugin. +I create tests from executable comments and run these tests. +" +Class { + #name : 'DTCommentToTestPlugin', + #superclass : 'DrTestsPlugin', + #category : 'DrTests-CommentsToTests-Base', + #package : 'DrTests-CommentsToTests', + #tag : 'Base' +} + +{ #category : 'api - accessing' } +DTCommentToTestPlugin class >> pluginName [ + "The name of the plugin to be displayed in DrTests UI." + ^ 'Executable comments checker' +] + +{ #category : 'api - accessing' } +DTCommentToTestPlugin class >> pluginResultClass [ + ^ DTCommentToTestResult +] + +{ #category : 'api - accessing' } +DTCommentToTestPlugin class >> weight [ + "The lighter is a plugin, the higher it is displayed in the drop list for plugin selection." + ^ 10 +] + +{ #category : 'configuration building' } +DTCommentToTestPlugin >> buildConfigurationFrom: aDrTests [ + ^ DTCommentTestConfiguration items: aDrTests selectedItems packages: aDrTests packagesSelected +] + +{ #category : 'api' } +DTCommentToTestPlugin >> firstListLabel [ + ^ 'Packages' +] + +{ #category : 'api' } +DTCommentToTestPlugin >> itemsToBeAnalysedFor: packagesSelected [ + + "note `asSet` is used to avoid duplication if a class is defined/extended in more than one package" + + ^ packagesSelected asSet flatCollect: [ :package | + package definedOrExtendedClasses select: [ :class | + class hasDocComment or: [ class class hasDocComment ] ] ] +] + +{ #category : 'api' } +DTCommentToTestPlugin >> packagesAvailableForAnalysis [ + + ^ self packageOrganizer packages select: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase not ] ] +] + +{ #category : 'accessing' } +DTCommentToTestPlugin >> pragmaForResultTrees [ + ^ #'dtCommentToTestResultTreeNamed:order:' +] + +{ #category : 'api' } +DTCommentToTestPlugin >> resultButtonHelp [ + ^ 'Browse the test selected in the result list.' +] + +{ #category : 'api' } +DTCommentToTestPlugin >> runForConfiguration: aDTpluginConfiguration [ + ^ self pluginResultClass new + testResults: (self runTestSuites: {aDTpluginConfiguration asTestSuite}); + yourself +] + +{ #category : 'api' } +DTCommentToTestPlugin >> runSuite: aTestSuite withResult: aResult [ + aTestSuite + when: TestAnnouncement + do: [ :testAnnouncement | + self announceStatusChanged: ('Running test {1}.' format: {testAnnouncement test asString}) ] + for: self. + [ aTestSuite run: aResult ] + ensure: [ aTestSuite unsubscribe: TestAnnouncement ] +] + +{ #category : 'api' } +DTCommentToTestPlugin >> runTestSuites: testSuites [ + | result | + result := TestAsserter classForTestResult new. + CurrentExecutionEnvironment + runTestsBy: [ testSuites + do: [ :testSuite | self runSuite: testSuite withResult: result ] + displayingProgress: 'Running Tests' ]. + ^ result +] + +{ #category : 'api' } +DTCommentToTestPlugin >> secondListLabel [ + ^ 'Classes' +] + +{ #category : 'api' } +DTCommentToTestPlugin >> startButtonHelp [ + ^ 'Run selected tests.' +] + +{ #category : 'api' } +DTCommentToTestPlugin >> startButtonLabel [ + ^ 'Run Tests' translated +] diff --git a/src/DrTests-CommentsToTests/DTCommentToTestResult.class.st b/src/DrTests-CommentsToTests/DTCommentToTestResult.class.st new file mode 100644 index 00000000..f571239e --- /dev/null +++ b/src/DrTests-CommentsToTests/DTCommentToTestResult.class.st @@ -0,0 +1,55 @@ +" +I build a tree with the testsResult created by comments listed in groups: +- Errors +- Failures +- Passed test +I am used in DrTestsUI to show the results in a orderly manner. +" +Class { + #name : 'DTCommentToTestResult', + #superclass : 'DTPluginResult', + #instVars : [ + 'testsResult' + ], + #category : 'DrTests-CommentsToTests-Base', + #package : 'DrTests-CommentsToTests', + #tag : 'Base' +} + +{ #category : 'accessing' } +DTCommentToTestResult >> buildTreeForUI [ + + + ^ DTTreeNode new + subResults: { + (DTTreeNode new + name: 'Errors'; + subResults: (self testResults errors collect: [:each | each asResultForDrTest ]); + startExpanded; + displayColorIfNotEmpty: TestResult defaultColorBackGroundForErrorTest; + yourself). + (DTTreeNode new + name: 'Failures'; + subResults: (self testResults failures + collect: [:each | each asResultForDrTest] + as: OrderedCollection); + startExpanded; + displayColorIfNotEmpty: TestResult defaultColorBackGroundForFailureTest; + yourself). + (DTTreeNode new + name: 'Passed tests'; + subResults: (self testResults passed collect: [:each | each asResultForDrTest] ); + displayColorIfNotEmpty: TestResult defaultColorBackGroundForPassingTest; + yourself) }; + yourself +] + +{ #category : 'accessing' } +DTCommentToTestResult >> testResults [ + ^ testsResult +] + +{ #category : 'accessing' } +DTCommentToTestResult >> testResults: anObject [ + testsResult := anObject +] diff --git a/src/DrTests-CommentsToTests/package.st b/src/DrTests-CommentsToTests/package.st new file mode 100644 index 00000000..1500129e --- /dev/null +++ b/src/DrTests-CommentsToTests/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-CommentsToTests' } diff --git a/src/DrTests-RottenGreenTestsFinder/DTRFTPlugin.class.st b/src/DrTests-RottenGreenTestsFinder/DTRFTPlugin.class.st new file mode 100644 index 00000000..d0a4790e --- /dev/null +++ b/src/DrTests-RottenGreenTestsFinder/DTRFTPlugin.class.st @@ -0,0 +1,80 @@ +" +I am plugin implementing RottenGreenTestsFinder in DrTests +" +Class { + #name : 'DTRFTPlugin', + #superclass : 'DrTestsPlugin', + #category : 'DrTests-RottenGreenTestsFinder-Base', + #package : 'DrTests-RottenGreenTestsFinder', + #tag : 'Base' +} + +{ #category : 'api - accessing' } +DTRFTPlugin class >> pluginName [ + "The name of the plugin to be displayed in DrTests UI." + ^ 'Rotten green tests finder' +] + +{ #category : 'api - accessing' } +DTRFTPlugin class >> pluginResultClass [ + "Returns the class that this plugin instantiate for its results." + ^ DTRTFResult +] + +{ #category : 'api - accessing' } +DTRFTPlugin class >> weight [ + "The lighter is a plugin, the higher it is displayed in the drop list for plugin selection." + ^ 7 +] + +{ #category : 'analyze' } +DTRFTPlugin >> analyse: aTestClass [ + + ^ RottenTestsFinder analyze: aTestClass +] + +{ #category : 'api' } +DTRFTPlugin >> analyseTestFrom: aDTpluginConfiguration [ + |result| + result := self pluginResultClass new. + aDTpluginConfiguration items do: [ :testClass | + result add: (self analyse: testClass) ]. + ^ result +] + +{ #category : 'accessing' } +DTRFTPlugin >> firstListLabel [ + ^ 'Packages' +] + +{ #category : 'accessing' } +DTRFTPlugin >> pragmaForResultTrees [ + "Returns the selector of the pragma to gather result trees." + ^ 'dtTestRTFResultTreeNamed:order:' +] + +{ #category : 'api' } +DTRFTPlugin >> resultButtonHelp [ + ^ 'Browse the test selected in the results list.' translated +] + +{ #category : 'api' } +DTRFTPlugin >> runForConfiguration: aDTpluginConfiguration [ + + ^ self analyseTestFrom: aDTpluginConfiguration +] + +{ #category : 'accessing' } +DTRFTPlugin >> secondListLabel [ + ^ 'Tests Cases' +] + +{ #category : 'api' } +DTRFTPlugin >> startButtonHelp [ + ^ 'Run Tests' translated +] + +{ #category : 'api' } +DTRFTPlugin >> startButtonLabel [ + ^ 'Run tests selected.' translated +] diff --git a/src/DrTests-RottenGreenTestsFinder/DTRTFConfiguration.class.st b/src/DrTests-RottenGreenTestsFinder/DTRTFConfiguration.class.st new file mode 100644 index 00000000..16be2811 --- /dev/null +++ b/src/DrTests-RottenGreenTestsFinder/DTRTFConfiguration.class.st @@ -0,0 +1,10 @@ +" +I am a configuration for Rotten green tests finder for DrTests +" +Class { + #name : 'DTRTFConfiguration', + #superclass : 'DTPluginConfiguration', + #category : 'DrTests-RottenGreenTestsFinder-Base', + #package : 'DrTests-RottenGreenTestsFinder', + #tag : 'Base' +} diff --git a/src/DrTests-RottenGreenTestsFinder/DTRTFResult.class.st b/src/DrTests-RottenGreenTestsFinder/DTRTFResult.class.st new file mode 100644 index 00000000..b9665f68 --- /dev/null +++ b/src/DrTests-RottenGreenTestsFinder/DTRTFResult.class.st @@ -0,0 +1,46 @@ +Class { + #name : 'DTRTFResult', + #superclass : 'DTPluginResult', + #instVars : [ + 'result' + ], + #category : 'DrTests-RottenGreenTestsFinder-Base', + #package : 'DrTests-RottenGreenTestsFinder', + #tag : 'Base' +} + +{ #category : 'adding' } +DTRTFResult >> add: aRottenTestsSet [ + + self result mergeWith: aRottenTestsSet +] + +{ #category : 'accessing' } +DTRTFResult >> addRottenTest: aRottenTest [ + + self rottenTests add: aRottenTest +] + +{ #category : 'accessing' } +DTRTFResult >> buildTreeForUI [ + "build the UI for presenting result" + + ^ DTTreeNode new subResults: { (DTTreeNode new + name: 'Rotten green tests'; + subResults: + (self rottenTests collect: [ :m | m compiledMethod asResultForDrTest ]); + yourself) } +] + +{ #category : 'accessing' } +DTRTFResult >> result [ + + ^ result ifNil: [ result := RottenTestsSet new ] +] + +{ #category : 'accessing' } +DTRTFResult >> rottenTests [ + + ^ (self result rottenTests ifNil: [ result := RottenTestsSet ]) + asOrderedCollection +] diff --git a/src/DrTests-RottenGreenTestsFinder/RottenTestsSet.extension.st b/src/DrTests-RottenGreenTestsFinder/RottenTestsSet.extension.st new file mode 100644 index 00000000..54c78ea1 --- /dev/null +++ b/src/DrTests-RottenGreenTestsFinder/RottenTestsSet.extension.st @@ -0,0 +1,28 @@ +Extension { #name : 'RottenTestsSet' } + +{ #category : '*DrTests-RottenGreenTestsFinder' } +RottenTestsSet >> addToTestRunCount: anInteger [ + + testsRunCount := self testsRunCount + anInteger +] + +{ #category : '*DrTests-RottenGreenTestsFinder' } +RottenTestsSet >> addToTestsVisitedCount: anInteger [ + + testsVisitedCount := self testsVisitedCount + anInteger +] + +{ #category : '*DrTests-RottenGreenTestsFinder' } +RottenTestsSet >> mergeWith: aRottenTestsSet [ + + self + addAll: aRottenTestsSet rottenTests; + addToTestsVisitedCount: aRottenTestsSet testsVisitedCount; + addToTestRunCount: aRottenTestsSet testsRunCount +] + +{ #category : '*DrTests-RottenGreenTestsFinder' } +RottenTestsSet >> testsRunCount [ + + ^ testsRunCount ifNil: [ testsRunCount := 0 ] +] diff --git a/src/DrTests-RottenGreenTestsFinder/package.st b/src/DrTests-RottenGreenTestsFinder/package.st new file mode 100644 index 00000000..c38f46fc --- /dev/null +++ b/src/DrTests-RottenGreenTestsFinder/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-RottenGreenTestsFinder' } diff --git a/src/DrTests-TestCoverage-Tests-Mocks/DTCoverageMockTest.class.st b/src/DrTests-TestCoverage-Tests-Mocks/DTCoverageMockTest.class.st new file mode 100644 index 00000000..06bf48d2 --- /dev/null +++ b/src/DrTests-TestCoverage-Tests-Mocks/DTCoverageMockTest.class.st @@ -0,0 +1,37 @@ +Class { + #name : 'DTCoverageMockTest', + #superclass : 'TestCase', + #instVars : [ + 'mockObj' + ], + #category : 'DrTests-TestCoverage-Tests-Mocks-Base', + #package : 'DrTests-TestCoverage-Tests-Mocks', + #tag : 'Base' +} + +{ #category : 'running' } +DTCoverageMockTest >> setUp [ + + super setUp. + mockObj := MockForCoverage new +] + +{ #category : 'running' } +DTCoverageMockTest >> testMethod1forMock [ + + self assert: mockObj method1ForMock equals: 2 +] + +{ #category : 'running' } +DTCoverageMockTest >> testMethod2forMock [ + + self + assert: 5 + equals: 5 +] + +{ #category : 'running' } +DTCoverageMockTest >> testMethod3forMock [ + + self assert: (mockObj method3ForMockWithConditional: 2 ) equals: 0 +] diff --git a/src/DrTests-TestCoverage-Tests-Mocks/MockForCoverage.class.st b/src/DrTests-TestCoverage-Tests-Mocks/MockForCoverage.class.st new file mode 100644 index 00000000..31714a25 --- /dev/null +++ b/src/DrTests-TestCoverage-Tests-Mocks/MockForCoverage.class.st @@ -0,0 +1,30 @@ +" +A mock class with methods used for testing the coverage plugin of DrTest +" +Class { + #name : 'MockForCoverage', + #superclass : 'Object', + #category : 'DrTests-TestCoverage-Tests-Mocks-Mocking', + #package : 'DrTests-TestCoverage-Tests-Mocks', + #tag : 'Mocking' +} + +{ #category : 'sample methods' } +MockForCoverage >> method1ForMock [ + + ^ 1 + 1 +] + +{ #category : 'sample methods' } +MockForCoverage >> method2ForMock: anObject [ + + ^ 1 + anObject +] + +{ #category : 'sample methods' } +MockForCoverage >> method3ForMockWithConditional: anInteger [ + + anInteger > 5 + ifTrue: [ ^ 1 ] + ifFalse: [ ^ 0 ] +] diff --git a/src/DrTests-TestCoverage-Tests-Mocks/package.st b/src/DrTests-TestCoverage-Tests-Mocks/package.st new file mode 100644 index 00000000..5d29f8b6 --- /dev/null +++ b/src/DrTests-TestCoverage-Tests-Mocks/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-TestCoverage-Tests-Mocks' } diff --git a/src/DrTests-TestCoverage-Tests/DTCoverageCollectorTest.class.st b/src/DrTests-TestCoverage-Tests/DTCoverageCollectorTest.class.st new file mode 100644 index 00000000..9fd7f66a --- /dev/null +++ b/src/DrTests-TestCoverage-Tests/DTCoverageCollectorTest.class.st @@ -0,0 +1,36 @@ +Class { + #name : 'DTCoverageCollectorTest', + #superclass : 'TestCase', + #category : 'DrTests-TestCoverage-Tests', + #package : 'DrTests-TestCoverage-Tests' +} + +{ #category : 'tests' } +DTCoverageCollectorTest >> testResultIsADTCoverageResultClass [ + + | cov res | + cov := DTCoverageCollector new. + cov methods: { (MockForCoverage >> #method1ForMock) . (MockForCoverage >> #method2ForMock:) }. + res := cov runOn: [ |mockClass| mockClass := MockForCoverage new. mockClass method1ForMock ]. + + self assert: res class equals: DTCoverageResult . +] + +{ #category : 'tests' } +DTCoverageCollectorTest >> testReturnCoverageResult [ + + | cov res | + cov := DTCoverageCollector new. + cov methods: { + (MockForCoverage >> #method1ForMock). + (MockForCoverage >> #method2ForMock:). + (MockForCoverage >> #method3ForMockWithConditional:)}. + res := cov runOn: [ + | mockClass | + mockClass := MockForCoverage new. + mockClass method1ForMock. + mockClass method3ForMockWithConditional: 0 ]. + + self assert: res methods size equals: 2. + self assert: res partiallyCoveredMethods size equals: 1 +] diff --git a/src/DrTests-TestCoverage-Tests/DTTestCoverageTest.class.st b/src/DrTests-TestCoverage-Tests/DTTestCoverageTest.class.st new file mode 100644 index 00000000..0370c8f9 --- /dev/null +++ b/src/DrTests-TestCoverage-Tests/DTTestCoverageTest.class.st @@ -0,0 +1,134 @@ +Class { + #name : 'DTTestCoverageTest', + #superclass : 'TestCase', + #instVars : [ + 'plugin', + 'package', + 'pluginConfiguration' + ], + #category : 'DrTests-TestCoverage-Tests', + #package : 'DrTests-TestCoverage-Tests' +} + +{ #category : 'running' } +DTTestCoverageTest >> setUp [ + + super setUp. + package := self packageOrganizer packageNamed: 'DrTests-TestCoverage-Tests-Mocks'. + "The test classes are in the same package as classes under test." + pluginConfiguration := DTPluginConfiguration items: { package } packages: { package }. + plugin := DTTestCoveragePlugin new +] + +{ #category : 'running' } +DTTestCoverageTest >> testCoveragePercentForMock [ + + | result | + result := plugin runForConfiguration: pluginConfiguration. + self assert: result percent class equals: ScaledDecimal +] + +{ #category : 'running' } +DTTestCoverageTest >> testCoverageResultIsAnInstanceOfDTTestCoverageResult [ + + | result | + result := plugin runForConfiguration: pluginConfiguration. + self assert: result class equals: DTTestCoverageResult +] + +{ #category : 'running' } +DTTestCoverageTest >> testDTTestCoverageResultAsResultForDrTests [ + "the packages contains at least one test class" + + | items | + items := plugin packagesAvailableForAnalysis. + self + assert: + (items + allSatisfy: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase ] ]) +] + +{ #category : 'running' } +DTTestCoverageTest >> testDTTestCoverageResultBuildTreeForUIContainsNodes [ + + | resultTree | + resultTree := (plugin runForConfiguration: pluginConfiguration) buildTreeForUI. + self + assert: + (resultTree subResults + allSatisfy: [ :subResult | subResult class = DTTreeNode ]) +] + +{ #category : 'running' } +DTTestCoverageTest >> testDTTestCoverageResultHas2Nodes [ + + | resultTree | + resultTree := (plugin runForConfiguration: pluginConfiguration) buildTreeForUI. + self assert: resultTree subResults size equals: 3 +] + +{ #category : 'improvements' } +DTTestCoverageTest >> testDTTestCoverageResultHasCovered_Uncovered_PartiallyCoveredMethods [ + + | result | + result := plugin runForConfiguration: pluginConfiguration. + self assert: result methodList size equals: 1. + self assert: result partiallyCoveredMethods size equals: 1 . +] + +{ #category : 'running' } +DTTestCoverageTest >> testDTTestCoverageResultTheFirstNodeIsPercent [ + + | resultTree | + resultTree := (plugin runForConfiguration: pluginConfiguration) buildTreeForUI. + self + assert: + ((resultTree subResults at: 1) name + includesSubstring: '% Code Coverage') +] + +{ #category : 'running' } +DTTestCoverageTest >> testDTTestCoverageResultTheSecondNodeSubResultsAreLeafs [ + + | resultTree leafs | + resultTree := (plugin runForConfiguration: pluginConfiguration) buildTreeForUI. + leafs := resultTree subResults at: 2. + self + assert: (leafs subResults allSatisfy: #isLeaf ) +] + +{ #category : 'running' } +DTTestCoverageTest >> testItemsAvailableInTestCoveragePlugin [ + | items | + items := plugin itemsToBeAnalysedFor: package. + self + assert: + (items + allSatisfy: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase not ] ]) +] + +{ #category : 'running' } +DTTestCoverageTest >> testNotExecutedMethodList [ + + | result notExecutedMethodList | + result := plugin runForConfiguration: pluginConfiguration. + notExecutedMethodList := {(MockForCoverage >> #method2ForMock:)}. + self + assert: + (notExecutedMethodList + allSatisfy: [ :expectedNotExecutedMethod | + result methodList + anySatisfy: [ :anyMethod | + anyMethod methodClass = expectedNotExecutedMethod methodClass + and: [ anyMethod selector = expectedNotExecutedMethod selector ] ] ]) +] + +{ #category : 'running' } +DTTestCoverageTest >> testPackagesAvailableInTestCoveragePlugin [ + | items | + items := plugin packagesAvailableForAnalysis. + self + assert: + (items + allSatisfy: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase ] ]) +] diff --git a/src/DrTests-TestCoverage-Tests/package.st b/src/DrTests-TestCoverage-Tests/package.st new file mode 100644 index 00000000..e007d54c --- /dev/null +++ b/src/DrTests-TestCoverage-Tests/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-TestCoverage-Tests' } diff --git a/src/DrTests-TestCoverage/CompiledMethod.extension.st b/src/DrTests-TestCoverage/CompiledMethod.extension.st new file mode 100644 index 00000000..588ba3a3 --- /dev/null +++ b/src/DrTests-TestCoverage/CompiledMethod.extension.st @@ -0,0 +1,6 @@ +Extension { #name : 'CompiledMethod' } + +{ #category : '*DrTests-TestCoverage' } +CompiledMethod >> drTestsName [ + ^ self printString +] diff --git a/src/DrTests-TestCoverage/DTCoverageCollector.class.st b/src/DrTests-TestCoverage/DTCoverageCollector.class.st new file mode 100644 index 00000000..fd3696bc --- /dev/null +++ b/src/DrTests-TestCoverage/DTCoverageCollector.class.st @@ -0,0 +1,46 @@ +" +I am a specialized `CoverageCollector` for DrTests. + +I specify some changes to better fit the needs of the DrTests coverage plugin and display the source code in a panel by highlighting the covered lines of code. + +The main change is in `DTCoverageCollector>>#collectResult` where I omit the ""reset"" step. +" +Class { + #name : 'DTCoverageCollector', + #superclass : 'CoverageCollector', + #category : 'DrTests-TestCoverage', + #package : 'DrTests-TestCoverage' +} + +{ #category : 'basic' } +DTCoverageCollector >> basicCollectResult [ + "Collect the results but does not reset the annotations." + + | res | + res := DTCoverageResult new. + res collector: self. + res methods: (methods select: [ :m | m ast hasBeenExecuted ]). + res nodes: IdentitySet new. + nodes do: [ :node | + node hasBeenExecuted ifTrue: [ res nodes add: node ] ]. + res partiallyCoveredMethods: (methods select: [ :meth | + meth ast hasBeenExecuted and: [ (self hasAllNodesCovered: meth) not ] ]). + ^ res +] + +{ #category : 'basic' } +DTCoverageCollector >> collectResult [ + "Collect the results. + This also remaps the methods and NOT resets the annotations." + + self remapMethods. + ^ self basicCollectResult +] + +{ #category : 'precalculations' } +DTCoverageCollector >> hasAllNodesCovered: aMethod [ + + aMethod ast nodesDo: [ :node | + node isSequence ifTrue: [ node hasBeenExecuted ifFalse: [ ^ false ] ] ]. + ^ true +] diff --git a/src/DrTests-TestCoverage/DTCoverageResult.class.st b/src/DrTests-TestCoverage/DTCoverageResult.class.st new file mode 100644 index 00000000..3e2a8ae8 --- /dev/null +++ b/src/DrTests-TestCoverage/DTCoverageResult.class.st @@ -0,0 +1,32 @@ +" +I am a specialized `CoverageResult` for DrTests. +Like my parent: +- I represent the result of a code coverage measurement. +- My instance is produced by `DTCoverageCollector>>#basicCollectResult`. +- I contain the set of covered methods and sequence nodes. + +I add the partiallyCoveredMethods attribute to store the methods that are only partially covered by tests. + +I am used to display the sourceCode panel in DrTest's Coverage plugin. +" +Class { + #name : 'DTCoverageResult', + #superclass : 'CoverageResult', + #instVars : [ + 'partiallyCoveredMethods' + ], + #category : 'DrTests-TestCoverage', + #package : 'DrTests-TestCoverage' +} + +{ #category : 'accessing' } +DTCoverageResult >> partiallyCoveredMethods [ + + ^ partiallyCoveredMethods +] + +{ #category : 'accessing' } +DTCoverageResult >> partiallyCoveredMethods: anObject [ + + partiallyCoveredMethods := anObject +] diff --git a/src/DrTests-TestCoverage/DTTestCoverageConfiguration.class.st b/src/DrTests-TestCoverage/DTTestCoverageConfiguration.class.st new file mode 100644 index 00000000..44a4d17d --- /dev/null +++ b/src/DrTests-TestCoverage/DTTestCoverageConfiguration.class.st @@ -0,0 +1,18 @@ +" +I know the items to create a testSuite that will be analysed by a DrTestsPlugin. +" +Class { + #name : 'DTTestCoverageConfiguration', + #superclass : 'DTPluginConfiguration', + #category : 'DrTests-TestCoverage', + #package : 'DrTests-TestCoverage' +} + +{ #category : 'tests' } +DTTestCoverageConfiguration >> testMethods [ + ^ (packagesSelected + flatCollect: + [ :p | p definedClasses select: [ :c | c allSuperclasses includes: TestCase ] ]) + flatCollect: + [ :c | c methods select:[:m| m isTestMethod ] ] +] diff --git a/src/DrTests-TestCoverage/DTTestCoveragePlugin.class.st b/src/DrTests-TestCoverage/DTTestCoveragePlugin.class.st new file mode 100644 index 00000000..c77cf486 --- /dev/null +++ b/src/DrTests-TestCoverage/DTTestCoveragePlugin.class.st @@ -0,0 +1,152 @@ +" +I am a DrTestPlugin. +I show the percentage of covered methods with tests and show the list of the uncovered methods. +" +Class { + #name : 'DTTestCoveragePlugin', + #superclass : 'DrTestsPlugin', + #instVars : [ + 'methods', + 'testClasses' + ], + #category : 'DrTests-TestCoverage', + #package : 'DrTests-TestCoverage' +} + +{ #category : 'api - accessing' } +DTTestCoveragePlugin class >> pluginName [ + ^ 'Test Coverage' +] + +{ #category : 'api - accessing' } +DTTestCoveragePlugin class >> pluginResultClass [ + ^ DTTestCoverageResult +] + +{ #category : 'api - accessing' } +DTTestCoveragePlugin class >> weight [ + ^ 3 +] + +{ #category : 'api' } +DTTestCoveragePlugin >> allowMiniDrTests [ + ^ true +] + +{ #category : 'api' } +DTTestCoveragePlugin >> allowMultipleSelectionInSecondList [ + ^ false +] + +{ #category : 'api' } +DTTestCoveragePlugin >> defineData: aDTpluginConfiguration [ + + methods := aDTpluginConfiguration items flatCollect: [ :p | + p methods reject: [ :meth | + meth isTestMethod or: [meth methodClass isTestCase] ] ]. + methods := methods reject: [ :method | method isAbstract or: [ (method hasPragmaNamed: #ignoreForCoverage) ] ] . + + testClasses := aDTpluginConfiguration packagesSelected flatCollect: [ + :p | p classes ] +] + +{ #category : 'accessing' } +DTTestCoveragePlugin >> firstListLabel [ + ^ 'Test Packages' +] + +{ #category : 'api' } +DTTestCoveragePlugin >> itemsToBeAnalysedFor: packagesSelected [ + + ^ self packageOrganizer packages select: [ :p | p definedClasses anySatisfy: [ :c | c isTestCase not ] ] +] + +{ #category : 'ui' } +DTTestCoveragePlugin >> pluginPresenterClass [ + + ^ DTCoveragePluginPresenter +] + +{ #category : 'accessing' } +DTTestCoveragePlugin >> pragmaForResultTrees [ + ^ #'dtTestCoverageResultTreeNamed:order:' +] + +{ #category : 'api' } +DTTestCoveragePlugin >> resultButtonHelp [ + ^ 'Browse the method selected in the results list.' translated +] + +{ #category : 'api' } +DTTestCoveragePlugin >> runForConfiguration: aDTpluginConfiguration [ + + | suite collector coverage notExecuted result | + result := self pluginResultClass new. + self defineData: aDTpluginConfiguration. + suite := self suiteFor: testClasses. + collector := DTCoverageCollector new. + collector methods: methods. + coverage := collector runOn: [ self runTestSuites: { suite } ]. + notExecuted := coverage uncoveredMethods. + + methods ifNotEmpty: [ + result + percent: 1s2 - (notExecuted size / methods size asScaledDecimal: 2); + methodList: notExecuted; + partiallyCoveredMethods: coverage partiallyCoveredMethods ]. + ^ result +] + +{ #category : 'api' } +DTTestCoveragePlugin >> runSuite: aTestSuite withResult: aResult [ + + aTestSuite when: TestAnnouncement do: [ :testAnnouncement | + self announceStatusChanged: ('Running test {1}.' format: { testAnnouncement test asString }) ] + for: self. + [ aTestSuite run: aResult ] ensure: [ + aTestSuite unsubscribe: TestAnnouncement ] +] + +{ #category : 'api' } +DTTestCoveragePlugin >> runTestSuites: testSuites [ + | result | + result := TestAsserter classForTestResult new. + CurrentExecutionEnvironment + runTestsBy: [ testSuites + do: [ :testSuite | self runSuite: testSuite withResult: result ] + displayingProgress: 'Running Tests' ] +] + +{ #category : 'accessing' } +DTTestCoveragePlugin >> secondListLabel [ + ^ 'Package under coverage' +] + +{ #category : 'api' } +DTTestCoveragePlugin >> setSelectionModeOfItemsList: aListPresenter [ + aListPresenter + beMultipleSelection; + unselectAll +] + +{ #category : 'api' } +DTTestCoveragePlugin >> startButtonHelp [ + ^ 'Run test coverage in selected packages' translated +] + +{ #category : 'api' } +DTTestCoveragePlugin >> startButtonLabel [ + ^ 'Run Coverage' translated +] + +{ #category : 'api' } +DTTestCoveragePlugin >> suiteFor: classesSelected [ + "Return the suite for all the selected test case classes" + + | suite | + suite := TestSuite new. + classesSelected do: [ :each | + each isAbstract ifFalse: [ + each isTestCase ifTrue: [ each addToSuiteFromSelectors: suite ] ] ]. + ^ suite name: 'Test' +] diff --git a/src/DrTests-TestCoverage/DTTestCoverageResult.class.st b/src/DrTests-TestCoverage/DTTestCoverageResult.class.st new file mode 100644 index 00000000..31e69cca --- /dev/null +++ b/src/DrTests-TestCoverage/DTTestCoverageResult.class.st @@ -0,0 +1,90 @@ +" +I build a tree with information: +-percent of covered methods in the selected packages +-List of the uncovered methods +I am used in DrTestsUI to show the results in a orderly manner. +" +Class { + #name : 'DTTestCoverageResult', + #superclass : 'DTPluginResult', + #instVars : [ + 'methodList', + 'percent', + 'partiallyCoveredMethods' + ], + #category : 'DrTests-TestCoverage', + #package : 'DrTests-TestCoverage' +} + +{ #category : 'accessing' } +DTTestCoverageResult >> buildTreeForUI [ + + ^ DTTreeNode new + subResults: (self methodList + ifNotNil: [ + {(DTTreeNode new + name: (percent * 100 printShowingDecimalPlaces: 2) , ' % Code Coverage'; + subResults: {}; + yourself). + (DTTreeNode new + name: 'Uncovered methods'; + subResults: (self methodList collect: [:each | each asResultForDrTest]); + yourself). + (DTTreeNode new + name: 'Partially covered methods'; + subResults: (self partiallyCoveredMethods collect: [:each | each asResultForDrTest]); + yourself)} + ]ifNil: [ + {(DTTreeNode new + name: 'no package has been selected'; + subResults: {}; + yourself)} + ]) +] + +{ #category : 'accessing' } +DTTestCoverageResult >> methodList [ + ^methodList +] + +{ #category : 'accessing' } +DTTestCoverageResult >> methodList: aCollectionOfMethods [ + methodList := aCollectionOfMethods +] + +{ #category : 'accessing' } +DTTestCoverageResult >> partiallyCoveredMethods [ + + ^ partiallyCoveredMethods +] + +{ #category : 'accessing' } +DTTestCoverageResult >> partiallyCoveredMethods: aCollectionOfMethods [ + + partiallyCoveredMethods := aCollectionOfMethods +] + +{ #category : 'accessing' } +DTTestCoverageResult >> percent [ + ^ percent +] + +{ #category : 'accessing' } +DTTestCoverageResult >> percent: anObject [ + percent := anObject +] + +{ #category : 'accessing' } +DTTestCoverageResult >> summarizeInfo [ + "Text showed in miniDrTests with info of the result " + + ^ String + streamContents: [ :s | + s + << (percent*100 printShowingDecimalPlaces: 2); + << ' % Code Coverage'; + << String cr; + << 'Uncovered methods:'; + << String cr; + << self methodList size asString ] +] diff --git a/src/DrTests-TestCoverage/package.st b/src/DrTests-TestCoverage/package.st new file mode 100644 index 00000000..dda987b6 --- /dev/null +++ b/src/DrTests-TestCoverage/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-TestCoverage' } diff --git a/src/DrTests-Tests/DTCoveragePluginPresenterTest.class.st b/src/DrTests-Tests/DTCoveragePluginPresenterTest.class.st new file mode 100644 index 00000000..76434a08 --- /dev/null +++ b/src/DrTests-Tests/DTCoveragePluginPresenterTest.class.st @@ -0,0 +1,39 @@ +Class { + #name : 'DTCoveragePluginPresenterTest', + #superclass : 'TestCase', + #instVars : [ + 'presenter' + ], + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'running' } +DTCoveragePluginPresenterTest >> setUp [ + + super setUp. + presenter := MockDTCoveragePluginPresenter new +] + +{ #category : 'tests' } +DTCoveragePluginPresenterTest >> testEmptyInitializeOfAttributes [ + + | emptyPresenter | + emptyPresenter := MockDTCoveragePluginPresenter new . + self assert: emptyPresenter uncoveredNodes isNil. + self assert: emptyPresenter coveredNodes isNil. + self assert: emptyPresenter yellowNodes isNil. +] + +{ #category : 'tests' } +DTCoveragePluginPresenterTest >> testUpdateSourceCodePanelUncovered [ + + | oneMethod | + oneMethod := MockForCoverage >> #method2ForMock:. + presenter cleanAttributesForHighlighting . + presenter defineColorCoverage: oneMethod. + + self assert: presenter uncoveredNodes size equals: 1. + self assert: presenter coveredNodes size isZero . + self assert: presenter yellowNodes size isZero. +] diff --git a/src/DrTests-Tests/DTFilterableListPresenterTest.class.st b/src/DrTests-Tests/DTFilterableListPresenterTest.class.st new file mode 100644 index 00000000..c1ebb95a --- /dev/null +++ b/src/DrTests-Tests/DTFilterableListPresenterTest.class.st @@ -0,0 +1,61 @@ +" +A DTFilterableListPresenterTest is a test class for testing the behavior of DTFilterableListPresenter +" +Class { + #name : 'DTFilterableListPresenterTest', + #superclass : 'TestCase', + #instVars : [ + 'filterableList' + ], + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'running' } +DTFilterableListPresenterTest >> setUp [ + super setUp. + filterableList := DTFilterableListPresenter new + items: (1 to: 20); + displayBlock: #asString; + yourself +] + +{ #category : 'tests' } +DTFilterableListPresenterTest >> testFilterStrings [ + + filterableList filterTextInput text: 'foo|bar'. + + self assertCollection: filterableList filterStrings hasSameElements: #( '*foo*' '*bar*' ). + + filterableList filterTextInput text: '|bar'. + + self assertCollection: filterableList filterStrings hasSameElements: #( '*bar*' ). + + filterableList filterTextInput text: 'foo|'. + + self assertCollection: filterableList filterStrings hasSameElements: #( '*foo*' ) +] + +{ #category : 'tests' } +DTFilterableListPresenterTest >> testFilterWorks [ + self assertCollection: filterableList allItems equals: (1 to: 20). + self assertCollection: filterableList visibleItems equals: (1 to: 20). + + filterableList filterTextInput text: '2'. + + self assertCollection: filterableList allItems equals: (1 to: 20). + self assertCollection: filterableList visibleItems equals: #(2 12 20). + + filterableList filterTextInput text: ''. + + self assertCollection: filterableList allItems equals: filterableList visibleItems. "We want to show everything if no filter is written." +] + +{ #category : 'running' } +DTFilterableListPresenterTest >> testLabel [ + self assert: filterableList label equals: ''. + + filterableList label: 'title'. + + self assert: filterableList label equals: 'title' +] diff --git a/src/DrTests-Tests/DTMockPlugin.class.st b/src/DrTests-Tests/DTMockPlugin.class.st new file mode 100644 index 00000000..f90aa52c --- /dev/null +++ b/src/DrTests-Tests/DTMockPlugin.class.st @@ -0,0 +1,81 @@ +" +A Mock object used in test +" +Class { + #name : 'DTMockPlugin', + #superclass : 'DrTestsPlugin', + #instVars : [ + 'hasBeenRun' + ], + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'testing' } +DTMockPlugin class >> isAbstract [ + ^ self = DTMockPlugin +] + +{ #category : 'api - accessing' } +DTMockPlugin class >> pluginName [ + + ^ 'Mock plugin for test' +] + +{ #category : 'api - accessing' } +DTMockPlugin class >> pluginResultClass [ + ^ DTMockPluginResult +] + +{ #category : 'api - accessing' } +DTMockPlugin class >> weight [ + ^ 40 +] + +{ #category : 'accessing' } +DTMockPlugin >> hasBeenRun [ + ^ hasBeenRun +] + +{ #category : 'initialization' } +DTMockPlugin >> initialize [ + + super initialize. + hasBeenRun := false +] + +{ #category : 'api' } +DTMockPlugin >> packagesAvailableForAnalysis [ + "This is a seleciton only for tests" + + ^ {self class package} +] + +{ #category : 'accessing' } +DTMockPlugin >> pragmaForResultTrees [ + ^ #'pragmaForTest:order:' +] + +{ #category : 'api' } +DTMockPlugin >> resultButtonHelp [ + + ^ 'Result help?' +] + +{ #category : 'api' } +DTMockPlugin >> runForConfiguration: aDTpluginConfiguration [ + hasBeenRun := true. + ^ DTMockPluginResult new +] + +{ #category : 'api' } +DTMockPlugin >> startButtonHelp [ + + ^ 'Help me!' +] + +{ #category : 'api' } +DTMockPlugin >> startButtonLabel [ + + ^ 'Mock start' +] diff --git a/src/DrTests-Tests/DTMockPluginResult.class.st b/src/DrTests-Tests/DTMockPluginResult.class.st new file mode 100644 index 00000000..72772660 --- /dev/null +++ b/src/DrTests-Tests/DTMockPluginResult.class.st @@ -0,0 +1,32 @@ +" +A Mock object used in test +" +Class { + #name : 'DTMockPluginResult', + #superclass : 'DTPluginResult', + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'accessing' } +DTMockPluginResult >> backgroundColor [ + " Backgournd color, although untested is used by updateResultLabel, which is called after a test suite is runned " + " It is untested, so we return a random color" + ^ Color black +] + +{ #category : 'accessing' } +DTMockPluginResult >> buildAnotherTreeForUI [ + + ^ DTTreeNode new + subResults: {}; + yourself +] + +{ #category : 'accessing' } +DTMockPluginResult >> buildTreeForUI [ + + ^ DTTreeNode new + subResults: {}; + yourself +] diff --git a/src/DrTests-Tests/DTMockPluginTest.class.st b/src/DrTests-Tests/DTMockPluginTest.class.st new file mode 100644 index 00000000..a3c8c5c1 --- /dev/null +++ b/src/DrTests-Tests/DTMockPluginTest.class.st @@ -0,0 +1,22 @@ +" +A DTMockPluginTest is a test class for testing the behavior of DTMockPlugin +" +Class { + #name : 'DTMockPluginTest', + #superclass : 'TestCase', + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'tests' } +DTMockPluginTest >> testResultTreeViews [ + | plugin treeViews | + plugin := DTMockPlugin new. + + treeViews := plugin resultTreeViews. + + self assert: treeViews size equals: 2. + + self assert: treeViews first name equals: 'for tests'. + self assert: treeViews second name equals: 'for other tests' +] diff --git a/src/DrTests-Tests/DrTestsTestRunnerTest.class.st b/src/DrTests-Tests/DrTestsTestRunnerTest.class.st new file mode 100644 index 00000000..11558bfc --- /dev/null +++ b/src/DrTests-Tests/DrTestsTestRunnerTest.class.st @@ -0,0 +1,80 @@ +" +A DrTestsUITest is a test class for testing the behavior of DrTests-TestRunner +" +Class { + #name : 'DrTestsTestRunnerTest', + #superclass : 'TestCase', + #instVars : [ + 'plugin', + 'package', + 'testToReRun', + 'conf', + 'reRunconf', + 'testCase' + ], + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'running' } +DrTestsTestRunnerTest >> setUp [ + + super setUp. + package := self packageOrganizer packageNamed: 'DrTests-TestCoverage-Tests-Mocks'. + testToReRun := DTCoverageMockTest selector: #testMethod1forMock. + testCase := DTCoverageMockTest. + conf := DTPluginConfiguration + items: ({ package } flatCollect: [ :p | p definedClasses select: [ :c | c allSuperclasses includes: TestCase ] ]) + packages: { package }. + reRunconf := DTReRunConfiguration new. + plugin := DTTestsRunnerPlugin new +] + +{ #category : 'tests' } +DrTestsTestRunnerTest >> testAllSelectedClassesAreTestCases [ + + | thePackage | + thePackage := plugin packagesAvailableForAnalysis anyOne. + self assert: ((plugin itemsToBeAnalysedFor: {thePackage}) flattened allSatisfy: [ :each | each isTestCase ]) +] + +{ #category : 'tests' } +DrTestsTestRunnerTest >> testReRunResultIsDTTestRunnerResult [ + | pluginResult | + pluginResult := plugin runForConfiguration: conf. + reRunconf := DTReRunConfiguration new + previousResult: pluginResult; + configurationToRun: (DTTestsRunnerConfiguration items: { testToReRun }); + yourself. + self + assert: (plugin runForConfiguration: reRunconf) class + equals: DTTestsRunnerResult +] + +{ #category : 'tests' } +DrTestsTestRunnerTest >> testRunResultBuildTreeForUI [ + self + assert: (plugin runForConfiguration: conf) buildTreeForUI class + equals: DTTreeNode +] + +{ #category : 'tests' } +DrTestsTestRunnerTest >> testRunResultIsDTTestRunnerResult [ + self + assert: (plugin runForConfiguration: conf) class + equals: DTTestsRunnerResult +] + +{ #category : 'tests' } +DrTestsTestRunnerTest >> testSelectedPackagesContainTestCases [ + + self assert: (plugin packagesAvailableForAnalysis allSatisfy: [ :pkg | + pkg definedClasses anySatisfy: [ :class | + class isTestCase ] ]) +] + +{ #category : 'tests' } +DrTestsTestRunnerTest >> testTestResultIsNotEmpty [ + self + deny: (plugin runForConfiguration: conf) testResults passed isEmpty +] diff --git a/src/DrTests-Tests/DrTestsTestRunnerUITest.class.st b/src/DrTests-Tests/DrTestsTestRunnerUITest.class.st new file mode 100644 index 00000000..f00f0325 --- /dev/null +++ b/src/DrTests-Tests/DrTestsTestRunnerUITest.class.st @@ -0,0 +1,26 @@ +" +A DrTestsUITest is a test class for testing the behavior of DrTests-TestRunner UI +" +Class { + #name : 'DrTestsTestRunnerUITest', + #superclass : 'TestCase', + #instVars : [ + 'drTest' + ], + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'running' } +DrTestsTestRunnerUITest >> setUp [ + + super setUp. + drTest := DrTests on: { DTTestsRunnerPlugin } +] + +{ #category : 'tests' } +DrTestsTestRunnerUITest >> testRunTestsUpdatesUIWithResults [ + + drTest pluginPresenter startButton performAction. + self assert: drTest pluginPresenter resultsList roots notEmpty +] diff --git a/src/DrTests-Tests/DrTestsUITest.class.st b/src/DrTests-Tests/DrTestsUITest.class.st new file mode 100644 index 00000000..3695a66b --- /dev/null +++ b/src/DrTests-Tests/DrTestsUITest.class.st @@ -0,0 +1,163 @@ +" +A DrTestsUITest is a test class for testing the behavior of DrTestsUI +" +Class { + #name : 'DrTestsUITest', + #superclass : 'TestCase', + #instVars : [ + 'drTestsUI', + 'plugins', + 'plugin1', + 'plugin2' + ], + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'running' } +DrTestsUITest >> setUp [ + "Hooks that subclasses may override to define the fixture of test." + + super setUp. + plugin1 := DTTestsRunnerPlugin. + plugin2 := DTMockPlugin. + plugins := {plugin1. plugin2}. + drTestsUI := DrTests on: plugins +] + +{ #category : 'tests' } +DrTestsUITest >> testClickButtonRunCallsPluginRun [ + drTestsUI pluginsDropList selectItem: DTMockPlugin. + drTestsUI pluginPresenter startButton performAction. + self assert: drTestsUI currentPlugin hasBeenRun +] + +{ #category : 'tests' } +DrTestsUITest >> testCurrentPluginIsSelectedInDropDown [ + | currentPluginSelected | + currentPluginSelected := drTestsUI pluginsDropList selectedItem. + self + assert: drTestsUI currentPlugin class + equals: currentPluginSelected +] + +{ #category : 'tests' } +DrTestsUITest >> testInitialPackagesAreInitialPluginPackages [ + self + assertCollection: drTestsUI pluginPresenter packagesList items + hasSameElements: drTestsUI currentPlugin packagesAvailableForAnalysis +] + +{ #category : 'tests' } +DrTestsUITest >> testInitialResultListIsEmpty [ + + self assert: drTestsUI pluginPresenter resultsList roots isEmpty +] + +{ #category : 'tests' } +DrTestsUITest >> testInitialSelectedPluginIsFirstPluginInList [ + + self assert: drTestsUI currentPlugin class equals: plugins first +] + +{ #category : 'tests' } +DrTestsUITest >> testInitialStatusIsInitialStatusPluginName [ + |status| + status:= (drTestsUI currentPlugin pluginName , ' plugin is ready to work!') translated. + + self + assert: drTestsUI statusLabel label + equals: ('{1}: {2}' format: { (drTestsUI dateAndTimeString ). status }) +] + +{ #category : 'tests' } +DrTestsUITest >> testInitialWindowTitleIsInitialPluginWindowTitle [ + + self + assert: drTestsUI title + equals: 'Dr Tests - ' , drTestsUI currentPlugin pluginName +] + +{ #category : 'tests' } +DrTestsUITest >> testMultipleSelectingPackagesWillUpdateTheClassesList [ + | currentPluginSelected randomPackage newPackagesSelected classesList packageSelected | + currentPluginSelected := drTestsUI pluginsDropList selectedItem. + newPackagesSelected := OrderedCollection new. + packageSelected := drTestsUI pluginPresenter packagesList items anyOne. + randomPackage := (drTestsUI pluginPresenter packagesList items + \ {packageSelected}) anyOne. + newPackagesSelected add: packageSelected. + newPackagesSelected add: randomPackage. + drTestsUI pluginPresenter whenPackagesSelectionChanged: newPackagesSelected. + classesList := currentPluginSelected new + itemsToBeAnalysedFor: newPackagesSelected. + self + assertCollection: drTestsUI pluginPresenter itemsList items + hasSameElements: classesList flattened +] + +{ #category : 'tests' } +DrTestsUITest >> testNoPackageSelected [ + self + assertCollection: drTestsUI pluginPresenter itemsList items + hasSameElements: #() +] + +{ #category : 'tests' } +DrTestsUITest >> testPluginsAreConfiguredPluginsOnly [ + self + assert: drTestsUI pluginsDropList listItems asArray + equals: plugins +] + +{ #category : 'tests' } +DrTestsUITest >> testSelectingPackageWillUpdateTheClassesList [ + | newPackagesSelected | + newPackagesSelected := {drTestsUI pluginPresenter packagesList items + anyOne}. + drTestsUI pluginPresenter whenPackagesSelectionChanged: newPackagesSelected. + self + assertCollection: drTestsUI pluginPresenter itemsList items + hasSameElements: (drTestsUI currentPlugin itemsToBeAnalysedFor: newPackagesSelected) +] + +{ #category : 'tests' } +DrTestsUITest >> testSelectingPluginWillUpdateCurrentPluginInstanceVariable [ + drTestsUI pluginsDropList selectItem: plugin2. + self assert: drTestsUI currentPlugin class equals: plugin2 +] + +{ #category : 'tests' } +DrTestsUITest >> testSelectingPluginWillUpdatePackagesList [ + + drTestsUI pluginsDropList selectItem: plugin2. + self + assertCollection: drTestsUI pluginPresenter packagesList items + hasSameElements: + drTestsUI currentPlugin packagesAvailableForAnalysis +] + +{ #category : 'tests' } +DrTestsUITest >> testSelectingPluginWillUpdateWindowTitle [ + + drTestsUI pluginsDropList selectItem: plugin2. + self + assert: drTestsUI title + equals: 'Dr Tests - ' , drTestsUI currentPlugin pluginName +] + +{ #category : 'tests' } +DrTestsUITest >> testStartButtonHelpIsCurrentPluginStartButtonHelp [ + + self + assert: drTestsUI pluginPresenter startButton help + equals: drTestsUI currentPlugin startButtonHelp +] + +{ #category : 'tests' } +DrTestsUITest >> testStartButtonLabelIsCurrentPluginStartButtonLabel [ + + self + assert: drTestsUI pluginPresenter startButton label + equals: drTestsUI currentPlugin startButtonLabel +] diff --git a/src/DrTests-Tests/MockDTCoveragePluginPresenter.class.st b/src/DrTests-Tests/MockDTCoveragePluginPresenter.class.st new file mode 100644 index 00000000..1b078555 --- /dev/null +++ b/src/DrTests-Tests/MockDTCoveragePluginPresenter.class.st @@ -0,0 +1,32 @@ +Class { + #name : 'MockDTCoveragePluginPresenter', + #superclass : 'DTCoveragePluginPresenter', + #category : 'DrTests-Tests', + #package : 'DrTests-Tests' +} + +{ #category : 'accessing - attributes' } +MockDTCoveragePluginPresenter >> coveredNodes [ + ^ coveredNodes +] + +{ #category : 'accessing - attributes' } +MockDTCoveragePluginPresenter >> uncoveredNodes [ + ^ uncoveredNodes +] + +{ #category : 'initialization' } +MockDTCoveragePluginPresenter >> updatePresenter [ + "I rewrite this method by commenting, so this class cannot be initialized and run other methods that are unnecessary to perform the tests." + + "super updatePresenter. + self updatePackagesList. + self updateResultViewsDropList." + + +] + +{ #category : 'accessing - attributes' } +MockDTCoveragePluginPresenter >> yellowNodes [ + ^ yellowNodes +] diff --git a/src/DrTests-Tests/package.st b/src/DrTests-Tests/package.st new file mode 100644 index 00000000..c8aa68db --- /dev/null +++ b/src/DrTests-Tests/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-Tests' } diff --git a/src/DrTests-TestsProfiling-Tests/DTTestProfilingTest.class.st b/src/DrTests-TestsProfiling-Tests/DTTestProfilingTest.class.st new file mode 100644 index 00000000..521bd8b1 --- /dev/null +++ b/src/DrTests-TestsProfiling-Tests/DTTestProfilingTest.class.st @@ -0,0 +1,101 @@ +Class { + #name : 'DTTestProfilingTest', + #superclass : 'TestCase', + #instVars : [ + 'package', + 'classes', + 'dTconf', + 'plugin' + ], + #category : 'DrTests-TestsProfiling-Tests', + #package : 'DrTests-TestsProfiling-Tests' +} + +{ #category : 'running' } +DTTestProfilingTest >> setUp [ + + super setUp. + plugin := DTTestsProfilingPlugin new. + package := self packageOrganizer packageNamed: 'DrTests-TestCoverage-Tests-Mocks'. + classes := plugin itemsToBeAnalysedFor: { package }. + dTconf := DTPluginConfiguration items: classes packages: { package } +] + +{ #category : 'running' } +DTTestProfilingTest >> testCoverageResultIsAnInstanceOfDTTestProfilingResult [ + | result | + result := plugin runForConfiguration: dTconf. + self assert: result class equals: DTTestsProfilingResult +] + +{ #category : 'running' } +DTTestProfilingTest >> testDTTestCoverageResulLeafsContentHaveATestCase [ + | resultTree leafs | + resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI. + leafs := resultTree subResults at: 4. + self + assert: + (leafs subResults + allSatisfy: [ :subResult | subResult content testCase isKindOf: TestCase]) +] + +{ #category : 'running' } +DTTestProfilingTest >> testDTTestCoverageResulLeafsContentHaveATestResult [ + | resultTree leafs | + resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI. + leafs := resultTree subResults at: 4. + self + assert: + (leafs subResults + allSatisfy: [ :subResult | subResult content testResult isKindOf: TestResult ]) +] + +{ #category : 'running' } +DTTestProfilingTest >> testDTTestCoverageResulLeafsContentHaveDuration [ + | resultTree leafs | + resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI. + leafs := resultTree subResults at: 4. + self + assert: + (leafs subResults + allSatisfy: [ :subResult | subResult content duration class = Duration ]) +] + +{ #category : 'running' } +DTTestProfilingTest >> testDTTestCoverageResultHas4Nodes [ + | resultTree | + resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI. + self assert: resultTree subResults size equals: 4 +] + +{ #category : 'running' } +DTTestProfilingTest >> testDTTestCoverageResultTheSecondNodeSubResultsAreLeafs [ + | resultTree leafs | + resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI. + leafs := resultTree subResults at: 3. + self + assert: + (leafs subResults + allSatisfy: [ :subResult | subResult class = DTTreeLeafNode ]) +] + +{ #category : 'running' } +DTTestProfilingTest >> testDTTestCoverageResultTheThirdNodeSubResultsLeafsContentsAreDTTestCaseProfilingData [ + | resultTree leafs | + resultTree := (plugin runForConfiguration: dTconf) buildTreeForUI. + leafs := resultTree subResults at: 3. + self + assert: + (leafs subResults + allSatisfy: [ :subResult | subResult content class = DTTestCaseProfilingData ]) +] + +{ #category : 'running' } +DTTestProfilingTest >> testItemsAvailableInTestProfilerPlugin [ + | items | + items := plugin itemsToBeAnalysedFor: {package}. + self + assert: + (items + allSatisfy: [ :p | p methods anySatisfy: [ :m | m isTestMethod ] ]) +] diff --git a/src/DrTests-TestsProfiling-Tests/package.st b/src/DrTests-TestsProfiling-Tests/package.st new file mode 100644 index 00000000..386e93de --- /dev/null +++ b/src/DrTests-TestsProfiling-Tests/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-TestsProfiling-Tests' } diff --git a/src/DrTests-TestsProfiling/DTTestCaseProfilingData.class.st b/src/DrTests-TestsProfiling/DTTestCaseProfilingData.class.st new file mode 100644 index 00000000..c1158825 --- /dev/null +++ b/src/DrTests-TestsProfiling/DTTestCaseProfilingData.class.st @@ -0,0 +1,76 @@ +" +I stores the information for every test. +I have the duration that is the times it takes when a test is executed. +I also have the testCase ande the testResult. +" +Class { + #name : 'DTTestCaseProfilingData', + #superclass : 'Object', + #instVars : [ + 'testCase', + 'duration', + 'testResult' + ], + #category : 'DrTests-TestsProfiling', + #package : 'DrTests-TestsProfiling' +} + +{ #category : 'instance creation' } +DTTestCaseProfilingData class >> testCase: testCase duration: aDuration [ + ^ self new + testCase: testCase; + duration: aDuration; + yourself +] + +{ #category : 'instance creation' } +DTTestCaseProfilingData class >> testCase: testCase duration: aDuration testResult: aTestResult [ + ^ self new + testCase: testCase; + duration: aDuration; + testResult: aTestResult; + yourself +] + +{ #category : 'actions' } +DTTestCaseProfilingData >> drTestsBrowse [ + + self browser + openOnClass: testCase class + selector: testCase selector +] + +{ #category : 'accessing' } +DTTestCaseProfilingData >> drTestsName [ + ^ self testCase asString , ' : ', self duration asString +] + +{ #category : 'accessing' } +DTTestCaseProfilingData >> duration [ + ^ duration +] + +{ #category : 'accessing' } +DTTestCaseProfilingData >> duration: anObject [ + duration := anObject +] + +{ #category : 'accessing' } +DTTestCaseProfilingData >> testCase [ + ^ testCase +] + +{ #category : 'accessing' } +DTTestCaseProfilingData >> testCase: anObject [ + testCase := anObject +] + +{ #category : 'accessing' } +DTTestCaseProfilingData >> testResult [ + ^ testResult +] + +{ #category : 'accessing' } +DTTestCaseProfilingData >> testResult: anObject [ + testResult := anObject +] diff --git a/src/DrTests-TestsProfiling/DTTestsProfilerVisitor.class.st b/src/DrTests-TestsProfiling/DTTestsProfilerVisitor.class.st new file mode 100644 index 00000000..6e1f9e18 --- /dev/null +++ b/src/DrTests-TestsProfiling/DTTestsProfilerVisitor.class.st @@ -0,0 +1,45 @@ +" +I collect the time for every executed test. +I create a DTTestCaseProfilingData for each test and store all of them in a collection. +" +Class { + #name : 'DTTestsProfilerVisitor', + #superclass : 'SUnitVisitor', + #instVars : [ + 'profilingData' + ], + #category : 'DrTests-TestsProfiling', + #package : 'DrTests-TestsProfiling' +} + +{ #category : 'initialization' } +DTTestsProfilerVisitor >> initialize [ + super initialize. + self profilingData: OrderedCollection new +] + +{ #category : 'accessing' } +DTTestsProfilerVisitor >> profilingData [ + ^ profilingData +] + +{ #category : 'accessing' } +DTTestsProfilerVisitor >> profilingData: anObject [ + profilingData := anObject +] + +{ #category : 'visiting' } +DTTestsProfilerVisitor >> visitTestCase: aTestCase [ + "Defines the behaviour while visiting a TestCase. + This method must be overriden by concrete subclasses. + " + "We make explicit the dependency to duration" + + | aTestresult | + self profilingData + add: + (DTTestCaseProfilingData + testCase: aTestCase + duration: (Duration milliSeconds: ([ aTestresult := aTestCase run ] millisecondsToRun)) + testResult: aTestresult) +] diff --git a/src/DrTests-TestsProfiling/DTTestsProfilingPlugin.class.st b/src/DrTests-TestsProfiling/DTTestsProfilingPlugin.class.st new file mode 100644 index 00000000..0888c341 --- /dev/null +++ b/src/DrTests-TestsProfiling/DTTestsProfilingPlugin.class.st @@ -0,0 +1,67 @@ +" +I am a DrTestPlugin. +I show the time that takes execute the test and the result of the tests. +" +Class { + #name : 'DTTestsProfilingPlugin', + #superclass : 'DrTestsPlugin', + #category : 'DrTests-TestsProfiling', + #package : 'DrTests-TestsProfiling' +} + +{ #category : 'api - accessing' } +DTTestsProfilingPlugin class >> pluginName [ + ^ 'Tests Profiler' +] + +{ #category : 'api - accessing' } +DTTestsProfilingPlugin class >> pluginResultClass [ + ^ DTTestsProfilingResult +] + +{ #category : 'api - accessing' } +DTTestsProfilingPlugin class >> weight [ + ^ 5 +] + +{ #category : 'api' } +DTTestsProfilingPlugin >> firstListLabel [ + ^ 'Packages' +] + +{ #category : 'accessing' } +DTTestsProfilingPlugin >> pragmaForResultTrees [ + ^ #'drTestsProfilingResultTreeNamed:order:' +] + +{ #category : 'api' } +DTTestsProfilingPlugin >> resultButtonHelp [ + ^ 'Browse the test selected in the results list.' translated +] + +{ #category : 'api' } +DTTestsProfilingPlugin >> runForConfiguration: aDTpluginConfiguration [ + | results profilerVisitor | + profilerVisitor := DTTestsProfilerVisitor new. + aDTpluginConfiguration asTestSuite + acceptSUnitVisitor: profilerVisitor. + results := self pluginResultClass new + testResults: profilerVisitor profilingData; + yourself. + ^ results +] + +{ #category : 'api' } +DTTestsProfilingPlugin >> secondListLabel [ + ^ 'Tests Cases' +] + +{ #category : 'api' } +DTTestsProfilingPlugin >> startButtonHelp [ + ^ 'Run tests selected.' translated +] + +{ #category : 'api' } +DTTestsProfilingPlugin >> startButtonLabel [ + ^ 'Profile Tests' translated +] diff --git a/src/DrTests-TestsProfiling/DTTestsProfilingResult.class.st b/src/DrTests-TestsProfiling/DTTestsProfilingResult.class.st new file mode 100644 index 00000000..2c1645c3 --- /dev/null +++ b/src/DrTests-TestsProfiling/DTTestsProfilingResult.class.st @@ -0,0 +1,104 @@ +" +I build a tree with DTTestCaseProfilingData objects listed in groups: +-Errors +-Failures +-Skipped tests +-Passed test +Each group has in adition the total execution time for each test. +I am used in DrTestsUI to show the results in a orderly manner. +" +Class { + #name : 'DTTestsProfilingResult', + #superclass : 'DTPluginResult', + #instVars : [ + 'testsResult' + ], + #category : 'DrTests-TestsProfiling', + #package : 'DrTests-TestsProfiling' +} + +{ #category : 'accessing' } +DTTestsProfilingResult >> buildTreeForUI [ + + ^ DTTreeNode new + subResults: + {(self buildTreeNode + name: 'Errors'; + subResults: + ((self testResults + select: + [ :testCaseToTimeTaken | testCaseToTimeTaken testResult errors isNotEmpty ]) + collect: [ :testCaseToTimeTaken | + DTTreeLeafNode new + content: testCaseToTimeTaken; + yourself ]); + yourself). + (self buildTreeNode + name: 'Failures'; + subResults: + ((self testResults + select: + [ :testCaseToTimeTaken | testCaseToTimeTaken testResult failures isNotEmpty ]) + collect: [ :testCaseToTimeTaken | + DTTreeLeafNode new + content: testCaseToTimeTaken; + yourself ]); + yourself). + (self buildTreeNode + name: 'Skipped tests'; + subResults: + ((self testResults + select: + [ :testCaseToTimeTaken | testCaseToTimeTaken testResult skipped isNotEmpty ]) + collect: [ :testCaseToTimeTaken | + DTTreeLeafNode new + content: testCaseToTimeTaken; + yourself ]); + yourself). + (self buildTreeNode + name: 'Passed tests'; + subResults: + ((self testResults + select: + [ :testProfilerResult | testProfilerResult testResult passed isNotEmpty ]) + collect: [ :testCaseToTimeTaken | + DTTreeLeafNode new + content: testCaseToTimeTaken; + yourself ]); + yourself)}; + yourself +] + +{ #category : 'accessing' } +DTTestsProfilingResult >> buildTreeGroupedByClass [ + + ^ self buildTreeNode + subResults: ((self testResults groupedBy: [ :d | d testCase class ]) associations collect: [ :assoc | + self buildTreeNode + name: assoc key name; + subResults: (assoc value collect: [ :t | DTTreeLeafNode content: t ]); + yourself ]); + yourself +] + +{ #category : 'private' } +DTTestsProfilingResult >> buildTreeNode [ + "Returns a node with the sub-results aggregator initialized in a way that it sum the durations of sub results." + + ^ DTTreeNode new + subResultsAggregator: [ :subResults | + subResults + inject: 0 milliSecond + into: [ :totalDuration :dtTreeLeaf | totalDuration + dtTreeLeaf content duration ] ]; + yourself +] + +{ #category : 'accessing' } +DTTestsProfilingResult >> testResults [ + ^ testsResult +] + +{ #category : 'accessing' } +DTTestsProfilingResult >> testResults: anObject [ + testsResult := anObject +] diff --git a/src/DrTests-TestsProfiling/package.st b/src/DrTests-TestsProfiling/package.st new file mode 100644 index 00000000..c843a6b9 --- /dev/null +++ b/src/DrTests-TestsProfiling/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-TestsProfiling' } diff --git a/src/DrTests-TestsRunner/DTDebugTestCommand.class.st b/src/DrTests-TestsRunner/DTDebugTestCommand.class.st new file mode 100644 index 00000000..bb6eca26 --- /dev/null +++ b/src/DrTests-TestsRunner/DTDebugTestCommand.class.st @@ -0,0 +1,29 @@ +" +I am the command allowing one to debug a failing test. +" +Class { + #name : 'DTDebugTestCommand', + #superclass : 'DTLeafResultCommand', + #category : 'DrTests-TestsRunner-Commands', + #package : 'DrTests-TestsRunner', + #tag : 'Commands' +} + +{ #category : 'hooks' } +DTDebugTestCommand >> canBeRun [ + ^ super canBeRun and: [ self resultSelected type isPass not ] +] + +{ #category : 'hooks' } +DTDebugTestCommand >> execute [ + self resultSelected content debug +] + +{ #category : 'initialization' } +DTDebugTestCommand >> initialize [ + + super initialize. + self + name: 'Debug test'; + description: 'Re-run the test selected and opens a debugger when an assertion fails.' +] diff --git a/src/DrTests-TestsRunner/DTErrorResultType.class.st b/src/DrTests-TestsRunner/DTErrorResultType.class.st new file mode 100644 index 00000000..1afe9ccb --- /dev/null +++ b/src/DrTests-TestsRunner/DTErrorResultType.class.st @@ -0,0 +1,26 @@ +" +I model the fact that a test generated an error. +" +Class { + #name : 'DTErrorResultType', + #superclass : 'DTTestResultType', + #category : 'DrTests-TestsRunner-Results', + #package : 'DrTests-TestsRunner', + #tag : 'Results' +} + +{ #category : 'factory' } +DTErrorResultType class >> backgroundColorStyle [ + + ^ 'testError' +] + +{ #category : 'testing' } +DTErrorResultType >> isError [ + ^ true +] + +{ #category : 'accessing' } +DTErrorResultType >> name [ + ^ 'Error' +] diff --git a/src/DrTests-TestsRunner/DTExpectedFailureResultType.class.st b/src/DrTests-TestsRunner/DTExpectedFailureResultType.class.st new file mode 100644 index 00000000..23d4033b --- /dev/null +++ b/src/DrTests-TestsRunner/DTExpectedFailureResultType.class.st @@ -0,0 +1,26 @@ +" +I model the fact that a tests expected to fail failed +" +Class { + #name : 'DTExpectedFailureResultType', + #superclass : 'DTTestResultType', + #category : 'DrTests-TestsRunner-Results', + #package : 'DrTests-TestsRunner', + #tag : 'Results' +} + +{ #category : 'factory' } +DTExpectedFailureResultType class >> backgroundColorStyle [ + + ^ 'testExpectedFailure' +] + +{ #category : 'accessing' } +DTExpectedFailureResultType >> isExpectedFailure [ + ^ true +] + +{ #category : 'accessing' } +DTExpectedFailureResultType >> name [ + ^ 'ExpectedFailure' +] diff --git a/src/DrTests-TestsRunner/DTFailResultType.class.st b/src/DrTests-TestsRunner/DTFailResultType.class.st new file mode 100644 index 00000000..f3935a4d --- /dev/null +++ b/src/DrTests-TestsRunner/DTFailResultType.class.st @@ -0,0 +1,26 @@ +" +I model the fact that a test failed. +" +Class { + #name : 'DTFailResultType', + #superclass : 'DTTestResultType', + #category : 'DrTests-TestsRunner-Results', + #package : 'DrTests-TestsRunner', + #tag : 'Results' +} + +{ #category : 'factory' } +DTFailResultType class >> backgroundColorStyle [ + + ^ 'testFail' +] + +{ #category : 'testing' } +DTFailResultType >> isFail [ + ^ true +] + +{ #category : 'accessing' } +DTFailResultType >> name [ + ^ 'Failure' +] diff --git a/src/DrTests-TestsRunner/DTPassResultType.class.st b/src/DrTests-TestsRunner/DTPassResultType.class.st new file mode 100644 index 00000000..915f026a --- /dev/null +++ b/src/DrTests-TestsRunner/DTPassResultType.class.st @@ -0,0 +1,26 @@ +" +I model the fact that a test passed. +" +Class { + #name : 'DTPassResultType', + #superclass : 'DTTestResultType', + #category : 'DrTests-TestsRunner-Results', + #package : 'DrTests-TestsRunner', + #tag : 'Results' +} + +{ #category : 'factory' } +DTPassResultType class >> backgroundColorStyle [ + + ^ 'testPass' +] + +{ #category : 'testing' } +DTPassResultType >> isPass [ + ^ true +] + +{ #category : 'accessing' } +DTPassResultType >> name [ + ^ 'Passing test' +] diff --git a/src/DrTests-TestsRunner/DTReRunConfiguration.extension.st b/src/DrTests-TestsRunner/DTReRunConfiguration.extension.st new file mode 100644 index 00000000..0577d966 --- /dev/null +++ b/src/DrTests-TestsRunner/DTReRunConfiguration.extension.st @@ -0,0 +1,6 @@ +Extension { #name : 'DTReRunConfiguration' } + +{ #category : '*DrTests-TestsRunner' } +DTReRunConfiguration >> handleResults: aPluginResult for: aPlugin [ + ^ aPlugin handleReRunResult: aPluginResult forConfiguration: self +] diff --git a/src/DrTests-TestsRunner/DTRerunCommand.class.st b/src/DrTests-TestsRunner/DTRerunCommand.class.st new file mode 100644 index 00000000..37321e57 --- /dev/null +++ b/src/DrTests-TestsRunner/DTRerunCommand.class.st @@ -0,0 +1,22 @@ +" +I am the command allowing one to rerun a subparts of the results of a test-run. +" +Class { + #name : 'DTRerunCommand', + #superclass : 'DTResultCommand', + #category : 'DrTests-TestsRunner-Commands', + #package : 'DrTests-TestsRunner', + #tag : 'Commands' +} + +{ #category : 'executing' } +DTRerunCommand >> execute [ + self context drTests runPluginFor: (self plugin buildReRunConfigurationFrom: self context drTests) +] + +{ #category : 'initialization' } +DTRerunCommand >> initialize [ + + super initialize. + self name: 'Re-run all tests' +] diff --git a/src/DrTests-TestsRunner/DTSkippedResultType.class.st b/src/DrTests-TestsRunner/DTSkippedResultType.class.st new file mode 100644 index 00000000..42b0909c --- /dev/null +++ b/src/DrTests-TestsRunner/DTSkippedResultType.class.st @@ -0,0 +1,26 @@ +" +I model the fact that a test was skipped. +" +Class { + #name : 'DTSkippedResultType', + #superclass : 'DTTestResultType', + #category : 'DrTests-TestsRunner-Results', + #package : 'DrTests-TestsRunner', + #tag : 'Results' +} + +{ #category : 'factory' } +DTSkippedResultType class >> backgroundColorStyle [ + + ^ 'testSkipped' +] + +{ #category : 'testing' } +DTSkippedResultType >> isSkipped [ + ^ true +] + +{ #category : 'accessing' } +DTSkippedResultType >> name [ + ^ 'Skipped test' +] diff --git a/src/DrTests-TestsRunner/DTTestLeafNode.class.st b/src/DrTests-TestsRunner/DTTestLeafNode.class.st new file mode 100644 index 00000000..08a04122 --- /dev/null +++ b/src/DrTests-TestsRunner/DTTestLeafNode.class.st @@ -0,0 +1,32 @@ +" +I am a leaf of the results tree for the test-runner plugin. + +Additionally to my superclass, I store the type of the result. +" +Class { + #name : 'DTTestLeafNode', + #superclass : 'DTTreeLeafNode', + #instVars : [ + 'type' + ], + #category : 'DrTests-TestsRunner-Base', + #package : 'DrTests-TestsRunner', + #tag : 'Base' +} + +{ #category : 'instance creation' } +DTTestLeafNode class >> content: anObject type: aTestResultType [ + ^ (self content: anObject) + type: aTestResultType; + yourself +] + +{ #category : 'accessing' } +DTTestLeafNode >> type [ + ^ type +] + +{ #category : 'accessing' } +DTTestLeafNode >> type: anObject [ + type := anObject +] diff --git a/src/DrTests-TestsRunner/DTTestResultType.class.st b/src/DrTests-TestsRunner/DTTestResultType.class.st new file mode 100644 index 00000000..a203bea6 --- /dev/null +++ b/src/DrTests-TestsRunner/DTTestResultType.class.st @@ -0,0 +1,90 @@ +" +I model an abstract type of result for the run of a test case. +" +Class { + #name : 'DTTestResultType', + #superclass : 'Object', + #category : 'DrTests-TestsRunner-Results', + #package : 'DrTests-TestsRunner', + #tag : 'Results' +} + +{ #category : 'factory' } +DTTestResultType class >> backgroundColorStyle [ + ^ self subclassResponsibility +] + +{ #category : 'factory' } +DTTestResultType class >> error [ + ^ DTErrorResultType new +] + +{ #category : 'factory' } +DTTestResultType class >> expectedFailure [ + ^ DTExpectedFailureResultType new +] + +{ #category : 'factory' } +DTTestResultType class >> fail [ + ^ DTFailResultType new +] + +{ #category : 'factory' } +DTTestResultType class >> pass [ + ^ DTPassResultType new +] + +{ #category : 'factory' } +DTTestResultType class >> skipped [ + ^ DTSkippedResultType new +] + +{ #category : 'factory' } +DTTestResultType class >> textColor [ + ^ TestResult defaultColorText +] + +{ #category : 'factory' } +DTTestResultType class >> unexpectedPass [ + ^ DTUnexpectedPassResultType new +] + +{ #category : 'testing' } +DTTestResultType >> isError [ + ^ false +] + +{ #category : 'accessing' } +DTTestResultType >> isExpectedFailure [ + ^ false +] + +{ #category : 'testing' } +DTTestResultType >> isFail [ + ^ false +] + +{ #category : 'testing' } +DTTestResultType >> isPass [ + ^ false +] + +{ #category : 'testing' } +DTTestResultType >> isSkipped [ + ^ false +] + +{ #category : 'accessing' } +DTTestResultType >> isUnexpectedPass [ + ^ false +] + +{ #category : 'accessing' } +DTTestResultType >> name [ + ^ self subclassResponsibility +] + +{ #category : 'accessing' } +DTTestResultType >> pluralName [ + ^ self name , 's' +] diff --git a/src/DrTests-TestsRunner/DTTestsRunnerConfiguration.class.st b/src/DrTests-TestsRunner/DTTestsRunnerConfiguration.class.st new file mode 100644 index 00000000..7c28a93e --- /dev/null +++ b/src/DrTests-TestsRunner/DTTestsRunnerConfiguration.class.st @@ -0,0 +1,22 @@ +" +I am a configuration for the tests runner plugin. + +I can be converted as a test suite via #asTestSuite. +" +Class { + #name : 'DTTestsRunnerConfiguration', + #superclass : 'DTPluginConfiguration', + #category : 'DrTests-TestsRunner-Base', + #package : 'DrTests-TestsRunner', + #tag : 'Base' +} + +{ #category : 'converting' } +DTTestsRunnerConfiguration >> asTestSuite [ + |newTestSuite| + newTestSuite := TestSuite new. + self items + reject: #drTestsIsAbstract "This method allows to either test a test case instance or a test suite depending on kind of item." + thenDo: [ :item | newTestSuite addTest: item drTestsSuite "This method allows to either add a test case instance or a test suite depending on kind of item." ]. + ^ newTestSuite +] diff --git a/src/DrTests-TestsRunner/DTTestsRunnerPlugin.class.st b/src/DrTests-TestsRunner/DTTestsRunnerPlugin.class.st new file mode 100644 index 00000000..268934d6 --- /dev/null +++ b/src/DrTests-TestsRunner/DTTestsRunnerPlugin.class.st @@ -0,0 +1,177 @@ +" +I am the plugin implementing test runner for DrTests. +" +Class { + #name : 'DTTestsRunnerPlugin', + #superclass : 'DrTestsPlugin', + #category : 'DrTests-TestsRunner-Base', + #package : 'DrTests-TestsRunner', + #tag : 'Base' +} + +{ #category : 'api - accessing' } +DTTestsRunnerPlugin class >> pluginName [ + ^ 'Tests Runner' +] + +{ #category : 'api - accessing' } +DTTestsRunnerPlugin class >> pluginResultClass [ + ^ DTTestsRunnerResult +] + +{ #category : 'api - accessing' } +DTTestsRunnerPlugin class >> weight [ + ^ 0 +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> allowMiniDrTests [ + ^ true +] + +{ #category : 'configuration building' } +DTTestsRunnerPlugin >> buildConfigurationFrom: aDrTests [ + "Builds a configuration from the plugin by reading the information held by the UI (aDrTests)." + ^ DTTestsRunnerConfiguration + items: aDrTests selectedItems + packages: aDrTests packagesSelected +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> buildContextualMenuGroupWith: presenterInstance [ + + ^ (CmCommandGroup named: 'TestRunnerResult context menu') asSpecGroup + description: 'Commands related to re-run a result.'; + register: (DTDebugTestCommand forSpecContext: presenterInstance) beHiddenWhenCantBeRun; + register: (DTRerunCommand forSpecContext: presenterInstance) beHiddenWhenCantBeRun; + beDisplayedAsGroup; + yourself +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> firstListLabel [ + ^ 'Packages' +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> handleReRunResult: rerunnedResult forConfiguration: aDTRerunConfiguration [ + | oldResult | + oldResult := self + removeTests: aDTRerunConfiguration configurationToRun items + from: aDTRerunConfiguration previousResult testResults. + ^ self pluginResultClass new + testResults: (self joinTestResult: oldResult with: rerunnedResult testResults); + yourself +] + +{ #category : 'private' } +DTTestsRunnerPlugin >> joinTestResult: aTestResult with: partialResult [ + | newResult | + newResult := aTestResult. + partialResult passed do: [ :each | newResult addPass: each ]. + partialResult errors do: [ :each | newResult addError: each ]. + partialResult failures do: [ :each | newResult addFailure: each ]. + partialResult skipped do: [ :each | newResult addSkip: each ]. + ^ newResult +] + +{ #category : 'tests' } +DTTestsRunnerPlugin >> label: aString forSuite: aTestSuite [ + ^ String streamContents: [ :stream | + stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString. + aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ] +] + +{ #category : 'accessing' } +DTTestsRunnerPlugin >> pragmaForResultTrees [ + ^ #'dtTestRunnerResultTreeNamed:order:' +] + +{ #category : 'private' } +DTTestsRunnerPlugin >> removeTest: aTest from: aTestResult [ + aTestResult + passed: (aTestResult passed copyWithout: aTest). + aTestResult + failures: (aTestResult failures copyWithout: aTest). + aTestResult + errors: (aTestResult errors copyWithout: aTest). + ^ aTestResult +] + +{ #category : 'private' } +DTTestsRunnerPlugin >> removeTests: aCollectionOfTest from: aTestResult [ + aCollectionOfTest do: [ :test | + self removeTest: test from: aTestResult ]. + ^ aTestResult +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> resultButtonHelp [ + ^ 'Browse the test selected in the results list.' translated +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> runForConfiguration: aDTpluginConfiguration [ + | results | + results := self pluginResultClass new + testResults: (self runTestSuites: { aDTpluginConfiguration asTestSuite }); + yourself. + ^ aDTpluginConfiguration handleResults: results for: self +] + +{ #category : 'private' } +DTTestsRunnerPlugin >> runSuite: aTestSuite withResult: aResult [ + + aTestSuite when: TestAnnouncement do: [ :testAnnouncement | + self flag: #TODO. "Dirty" + testAnnouncement test class = TestSuite ifTrue: [ + self announceStatusChanged: + ('Running test {1}.' format: { testAnnouncement test name }) ] ] + for: self. + [ aResult mergeWith: (aTestSuite run) ] ensure: [ + aTestSuite unsubscribe: TestAnnouncement ] +] + +{ #category : 'private' } +DTTestsRunnerPlugin >> runTestSuites: testSuites [ + + | result | + result := TestAsserter classForTestResult new. + CurrentExecutionEnvironment runTestsBy: [ + testSuites + do: [ :testSuite | + | specificResult | + specificResult := testSuite resultClass new. + self runSuite: testSuite withResult: specificResult. + result mergeWith: specificResult ] + displayingProgress: 'Running Tests' ]. + result updateResultsInHistory. + ^ result +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> secondListLabel [ + ^ 'Tests Cases' +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> startButtonHelp [ + ^ 'Run tests selected.' translated +] + +{ #category : 'api' } +DTTestsRunnerPlugin >> startButtonLabel [ + ^ 'Run Tests' translated +] + +{ #category : 'tests' } +DTTestsRunnerPlugin >> testSuiteOf: aSetOfTest withName: aString [ + ^ aSetOfTest + collect: [ :each | + TestSuite new + in: [ :suite | + suite + addTest: each; + name: (self label: aString forSuite: suite) ]; + yourself ] +] diff --git a/src/DrTests-TestsRunner/DTTestsRunnerResult.class.st b/src/DrTests-TestsRunner/DTTestsRunnerResult.class.st new file mode 100644 index 00000000..f92331de --- /dev/null +++ b/src/DrTests-TestsRunner/DTTestsRunnerResult.class.st @@ -0,0 +1,197 @@ +" +I build a tree with the testsResult listed in groups: +-Errors +-Failures +-Skipped tests +-Passed test +I am used in DrTestsUI to show the results in a orderly manner. +" +Class { + #name : 'DTTestsRunnerResult', + #superclass : 'DTPluginResult', + #instVars : [ + 'testsResult' + ], + #category : 'DrTests-TestsRunner-Base', + #package : 'DrTests-TestsRunner', + #tag : 'Base' +} + +{ #category : 'accessing' } +DTTestsRunnerResult >> backgroundColorStyle [ + + testsResult errors ifNotEmpty: [ ^ 'testError' ]. + testsResult failures ifNotEmpty: [ ^ 'testFail' ]. + ^ 'testPass' +] + +{ #category : 'tree building' } +DTTestsRunnerResult >> buildLeavesFrom: aCollection type: testResultType [ + ^ aCollection collect: [ :t | DTTestLeafNode content: t type: testResultType ] +] + +{ #category : 'tree building' } +DTTestsRunnerResult >> buildNodeGroupedByTypeAndClass: anOrderedColletion type: testResultType [ + ^ DTTreeNode new + name: testResultType pluralName; + subResults: ((anOrderedColletion groupedBy: #class) associations collect: [ :assoc | + DTTreeNode new + name: assoc key name; + browseBlock: [ assoc key drTestsBrowse ]; + subResults: (self buildLeavesFrom: assoc value type: testResultType); + yourself ]); + yourself +] + +{ #category : 'tree building' } +DTTestsRunnerResult >> buildNodeGroupedByTypeClassAndProtocol: anOrderedColletion type: testResultType [ + ^ DTTreeNode new + name: testResultType pluralName; + subResults: ((anOrderedColletion groupedBy: #class) associations collect: [ :assoc | + DTTreeNode new + name: assoc key name; + subResults: ((assoc value groupedBy: [ :testCase | (testCase class lookupSelector: testCase selector) protocolName ]) associations collect: [ :protocolToTest | + DTTreeNode new + name: protocolToTest key; + subResults: (self buildLeavesFrom: protocolToTest value type: testResultType) ]); + yourself ]); + yourself +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> buildTreeForUI [ + + ^ DTTreeNode new + subResults: { + DTTreeNode new + name: DTTestResultType error pluralName; + subResults: (self buildLeavesFrom: self errors type: DTTestResultType error); + startExpanded; + displayColorIfNotEmpty: TestResult defaultColorBackGroundForErrorTest; + yourself. + DTTreeNode new + name: DTTestResultType fail pluralName; + subResults: (self buildLeavesFrom: self failures type: DTTestResultType fail); + startExpanded; + displayColorIfNotEmpty: TestResult defaultColorBackGroundForFailureTest. + DTTreeNode new + name: DTTestResultType skipped pluralName; + subResults: (self buildLeavesFrom: self skipped type: DTTestResultType skipped). + DTTreeNode new + name: DTTestResultType pass pluralName; + subResults: (self buildLeavesFrom: self passed type: DTTestResultType pass); + displayColorIfNotEmpty: TestResult defaultColorBackGroundForPassingTest. + DTTreeNode new + name: DTTestResultType expectedFailure pluralName; + subResults: (self buildLeavesFrom: self expectedFailures type: DTTestResultType expectedFailure). + DTTreeNode new + name: DTTestResultType unexpectedPass pluralName; + subResults: (self buildLeavesFrom: self unexpectedPassed type: DTTestResultType unexpectedPass) }; + yourself +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> buildTreeForUIByClasses [ + + + | errors failures skipped passed | + errors := self buildNodeGroupedByTypeAndClass: self testResults errors type: DTTestResultType error. + failures := self buildNodeGroupedByTypeAndClass: self testResults failures asOrderedCollection type: DTTestResultType fail. + skipped := self buildNodeGroupedByTypeAndClass: self testResults skipped type: DTTestResultType skipped. + passed := self buildNodeGroupedByTypeAndClass: self testResults passed type: DTTestResultType pass. + ^ DTTreeNode new + subResults: + {errors. + failures. + skipped. + passed}; + yourself +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> buildTreeForUIByClassesAndProtocol [ + + + | errors failures skipped passed | + errors := self buildNodeGroupedByTypeClassAndProtocol: self testResults errors type: DTTestResultType error. + failures := self buildNodeGroupedByTypeClassAndProtocol: self testResults failures asOrderedCollection type: DTTestResultType fail. + skipped := self buildNodeGroupedByTypeClassAndProtocol: self testResults skipped type: DTTestResultType skipped. + passed := self buildNodeGroupedByTypeClassAndProtocol: self testResults passed type: DTTestResultType pass. + ^ DTTreeNode new + subResults: + {errors. + failures. + skipped. + passed}; + yourself +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> errors [ + + ^ self testResults errors asOrderedCollection +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> expectedFailures [ + ^ self testResults expectedDefects +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> failures [ + ^ self testResults failures asOrderedCollection + select: [ :t | t shouldPass ] +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> passed [ + ^ self testResults passed asOrderedCollection + select: [ :t | t shouldPass] +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> skipped [ + ^ self testResults skipped +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> summarizeInfo [ + "Text showed in miniDrTests with info of the result " + + ^ String + streamContents: [ :s | + s + print: self testResults passed size; + << ' passed'; + cr; + print: self testResults failures size; + << ' failures'; + cr; + print: self testResults errors size; + << ' errors'; + cr; + print: self testResults skipped size; + << ' skipped' ] +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> testResults [ + ^ testsResult +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> testResults: anObject [ + testsResult := anObject +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> textColor [ + testsResult errors ifNotEmpty: [ ^ DTErrorResultType textColor ]. + testsResult failures ifNotEmpty: [ ^ DTFailResultType textColor ]. + ^ DTPassResultType textColor +] + +{ #category : 'accessing' } +DTTestsRunnerResult >> unexpectedPassed [ + ^ self testResults unexpectedPasses asOrderedCollection +] diff --git a/src/DrTests-TestsRunner/DTUnexpectedPassResultType.class.st b/src/DrTests-TestsRunner/DTUnexpectedPassResultType.class.st new file mode 100644 index 00000000..4d575d7d --- /dev/null +++ b/src/DrTests-TestsRunner/DTUnexpectedPassResultType.class.st @@ -0,0 +1,27 @@ +" +I model the fact that a test expected to fail passed +" +Class { + #name : 'DTUnexpectedPassResultType', + #superclass : 'DTTestResultType', + #category : 'DrTests-TestsRunner-Results', + #package : 'DrTests-TestsRunner', + #tag : 'Results' +} + +{ #category : 'factory' } +DTUnexpectedPassResultType class >> backgroundColorStyle [ + + ^ 'testUnexpectedPass' +] + +{ #category : 'accessing' } +DTUnexpectedPassResultType >> isUnexpectedPass [ + + ^ true +] + +{ #category : 'accessing' } +DTUnexpectedPassResultType >> name [ + ^ 'Unexpected passed test' +] diff --git a/src/DrTests-TestsRunner/DrTestsPlugin.extension.st b/src/DrTests-TestsRunner/DrTestsPlugin.extension.st new file mode 100644 index 00000000..b980b843 --- /dev/null +++ b/src/DrTests-TestsRunner/DrTestsPlugin.extension.st @@ -0,0 +1,12 @@ +Extension { #name : 'DrTestsPlugin' } + +{ #category : '*DrTests-TestsRunner' } +DrTestsPlugin >> buildReRunConfigurationFrom: aDrTests [ + "Builds a configuration for the plugin by reading the information held by the UI (aDrTests) and the last value of results." + + ^ DTReRunConfiguration new + originalConfiguration: aDrTests testsConfiguration; + previousResult: aDrTests pluginResult; + configurationToRun: (DTTestsRunnerConfiguration items: aDrTests contentForReRun); + yourself +] diff --git a/src/DrTests-TestsRunner/TestCase.extension.st b/src/DrTests-TestsRunner/TestCase.extension.st new file mode 100644 index 00000000..fc2968d8 --- /dev/null +++ b/src/DrTests-TestsRunner/TestCase.extension.st @@ -0,0 +1,33 @@ +Extension { #name : 'TestCase' } + +{ #category : '*DrTests-TestsRunner' } +TestCase >> asResultForDrTest [ + ^ DTTestLeafNode content: self +] + +{ #category : '*DrTests-TestsRunner' } +TestCase >> drTestsBrowse [ + + "May be using double dispatch would be better + so that the application of DrTest can open tools + without relying on this global." + + (Smalltalk tools toolNamed: #browser) + openOnClass: self class + selector: self selector +] + +{ #category : '*DrTests-TestsRunner' } +TestCase >> drTestsBuildContextMenu: aMenuModel [ + "Nothing to display yet." +] + +{ #category : '*DrTests-TestsRunner' } +TestCase >> drTestsName [ + ^ self asString +] + +{ #category : '*DrTests-TestsRunner' } +TestCase class >> drTestsSuite [ + ^ self suite +] diff --git a/src/DrTests-TestsRunner/package.st b/src/DrTests-TestsRunner/package.st new file mode 100644 index 00000000..c1952615 --- /dev/null +++ b/src/DrTests-TestsRunner/package.st @@ -0,0 +1 @@ +Package { #name : 'DrTests-TestsRunner' } diff --git a/src/DrTests/AbstractDrTestsPresenter.class.st b/src/DrTests/AbstractDrTestsPresenter.class.st new file mode 100644 index 00000000..f440face --- /dev/null +++ b/src/DrTests/AbstractDrTestsPresenter.class.st @@ -0,0 +1,204 @@ +" +Abstract superclass for UI's of Dr Test +" +Class { + #name : 'AbstractDrTestsPresenter', + #superclass : 'StPresenter', + #instVars : [ + 'pluginResult', + 'testsConfiguration', + 'currentPlugin', + 'switchButton' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'testing' } +AbstractDrTestsPresenter class >> isAbstract [ + + ^ self name = #AbstractDrTestsPresenter +] + +{ #category : 'icons' } +AbstractDrTestsPresenter class >> taskbarIconName [ + "Answer the icon for the receiver in a task bar." + + ^ #testRunner +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> currentPlugin [ + + ^ currentPlugin +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> currentPlugin: anObject [ + "If a plugin was set before, unsubscribe first." + + currentPlugin ifNotNil: [ currentPlugin unconfigureUI: self ]. + currentPlugin := anObject. + + currentPlugin announcer + when: DTStatusUpdate + send: #handlePluginStatusUpdate: + to: self. + + currentPlugin announcer + when: DTUpdateResults + send: #handlePluginResultUpdate: + to: self. + + titleHolder := self windowTitle. +] + +{ #category : 'events' } +AbstractDrTestsPresenter >> handlePluginResultUpdate: resultsAnnouncement [ + + self updateWithPluginResult: resultsAnnouncement results +] + +{ #category : 'announcement handling' } +AbstractDrTestsPresenter >> handlePluginStatusUpdate: aDTStatusUpdate [ + + self updateStatus: aDTStatusUpdate message +] + +{ #category : 'initialization' } +AbstractDrTestsPresenter >> initializeButtons [ + + switchButton := self newButton. + switchButton + action: [ self switchUI ]; + icon: (self iconNamed: #smallRemoteOpen) +] + +{ #category : 'initialization' } +AbstractDrTestsPresenter >> initializePresenters [ + + self initializeButtons +] + +{ #category : 'api - locking' } +AbstractDrTestsPresenter >> lock [ + "Lock the UI, once this method is called, the user is not able to click on buttons or lists anymore." + + self locked: false +] + +{ #category : 'api - locking' } +AbstractDrTestsPresenter >> locked: aBoolean [ + "Lock or unlock widgets returned by #subwidgetsToLock depending on aBoolean." + + self subwidgetsToLock + do: [ :subwidget | subwidget enabled: aBoolean ] +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> pluginResult [ + + ^ pluginResult +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> pluginResult: anObject [ + + pluginResult := anObject +] + +{ #category : 'running' } +AbstractDrTestsPresenter >> runPlugin [ + + self runPluginFor: self testsConfiguration +] + +{ #category : 'running' } +AbstractDrTestsPresenter >> runPluginFor: aTestsConfiguration [ + + [ self + lock; + updateStatus: 'Tests started.'; + updateWithResults: (self currentPlugin runForConfiguration: aTestsConfiguration); + updateStatus: 'Tests finished.' ] ensure: [ self unlock ] +] + +{ #category : 'api - locking' } +AbstractDrTestsPresenter >> subwidgetsToLock [ + + ^ { self startButton } +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> switchButton [ + + ^ switchButton +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> switchButton: anObject [ + + switchButton := anObject +] + +{ #category : 'api - subwidgets configuration' } +AbstractDrTestsPresenter >> switchButtonAction: aBlock [ + + self switchButton action: aBlock +] + +{ #category : 'actions' } +AbstractDrTestsPresenter >> switchUI [ + + self withWindowDo: [ :window | window close ] +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> testsConfiguration [ + + ^ testsConfiguration +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> testsConfiguration: anObject [ + + testsConfiguration := anObject +] + +{ #category : 'api - locking' } +AbstractDrTestsPresenter >> unlock [ + "Unlock the UI, once this method is called, the user is able to click on buttons or lists and to launch analysis." + + self locked: true +] + +{ #category : 'updating' } +AbstractDrTestsPresenter >> updateStatus: aString [ + "Does nothing on purpose." +] + +{ #category : 'updating' } +AbstractDrTestsPresenter >> updateUI [ + + self withWindowDo: [ :window | window title: self title ] +] + +{ #category : 'updating' } +AbstractDrTestsPresenter >> updateWithPluginResult: aPluginResult [ + + aPluginResult ifNil: [ ^ self ]. + self updateWithResults: aPluginResult +] + +{ #category : 'updating' } +AbstractDrTestsPresenter >> updateWithResults: results [ + + self subclassResponsibility +] + +{ #category : 'TOREMOVE' } +AbstractDrTestsPresenter >> windowIcon [ + + ^ self application iconNamed: #testRunner +] diff --git a/src/DrTests/ClassDescription.extension.st b/src/DrTests/ClassDescription.extension.st new file mode 100644 index 00000000..12d1c7e7 --- /dev/null +++ b/src/DrTests/ClassDescription.extension.st @@ -0,0 +1,10 @@ +Extension { #name : 'ClassDescription' } + +{ #category : '*DrTests' } +ClassDescription >> drTestsBrowse [ + "May be using double dispatch would be better + so that the application of DrTest can open tools + without relying on this global." + + (Smalltalk tools toolNamed: #browser) openOnClass: self +] diff --git a/src/DrTests/CompiledMethod.extension.st b/src/DrTests/CompiledMethod.extension.st new file mode 100644 index 00000000..9a3d43cb --- /dev/null +++ b/src/DrTests/CompiledMethod.extension.st @@ -0,0 +1,18 @@ +Extension { #name : 'CompiledMethod' } + +{ #category : '*DrTests' } +CompiledMethod >> asResultForDrTest [ + + ^ DTTestLeafNode content: self +] + +{ #category : '*DrTests' } +CompiledMethod >> drTestsBrowse [ + "May be using double dispatch would be better + so that the application of DrTest can open tools + without relying on this global." + + (Smalltalk tools toolNamed: #browser) + openOnClass: self methodClass + selector: self selector +] diff --git a/src/DrTests/DTAbstractTreeNode.class.st b/src/DrTests/DTAbstractTreeNode.class.st new file mode 100644 index 00000000..6a959c0a --- /dev/null +++ b/src/DrTests/DTAbstractTreeNode.class.st @@ -0,0 +1,55 @@ +" +I am the abstract superclass for all classes that are nodes or leafs used to show results. +" +Class { + #name : 'DTAbstractTreeNode', + #superclass : 'Object', + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'testing' } +DTAbstractTreeNode >> canBeBrowsed [ + ^ self subclassResponsibility +] + +{ #category : 'api' } +DTAbstractTreeNode >> displayColor [ + + ^ nil +] + +{ #category : 'actions' } +DTAbstractTreeNode >> drTestsBrowse [ + "Actions to perform in order to browse the result. + Does nothing by default." +] + +{ #category : 'menu' } +DTAbstractTreeNode >> drTestsBuildContextMenu: menu [ + "Builds the contextual menu to display in DrTests results tree when a node of the tree is right-clicked. + Does nothing by default." +] + +{ #category : 'accessing' } +DTAbstractTreeNode >> drTestsName [ + "Returns the name to display for this object in DrTestsUI." + ^ self subclassResponsibility +] + +{ #category : 'testing' } +DTAbstractTreeNode >> isLeaf [ + ^ false +] + +{ #category : 'testing' } +DTAbstractTreeNode >> shouldStartExpanded [ + + ^ false +] + +{ #category : 'accessing' } +DTAbstractTreeNode >> subResults [ + ^ #() +] diff --git a/src/DrTests/DTBrowseSelectedItemCommand.class.st b/src/DrTests/DTBrowseSelectedItemCommand.class.st new file mode 100644 index 00000000..afef90b3 --- /dev/null +++ b/src/DrTests/DTBrowseSelectedItemCommand.class.st @@ -0,0 +1,29 @@ +" +I browse the item selected in middle list of DrTests. +" +Class { + #name : 'DTBrowseSelectedItemCommand', + #superclass : 'DTMiddleListCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'defaults' } +DTBrowseSelectedItemCommand class >> defaultName [ + "Return the default name of the command" + + ^ 'Browse' +] + +{ #category : 'testing' } +DTBrowseSelectedItemCommand >> canBeExecuted [ + + ^ self selectedItems size = 1 +] + +{ #category : 'executing' } +DTBrowseSelectedItemCommand >> execute [ + + self context browseSelectedItem +] diff --git a/src/DrTests/DTCommand.class.st b/src/DrTests/DTCommand.class.st new file mode 100644 index 00000000..e779c8d9 --- /dev/null +++ b/src/DrTests/DTCommand.class.st @@ -0,0 +1,21 @@ +" +I am an abstract command concerning DrTests. +" +Class { + #name : 'DTCommand', + #superclass : 'CmCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTCommand class >> isAbstract [ + + ^self name = #DTCommand +] + +{ #category : 'accessing' } +DTCommand >> plugin [ + ^ self context plugin +] diff --git a/src/DrTests/DTCoveragePluginPresenter.class.st b/src/DrTests/DTCoveragePluginPresenter.class.st new file mode 100644 index 00000000..7c355bd0 --- /dev/null +++ b/src/DrTests/DTCoveragePluginPresenter.class.st @@ -0,0 +1,162 @@ +" +I am a specialized `DTDefaultPluginPresenter` for the DrTests coverage plugin. + +This subclass adds an extra panel to display the source code of the methods and highlight the covered lines of code. The highlighting has 3 colors where: +- green indicates fully covered lines. +- yellow indicates partially covered lines. +- red indicates uncovered lines. + +To achieve this, this subclass has 4 new attributes: sourceCodePanel, coveredNodes, uncoveredNodes, and yellowNodes. The sourceCodePanel is the panel that displays the highlighted source code below the list of method nodes. It also has 4 new methods: +1) `DTCoveragePluginPresenter>>#updateSourceCodePanel:` updates the panel when the user clicks on a method in the result list. It colors in the order they are presented above, starting from green as a base color. +2) `DTCoveragePluginPresenter>>#defineColorCoverage:` updates the coveredNodes and uncoveredNodes attributes according to the selected method. +3) `DTCoveragePluginPresenter>>#defineColorMessageNode:` updates the yellowNodes attribute according to the selected method. If an ASTMessageNode contains selectors with block arguments like `ifTrue:`, `ifFalse:`, `do:` and others, it decides whether they should be highlighted in yellow or green. +4) `DTCoveragePluginPresenter>>#addHighlightingOf:withColor:` applies the highlighting to the source code panel for each attribute (coveredNodes, uncoveredNodes, and yellowNodes). +" +Class { + #name : 'DTCoveragePluginPresenter', + #superclass : 'DTDefaultPluginPresenter', + #instVars : [ + 'sourceCodePanel', + 'coveredNodes', + 'uncoveredNodes', + 'yellowNodes' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'highlighting' } +DTCoveragePluginPresenter >> addHighlightingOf: nodesCollection withColor: aColor [ + + nodesCollection do: [ :node | + sourceCodePanel addTextSegmentDecoration: + (SpTextPresenterDecorator forHighlight + interval: + (node sourceInterval first to: node sourceInterval last + 1); + highlightColor: aColor) ] +] + +{ #category : 'initialization' } +DTCoveragePluginPresenter >> cleanAttributesForHighlighting [ + " Clean the attributes to store new value to display on Source Code panel " + + yellowNodes := OrderedCollection new. + uncoveredNodes := OrderedCollection new. + coveredNodes := OrderedCollection new +] + +{ #category : 'initialization' } +DTCoveragePluginPresenter >> connectPresenters [ + + super connectPresenters. + + self resultViewsDropList whenSelectedItemChangedDo: [ + :resultTreeViewOrNil | + resultTreeViewOrNil ifNotNil: [ + resultsList roots: + (resultTreeViewOrNil resultTreeFor: drTests pluginResult) + subResults ] ]. + + resultsList whenSelectionChangedDo: [ :selection | + (selection selectedItem isKindOf: DTTestLeafNode) ifTrue: [ + selection selectedItem ifNotNil: [ :item | + self updateSourceCodePanel: item content ] ] ] +] + +{ #category : 'layout' } +DTCoveragePluginPresenter >> defaultLayout [ + + ^ SpBoxLayout newTopToBottom + add: (SpPanedLayout newLeftToRight + add: (SpPanedLayout newLeftToRight + add: packagesList; + add: itemsList; + yourself); + add: (SpBoxLayout newTopToBottom + spacing: 5; + add: resultViewsDropList expand: false; + add: resultLabel expand: false; + add: resultsList; + add: sourceCodePanel; + yourself); + yourself); + add: startButton expand: false; + yourself +] + +{ #category : 'highlighting' } +DTCoveragePluginPresenter >> defineColorCoverage: aMethod [ + + aMethod ast nodesDo: [ :node | + node isSequence ifTrue: [ + node hasBeenExecuted + ifTrue: [ + (self hasSequenceNodeInside: node) ifFalse: [ + coveredNodes add: node ] ] + ifFalse: [ uncoveredNodes add: node ] ]. + + node isMessage ifTrue: [ self defineColorMessageNode: node ] ] +] + +{ #category : 'highlighting' } +DTCoveragePluginPresenter >> defineColorMessageNode: aMessageNode [ + "handle arguments of an ASTMessageNode" + + | blockNodes | + blockNodes := aMessageNode arguments select: [ :element | + element isBlock ]. + blockNodes ifNotEmpty: [ + (blockNodes allSatisfy: [ :arg | arg body hasBeenExecuted ]) + ifFalse: [ yellowNodes add: aMessageNode . ] ] +] + +{ #category : 'highlighting' } +DTCoveragePluginPresenter >> hasSequenceNodeInside: aSequenceNode [ + + ^ aSequenceNode statements anySatisfy: [ :statement | + statement allChildren anySatisfy: [ :node | node isSequence ] ] +] + +{ #category : 'initialization' } +DTCoveragePluginPresenter >> initializeResultsTreeAndLabel [ + + resultLabel := self newLabel label: 'Results:'. + resultsList := self newTree. + resultsList + display: [ :node | node drTestsName ]; + displayColor: [ :node | node displayColor ]; + children: [ :node | node subResults ]; + actions: self rootCommandsGroup / 'Results tools'. + + resultsList outputActivationPort transmitDo: [ + (DTResultBrowseCommand forSpecContext: self) execute ]. + sourceCodePanel := self instantiate: SpCodePresenter . +] + +{ #category : 'layout' } +DTCoveragePluginPresenter >> updateSourceCodePanel: compiledMethod [ + " The colors overlap and paint in descending order" + + self cleanAttributesForHighlighting. + self defineColorCoverage: compiledMethod. + sourceCodePanel beForMethod: compiledMethod. + sourceCodePanel text: compiledMethod sourceCode. + self + addHighlightingOf: coveredNodes + withColor: (Color r: 0.74 g: 0.98 b: 0.71). + self + addHighlightingOf: uncoveredNodes + withColor: (Color r: 0.98 g: 0.71 b: 0.71). + self + addHighlightingOf: yellowNodes + withColor: (Color r: 0.98 g: 0.95 b: 0.71). + + "Base color is green" + sourceCodePanel addTextSegmentDecoration: + (SpTextPresenterDecorator forHighlight + interval: (compiledMethod ast body sourceInterval first to: + compiledMethod ast body sourceInterval last + 1); + highlightColor: (Color r: 0.74 g: 0.98 b: 0.71)). + ^ sourceCodePanel yourself +] diff --git a/src/DrTests/DTDefaultPluginPresenter.class.st b/src/DrTests/DTDefaultPluginPresenter.class.st new file mode 100644 index 00000000..0166d608 --- /dev/null +++ b/src/DrTests/DTDefaultPluginPresenter.class.st @@ -0,0 +1,448 @@ +Class { + #name : 'DTDefaultPluginPresenter', + #superclass : 'SpPresenter', + #instVars : [ + 'packagesList', + 'resultsList', + 'itemsList', + 'resultViewsDropList', + 'resultLabel', + 'plugin', + 'drTests', + 'lastResults', + 'startButton' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'commands' } +DTDefaultPluginPresenter class >> buildCommandsGroupWith: presenterInstance forRoot: rootCommandGroup [ + + rootCommandGroup + register: (self buildContextualPackageGroupWith: presenterInstance); + register: (self buildItemsListGroupWith: presenterInstance); + register: (self buildResultGroupWith: presenterInstance) +] + +{ #category : 'private - commands' } +DTDefaultPluginPresenter class >> buildContextualPackageGroupWith: presenterInstance [ + + ^ (CmCommandGroup named: 'Package menu') asSpecGroup + register: (self buildPackageGroupWith: presenterInstance); + yourself +] + +{ #category : 'private - commands' } +DTDefaultPluginPresenter class >> buildItemsListGroupWith: presenterInstance [ + + ^ (CmCommandGroup named: 'List items menu') asSpecGroup + register: + (DTInspectSelectedItemCommand forSpecContext: presenterInstance) + beHiddenWhenCantBeRun; + register: + (DTBrowseSelectedItemCommand forSpec context: presenterInstance); + yourself +] + +{ #category : 'private - commands' } +DTDefaultPluginPresenter class >> buildPackageGroupWith: presenterInstance [ + + |group| + group := (CmCommandGroup named: 'Package tools') asSpecGroup. + group description: 'Commands related to packages list.'. + + DTPackagesCommand allSubclasses do: [:each | + group register: (each forSpec context: presenterInstance) ]. + + ^group + beDisplayedAsGroup; + yourself +] + +{ #category : 'private - commands' } +DTDefaultPluginPresenter class >> buildResultGroupWith: presenterInstance [ + + | commandGroup pluginCommands plugin | + commandGroup := (CmCommandGroup named: 'Results tools') asSpecGroup + description: 'Commands related to result.'; + register: + (DTResultBrowseCommand forSpecContext: + presenterInstance) beHiddenWhenCantBeRun; + yourself. + + plugin := presenterInstance plugin. + plugin ifNil: [ ^ commandGroup ]. + + pluginCommands := plugin buildContextualMenuGroupWith: + presenterInstance. + pluginCommands entries ifEmpty: [ ^ commandGroup ]. + ^ commandGroup + register: pluginCommands beDisplayedAsGroup; + yourself +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> browseSelectedItem [ + "Because of DTBrowseSelectedItem>>#canBeExecuted, we know there is a single item in the selection. + Thus, we take the first one and browse it. + " + + self selectedItems first drTestsBrowse +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> browseSelectedPackage [ + + self selectedPackage browse +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> browseSelectedResult [ + + self resultSelected drTestsBrowse +] + +{ #category : 'private' } +DTDefaultPluginPresenter >> buildLabelString: nameOfItems numberOfItemsSelected: aInt [ + + ^ String streamContents: [ :stream | + stream + << nameOfItems; + << ' ('; + << aInt asString; + << ' selected):' ] +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> connectPresenters [ + + super connectPresenters. + + self resultViewsDropList + whenSelectedItemChangedDo: [ :resultTreeViewOrNil | + resultTreeViewOrNil + ifNotNil: [ resultsList + roots: (resultTreeViewOrNil resultTreeFor: drTests pluginResult) subResults ] ] +] + +{ #category : 'layout' } +DTDefaultPluginPresenter >> defaultLayout [ + + ^ SpBoxLayout newTopToBottom + add: (SpPanedLayout newLeftToRight + add: (SpPanedLayout newLeftToRight + add: packagesList; + add: itemsList; + yourself); + add: (SpBoxLayout newTopToBottom + spacing: 5; + add: resultViewsDropList expand: false; + add: resultLabel expand: false; + add: resultsList; + yourself); + yourself); + add: startButton expand: false; + yourself +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> drTests [ + ^ drTests +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializeItemsListAndLabel [ + + itemsList := self newFilterableTreePresenter. + itemsList + displayIcon: [ :aClass | self iconNamed: aClass systemIconName ]; + displayColor: [ :aClass | + (self packagesSelected includes: aClass package) + ifTrue: [ self theme textColor ] + ifFalse: [ self theme classExtensionColor ] ]; + help: + 'Select the classes to analyze. Cmd+A or Ctrl+A to select all classes.'; + displayBlock: [ :item | item name ]; + whenSelectionChangedDo: [ + self whenItemsSelectionChanged: self selectedItems ]; + beMultipleSelection; + actions: (self rootCommandsGroup / 'List items menu') beRoot. + + packagesList whenSelectionChangedDo: [ + self whenPackagesSelectionChanged: self packagesSelected ] +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializePackagesListAndLabel [ + + packagesList := self newFilterableListPresenter. + packagesList + help: 'Select the packages to analyze. Cmd+A or Ctrl+A to select all packages.'; + sortingBlock: #name ascending; + displayBlock: [ :package | package name ]; + beMultipleSelection; + actions: self rootCommandsGroup / 'Package menu' +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializePresenters [ + + super initializePresenters. + + self + initializePackagesListAndLabel; + initializeItemsListAndLabel; + initializeResultsTreeAndLabel; + initializeResultViewsDropList. + + startButton := self newButton. + startButton action: [ drTests runPlugin ] +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializeResultViewsDropList [ + + resultViewsDropList := self newDropList. + self resultViewsDropList + help: 'Select the different views for results'; + display: [ :resultTreeView | resultTreeView name ] +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializeResultsTreeAndLabel [ + + resultLabel := self newLabel label: 'Results:'. + resultsList := self newTree. + resultsList + display: [ :node | node drTestsName ]; + displayColor: [ :node | node displayColor ]; + children: [ :node | node subResults ]; + actions: self rootCommandsGroup / 'Results tools'. + + resultsList outputActivationPort + transmitDo: [ + (DTResultBrowseCommand forSpecContext: self) execute ] +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> inspectSelectedItem [ + + self selectedItems first inspect +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> inspectSelectedPackage [ + + self selectedPackage inspect +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> itemsList [ + ^ itemsList +] + +{ #category : 'widgets' } +DTDefaultPluginPresenter >> newFilterableListPresenter [ + + ^ self instantiate: DTFilterableListPresenter +] + +{ #category : 'widgets' } +DTDefaultPluginPresenter >> newFilterableTreePresenter [ + + ^ self instantiate: DTFilterableTreePresenter +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> packagesList [ + ^ packagesList +] + +{ #category : 'private' } +DTDefaultPluginPresenter >> packagesSelected [ + + ^ self packagesList ifNil: [ #( ) ] ifNotNil: #selectedItems +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> plugin [ + ^ plugin +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> resultSelected [ + + ^ self resultsList selectedItem +] + +{ #category : 'api' } +DTDefaultPluginPresenter >> resultTree: aResultGroup [ + + | roots | + aResultGroup ifNil: [ ^ self ]. + roots := aResultGroup subResults. + resultsList roots: roots. + roots withIndexDo: [ :each :index | + each shouldStartExpanded ifTrue: [ + "here there was a each name crTrace. + It does not look like the good way to provide feedback in the transcript" + resultsList expandPath: { index } ] ] +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> resultViewsDropList [ + ^ resultViewsDropList +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> resultsList [ + ^ resultsList +] + +{ #category : 'api' } +DTDefaultPluginPresenter >> selectAllInPackageList [ + + packagesList selectAll +] + +{ #category : 'api' } +DTDefaultPluginPresenter >> selectNoneInPackageList [ + + packagesList unselectAll +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> selectedItems [ + + ^ itemsList selectedItems +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> selectedPackage [ + + ^ packagesList selectedItem +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> setModelBeforeInitialization: aPair [ + + plugin := aPair first. + drTests := aPair second +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> startButton [ + ^ startButton +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> subwidgetsToLock [ + + ^ { packagesList. itemsList. resultsList. startButton} +] + +{ #category : 'private - updating' } +DTDefaultPluginPresenter >> updateItemsListLabel [ + + itemsList label: (self + buildLabelString: plugin secondListLabel + numberOfItemsSelected: self selectedItems size) +] + +{ #category : 'private - updating' } +DTDefaultPluginPresenter >> updatePackagesList [ + + packagesList unselectAll. + itemsList beEmpty. + packagesList items: plugin packagesAvailableForAnalysis. + packagesList label: plugin firstListLabel. + itemsList label: plugin secondListLabel. + plugin setSelectionModeOfPackageList: packagesList. + plugin setSelectionModeOfItemsList: itemsList +] + +{ #category : 'private - updating' } +DTDefaultPluginPresenter >> updatePackagesListLabel [ + + self packagesList label: (self + buildLabelString: plugin firstListLabel + numberOfItemsSelected: self packagesSelected size) +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> updatePresenter [ + + super updatePresenter. + + self updatePackagesList. + self updateResultViewsDropList. + + startButton label: plugin startButtonLabel. + startButton help: plugin startButtonHelp +] + +{ #category : 'updating' } +DTDefaultPluginPresenter >> updateResultLabel [ + + resultLabel styles copy + do: [ :each | resultLabel removeStyle: each ]. + resultLabel + label: 'Results:'; + addStyle: lastResults backgroundColorStyle +] + +{ #category : 'updating' } +DTDefaultPluginPresenter >> updateResultViewsDropList [ + | newPragmas | + + newPragmas := plugin resultTreeViews. + (resultViewsDropList listItems = newPragmas + and: [ newPragmas isNotEmpty ]) + ifTrue: [ + "Trigger action attached to selection change." + resultViewsDropList selectedIndex: resultViewsDropList selectedIndex. + ^ self ]. + + self resultViewsDropList selectedItem + ifNotNil: [ self resultViewsDropList resetSelection ]. + self resultViewsDropList items: newPragmas. + newPragmas isNotEmpty + ifTrue: [ self resultViewsDropList selectIndex: 1 ] +] + +{ #category : 'updating' } +DTDefaultPluginPresenter >> updateWithResults: someResults [ + + lastResults := someResults. + + self updateResultViewsDropList. + self updateResultLabel. + self resultTree: lastResults buildTreeForUI. + resultsList actions: self rootCommandsGroup / 'Results tools' +] + +{ #category : 'private' } +DTDefaultPluginPresenter >> whenItemsSelectionChanged: itemsSelected [ + + self updateItemsListLabel. + drTests updateSwitchButton: itemsSelected +] + +{ #category : 'private' } +DTDefaultPluginPresenter >> whenPackagesSelectionChanged: packagesSelected [ + + itemsList + roots: ((plugin itemsToBeAnalysedFor: packagesSelected) sorted: + #name ascending); + children: [ :aClass | + aClass subclasses + & (packagesSelected flatCollect: [ :package | package classes ]) + sorted: #name ascending ]; + expandAll. + itemsList roots: itemsList items. + + itemsList selectAll. + self updatePackagesListLabel +] diff --git a/src/DrTests/DTFilterableListPresenter.class.st b/src/DrTests/DTFilterableListPresenter.class.st new file mode 100644 index 00000000..2b17bc4e --- /dev/null +++ b/src/DrTests/DTFilterableListPresenter.class.st @@ -0,0 +1,249 @@ +" +I am a list presenter that can be filtered. + +I also have a label. +" +Class { + #name : 'DTFilterableListPresenter', + #superclass : 'SpPresenter', + #instVars : [ + 'listPresenter', + 'filterTextInput', + 'initialItems', + 'labelPresenter' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'api - actions' } +DTFilterableListPresenter >> actions [ + + ^ self listPresenter actions +] + +{ #category : 'api - actions' } +DTFilterableListPresenter >> actions: aCommandGroup [ + + self listPresenter actions: aCommandGroup +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> allItems [ + + ^ initialItems +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> beEmpty [ + + self items: #() +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> beMultipleSelection [ + + ^ self listPresenter beMultipleSelection +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> beSingleSelection [ + + ^ self listPresenter beSingleSelection +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> contextMenu: aBlock [ + + ^ self listPresenter contextMenu: aBlock +] + +{ #category : 'layout' } +DTFilterableListPresenter >> defaultLayout [ + + ^ SpBoxLayout newTopToBottom + spacing: 5; + add: labelPresenter expand: false; + add: listPresenter; + add: filterTextInput expand: false; + yourself +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> displayBlock: aBlock [ + + ^ self listPresenter display: aBlock +] + +{ #category : 'api' } +DTFilterableListPresenter >> displayColor: aBlock [ + + self listPresenter displayColor: aBlock +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> displayIcon: aFullBlockClosure [ + + self listPresenter displayIcon: aFullBlockClosure +] + +{ #category : 'private - actions' } +DTFilterableListPresenter >> ensureActions [ + + ^ self listPresenter ensureActions +] + +{ #category : 'private' } +DTFilterableListPresenter >> filterList [ + "Filters the list according to the filterTextInput." + + self unselectAll. + self filterStrings + ifEmpty: [ + self listPresenter + items: initialItems. + ^ self ]. + self listPresenter + items: + (initialItems + select: [ :each | + self filterStrings + anySatisfy: [ :any | any match: (self listPresenter display value: each) ] ]) +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> filterStrings [ + + ^ (self filterTextInput text splitOn: $|) + reject: #isEmpty + thenCollect: [ :pattern | '*' , pattern , '*' ] +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> filterTextInput [ + + ^ filterTextInput +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> help [ + + ^ labelPresenter help +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> help: aString [ + + labelPresenter help: aString +] + +{ #category : 'initialization' } +DTFilterableListPresenter >> initialize [ + + super initialize. + initialItems := #() +] + +{ #category : 'initialization' } +DTFilterableListPresenter >> initializePresenters [ + + labelPresenter := self newLabel. + listPresenter := self newList. + filterTextInput := self newTextInput + placeholder: 'Filter...'; + whenTextChangedDo: [ self filterList ]; + yourself +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> items [ + + ^ self visibleItems +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> items: items [ + + initialItems := items. + self listPresenter items: items +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> label [ + + ^ labelPresenter label +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> label: aString [ + + labelPresenter label: aString +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> labelPresenter [ + + ^ labelPresenter +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> listPresenter [ + + ^ listPresenter +] + +{ #category : 'actions' } +DTFilterableListPresenter >> resetFilter [ + + self filterTextInput text: ''. + self listPresenter items: initialItems +] + +{ #category : 'actions' } +DTFilterableListPresenter >> selectAll [ + + ^ self listPresenter selectAll +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> selectItems: aBlock [ + + ^ self listPresenter selectItems: aBlock +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> selectedItem [ + + ^ listPresenter selectedItem +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> selectedItems [ + + ^ self listPresenter selectedItems +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> sortingBlock: aBlock [ + + ^ self listPresenter sortingBlock: aBlock +] + +{ #category : 'actions' } +DTFilterableListPresenter >> unselectAll [ + + ^ self listPresenter unselectAll +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> visibleItems [ + + ^ self listPresenter items +] + +{ #category : 'events' } +DTFilterableListPresenter >> whenSelectionChangedDo: aBlock [ + + ^ self listPresenter whenSelectionChangedDo: aBlock +] diff --git a/src/DrTests/DTFilterableTreePresenter.class.st b/src/DrTests/DTFilterableTreePresenter.class.st new file mode 100644 index 00000000..c48d9672 --- /dev/null +++ b/src/DrTests/DTFilterableTreePresenter.class.st @@ -0,0 +1,256 @@ +" +I am a list presenter that can be filtered. + +I also have a label. +" +Class { + #name : 'DTFilterableTreePresenter', + #superclass : 'SpPresenter', + #instVars : [ + 'treePresenter', + 'filterTextInput', + 'initialItems', + 'labelPresenter' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'api - actions' } +DTFilterableTreePresenter >> actions [ + + ^ self treePresenter actions +] + +{ #category : 'api - actions' } +DTFilterableTreePresenter >> actions: aCommandGroup [ + + self treePresenter actions: aCommandGroup +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> allItems [ + + ^ initialItems +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> beEmpty [ + + self roots: #() +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> beMultipleSelection [ + + ^ self treePresenter beMultipleSelection +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> beSingleSelection [ + + ^ self treePresenter beSingleSelection +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> children [ + + ^ self treePresenter children +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> children: aBlock [ + + self treePresenter children: aBlock +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> contextMenu: aBlock [ + + ^ self treePresenter contextMenu: aBlock +] + +{ #category : 'layout' } +DTFilterableTreePresenter >> defaultLayout [ + + ^ SpBoxLayout newTopToBottom + spacing: 5; + add: labelPresenter expand: false; + add: treePresenter; + add: filterTextInput expand: false; + yourself +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> displayBlock: aBlock [ + + ^ self treePresenter display: aBlock +] + +{ #category : 'api' } +DTFilterableTreePresenter >> displayColor: aBlock [ + + self treePresenter displayColor: aBlock +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> displayIcon: aFullBlockClosure [ + + self treePresenter displayIcon: aFullBlockClosure +] + +{ #category : 'private - actions' } +DTFilterableTreePresenter >> ensureActions [ + + ^ self treePresenter ensureActions +] + +{ #category : 'expanding-collapsing' } +DTFilterableTreePresenter >> expandAll [ + + self treePresenter expandAll +] + +{ #category : 'private' } +DTFilterableTreePresenter >> filterList [ + "Filters the list according to the filterTextInput." + + self unselectAll. + self filterStrings ifEmpty: [ + self roots: initialItems. + ^ self ]. + self roots: (initialItems select: [ :each | + self filterStrings anySatisfy: [ :any | + any match: (self treePresenter display value: each) ] ]) +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> filterStrings [ + + ^ (self filterTextInput text splitOn: $|) + reject: #isEmpty + thenCollect: [ :pattern | '*' , pattern , '*' ] +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> filterTextInput [ + + ^ filterTextInput +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> help [ + + ^ labelPresenter help +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> help: aString [ + + labelPresenter help: aString +] + +{ #category : 'initialization' } +DTFilterableTreePresenter >> initialize [ + + super initialize. + initialItems := #() +] + +{ #category : 'initialization' } +DTFilterableTreePresenter >> initializePresenters [ + + labelPresenter := self newLabel. + treePresenter := self newTree. + filterTextInput := self newTextInput + placeholder: 'Filter...'; + whenTextChangedDo: [ self filterList ]; + yourself +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> items [ + + ^ self visibleItems +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> label [ + + ^ labelPresenter label +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> label: aString [ + + labelPresenter label: aString +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> labelPresenter [ + + ^ labelPresenter +] + +{ #category : 'actions' } +DTFilterableTreePresenter >> resetFilter [ + + self filterTextInput text: ''. + self treePresenter roots: initialItems +] + +{ #category : 'api' } +DTFilterableTreePresenter >> roots: aBlock [ + + initialItems := aBlock. + self treePresenter roots: aBlock +] + +{ #category : 'actions' } +DTFilterableTreePresenter >> selectAll [ + + ^ self treePresenter selectAll +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> selectItems: aBlock [ + + ^ self treePresenter selectItems: aBlock +] + +{ #category : 'api - selection' } +DTFilterableTreePresenter >> selectPaths: aPathArray [ + + self treePresenter selectPaths: aPathArray +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> selectedItems [ + + ^ self treePresenter selectedItems +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> treePresenter [ + + ^ treePresenter +] + +{ #category : 'actions' } +DTFilterableTreePresenter >> unselectAll [ + + ^ self treePresenter unselectAll +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> visibleItems [ + + ^ self treePresenter roots +] + +{ #category : 'events' } +DTFilterableTreePresenter >> whenSelectionChangedDo: aBlock [ + + ^ self treePresenter whenSelectionChangedDo: aBlock +] diff --git a/src/DrTests/DTInspectSelectedItemCommand.class.st b/src/DrTests/DTInspectSelectedItemCommand.class.st new file mode 100644 index 00000000..6eaf53e3 --- /dev/null +++ b/src/DrTests/DTInspectSelectedItemCommand.class.st @@ -0,0 +1,22 @@ +" +I browse the selected result in the results list of DrTests. +" +Class { + #name : 'DTInspectSelectedItemCommand', + #superclass : 'DTMiddleListCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'default' } +DTInspectSelectedItemCommand class >> defaultName [ + + ^ 'Inspect' +] + +{ #category : 'executing' } +DTInspectSelectedItemCommand >> execute [ + + self context inspectSelectedItem +] diff --git a/src/DrTests/DTLeafResultCommand.class.st b/src/DrTests/DTLeafResultCommand.class.st new file mode 100644 index 00000000..9463bc28 --- /dev/null +++ b/src/DrTests/DTLeafResultCommand.class.st @@ -0,0 +1,21 @@ +" +I am an abstract command concerning DrTests' results tree but I can only be executed if a leaf is selected by user. +" +Class { + #name : 'DTLeafResultCommand', + #superclass : 'DTResultCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTLeafResultCommand class >> isAbstract [ + + ^ self name = #DTLeafResultCommand +] + +{ #category : 'hooks' } +DTLeafResultCommand >> canBeRun [ + ^ self resultSelected isLeaf +] diff --git a/src/DrTests/DTLeavesCollector.class.st b/src/DrTests/DTLeavesCollector.class.st new file mode 100644 index 00000000..22a8a280 --- /dev/null +++ b/src/DrTests/DTLeavesCollector.class.st @@ -0,0 +1,43 @@ +" +I am a visitor that collect the leaves of the DTTreeNode I visit. + +If there are multiple levels of DTTreeNode, no problem, I traverse them until I find the leaves. +" +Class { + #name : 'DTLeavesCollector', + #superclass : 'DTResultsTreeVisitor', + #instVars : [ + 'leaves' + ], + #category : 'DrTests-Visitors', + #package : 'DrTests', + #tag : 'Visitors' +} + +{ #category : 'instance creation' } +DTLeavesCollector class >> collectLeavesOf: aDTTreeNode [ + ^ self new + visit: aDTTreeNode; + leaves +] + +{ #category : 'initialization' } +DTLeavesCollector >> initialize [ + super initialize. + leaves := OrderedCollection new +] + +{ #category : 'accessing' } +DTLeavesCollector >> leaves [ + ^ leaves +] + +{ #category : 'accessing' } +DTLeavesCollector >> leaves: anObject [ + leaves := anObject +] + +{ #category : 'visiting' } +DTLeavesCollector >> visitDTTreeLeaf: aDTTreeLeaf [ + self leaves add: aDTTreeLeaf +] diff --git a/src/DrTests/DTMiddleListCommand.class.st b/src/DrTests/DTMiddleListCommand.class.st new file mode 100644 index 00000000..84d36a34 --- /dev/null +++ b/src/DrTests/DTMiddleListCommand.class.st @@ -0,0 +1,22 @@ +" +I am an abstract command concerning DrTests' middle list. +" +Class { + #name : 'DTMiddleListCommand', + #superclass : 'DTCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTMiddleListCommand class >> isAbstract [ + + ^ self name = #DTMiddleListCommand +] + +{ #category : 'accessing' } +DTMiddleListCommand >> selectedItems [ + + ^ self context selectedItems +] diff --git a/src/DrTests/DTNullPluginPresenter.class.st b/src/DrTests/DTNullPluginPresenter.class.st new file mode 100644 index 00000000..b45c216a --- /dev/null +++ b/src/DrTests/DTNullPluginPresenter.class.st @@ -0,0 +1,17 @@ +Class { + #name : 'DTNullPluginPresenter', + #superclass : 'SpPresenter', + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'layout' } +DTNullPluginPresenter >> defaultLayout [ + + ^ SpBoxLayout newHorizontal +] + +{ #category : 'updating' } +DTNullPluginPresenter >> updateUI [ +] diff --git a/src/DrTests/DTPackagesBrowseCommand.class.st b/src/DrTests/DTPackagesBrowseCommand.class.st new file mode 100644 index 00000000..54db0c5d --- /dev/null +++ b/src/DrTests/DTPackagesBrowseCommand.class.st @@ -0,0 +1,22 @@ +" +I browse the selected package in the package list of DrTests. +" +Class { + #name : 'DTPackagesBrowseCommand', + #superclass : 'DTPackagesCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'default' } +DTPackagesBrowseCommand class >> defaultName [ + + ^ 'Browse' +] + +{ #category : 'executing' } +DTPackagesBrowseCommand >> execute [ + + self context browseSelectedPackage +] diff --git a/src/DrTests/DTPackagesCommand.class.st b/src/DrTests/DTPackagesCommand.class.st new file mode 100644 index 00000000..a94761a8 --- /dev/null +++ b/src/DrTests/DTPackagesCommand.class.st @@ -0,0 +1,16 @@ +" +I am an abstract command concerning DrTests' package list. +" +Class { + #name : 'DTPackagesCommand', + #superclass : 'DTCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTPackagesCommand class >> isAbstract [ + + ^ self name = #DTPackagesCommand +] diff --git a/src/DrTests/DTPackagesInspectCommand.class.st b/src/DrTests/DTPackagesInspectCommand.class.st new file mode 100644 index 00000000..5d7bfb1d --- /dev/null +++ b/src/DrTests/DTPackagesInspectCommand.class.st @@ -0,0 +1,22 @@ +" +I inspect the selected package in the package list of DrTests. +" +Class { + #name : 'DTPackagesInspectCommand', + #superclass : 'DTPackagesCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'default' } +DTPackagesInspectCommand class >> defaultName [ + + ^ 'Inspect' +] + +{ #category : 'executing' } +DTPackagesInspectCommand >> execute [ + + self context inspectSelectedPackage +] diff --git a/src/DrTests/DTPackagesSelectAllCommand.class.st b/src/DrTests/DTPackagesSelectAllCommand.class.st new file mode 100644 index 00000000..de3b19e5 --- /dev/null +++ b/src/DrTests/DTPackagesSelectAllCommand.class.st @@ -0,0 +1,22 @@ +" +I select all packages in the package list of DrTests. +" +Class { + #name : 'DTPackagesSelectAllCommand', + #superclass : 'DTPackagesCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'defaults' } +DTPackagesSelectAllCommand class >> defaultName [ + + ^ 'Select all' +] + +{ #category : 'hooks' } +DTPackagesSelectAllCommand >> execute [ + + self context selectAllInPackageList +] diff --git a/src/DrTests/DTPackagesSelectNoneCommand.class.st b/src/DrTests/DTPackagesSelectNoneCommand.class.st new file mode 100644 index 00000000..516647af --- /dev/null +++ b/src/DrTests/DTPackagesSelectNoneCommand.class.st @@ -0,0 +1,22 @@ +" +I deselect all packages in the package list of DrTests. +" +Class { + #name : 'DTPackagesSelectNoneCommand', + #superclass : 'DTPackagesCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'defaults' } +DTPackagesSelectNoneCommand class >> defaultName [ + + ^ 'Select none' +] + +{ #category : 'executing' } +DTPackagesSelectNoneCommand >> execute [ + + self context selectNoneInPackageList +] diff --git a/src/DrTests/DTPluginConfiguration.class.st b/src/DrTests/DTPluginConfiguration.class.st new file mode 100644 index 00000000..4e0ebc6f --- /dev/null +++ b/src/DrTests/DTPluginConfiguration.class.st @@ -0,0 +1,81 @@ +" +I hold the information that would be used by a DrTestPlugin. +" +Class { + #name : 'DTPluginConfiguration', + #superclass : 'Object', + #instVars : [ + 'items', + 'packagesSelected', + 'testSuite' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'tests' } +DTPluginConfiguration class >> items: aCollectionOfClasses [ + ^ self new + items: aCollectionOfClasses; + yourself +] + +{ #category : 'tests' } +DTPluginConfiguration class >> items: aCollectionOfClasses packages: aCollectionOfPackages [ + ^ self new + items: aCollectionOfClasses; + packagesSelected: aCollectionOfPackages; + yourself +] + +{ #category : 'converting' } +DTPluginConfiguration >> asTestSuite [ + | suite | + suite := TestSuite new. + self items + reject: #isAbstract + thenDo: [ :s | suite addTest: s suite ]. + ^ suite +] + +{ #category : 'result handling' } +DTPluginConfiguration >> handleResults: aPluginResult for: aPlugin [ + ^ aPluginResult +] + +{ #category : 'accessing' } +DTPluginConfiguration >> items [ + ^ items +] + +{ #category : 'accessing' } +DTPluginConfiguration >> items: anObject [ + items := anObject +] + +{ #category : 'accessing' } +DTPluginConfiguration >> items: anObject packages: packages [ + items := anObject. + packagesSelected := packages +] + +{ #category : 'accessing' } +DTPluginConfiguration >> packagesSelected [ + ^ packagesSelected +] + +{ #category : 'accessing' } +DTPluginConfiguration >> packagesSelected: packages [ + packagesSelected := packages +] + +{ #category : 'accessing' } +DTPluginConfiguration >> testSuite [ + ^ testSuite +] + +{ #category : 'accessing' } +DTPluginConfiguration >> testSuite: anObject [ + testSuite := anObject +] diff --git a/src/DrTests/DTPluginResult.class.st b/src/DrTests/DTPluginResult.class.st new file mode 100644 index 00000000..b362f9e1 --- /dev/null +++ b/src/DrTests/DTPluginResult.class.st @@ -0,0 +1,38 @@ +" +I am the abstract superclass for all classes that are results of a plugin in DrTests. +" +Class { + #name : 'DTPluginResult', + #superclass : 'Object', + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'accessing' } +DTPluginResult >> backgroundColorStyle [ + + ^ 'testResult' +] + +{ #category : 'accessing' } +DTPluginResult >> buildTreeForUI [ + ^ self subclassResponsibility +] + +{ #category : 'accessing' } +DTPluginResult >> summarizeInfo [ + "Text showed in miniDrTests with info of the result " + + ^ self asString +] + +{ #category : 'accessing' } +DTPluginResult >> textColor [ + ^ TestResult defaultColorText +] + +{ #category : 'accessing' } +DTPluginResult >> theme [ + ^ Smalltalk ui theme +] diff --git a/src/DrTests/DTReRunConfiguration.class.st b/src/DrTests/DTReRunConfiguration.class.st new file mode 100644 index 00000000..fa98115a --- /dev/null +++ b/src/DrTests/DTReRunConfiguration.class.st @@ -0,0 +1,50 @@ +" +I am a configuration that re-run a part of the result of a previously-run configuration. +" +Class { + #name : 'DTReRunConfiguration', + #superclass : 'DTPluginConfiguration', + #instVars : [ + 'previousResult', + 'configurationToRun', + 'originalConfiguration' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'converting' } +DTReRunConfiguration >> asTestSuite [ + ^ self configurationToRun asTestSuite +] + +{ #category : 'accessing' } +DTReRunConfiguration >> configurationToRun [ + ^ configurationToRun +] + +{ #category : 'accessing' } +DTReRunConfiguration >> configurationToRun: anObject [ + configurationToRun := anObject +] + +{ #category : 'accessing' } +DTReRunConfiguration >> originalConfiguration [ + ^ originalConfiguration +] + +{ #category : 'accessing' } +DTReRunConfiguration >> originalConfiguration: anObject [ + originalConfiguration := anObject +] + +{ #category : 'accessing' } +DTReRunConfiguration >> previousResult [ + ^ previousResult +] + +{ #category : 'accessing' } +DTReRunConfiguration >> previousResult: anObject [ + previousResult := anObject +] diff --git a/src/DrTests/DTResultBrowseCommand.class.st b/src/DrTests/DTResultBrowseCommand.class.st new file mode 100644 index 00000000..378e1a55 --- /dev/null +++ b/src/DrTests/DTResultBrowseCommand.class.st @@ -0,0 +1,26 @@ +" +I browse the result selected by user of DrTests. +" +Class { + #name : 'DTResultBrowseCommand', + #superclass : 'DTLeafResultCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'defaults' } +DTResultBrowseCommand class >> defaultName [ + + ^ 'Browse' +] + +{ #category : 'testing' } +DTResultBrowseCommand >> canBeExecuted [ + ^ self resultSelected canBeBrowsed +] + +{ #category : 'hooks' } +DTResultBrowseCommand >> execute [ + self context browseSelectedResult +] diff --git a/src/DrTests/DTResultCommand.class.st b/src/DrTests/DTResultCommand.class.st new file mode 100644 index 00000000..aaba608e --- /dev/null +++ b/src/DrTests/DTResultCommand.class.st @@ -0,0 +1,21 @@ +" +I am an abstract command concerning DrTests' results tree. +" +Class { + #name : 'DTResultCommand', + #superclass : 'DTCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTResultCommand class >> isAbstract [ + + ^ self name = #DTResultCommand +] + +{ #category : 'hooks' } +DTResultCommand >> resultSelected [ + ^ self context resultSelected +] diff --git a/src/DrTests/DTResultTreeView.class.st b/src/DrTests/DTResultTreeView.class.st new file mode 100644 index 00000000..d41c6854 --- /dev/null +++ b/src/DrTests/DTResultTreeView.class.st @@ -0,0 +1,49 @@ +" +I model a tree view that can be created on a DTPluginResult. +" +Class { + #name : 'DTResultTreeView', + #superclass : 'Object', + #instVars : [ + 'name', + 'blockToExtractViewFromResult' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'instance creation' } +DTResultTreeView class >> name: aString blockToExtractViewFromResult: blockToExtractViewFromResult [ + ^ self new + name: aString; + blockToExtractViewFromResult: blockToExtractViewFromResult; + yourself +] + +{ #category : 'accessing' } +DTResultTreeView >> blockToExtractViewFromResult [ + ^ blockToExtractViewFromResult +] + +{ #category : 'accessing' } +DTResultTreeView >> blockToExtractViewFromResult: anObject [ + blockToExtractViewFromResult := anObject +] + +{ #category : 'accessing' } +DTResultTreeView >> name [ + ^ name +] + +{ #category : 'accessing' } +DTResultTreeView >> name: anObject [ + name := anObject +] + +{ #category : 'accessing' } +DTResultTreeView >> resultTreeFor: result [ + result ifNil: [ + ^ DTTreeNode empty ]. + ^ self blockToExtractViewFromResult value: result +] diff --git a/src/DrTests/DTResultsTreeVisitor.class.st b/src/DrTests/DTResultsTreeVisitor.class.st new file mode 100644 index 00000000..9e8bf4ea --- /dev/null +++ b/src/DrTests/DTResultsTreeVisitor.class.st @@ -0,0 +1,25 @@ +" +I am an abstract visitor for the results tree of DrTests. +" +Class { + #name : 'DTResultsTreeVisitor', + #superclass : 'Object', + #category : 'DrTests-Visitors', + #package : 'DrTests', + #tag : 'Visitors' +} + +{ #category : 'visiting' } +DTResultsTreeVisitor >> visit: anObject [ + ^ anObject acceptVisitor: self +] + +{ #category : 'visiting' } +DTResultsTreeVisitor >> visitDTTreeLeaf: aDTTreeLeaf [ + ^ self subclassResponsibility +] + +{ #category : 'visiting' } +DTResultsTreeVisitor >> visitDTTreeNode: aDTTreeNode [ + ^ aDTTreeNode subResults collect: [ :subResult | self visit: subResult ] +] diff --git a/src/DrTests/DTStatusUpdate.class.st b/src/DrTests/DTStatusUpdate.class.st new file mode 100644 index 00000000..a956f332 --- /dev/null +++ b/src/DrTests/DTStatusUpdate.class.st @@ -0,0 +1,33 @@ +" +I am an announcement to force the UI to refresh the status bar. +This is useful when the results are handled in a asynchronous way +" +Class { + #name : 'DTStatusUpdate', + #superclass : 'Announcement', + #instVars : [ + 'message' + ], + #category : 'DrTests-Announcements', + #package : 'DrTests', + #tag : 'Announcements' +} + +{ #category : 'instance creation' } +DTStatusUpdate class >> message: aString [ + + ^ self new + message: aString; + yourself +] + +{ #category : 'accessing' } +DTStatusUpdate >> message [ + + ^ message +] + +{ #category : 'accessing' } +DTStatusUpdate >> message: anObject [ + message := anObject +] diff --git a/src/DrTests/DTStyleContributor.class.st b/src/DrTests/DTStyleContributor.class.st new file mode 100644 index 00000000..1accbefa --- /dev/null +++ b/src/DrTests/DTStyleContributor.class.st @@ -0,0 +1,38 @@ +Class { + #name : 'DTStyleContributor', + #superclass : 'StPharoStyleContributor', + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'styles' } +DTStyleContributor >> styleSheetContribution [ + + ^ SpStyle newApplication + addClass: 'testError' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: TestResult defaultColorBackGroundForErrorTest ] ]; + "addClass: 'testExpectedFailure' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: Color transparent ] ];" + addClass: 'testFail' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: TestResult defaultColorBackGroundForFailureTest ] ]; + addClass: 'testPass' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: TestResult defaultColorBackGroundForPassingTest ] ]; + addClass: 'testSkipped' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: TestResult defaultColorBackGroundForPassingTest ] ]; + "addClass: 'testUnexpectedPass' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: Color gray ] ];" + yourself +] + +{ #category : 'styles' } +DTStyleContributor >> theme [ + + ^ Smalltalk ui theme +] diff --git a/src/DrTests/DTTreeLeafNode.class.st b/src/DrTests/DTTreeLeafNode.class.st new file mode 100644 index 00000000..c6b5e9b3 --- /dev/null +++ b/src/DrTests/DTTreeLeafNode.class.st @@ -0,0 +1,68 @@ +" +I am a leaf of a Result Tree. +I have te content and I know the way to browse myself. +" +Class { + #name : 'DTTreeLeafNode', + #superclass : 'DTAbstractTreeNode', + #instVars : [ + 'content' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'instance creation' } +DTTreeLeafNode class >> content: aRottenTest [ + ^ self new + content: aRottenTest; + yourself +] + +{ #category : 'visiting' } +DTTreeLeafNode >> acceptVisitor: aDTResultsTreeVisitor [ + ^ aDTResultsTreeVisitor visitDTTreeLeaf: self +] + +{ #category : 'testing' } +DTTreeLeafNode >> canBeBrowsed [ + + ^ true +] + +{ #category : 'accessing' } +DTTreeLeafNode >> content [ + ^ content +] + +{ #category : 'accessing' } +DTTreeLeafNode >> content: anObject [ + content := anObject +] + +{ #category : 'accessing' } +DTTreeLeafNode >> contentForReRun [ + ^ { self content } +] + +{ #category : 'actions' } +DTTreeLeafNode >> drTestsBrowse [ + self content drTestsBrowse +] + +{ #category : 'menu' } +DTTreeLeafNode >> drTestsBuildContextMenu: menu [ + self content drTestsBuildContextMenu: menu +] + +{ #category : 'accessing' } +DTTreeLeafNode >> drTestsName [ + ^ self content drTestsName +] + +{ #category : 'testing' } +DTTreeLeafNode >> isLeaf [ + + ^ true +] diff --git a/src/DrTests/DTTreeNode.class.st b/src/DrTests/DTTreeNode.class.st new file mode 100644 index 00000000..d7561e50 --- /dev/null +++ b/src/DrTests/DTTreeNode.class.st @@ -0,0 +1,167 @@ +" +I am a node from a tree used to show results in DrTestUI. + +" +Class { + #name : 'DTTreeNode', + #superclass : 'DTAbstractTreeNode', + #instVars : [ + 'name', + 'subResults', + 'contextMenuBlock', + 'subResultsAggregator', + 'browseBlock', + 'shouldStartExpanded', + 'displayColor' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'instance creation' } +DTTreeNode class >> empty [ + ^ self new + subResults: #(); + yourself +] + +{ #category : 'visiting' } +DTTreeNode >> acceptVisitor: aDTResultsTreeVisitor [ + ^ aDTResultsTreeVisitor visitDTTreeNode: self +] + +{ #category : 'accessing' } +DTTreeNode >> browseBlock [ + ^ browseBlock +] + +{ #category : 'accessing' } +DTTreeNode >> browseBlock: anObject [ + browseBlock := anObject +] + +{ #category : 'testing' } +DTTreeNode >> canBeBrowsed [ + + ^ self browseBlock isNotNil +] + +{ #category : 'accessing' } +DTTreeNode >> contentForReRun [ + ^ (DTLeavesCollector collectLeavesOf: self) flatCollect: #contentForReRun +] + +{ #category : 'accessing' } +DTTreeNode >> contextMenuBlock [ + ^ contextMenuBlock +] + +{ #category : 'accessing' } +DTTreeNode >> contextMenuBlock: anObject [ + contextMenuBlock := anObject +] + +{ #category : 'accessing' } +DTTreeNode >> displayColor [ + + ^ displayColor value +] + +{ #category : 'accessing' } +DTTreeNode >> displayColor: aValuableOrColor [ + + displayColor := aValuableOrColor +] + +{ #category : 'accessing' } +DTTreeNode >> displayColorIfNotEmpty: aColor [ + + self displayColor: [ + self subResults + ifNotEmpty: [ aColor ] + ifEmpty: [ nil ] ] +] + +{ #category : 'actions' } +DTTreeNode >> drTestsBrowse [ + "Browse the tree node according to what is specified by my #browseBlock. + If my #browseBlock is nil, does nothing." + self canBeBrowsed + ifFalse: [ ^ self ]. + + self browseBlock cull: self +] + +{ #category : 'menu' } +DTTreeNode >> drTestsBuildContextMenu: menu [ + self contextMenuBlock value: menu +] + +{ #category : 'accessing' } +DTTreeNode >> drTestsName [ + + ^ String streamContents: [ :s | + s + << self name; + << ' ('; + << (self subResultsAggregator value: self subResults) asString; + << ')' ] +] + +{ #category : 'initialization' } +DTTreeNode >> initialize [ + + super initialize. + self contextMenuBlock: [ :menu | ]. "Does nothing by default." + self subResultsAggregator: [ :subRes | (DTLeavesCollector collectLeavesOf: self) size ]. + shouldStartExpanded := false +] + +{ #category : 'accessing' } +DTTreeNode >> name [ + ^ name +] + +{ #category : 'accessing' } +DTTreeNode >> name: anObject [ + name := anObject +] + +{ #category : 'testing' } +DTTreeNode >> shouldStartExpanded [ + + ^ shouldStartExpanded +] + +{ #category : 'accessing' } +DTTreeNode >> startContracted [ + + shouldStartExpanded := false +] + +{ #category : 'accessing' } +DTTreeNode >> startExpanded [ + + shouldStartExpanded := true +] + +{ #category : 'accessing' } +DTTreeNode >> subResults [ + ^ subResults +] + +{ #category : 'accessing' } +DTTreeNode >> subResults: anObject [ + subResults := anObject +] + +{ #category : 'accessing' } +DTTreeNode >> subResultsAggregator [ + ^ subResultsAggregator +] + +{ #category : 'accessing' } +DTTreeNode >> subResultsAggregator: anObject [ + subResultsAggregator := anObject +] diff --git a/src/DrTests/DTUpdateResults.class.st b/src/DrTests/DTUpdateResults.class.st new file mode 100644 index 00000000..7185d9ee --- /dev/null +++ b/src/DrTests/DTUpdateResults.class.st @@ -0,0 +1,26 @@ +" +I am an announcement to force the UI to refresh the results. +This is useful when the results are handled in a asynchronous way +" +Class { + #name : 'DTUpdateResults', + #superclass : 'Announcement', + #instVars : [ + 'results' + ], + #category : 'DrTests-Announcements', + #package : 'DrTests', + #tag : 'Announcements' +} + +{ #category : 'accessing' } +DTUpdateResults >> results [ + + ^ results +] + +{ #category : 'accessing' } +DTUpdateResults >> results: anObject [ + + results := anObject +] diff --git a/src/DrTests/DrTests.class.st b/src/DrTests/DrTests.class.st new file mode 100644 index 00000000..a13213aa --- /dev/null +++ b/src/DrTests/DrTests.class.st @@ -0,0 +1,321 @@ +" +I provide the ability to: +* select a plugin to create/run tests +* select sets of items to analyze +* obtain a detailed log of the results + +UI Description +___________ + +The droplist contains all the plugins available to start the analysis. + +My left-most pane lists all of the categories that contain items (could subclasses of TestCase, executable comments, etc.); Once items are selected, the items that can be analyzed appear in the pane to right. +The right-most pane shows the results in different groups, depends the plugin's analysis. + +Run and browse buttons behaviour are defined by the current plugin selected. + + +" +Class { + #name : 'DrTests', + #superclass : 'AbstractDrTestsPresenter', + #instVars : [ + 'pluginsDropList', + 'statusLabel', + 'plugins', + 'pluginPresenter' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'tools registry' } +DrTests class >> beDefaultTestRunner [ +