Helios-SUnit.st 15 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751
  1. Smalltalk createPackage: 'Helios-SUnit'!
  2. HLToolListWidget subclass: #HLMultiSelectToolListWidget
  3. slots: {}
  4. package: 'Helios-SUnit'!
  5. !HLMultiSelectToolListWidget commentStamp!
  6. This is a list that handles multiple selection!
  7. !HLMultiSelectToolListWidget methodsFor: 'accessing'!
  8. activeItemCssClass
  9. ^'selector'
  10. !
  11. listCssClass
  12. ^'nav nav-multiselect nav-pills nav-stacked'
  13. !
  14. listCssClassForItem: anObject
  15. ^(super listCssClassForItem: anObject), ((self isSelected: anObject)
  16. ifTrue: [' active']
  17. ifFalse: ['']).
  18. ! !
  19. !HLMultiSelectToolListWidget methodsFor: 'actions'!
  20. select: anObject
  21. self subclassResponsibility
  22. !
  23. toggleListItem: aListItem
  24. | item |
  25. (aListItem get: 0) ifNil: [ ^ self ].
  26. "Find item"
  27. item := aListItem data: 'item'.
  28. self toggleSelection: item
  29. !
  30. toggleSelection: anObject
  31. (self isSelected: anObject)
  32. ifTrue: [ self unselect: anObject ]
  33. ifFalse: [self select: anObject ]
  34. !
  35. unselect: anObject
  36. self subclassResponsibility
  37. ! !
  38. !HLMultiSelectToolListWidget methodsFor: 'rendering'!
  39. reselectItem: anObject
  40. anObject ifNil: [^self].
  41. self toggleSelection: anObject
  42. ! !
  43. !HLMultiSelectToolListWidget methodsFor: 'testing'!
  44. isSelected: anObject
  45. self subclassResponsibility
  46. ! !
  47. HLMultiSelectToolListWidget subclass: #HLSUnitClassesListWidget
  48. slots: {}
  49. package: 'Helios-SUnit'!
  50. !HLSUnitClassesListWidget commentStamp!
  51. I display a list of classes (subclasses of `TestCase`).!
  52. !HLSUnitClassesListWidget methodsFor: 'accessing'!
  53. buttonsDivCssClass
  54. ^ 'buttons_bar'
  55. !
  56. cssClassForItem: aClass
  57. | nonMeta |
  58. nonMeta := aClass theNonMetaClass.
  59. (nonMeta respondsTo: #classTag)
  60. ifTrue: [ ^ nonMeta classTag ]
  61. ifFalse: [ ^ nonMeta heliosClass ]
  62. !
  63. items
  64. ^ items ifNil: [ self initializeItems ]
  65. !
  66. label
  67. ^ 'Classes'
  68. ! !
  69. !HLSUnitClassesListWidget methodsFor: 'actions'!
  70. observeModel
  71. self model announcer
  72. on: HLPackageSelected
  73. send: #onPackageSelected:
  74. to: self;
  75. on: HLPackageUnselected
  76. send: #onPackageUnselected:
  77. to: self;
  78. on: HLClassSelected
  79. send: #onClassSelected:
  80. to: self;
  81. on: HLClassUnselected
  82. send: #onClassUnselected:
  83. to: self.
  84. !
  85. observeSystem
  86. self model systemAnnouncer
  87. on: ClassAdded
  88. send: #onClassAdded:
  89. to: self.
  90. !
  91. select: anObject
  92. model selectClass: anObject
  93. !
  94. unselect: anObject
  95. model unselectClass: anObject
  96. ! !
  97. !HLSUnitClassesListWidget methodsFor: 'initialization'!
  98. initializeItems
  99. ^items := model testClasses
  100. ! !
  101. !HLSUnitClassesListWidget methodsFor: 'reactions'!
  102. onClassAdded: anAnnouncement
  103. (self model selectedPackages includes: anAnnouncement theClass package)
  104. ifTrue: [
  105. self
  106. initializeItems;
  107. refresh ]
  108. !
  109. onClassSelected: anAnnouncement
  110. | listItem |
  111. listItem := self findListItemFor: anAnnouncement item.
  112. listItem addClass: 'active'.
  113. !
  114. onClassUnselected: anAnnouncement
  115. | listItem |
  116. listItem := self findListItemFor: anAnnouncement item.
  117. listItem removeClass: 'active'.
  118. !
  119. onPackageSelected: anAnnouncement
  120. self initializeItems;
  121. refresh
  122. !
  123. onPackageUnselected: anAnnouncement
  124. self initializeItems;
  125. refresh
  126. ! !
  127. !HLSUnitClassesListWidget methodsFor: 'rendering'!
  128. renderButtonsOn: html
  129. html button
  130. class: 'button';
  131. with: 'Select all';
  132. onClick: [ self model selectAllClasses ]
  133. !
  134. renderItemLabel: aClass on: html
  135. html with: aClass name
  136. ! !
  137. !HLSUnitClassesListWidget methodsFor: 'testing'!
  138. isSelected: anObject
  139. ^model selectedClasses includes: anObject
  140. ! !
  141. HLMultiSelectToolListWidget subclass: #HLSUnitPackagesListWidget
  142. slots: {}
  143. package: 'Helios-SUnit'!
  144. !HLSUnitPackagesListWidget commentStamp!
  145. I display a list of packages for which unit tests are associated (packages containing subclasses of `TestCase`).!
  146. !HLSUnitPackagesListWidget methodsFor: 'accessing'!
  147. buttonsDivCssClass
  148. ^ 'buttons_bar'
  149. !
  150. cssClassForItem: anItem
  151. ^ anItem isDirty
  152. ifTrue: [ 'package_dirty' ]
  153. ifFalse: [ 'package' ]
  154. !
  155. items
  156. ^ items ifNil: [ self initializeItems ]
  157. !
  158. label
  159. ^ 'Packages'
  160. ! !
  161. !HLSUnitPackagesListWidget methodsFor: 'actions'!
  162. observeModel
  163. self model announcer
  164. on: HLPackageSelected
  165. send: #onPackageSelected:
  166. to: self;
  167. on: HLPackageUnselected
  168. send: #onPackageUnselected:
  169. to: self
  170. !
  171. observeSystem
  172. self model systemAnnouncer
  173. on: ClassAdded
  174. send: #onClassAdded:
  175. to: self.
  176. !
  177. select: anObject
  178. model selectPackage: anObject
  179. !
  180. unselect: anObject
  181. model unselectPackage: anObject
  182. ! !
  183. !HLSUnitPackagesListWidget methodsFor: 'initialization'!
  184. initializeItems
  185. ^items := model testPackages
  186. sort: [:a :b | a name < b name]
  187. ! !
  188. !HLSUnitPackagesListWidget methodsFor: 'reactions'!
  189. onClassAdded: anAnnouncement
  190. ((self items includes: anAnnouncement theClass package) not and: [anAnnouncement theClass package isTestPackage])
  191. ifTrue: [
  192. self
  193. initializeItems;
  194. refresh ]
  195. !
  196. onPackageSelected: anAnnouncement
  197. | listItem |
  198. listItem := self findListItemFor: anAnnouncement item.
  199. listItem addClass: 'active'.
  200. !
  201. onPackageUnselected: anAnnouncement
  202. | listItem |
  203. listItem := self findListItemFor: anAnnouncement item.
  204. listItem removeClass: 'active'.
  205. ! !
  206. !HLSUnitPackagesListWidget methodsFor: 'rendering'!
  207. renderButtonsOn: html
  208. html button
  209. class: 'button';
  210. with: 'Run Tests';
  211. onClick: [ self model runTests ].
  212. html button
  213. class: 'button';
  214. with: 'Select all';
  215. onClick: [ self model selectAllPackages ]
  216. !
  217. renderItemLabel: aPackage on: html
  218. html with: aPackage name
  219. ! !
  220. !HLSUnitPackagesListWidget methodsFor: 'testing'!
  221. isSelected: anObject
  222. ^model selectedPackages includes: anObject
  223. ! !
  224. HLWidget subclass: #HLSUnit
  225. slots: {#model. #packagesListWidget. #classesListWidget. #resultWidget. #failuresWidget. #errorsWidget}
  226. package: 'Helios-SUnit'!
  227. !HLSUnit commentStamp!
  228. I am the main widget for running unit tests in Helios.
  229. I provide the ability to select set of tests to run per package, and a detailed result log with passed tests, failed tests and errors.!
  230. !HLSUnit methodsFor: 'accessing'!
  231. model
  232. ^ model ifNil: [ model := HLSUnitModel new ]
  233. !
  234. resultSection
  235. ^HLHorizontalSplitter
  236. with: self resultWidget
  237. with: (HLHorizontalSplitter
  238. with: self failuresWidget
  239. with: self errorsWidget)
  240. ! !
  241. !HLSUnit methodsFor: 'actions'!
  242. unregister
  243. super unregister.
  244. {
  245. self packagesListWidget.
  246. self classesListWidget.
  247. self resultWidget.
  248. self errorsWidget.
  249. self failuresWidget
  250. }
  251. do: [ :each | each unregister ]
  252. ! !
  253. !HLSUnit methodsFor: 'keybindings'!
  254. registerBindingsOn: aBindingGroup
  255. HLToolCommand
  256. registerConcreteClassesOn: aBindingGroup
  257. for: self model
  258. ! !
  259. !HLSUnit methodsFor: 'rendering'!
  260. renderContentOn: html
  261. | resultSection |
  262. html with: (HLContainer with: (
  263. HLVerticalSplitter
  264. with: (HLVerticalSplitter
  265. with: self packagesListWidget
  266. with: self classesListWidget)
  267. with: (resultSection := self resultSection))).
  268. [resultSection resize: 0] valueWithTimeout: 100.
  269. self packagesListWidget focus
  270. ! !
  271. !HLSUnit methodsFor: 'widgets'!
  272. classesListWidget
  273. ^ classesListWidget ifNil: [
  274. classesListWidget := HLSUnitClassesListWidget on: self model.
  275. classesListWidget next: self failuresWidget ]
  276. !
  277. errorsWidget
  278. ^ errorsWidget ifNil: [errorsWidget := HLSUnitErrorsListWidget on: self model]
  279. !
  280. failuresWidget
  281. ^ failuresWidget ifNil: [
  282. failuresWidget := HLSUnitFailuresListWidget on: self model.
  283. failuresWidget next: self errorsWidget]
  284. !
  285. packagesListWidget
  286. ^ packagesListWidget ifNil: [
  287. packagesListWidget := HLSUnitPackagesListWidget on: self model.
  288. packagesListWidget next: self classesListWidget]
  289. !
  290. resultWidget
  291. ^ resultWidget ifNil: [
  292. resultWidget := HLSUnitResults new
  293. model: self model;
  294. yourself]
  295. ! !
  296. !HLSUnit class methodsFor: 'accessing'!
  297. tabClass
  298. ^ 'sunit'
  299. !
  300. tabLabel
  301. ^ 'SUnit'
  302. !
  303. tabPriority
  304. ^ 1000
  305. ! !
  306. !HLSUnit class methodsFor: 'testing'!
  307. canBeOpenAsTab
  308. ^ true
  309. ! !
  310. HLModel subclass: #HLSUnitModel
  311. slots: {#selectedPackages. #selectedClasses. #testResult. #currentSuite}
  312. package: 'Helios-SUnit'!
  313. !HLSUnitModel commentStamp!
  314. I am the model for running unit tests in Helios.
  315. I provide the ability to select set of tests to run per package, and a detailed result log with passed tests, failed tests and errors.!
  316. !HLSUnitModel methodsFor: 'accessing'!
  317. currentSuite
  318. ^currentSuite
  319. !
  320. selectedClasses
  321. ^ (self unfilteredSelectedClasses) select: [ :each |
  322. self selectedPackages includes: each package ]
  323. !
  324. selectedPackages
  325. ^ selectedPackages ifNil: [ selectedPackages := Set new ]
  326. !
  327. testCases
  328. | testCases |
  329. testCases := #().
  330. self selectedClasses
  331. do: [ :each | testCases addAll: each buildSuite ].
  332. ^ testCases
  333. !
  334. testClasses
  335. "Answer all concrete subclasses of TestCase in selected packages"
  336. | stream |
  337. stream := Array new writeStream.
  338. self selectedPackages do: [ :package |
  339. stream nextPutAll: (package classes select: [ :each |
  340. each isTestClass ] ) ].
  341. ^ stream contents
  342. !
  343. testPackages
  344. "Answer all packages containing concrete subclasses of TestCase"
  345. ^ self environment packages
  346. select: [ :each | each isTestPackage ]
  347. !
  348. testResult
  349. ^testResult ifNil: [testResult := TestResult new]
  350. ! !
  351. !HLSUnitModel methodsFor: 'actions'!
  352. invertSelectedClasses
  353. self testClasses do: [:each |
  354. (self unfilteredSelectedClasses includes: each)
  355. ifTrue: [ self unselectClass: each ]
  356. ifFalse: [ self selectClass: each ]].
  357. !
  358. invertSelectedPackages
  359. self testPackages do: [:each |
  360. (self selectedPackages includes: each)
  361. ifTrue: [ self unselectPackage: each ]
  362. ifFalse: [ self selectPackage: each ]].
  363. !
  364. runTests
  365. | worker |
  366. worker := (self environment classNamed: #TestSuiteRunner) on: self testCases.
  367. testResult := worker result.
  368. self announcer announce: (HLRunTests on: worker).
  369. self subscribeToTestSuite: worker.
  370. worker run
  371. !
  372. selectAllClasses
  373. self testClasses do: [:each | self selectClass: each].
  374. !
  375. selectAllPackages
  376. self testPackages do: [:each | self selectPackage: each].
  377. !
  378. selectClass: aClass
  379. self unfilteredSelectedClasses add: aClass.
  380. self announcer announce: (HLClassSelected on: aClass).
  381. !
  382. selectPackage: aPackage
  383. self selectedPackages add: aPackage.
  384. self announcer announce: (HLPackageSelected on: aPackage).
  385. !
  386. subscribeToTestSuite: aTestSuiteRunner
  387. currentSuite ifNotNil: [ currentSuite announcer unsubscribe: self].
  388. currentSuite := aTestSuiteRunner.
  389. currentSuite announcer
  390. on: ResultAnnouncement
  391. send: #onResultAnnouncement:
  392. to: self
  393. !
  394. unselectClass: aClass
  395. self unfilteredSelectedClasses remove: aClass ifAbsent: [^self].
  396. self announcer announce: (HLClassUnselected on: aClass).
  397. !
  398. unselectPackage: aPackage
  399. self selectedPackages remove: aPackage ifAbsent: [^self].
  400. self announcer announce: (HLPackageUnselected on: aPackage).
  401. ! !
  402. !HLSUnitModel methodsFor: 'private'!
  403. unfilteredSelectedClasses
  404. ^ (selectedClasses ifNil: [ selectedClasses := Set new ])
  405. ! !
  406. !HLSUnitModel methodsFor: 'reacting'!
  407. onResultAnnouncement: announcement
  408. "Propogate announcement"
  409. self announcer announce: announcement.
  410. ! !
  411. HLToolListWidget subclass: #HLSUnitResultListWidget
  412. slots: {}
  413. package: 'Helios-SUnit'!
  414. !HLSUnitResultListWidget commentStamp!
  415. I group the lists that display test results!
  416. !HLSUnitResultListWidget methodsFor: 'actions'!
  417. performFailure: aTestCase
  418. aTestCase debugCase
  419. ! !
  420. !HLSUnitResultListWidget methodsFor: 'initialization'!
  421. observeModel
  422. self model announcer
  423. on: ResultAnnouncement
  424. send: #onResultAnnouncement:
  425. to: self
  426. ! !
  427. !HLSUnitResultListWidget methodsFor: 'reacting'!
  428. onResultAnnouncement: announcement
  429. self refresh.
  430. ! !
  431. !HLSUnitResultListWidget methodsFor: 'rendering'!
  432. renderItemLabel: anObject on: html
  433. html with: anObject class name, ' >> ', anObject selector
  434. !
  435. reselectItem: anObject
  436. self performFailure: anObject
  437. ! !
  438. HLSUnitResultListWidget subclass: #HLSUnitErrorsListWidget
  439. slots: {}
  440. package: 'Helios-SUnit'!
  441. !HLSUnitErrorsListWidget commentStamp!
  442. I display a list of tests that have errors!
  443. !HLSUnitErrorsListWidget methodsFor: 'accessing'!
  444. items
  445. ^self model testResult errors
  446. !
  447. label
  448. ^'Errors'
  449. ! !
  450. HLSUnitResultListWidget subclass: #HLSUnitFailuresListWidget
  451. slots: {}
  452. package: 'Helios-SUnit'!
  453. !HLSUnitFailuresListWidget commentStamp!
  454. I display a list of tests that have failures!
  455. !HLSUnitFailuresListWidget methodsFor: 'accessing'!
  456. items
  457. ^self model testResult failures
  458. !
  459. label
  460. ^'Failures'
  461. ! !
  462. HLWidget subclass: #HLSUnitResultStatus
  463. slots: {#model}
  464. package: 'Helios-SUnit'!
  465. !HLSUnitResultStatus commentStamp!
  466. I display the status of the previous test run
  467. 1. How many tests where run.
  468. * How many tests passed.
  469. * How many tests failed.
  470. * How many tests resulted in an error.!
  471. !HLSUnitResultStatus methodsFor: 'accessing'!
  472. model
  473. ^ model ifNil: [model := TestResult new]
  474. !
  475. model: anObject
  476. model := anObject.
  477. self observeModel.
  478. !
  479. result
  480. ^ self model testResult
  481. !
  482. statusCssClass
  483. ^'sunit status ', self result status
  484. !
  485. statusInfo
  486. ^ self printTotal, self printPasses, self printErrors, self printFailures
  487. ! !
  488. !HLSUnitResultStatus methodsFor: 'actions'!
  489. observeModel
  490. self model announcer
  491. on: ResultAnnouncement
  492. send: #onResultAnnouncement:
  493. to: self
  494. !
  495. unregister
  496. super unregister.
  497. self model announcer unsubscribe: self.
  498. ! !
  499. !HLSUnitResultStatus methodsFor: 'printing'!
  500. printErrors
  501. ^ self result errors size asString , ' errors, '
  502. !
  503. printFailures
  504. ^ self result failures size asString, ' failures'
  505. !
  506. printPasses
  507. ^ (self result runs - self result errors size - self result failures size) asString , ' passes, '
  508. !
  509. printTotal
  510. ^ self result total asString, ' runs, '
  511. ! !
  512. !HLSUnitResultStatus methodsFor: 'reacting'!
  513. onResultAnnouncement: announcement
  514. self refresh.
  515. ! !
  516. !HLSUnitResultStatus methodsFor: 'rendering'!
  517. renderContentOn: html
  518. html div
  519. class: self statusCssClass;
  520. with: [ html span with: self statusInfo ]
  521. ! !
  522. HLWidget subclass: #HLSUnitResults
  523. slots: {#model. #progressBarWidget. #resultStatusWidget}
  524. package: 'Helios-SUnit'!
  525. !HLSUnitResults commentStamp!
  526. I am the widget that displays the test results for a previous test run in Helios.
  527. I display.
  528. 1. The status of the tests.
  529. * Progress of the currently running test suite.!
  530. !HLSUnitResults methodsFor: 'accessing'!
  531. model
  532. ^model
  533. !
  534. model: anObject
  535. model := anObject.
  536. self observeModel
  537. !
  538. progressBarWidget
  539. ^progressBarWidget ifNil: [progressBarWidget := HLProgressBarWidget new
  540. label: '';
  541. yourself]
  542. !
  543. resultStatusWidget
  544. ^resultStatusWidget ifNil: [resultStatusWidget := HLSUnitResultStatus new
  545. model: self model;
  546. yourself]
  547. ! !
  548. !HLSUnitResults methodsFor: 'actions'!
  549. unregister
  550. super unregister.
  551. self model announcer unsubscribe: self.
  552. self resultStatusWidget unregister.
  553. ! !
  554. !HLSUnitResults methodsFor: 'initialization'!
  555. observeModel
  556. self model announcer
  557. on: HLRunTests
  558. send: #onRunTests:
  559. to: self;
  560. on: ResultAnnouncement
  561. send: #onResultAnnouncement:
  562. to: self
  563. ! !
  564. !HLSUnitResults methodsFor: 'reacting'!
  565. onResultAnnouncement: announcement
  566. [self progressBarWidget
  567. updateProgress: (self model testResult runs / self model testResult total * 100) rounded] fork
  568. !
  569. onRunTests: announcement
  570. self progressBarWidget updateProgress: 0;
  571. refresh.
  572. ! !
  573. !HLSUnitResults methodsFor: 'rendering'!
  574. renderContentOn: html
  575. html with: self resultStatusWidget;
  576. with: self progressBarWidget
  577. ! !