author | Claus Gittinger <cg@exept.de> |
Tue, 04 Sep 2001 15:07:08 +0200 | |
changeset 32 | 77f76ea3a7ef |
parent 14 | a4a5478621e3 |
child 37 | 6da5b7e8e3ab |
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 |
|
0 | 11 |
!TestSuitesScripter class methodsFor:'Example'! |
12 |
||
13 |
exampleScripting |
|
14 |
^(TestSuitesScripter script: ' "scratch suite 3" ExampleSetTest SUnitTest* ') value |
|
15 |
||
16 |
"Modified: / 21.6.2000 / 10:18:08 / Sames" |
|
17 |
! ! |
|
18 |
||
19 |
!TestSuitesScripter class methodsFor:'Init / Release'! |
|
20 |
||
21 |
run: aString |
|
6
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
22 |
^self new run: aString |
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 |
|
29 |
!TestSuitesScripter methodsFor:'Printing'! |
|
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 |
||
39 |
!TestSuitesScripter methodsFor:'Private'! |
|
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]. |
|
51 |
testCase := SUnitNameResolver classNamed: realName asSymbol. |
|
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. |
|
72 |
subSuite addTest: aTestCase suite. |
|
73 |
aTestCase allSubclasses do: [:each | subSuite addTest: each name asSymbol sunitAsClass suite]. |
|
74 |
^subSuite |
|
0 | 75 |
|
76 |
"Modified: / 21.6.2000 / 10:16:29 / Sames" |
|
77 |
! |
|
78 |
||
79 |
setScript: aString |
|
6
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
80 |
script := aString |
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
81 |
! |
0 | 82 |
|
83 |
skipComment |
|
84 |
| token inComment | |
|
85 |
token := stream next. |
|
86 |
token size > 1 & (token last = $") ifTrue: [^nil]. |
|
87 |
inComment := true. |
|
88 |
[inComment & stream atEnd not] |
|
89 |
whileTrue: |
|
90 |
[token := stream next. |
|
91 |
token last = $" ifTrue: [inComment := false]] |
|
92 |
||
93 |
"Modified: / 21.6.2000 / 10:16:47 / Sames" |
|
94 |
! ! |
|
95 |
||
96 |
!TestSuitesScripter methodsFor:'Scripting'! |
|
97 |
||
98 |
run: aString |
|
32 | 99 |
| suite subSuite token | |
100 |
suite := TestSuite new. |
|
101 |
stream := ReadStream on: aString asArrayOfSubstrings. |
|
102 |
[stream atEnd] whileFalse: |
|
103 |
[token := self getNextToken. |
|
104 |
token notNil ifTrue: [ |
|
105 |
subSuite := self executeSingleSuiteScript: token. |
|
106 |
subSuite notNil ifTrue:[suite addTest: subSuite]]]. |
|
107 |
^suite |
|
0 | 108 |
|
109 |
"Modified: / 21.6.2000 / 10:17:11 / Sames" |
|
110 |
! |
|
111 |
||
112 |
value |
|
6
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
113 |
^self run: script |
78bb1397e43d
added rerun-defect tests; fixed button enable bug
Claus Gittinger <cg@exept.de>
parents:
0
diff
changeset
|
114 |
! ! |
0 | 115 |
|
14 | 116 |
!TestSuitesScripter class methodsFor:'documentation'! |
117 |
||
118 |
version |
|
32 | 119 |
^ '$Header: /cvs/stx/stx/goodies/sunit/TestSuitesScripter.st,v 1.4 2001-09-04 13:06:59 cg Exp $' |
14 | 120 |
! ! |