SUnit.st 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521
  1. Smalltalk createPackage: 'SUnit'!
  2. Object subclass: #ResultAnnouncement
  3. slots: {#result}
  4. package: 'SUnit'!
  5. !ResultAnnouncement commentStamp!
  6. I get signaled when a `TestCase` has been run.
  7. My instances hold the result (instance of `TestResult`) of the test run.!
  8. !ResultAnnouncement methodsFor: 'accessing'!
  9. result
  10. ^ result
  11. !
  12. result: aTestResult
  13. result := aTestResult
  14. ! !
  15. Object subclass: #Teachable
  16. slots: {#learnings}
  17. package: 'SUnit'!
  18. !Teachable commentStamp!
  19. An object you can teach how to behave. Have a look at the
  20. class side for an example.
  21. For more infos have a look at: http://lists.squeakfoundation.org/pipermail/squeak-dev/2002-April/038170.html!
  22. !Teachable methodsFor: 'private'!
  23. doesNotUnderstand: aMessage
  24. | learning |
  25. learning := self learnings
  26. at: aMessage selector
  27. ifAbsent:[ ^super doesNotUnderstand: aMessage ].
  28. ^ learning class == Association
  29. ifTrue: [learning value]
  30. ifFalse: [learning valueWithPossibleArguments: aMessage arguments]
  31. !
  32. learnings
  33. learnings isNil ifTrue: [learnings := Dictionary new].
  34. ^learnings
  35. ! !
  36. !Teachable methodsFor: 'teaching'!
  37. acceptSend: aSymbol
  38. self whenSend: aSymbol return: self
  39. !
  40. whenSend: aSymbol evaluate: aBlock
  41. self learnings at: aSymbol put: aBlock
  42. !
  43. whenSend: aSymbol return: anObject
  44. self learnings at: aSymbol put: (#return -> anObject)
  45. ! !
  46. !Teachable class methodsFor: 'examples'!
  47. example
  48. | teachable |
  49. teachable := self new.
  50. teachable
  51. whenSend: #help return: 'ok';
  52. whenSend: #doit evaluate: [1 inspect];
  53. acceptSend: #noDebugger;
  54. whenSend: #negate: evaluate: [:num | num negated].
  55. teachable help.
  56. teachable doit.
  57. teachable noDebugger.
  58. teachable negate: 120
  59. ! !
  60. Object subclass: #TestCase
  61. slots: {#testSelector. #asyncTimeout. #context}
  62. package: 'SUnit'!
  63. !TestCase commentStamp!
  64. I am an implementation of the command pattern to run a test.
  65. ## API
  66. My instances are created with the class method `#selector:`,
  67. passing the symbol that names the method to be executed when the test case runs.
  68. When you discover a new fixture, subclass `TestCase` and create a `#test...` method for the first test.
  69. As that method develops and more `#test...` methods are added, you will find yourself refactoring temps
  70. into instance variables for the objects in the fixture and overriding `#setUp` to initialize these variables.
  71. As required, override `#tearDown` to nil references, release objects and deallocate.!
  72. !TestCase methodsFor: 'accessing'!
  73. context: aRunningTestContext
  74. context := aRunningTestContext
  75. !
  76. selector
  77. ^ testSelector
  78. !
  79. setTestSelector: aSelector
  80. testSelector := aSelector
  81. ! !
  82. !TestCase methodsFor: 'async'!
  83. async: aBlock
  84. | c |
  85. self errorIfNotAsync: '#async'.
  86. c := context.
  87. ^ [ self isAsync ifTrue: [ c execute: aBlock ] ]
  88. !
  89. finished
  90. self errorIfNotAsync: '#finished'.
  91. asyncTimeout := nil
  92. !
  93. timeout: aNumber
  94. "Set a grace time timeout in milliseconds to run the test asynchronously"
  95. asyncTimeout ifNotNil: [ asyncTimeout clearTimeout ].
  96. "to allow #async: message send without throwing an error"
  97. asyncTimeout := 0.
  98. asyncTimeout := (self async: [
  99. self assert: false description: 'SUnit grace time exhausted' ])
  100. valueWithTimeout: aNumber
  101. ! !
  102. !TestCase methodsFor: 'error handling'!
  103. errorIfNotAsync: aString
  104. self isAsync ifFalse: [
  105. self error: aString, ' used without prior #timeout:' ]
  106. ! !
  107. !TestCase methodsFor: 'private'!
  108. signalFailure: aString
  109. TestFailure new
  110. messageText: aString;
  111. signal
  112. ! !
  113. !TestCase methodsFor: 'running'!
  114. performTest
  115. asyncTimeout := nil.
  116. self perform: self selector
  117. !
  118. runCase
  119. "Runs a test case in isolated context, leaking all errors."
  120. (TestContext testCase: self) start
  121. !
  122. setUp
  123. !
  124. tearDown
  125. ! !
  126. !TestCase methodsFor: 'testing'!
  127. assert: aBoolean
  128. self assert: aBoolean description: 'Assertion failed'
  129. !
  130. assert: aBoolean description: aString
  131. aBoolean ifFalse: [ self signalFailure: aString ]
  132. !
  133. assert: actual equals: expected
  134. ^ self assert: (actual = expected) description: 'Expected: ', expected printString, ' but was: ', actual printString
  135. !
  136. deny: aBoolean
  137. self assert: aBoolean not
  138. !
  139. isAsync
  140. ^ asyncTimeout notNil
  141. !
  142. should: aBlock
  143. self assert: aBlock value
  144. !
  145. should: aBlock raise: anExceptionClass
  146. self assert: ([ aBlock value. false ]
  147. on: anExceptionClass
  148. do: [ :ex | true ])
  149. !
  150. shouldnt: aBlock raise: anExceptionClass
  151. self assert: ([ aBlock value. true ]
  152. on: anExceptionClass
  153. do: [ :ex | false ])
  154. ! !
  155. !TestCase class methodsFor: 'accessing'!
  156. allTestSelectors
  157. | selectors |
  158. selectors := self testSelectors.
  159. self shouldInheritSelectors ifTrue: [
  160. selectors addAll: self superclass allTestSelectors ].
  161. ^ selectors
  162. !
  163. buildSuite
  164. ^ self allTestSelectors collect: [ :each | self selector: each ]
  165. !
  166. classTag
  167. "Returns a tag or general category for this class.
  168. Typically used to help tools do some reflection.
  169. Helios, for example, uses this to decide what icon the class should display."
  170. ^ 'test'
  171. !
  172. lookupHierarchyRoot
  173. ^ TestCase
  174. !
  175. selector: aSelector
  176. ^ self new
  177. setTestSelector: aSelector;
  178. yourself
  179. !
  180. testSelectors
  181. ^ self methodDictionary keys select: [ :each | each match: '^test' ]
  182. ! !
  183. !TestCase class methodsFor: 'testing'!
  184. isAbstract
  185. ^ self name = TestCase name
  186. !
  187. isTestClass
  188. ^ self isAbstract not
  189. !
  190. shouldInheritSelectors
  191. ^ self ~= self lookupHierarchyRoot
  192. ! !
  193. Object subclass: #TestContext
  194. slots: {#testCase}
  195. package: 'SUnit'!
  196. !TestContext commentStamp!
  197. I govern running a particular test case.
  198. My main added value is `#execute:` method which runs a block as a part of test case (restores context, nilling it afterwards, cleaning/calling `#tearDown` as appropriate for sync/async scenario).!
  199. !TestContext methodsFor: 'accessing'!
  200. testCase: aTestCase
  201. testCase := aTestCase
  202. ! !
  203. !TestContext methodsFor: 'running'!
  204. execute: aBlock
  205. | failed |
  206. testCase context: self.
  207. [
  208. failed := true.
  209. aBlock value.
  210. failed := false
  211. ]
  212. ensure: [
  213. testCase context: nil.
  214. (failed and: [ testCase isAsync ]) ifTrue: [
  215. testCase finished ].
  216. testCase isAsync ifFalse: [
  217. testCase tearDown ] ]
  218. !
  219. start
  220. self execute: [
  221. testCase setUp.
  222. testCase performTest ]
  223. ! !
  224. !TestContext class methodsFor: 'instance creation'!
  225. testCase: aTestCase
  226. ^ self new
  227. testCase: aTestCase;
  228. yourself
  229. ! !
  230. TestContext subclass: #ReportingTestContext
  231. slots: {#finished. #result}
  232. package: 'SUnit'!
  233. !ReportingTestContext commentStamp!
  234. I add `TestResult` reporting to `TestContext`.
  235. Errors are caught and save into a `TestResult`,
  236. When test case is finished (which can be later for async tests), a callback block is executed; this is used by a `TestSuiteRunner`.!
  237. !ReportingTestContext methodsFor: 'accessing'!
  238. finished: aBlock
  239. finished := aBlock
  240. !
  241. result: aTestResult
  242. result := aTestResult
  243. ! !
  244. !ReportingTestContext methodsFor: 'private'!
  245. withErrorReporting: aBlock
  246. [ aBlock
  247. on: TestFailure
  248. do: [ :ex | result addFailure: testCase ]
  249. ]
  250. on: Error
  251. do: [ :ex | result addError: testCase ]
  252. ! !
  253. !ReportingTestContext methodsFor: 'running'!
  254. execute: aBlock
  255. [
  256. self withErrorReporting: [ super execute: aBlock ]
  257. ]
  258. ensure: [
  259. testCase isAsync ifFalse: [
  260. result increaseRuns. finished value ] ]
  261. ! !
  262. !ReportingTestContext class methodsFor: 'instance creation'!
  263. testCase: aTestCase result: aTestResult finished: aBlock
  264. ^ (super testCase: aTestCase)
  265. result: aTestResult;
  266. finished: aBlock;
  267. yourself
  268. ! !
  269. Error subclass: #TestFailure
  270. slots: {}
  271. package: 'SUnit'!
  272. !TestFailure commentStamp!
  273. I am raised when the boolean parameter of an #`assert:` or `#deny:` call is the opposite of what the assertion claims.
  274. The test framework distinguishes between failures and errors.
  275. A failure is an event whose possibiity is explicitly anticipated and checked for in an assertion,
  276. whereas an error is an unanticipated problem like a division by 0 or an index out of bounds.!
  277. Object subclass: #TestResult
  278. slots: {#timestamp. #runs. #errors. #failures. #total}
  279. package: 'SUnit'!
  280. !TestResult commentStamp!
  281. I implement the collecting parameter pattern for running a bunch of tests.
  282. My instances hold tests that have run, sorted into the result categories of passed, failures and errors.
  283. `TestResult` is an interesting object to subclass or substitute. `#runCase:` is the external protocol you need to reproduce!
  284. !TestResult methodsFor: 'accessing'!
  285. addError: anError
  286. self errors add: anError
  287. !
  288. addFailure: aFailure
  289. self failures add: aFailure
  290. !
  291. errors
  292. ^ errors
  293. !
  294. failures
  295. ^ failures
  296. !
  297. increaseRuns
  298. runs := runs + 1
  299. !
  300. runs
  301. ^ runs
  302. !
  303. status
  304. ^ self errors ifNotEmpty: [ 'error' ] ifEmpty: [
  305. self failures ifNotEmpty: [ 'failure' ] ifEmpty: [
  306. 'success' ]]
  307. !
  308. timestamp
  309. ^ timestamp
  310. !
  311. total
  312. ^ total
  313. !
  314. total: aNumber
  315. total := aNumber
  316. ! !
  317. !TestResult methodsFor: 'initialization'!
  318. initialize
  319. super initialize.
  320. timestamp := Date now.
  321. runs := 0.
  322. errors := Array new.
  323. failures := Array new.
  324. total := 0
  325. ! !
  326. !TestResult methodsFor: 'running'!
  327. nextRunDo: aBlock
  328. "Runs aBlock with index of next run or does nothing if no more runs"
  329. ^ self runs == self total
  330. ifFalse: [ aBlock value: self runs + 1 ]
  331. !
  332. runCase: aTestCase
  333. [ [ self increaseRuns.
  334. aTestCase runCase ]
  335. on: TestFailure do: [ :ex | self addFailure: aTestCase ]]
  336. on: Error do: [ :ex | self addError: aTestCase ]
  337. ! !
  338. Object subclass: #TestSuiteRunner
  339. slots: {#suite. #result. #announcer. #runNextTest}
  340. package: 'SUnit'!
  341. !TestSuiteRunner commentStamp!
  342. I am responsible for running a collection (`suite`) of tests.
  343. ## API
  344. Instances should be created using the class-side `#on:` method, taking a collection of tests to run as parameter.
  345. To run the test suite, use `#run`.!
  346. !TestSuiteRunner methodsFor: 'accessing'!
  347. announcer
  348. ^ announcer
  349. !
  350. result
  351. ^ result
  352. !
  353. suite: aCollection
  354. suite := aCollection
  355. ! !
  356. !TestSuiteRunner methodsFor: 'actions'!
  357. resume
  358. runNextTest fork.
  359. announcer announce: (ResultAnnouncement new result: result)
  360. !
  361. run
  362. result total: suite size.
  363. self resume
  364. ! !
  365. !TestSuiteRunner methodsFor: 'initialization'!
  366. initialize
  367. super initialize.
  368. announcer := Announcer new.
  369. result := TestResult new.
  370. runNextTest := [ | runs | runs := result runs. runs < result total ifTrue: [ (self contextOf: runs + 1) start ] ].
  371. ! !
  372. !TestSuiteRunner methodsFor: 'private'!
  373. contextOf: anInteger
  374. ^ ReportingTestContext testCase: (suite at: anInteger) result: result finished: [ self resume ]
  375. ! !
  376. !TestSuiteRunner class methodsFor: 'instance creation'!
  377. new
  378. self shouldNotImplement
  379. !
  380. on: aCollection
  381. ^ super new suite: aCollection
  382. ! !
  383. !Package methodsFor: '*SUnit'!
  384. isTestPackage
  385. ^ self classes anySatisfy: [ :each | each isTestClass ]
  386. ! !
  387. !TBehaviorDefaults methodsFor: '*SUnit'!
  388. isTestClass
  389. ^ false
  390. ! !