SUnit.st 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540
  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 ifNotNil: [ asyncTimeout clearTimeout ].
  92. asyncTimeout := nil
  93. !
  94. timeout: aNumber
  95. "Set a grace time timeout in milliseconds to run the test asynchronously"
  96. asyncTimeout ifNotNil: [ asyncTimeout clearTimeout ].
  97. "to allow #async: message send without throwing an error"
  98. asyncTimeout := 0.
  99. asyncTimeout := (self async: [
  100. self assert: false description: 'SUnit grace time exhausted' ])
  101. valueWithTimeout: aNumber
  102. ! !
  103. !TestCase methodsFor: 'error handling'!
  104. errorIfNotAsync: aString
  105. self isAsync ifFalse: [
  106. self error: aString, ' used without prior #timeout:' ]
  107. ! !
  108. !TestCase methodsFor: 'private'!
  109. signalFailure: aString
  110. TestFailure signal: aString
  111. ! !
  112. !TestCase methodsFor: 'running'!
  113. debugCase
  114. self deprecatedAPI: 'Use #runCase instead.'.
  115. ^ self runCase
  116. !
  117. performTest
  118. asyncTimeout := nil.
  119. ^ self perform: self selector
  120. !
  121. runCase
  122. "Runs a test case in isolated context, leaking all errors."
  123. (TestContext testCase: self) start
  124. !
  125. setUp
  126. !
  127. tearDown
  128. ! !
  129. !TestCase methodsFor: 'testing'!
  130. assert: aBoolean
  131. self assert: aBoolean description: 'Assertion failed'
  132. !
  133. assert: aBoolean description: aString
  134. aBoolean ifFalse: [ self signalFailure: aString ]
  135. !
  136. assert: actual equals: expected
  137. ^ self assert: (actual = expected) description: 'Expected: ', expected printString, ' but was: ', actual printString
  138. !
  139. deny: aBoolean
  140. self assert: aBoolean not
  141. !
  142. isAsync
  143. ^ asyncTimeout notNil
  144. !
  145. should: aBlock
  146. self assert: aBlock value
  147. !
  148. should: aBlock raise: anExceptionClass
  149. self assert: ([ aBlock value. false ]
  150. on: anExceptionClass
  151. do: [ :ex | true ])
  152. !
  153. shouldnt: aBlock raise: anExceptionClass
  154. self assert: ([ aBlock value. true ]
  155. on: anExceptionClass
  156. do: [ :ex | false ])
  157. ! !
  158. !TestCase class methodsFor: 'accessing'!
  159. allTestSelectors
  160. | selectors |
  161. selectors := self testSelectors.
  162. self shouldInheritSelectors ifTrue: [
  163. selectors addAll: self superclass allTestSelectors ].
  164. ^ selectors asSet
  165. !
  166. buildSuite
  167. ^ self allTestSelectors collect: [ :each | self selector: each ]
  168. !
  169. classTag
  170. "Returns a tag or general category for this class.
  171. Typically used to help tools do some reflection.
  172. Helios, for example, uses this to decide what icon the class should display."
  173. ^ 'test'
  174. !
  175. lookupHierarchyRoot
  176. ^ TestCase
  177. !
  178. selector: aSelector
  179. ^ self new
  180. setTestSelector: aSelector;
  181. yourself
  182. !
  183. testSelectors
  184. ^ self methodDictionary keys select: [ :each | each match: '^test' ]
  185. ! !
  186. !TestCase class methodsFor: 'testing'!
  187. isAbstract
  188. ^ self name = TestCase name
  189. !
  190. isTestClass
  191. ^ self isAbstract not
  192. !
  193. shouldInheritSelectors
  194. ^ self ~= self lookupHierarchyRoot
  195. ! !
  196. Object subclass: #TestContext
  197. slots: {#testCase}
  198. package: 'SUnit'!
  199. !TestContext commentStamp!
  200. I govern running a particular test case.
  201. 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).!
  202. !TestContext methodsFor: 'accessing'!
  203. testCase: aTestCase
  204. testCase := aTestCase
  205. ! !
  206. !TestContext methodsFor: 'running'!
  207. execute: aBlock
  208. | failed result |
  209. testCase context: self.
  210. [
  211. failed := true.
  212. result := aBlock value.
  213. testCase isAsync ifFalse: [
  214. testCase assert: result isThenable not description: testCase asString, ' returned promise without sending #timeout:' ].
  215. failed := false
  216. ]
  217. ensure: [
  218. "testCase context: nil."
  219. (failed and: [ testCase isAsync ]) ifTrue: [ testCase finished ].
  220. testCase isAsync
  221. ifFalse: [ testCase tearDown ]
  222. ifTrue: [ result isThenable ifTrue: [
  223. failed := false.
  224. (result
  225. catch: [ :error | testCase isAsync ifTrue: [ self execute: [ failed := true. (Smalltalk asSmalltalkException: error) pass ] ] ])
  226. then: [ failed ifFalse: [ testCase isAsync ifTrue: [ self execute: [ testCase finished ] ] ] ] ] ] ]
  227. !
  228. start
  229. self execute: [
  230. testCase setUp.
  231. testCase performTest ]
  232. ! !
  233. !TestContext class methodsFor: 'instance creation'!
  234. testCase: aTestCase
  235. ^ self new
  236. testCase: aTestCase;
  237. yourself
  238. ! !
  239. TestContext subclass: #ReportingTestContext
  240. slots: {#finished. #result}
  241. package: 'SUnit'!
  242. !ReportingTestContext commentStamp!
  243. I add `TestResult` reporting to `TestContext`.
  244. Errors are caught and save into a `TestResult`,
  245. When test case is finished (which can be later for async tests), a callback block is executed; this is used by a `TestSuiteRunner`.!
  246. !ReportingTestContext methodsFor: 'accessing'!
  247. finished: aBlock
  248. finished := aBlock
  249. !
  250. result: aTestResult
  251. result := aTestResult
  252. ! !
  253. !ReportingTestContext methodsFor: 'private'!
  254. withErrorReporting2: aBlock
  255. [ aBlock
  256. on: TestFailure
  257. do: [ :ex | result addFailure: testCase ]
  258. ]
  259. on: Error
  260. do: [ :ex | result addError: testCase ]
  261. !
  262. withErrorReporting: aBlock
  263. <inlineJS: '
  264. try { aBlock._value(); }
  265. catch (ex) {
  266. var smalltalkError = $globals.Smalltalk._asSmalltalkException_(ex);
  267. self._withErrorReporting2_(function () { smalltalkError._pass(); });
  268. }'>
  269. ! !
  270. !ReportingTestContext methodsFor: 'running'!
  271. execute: aBlock
  272. [
  273. self withErrorReporting: [ super execute: aBlock ]
  274. ]
  275. ensure: [
  276. testCase isAsync ifFalse: [
  277. result increaseRuns. finished value ] ]
  278. ! !
  279. !ReportingTestContext class methodsFor: 'instance creation'!
  280. testCase: aTestCase result: aTestResult finished: aBlock
  281. ^ (super testCase: aTestCase)
  282. result: aTestResult;
  283. finished: aBlock;
  284. yourself
  285. ! !
  286. Error subclass: #TestFailure
  287. slots: {}
  288. package: 'SUnit'!
  289. !TestFailure commentStamp!
  290. I am raised when the boolean parameter of an #`assert:` or `#deny:` call is the opposite of what the assertion claims.
  291. The test framework distinguishes between failures and errors.
  292. A failure is an event whose possibiity is explicitly anticipated and checked for in an assertion,
  293. whereas an error is an unanticipated problem like a division by 0 or an index out of bounds.!
  294. Object subclass: #TestResult
  295. slots: {#timestamp. #runs. #errors. #failures. #total}
  296. package: 'SUnit'!
  297. !TestResult commentStamp!
  298. I implement the collecting parameter pattern for running a bunch of tests.
  299. My instances hold tests that have run, sorted into the result categories of passed, failures and errors.
  300. `TestResult` is an interesting object to subclass or substitute. `#runCase:` is the external protocol you need to reproduce!
  301. !TestResult methodsFor: 'accessing'!
  302. addError: anError
  303. self errors add: anError
  304. !
  305. addFailure: aFailure
  306. self failures add: aFailure
  307. !
  308. errors
  309. ^ errors
  310. !
  311. failures
  312. ^ failures
  313. !
  314. increaseRuns
  315. runs := runs + 1
  316. !
  317. runs
  318. ^ runs
  319. !
  320. status
  321. ^ self errors ifNotEmpty: [ 'error' ] ifEmpty: [
  322. self failures ifNotEmpty: [ 'failure' ] ifEmpty: [
  323. 'success' ]]
  324. !
  325. timestamp
  326. ^ timestamp
  327. !
  328. total
  329. ^ total
  330. !
  331. total: aNumber
  332. total := aNumber
  333. ! !
  334. !TestResult methodsFor: 'initialization'!
  335. initialize
  336. super initialize.
  337. timestamp := Date now.
  338. runs := 0.
  339. errors := Array new.
  340. failures := Array new.
  341. total := 0
  342. ! !
  343. !TestResult methodsFor: 'running'!
  344. nextRunDo: aBlock
  345. "Runs aBlock with index of next run or does nothing if no more runs"
  346. ^ self runs == self total
  347. ifFalse: [ aBlock value: self runs + 1 ]
  348. !
  349. runCase: aTestCase
  350. [ [ self increaseRuns.
  351. aTestCase runCase ]
  352. on: TestFailure do: [ :ex | self addFailure: aTestCase ]]
  353. on: Error do: [ :ex | self addError: aTestCase ]
  354. ! !
  355. Object subclass: #TestSuiteRunner
  356. slots: {#suite. #result. #announcer. #runNextTest}
  357. package: 'SUnit'!
  358. !TestSuiteRunner commentStamp!
  359. I am responsible for running a collection (`suite`) of tests.
  360. ## API
  361. Instances should be created using the class-side `#on:` method, taking a collection of tests to run as parameter.
  362. To run the test suite, use `#run`.!
  363. !TestSuiteRunner methodsFor: 'accessing'!
  364. announcer
  365. ^ announcer
  366. !
  367. result
  368. ^ result
  369. !
  370. suite: aCollection
  371. suite := aCollection
  372. ! !
  373. !TestSuiteRunner methodsFor: 'actions'!
  374. resume
  375. runNextTest fork.
  376. announcer announce: (ResultAnnouncement new result: result)
  377. !
  378. run
  379. result total: suite size.
  380. self resume
  381. ! !
  382. !TestSuiteRunner methodsFor: 'initialization'!
  383. initialize
  384. super initialize.
  385. announcer := Announcer new.
  386. result := TestResult new.
  387. runNextTest := [ | runs | runs := result runs. runs < result total ifTrue: [ (self contextOf: runs + 1) start ] ].
  388. ! !
  389. !TestSuiteRunner methodsFor: 'private'!
  390. contextOf: anInteger
  391. ^ ReportingTestContext testCase: (suite at: anInteger) result: result finished: [ self resume ]
  392. ! !
  393. !TestSuiteRunner class methodsFor: 'instance creation'!
  394. new
  395. self shouldNotImplement
  396. !
  397. on: aCollection
  398. ^ super new suite: aCollection
  399. ! !
  400. !Package methodsFor: '*SUnit'!
  401. isTestPackage
  402. ^ self classes anySatisfy: [ :each | each isTestClass ]
  403. ! !
  404. !TBehaviorDefaults methodsFor: '*SUnit'!
  405. isTestClass
  406. ^ false
  407. ! !