author | Claus Gittinger <cg@exept.de> |
Wed, 07 Mar 2018 23:06:40 +0100 | |
changeset 704 | 399ebe2a2280 |
parent 436 | 1039a85f325b |
child 724 | 4dae63fce9f9 |
permissions | -rw-r--r-- |
0 | 1 |
"{ Package: 'stx:goodies/sunit' }" |
2 |
||
3 |
Object subclass:#TestSuitesScripter |
|
4 |
instanceVariableNames:'script stream' |
|
5 |
classVariableNames:'' |
|
6 |
poolDictionaries:'' |
|
6
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
7 |
category:'SUnit-Base' |
0 | 8 |
! |
9 |
||
14 | 10 |
|
68 | 11 |
!TestSuitesScripter class methodsFor:'example'! |
0 | 12 |
|
13 |
exampleScripting |
|
14 |
^(TestSuitesScripter script: ' "scratch suite 3" ExampleSetTest SUnitTest* ') value |
|
15 |
||
16 |
"Modified: / 21.6.2000 / 10:18:08 / Sames" |
|
17 |
! ! |
|
18 |
||
184 | 19 |
!TestSuitesScripter class methodsFor:'initialization & release'! |
0 | 20 |
|
37 | 21 |
run: testClassNameString |
22 |
^self new run: testClassNameString |
|
6
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
23 |
! |
0 | 24 |
|
25 |
script: aString |
|
6
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
26 |
^self new setScript: aString |
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
27 |
! ! |
0 | 28 |
|
68 | 29 |
!TestSuitesScripter methodsFor:'printing'! |
0 | 30 |
|
31 |
printOn: aStream |
|
32 |
aStream nextPutAll: (script isNil |
|
33 |
ifFalse: [script] |
|
34 |
ifTrue: ['N/A']) |
|
35 |
||
36 |
"Created: / 21.6.2000 / 10:15:29 / Sames" |
|
37 |
! ! |
|
38 |
||
68 | 39 |
!TestSuitesScripter methodsFor:'private'! |
0 | 40 |
|
41 |
executeSingleSuiteScript: aString |
|
32 | 42 |
| useHierachy realName testCase | |
43 |
aString last = $* |
|
44 |
ifTrue: |
|
45 |
[realName := aString copyFrom: 1 to: aString size - 1. |
|
46 |
useHierachy := true] |
|
47 |
ifFalse: |
|
48 |
[realName := aString. |
|
49 |
useHierachy := false]. |
|
50 |
realName isEmpty ifTrue: [^nil]. |
|
54 | 51 |
testCase := Smalltalk classNamed: realName asSymbol. |
32 | 52 |
testCase isNil ifTrue: [^nil]. |
53 |
^useHierachy |
|
54 |
ifTrue: [self hierachyOfTestSuitesFrom: testCase] |
|
55 |
ifFalse: [testCase suite] |
|
0 | 56 |
|
57 |
"Modified: / 21.6.2000 / 10:16:02 / Sames" |
|
58 |
! |
|
59 |
||
60 |
getNextToken |
|
61 |
[stream atEnd not and: [stream peek first = $"]] whileTrue: [self skipComment]. |
|
62 |
^stream atEnd not |
|
63 |
ifTrue: [stream next] |
|
64 |
ifFalse: [nil] |
|
65 |
||
66 |
"Modified: / 21.6.2000 / 10:16:16 / Sames" |
|
67 |
! |
|
68 |
||
69 |
hierachyOfTestSuitesFrom: aTestCase |
|
32 | 70 |
| subSuite | |
71 |
subSuite := TestSuite new. |
|
37 | 72 |
subSuite name:aTestCase name. |
32 | 73 |
subSuite addTest: aTestCase suite. |
123
5fb90858d4e6
Undefined: Behavior>>sunitAsClass
Stefan Vogel <sv@exept.de>
parents:
68
diff
changeset
|
74 |
aTestCase allSubclasses do: [:each | subSuite addTest:(Smalltalk classNamed:each name asSymbol) suite]. |
32 | 75 |
^subSuite |
0 | 76 |
|
77 |
"Modified: / 21.6.2000 / 10:16:29 / Sames" |
|
78 |
! |
|
79 |
||
80 |
setScript: aString |
|
6
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
81 |
script := aString |
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
82 |
! |
0 | 83 |
|
84 |
skipComment |
|
85 |
| token inComment | |
|
86 |
token := stream next. |
|
87 |
token size > 1 & (token last = $") ifTrue: [^nil]. |
|
88 |
inComment := true. |
|
89 |
[inComment & stream atEnd not] |
|
90 |
whileTrue: |
|
91 |
[token := stream next. |
|
92 |
token last = $" ifTrue: [inComment := false]] |
|
93 |
||
94 |
"Modified: / 21.6.2000 / 10:16:47 / Sames" |
|
95 |
! ! |
|
96 |
||
68 | 97 |
!TestSuitesScripter methodsFor:'scripting'! |
0 | 98 |
|
37 | 99 |
run: testClassNameString |
32 | 100 |
| suite subSuite token | |
101 |
suite := TestSuite new. |
|
37 | 102 |
suite name:testClassNameString. |
103 |
||
104 |
stream := ReadStream on: testClassNameString asArrayOfSubstrings. |
|
32 | 105 |
[stream atEnd] whileFalse: |
106 |
[token := self getNextToken. |
|
107 |
token notNil ifTrue: [ |
|
108 |
subSuite := self executeSingleSuiteScript: token. |
|
109 |
subSuite notNil ifTrue:[suite addTest: subSuite]]]. |
|
110 |
^suite |
|
0 | 111 |
|
112 |
"Modified: / 21.6.2000 / 10:17:11 / Sames" |
|
113 |
! |
|
114 |
||
115 |
value |
|
6
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
116 |
^self run: script |
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
117 |
! ! |
0 | 118 |
|
14 | 119 |
!TestSuitesScripter class methodsFor:'documentation'! |
120 |
||
121 |
version |
|
436
1039a85f325b
fixed: #version_SVN ($ to §)
Claus Gittinger <cg@exept.de>
parents:
222
diff
changeset
|
122 |
^ '$Header: /cvs/stx/stx/goodies/sunit/TestSuitesScripter.st,v 1.11 2011-11-24 11:51:24 cg Exp $' |
222 | 123 |
! |
124 |
||
125 |
version_SVN |
|
436
1039a85f325b
fixed: #version_SVN ($ to §)
Claus Gittinger <cg@exept.de>
parents:
222
diff
changeset
|
126 |
^ '§Id: TestSuitesScripter.st,v 1.10 2011/06/29 19:15:49 cg Exp §' |
14 | 127 |
! ! |