1
0

Kernel-Announcements.st 9.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429
  1. Smalltalk createPackage: 'Kernel-Announcements'!
  2. Object subclass: #AnnouncementSubscription
  3. instanceVariableNames: 'valuable announcementClass'
  4. package: 'Kernel-Announcements'!
  5. !AnnouncementSubscription commentStamp!
  6. I am a single entry in a subscription registry of an `Announcer`.
  7. Several subscriptions by the same object is possible.!
  8. !AnnouncementSubscription methodsFor: 'accessing'!
  9. announcementClass
  10. ^ announcementClass
  11. !
  12. announcementClass: aClass
  13. announcementClass := aClass
  14. !
  15. block
  16. "Use #valuable instead"
  17. self deprecatedAPI.
  18. ^ self valuable
  19. !
  20. block: aValuable
  21. "Use #valuable instead"
  22. self deprecatedAPI.
  23. self valuable: aValuable
  24. !
  25. receiver
  26. ^ self valuable receiver
  27. !
  28. valuable
  29. ^ valuable
  30. !
  31. valuable: aValuable
  32. valuable := aValuable
  33. ! !
  34. !AnnouncementSubscription methodsFor: 'announcing'!
  35. deliver: anAnnouncement
  36. (self handlesAnnouncement: anAnnouncement)
  37. ifTrue: [ self valuable value: anAnnouncement ]
  38. !
  39. handlesAnnouncement: anAnnouncement
  40. "anAnnouncement might be announced from within another Amber environment"
  41. ^ (Smalltalk globals at: self announcementClass name)
  42. ifNil: [ ^ false ]
  43. ifNotNil: [ :class |
  44. (Smalltalk globals at: anAnnouncement class theNonMetaClass name) includesBehavior: class ]
  45. ! !
  46. Object subclass: #AnnouncementValuable
  47. instanceVariableNames: 'valuable receiver'
  48. package: 'Kernel-Announcements'!
  49. !AnnouncementValuable commentStamp!
  50. I wrap `valuable` objects (typically instances of `BlockClosure`) with a `receiver` to be able to unregister subscriptions based on a `receiver`.!
  51. !AnnouncementValuable methodsFor: 'accessing'!
  52. receiver
  53. ^ receiver
  54. !
  55. receiver: anObject
  56. receiver := anObject
  57. !
  58. valuable
  59. ^ valuable
  60. !
  61. valuable: anObject
  62. valuable := anObject
  63. ! !
  64. !AnnouncementValuable methodsFor: 'evaluating'!
  65. value
  66. ^ self valuable value
  67. !
  68. value: anObject
  69. ^ self valuable value: anObject
  70. ! !
  71. Object subclass: #Announcer
  72. instanceVariableNames: 'registry subscriptions'
  73. package: 'Kernel-Announcements'!
  74. !Announcer commentStamp!
  75. I hold annoncement subscriptions (instances of `AnnouncementSubscription`) in a private registry.
  76. I announce (trigger) announces, which are then dispatched to all subscriptions.
  77. The code is based on the announcements as [described by Vassili Bykov](http://www.cincomsmalltalk.com/userblogs/vbykov/blogView?searchCategory=Announcements%20Framework).
  78. ## API
  79. Use `#announce:` to trigger an announcement.
  80. Use `#on:do:` or `#on:send:to:` to register subscriptions.
  81. When using `#on:send:to:`, unregistration can be done with `#unregister:`.
  82. ## Usage example:
  83. SystemAnnouncer current
  84. on: ClassAdded
  85. do: [ :ann | window alert: ann theClass name, ' added' ].!
  86. !Announcer methodsFor: 'announcing'!
  87. announce: anAnnouncement
  88. subscriptions do: [ :each |
  89. each deliver: anAnnouncement ]
  90. ! !
  91. !Announcer methodsFor: 'initialization'!
  92. initialize
  93. super initialize.
  94. subscriptions := OrderedCollection new
  95. ! !
  96. !Announcer methodsFor: 'subscribing'!
  97. on: aClass do: aBlock
  98. self on: aClass do: aBlock for: nil
  99. !
  100. on: aClass do: aBlock for: aReceiver
  101. subscriptions add: (AnnouncementSubscription new
  102. valuable: (AnnouncementValuable new
  103. valuable: aBlock;
  104. receiver: aReceiver;
  105. yourself);
  106. announcementClass: aClass;
  107. yourself)
  108. !
  109. on: aClass doOnce: aBlock
  110. | subscription |
  111. subscription := AnnouncementSubscription new
  112. announcementClass: aClass;
  113. yourself.
  114. subscription valuable: [ :ann |
  115. subscriptions remove: subscription.
  116. aBlock value: ann ].
  117. subscriptions add: subscription
  118. !
  119. on: aClass send: aSelector to: anObject
  120. subscriptions add: (AnnouncementSubscription new
  121. valuable: (MessageSend new
  122. receiver: anObject;
  123. selector: aSelector;
  124. yourself);
  125. announcementClass: aClass;
  126. yourself)
  127. !
  128. unsubscribe: anObject
  129. subscriptions := subscriptions reject: [ :each |
  130. each receiver = anObject ]
  131. ! !
  132. Announcer subclass: #SystemAnnouncer
  133. instanceVariableNames: ''
  134. package: 'Kernel-Announcements'!
  135. !SystemAnnouncer commentStamp!
  136. My unique instance is the global announcer handling all Amber system-related announces.
  137. ## API
  138. Access to the unique instance is done via `#current`!
  139. SystemAnnouncer class instanceVariableNames: 'current'!
  140. !SystemAnnouncer class methodsFor: 'accessing'!
  141. current
  142. ^ current ifNil: [ current := super new ]
  143. ! !
  144. !SystemAnnouncer class methodsFor: 'instance creation'!
  145. new
  146. self shouldNotImplement
  147. ! !
  148. Object subclass: #SystemAnnouncement
  149. instanceVariableNames: ''
  150. package: 'Kernel-Announcements'!
  151. !SystemAnnouncement commentStamp!
  152. I am the superclass of all system announcements!
  153. !SystemAnnouncement class methodsFor: 'helios'!
  154. heliosClass
  155. ^ 'announcement'
  156. ! !
  157. SystemAnnouncement subclass: #ClassAnnouncement
  158. instanceVariableNames: 'theClass'
  159. package: 'Kernel-Announcements'!
  160. !ClassAnnouncement commentStamp!
  161. I am the abstract superclass of class-related announcements.!
  162. !ClassAnnouncement methodsFor: 'accessing'!
  163. theClass
  164. ^ theClass
  165. !
  166. theClass: aClass
  167. theClass := aClass
  168. ! !
  169. ClassAnnouncement subclass: #ClassAdded
  170. instanceVariableNames: ''
  171. package: 'Kernel-Announcements'!
  172. !ClassAdded commentStamp!
  173. I am emitted when a class is added to the system.
  174. See ClassBuilder >> #addSubclassOf:... methods!
  175. ClassAnnouncement subclass: #ClassCommentChanged
  176. instanceVariableNames: ''
  177. package: 'Kernel-Announcements'!
  178. !ClassCommentChanged commentStamp!
  179. I am emitted when the comment of a class changes. (Behavior >> #comment)!
  180. ClassAnnouncement subclass: #ClassDefinitionChanged
  181. instanceVariableNames: ''
  182. package: 'Kernel-Announcements'!
  183. !ClassDefinitionChanged commentStamp!
  184. I am emitted when the definition of a class changes.
  185. See ClassBuilder >> #class:instanceVariableNames:!
  186. ClassAnnouncement subclass: #ClassMigrated
  187. instanceVariableNames: 'oldClass'
  188. package: 'Kernel-Announcements'!
  189. !ClassMigrated commentStamp!
  190. I am emitted when a class is migrated.!
  191. !ClassMigrated methodsFor: 'accessing'!
  192. oldClass
  193. ^ oldClass
  194. !
  195. oldClass: aClass
  196. oldClass := aClass
  197. ! !
  198. ClassAnnouncement subclass: #ClassMoved
  199. instanceVariableNames: 'oldPackage'
  200. package: 'Kernel-Announcements'!
  201. !ClassMoved commentStamp!
  202. I am emitted when a class is moved from one package to another.!
  203. !ClassMoved methodsFor: 'accessing'!
  204. oldPackage
  205. ^ oldPackage
  206. !
  207. oldPackage: aPackage
  208. oldPackage := aPackage
  209. ! !
  210. ClassAnnouncement subclass: #ClassRemoved
  211. instanceVariableNames: ''
  212. package: 'Kernel-Announcements'!
  213. !ClassRemoved commentStamp!
  214. I am emitted when a class is removed.
  215. See Smalltalk >> #removeClass:!
  216. ClassAnnouncement subclass: #ClassRenamed
  217. instanceVariableNames: ''
  218. package: 'Kernel-Announcements'!
  219. !ClassRenamed commentStamp!
  220. I am emitted when a class is renamed.
  221. See ClassBuilder >> #renameClass:to:!
  222. SystemAnnouncement subclass: #MethodAnnouncement
  223. instanceVariableNames: 'method'
  224. package: 'Kernel-Announcements'!
  225. !MethodAnnouncement commentStamp!
  226. I am the abstract superclass of method-related announcements.!
  227. !MethodAnnouncement methodsFor: 'accessing'!
  228. method
  229. ^ method
  230. !
  231. method: aCompiledMethod
  232. method := aCompiledMethod
  233. ! !
  234. MethodAnnouncement subclass: #MethodAdded
  235. instanceVariableNames: ''
  236. package: 'Kernel-Announcements'!
  237. !MethodAdded commentStamp!
  238. I am emitted when a `CompiledMethod` is added to a class.!
  239. MethodAnnouncement subclass: #MethodModified
  240. instanceVariableNames: 'oldMethod'
  241. package: 'Kernel-Announcements'!
  242. !MethodModified commentStamp!
  243. I am emitted when a `CompiledMethod` is modified (a new method is installed). I hold a reference to the old method being replaced.!
  244. !MethodModified methodsFor: 'accessing'!
  245. oldMethod
  246. ^ oldMethod
  247. !
  248. oldMethod: aMethod
  249. oldMethod := aMethod
  250. ! !
  251. MethodAnnouncement subclass: #MethodMoved
  252. instanceVariableNames: 'oldProtocol'
  253. package: 'Kernel-Announcements'!
  254. !MethodMoved commentStamp!
  255. I am emitted when a `CompiledMethod` is moved to another protocol. I hold a refernce to the old protocol of the method.!
  256. !MethodMoved methodsFor: 'accessing'!
  257. oldProtocol
  258. ^ oldProtocol
  259. !
  260. oldProtocol: aString
  261. oldProtocol := aString
  262. ! !
  263. MethodAnnouncement subclass: #MethodRemoved
  264. instanceVariableNames: ''
  265. package: 'Kernel-Announcements'!
  266. !MethodRemoved commentStamp!
  267. I am emitted when a `CompiledMethod` is removed from a class.!
  268. SystemAnnouncement subclass: #PackageAnnouncement
  269. instanceVariableNames: 'package'
  270. package: 'Kernel-Announcements'!
  271. !PackageAnnouncement commentStamp!
  272. I am the abstract superclass of package-related announcements.!
  273. !PackageAnnouncement methodsFor: 'accessing'!
  274. package
  275. ^ package
  276. !
  277. package: aPackage
  278. package := aPackage
  279. ! !
  280. PackageAnnouncement subclass: #PackageAdded
  281. instanceVariableNames: ''
  282. package: 'Kernel-Announcements'!
  283. !PackageAdded commentStamp!
  284. I am emitted when a `Package` is added to the system.!
  285. PackageAnnouncement subclass: #PackageClean
  286. instanceVariableNames: ''
  287. package: 'Kernel-Announcements'!
  288. !PackageClean commentStamp!
  289. I am emitted when a package is committed and becomes clean.!
  290. PackageAnnouncement subclass: #PackageDirty
  291. instanceVariableNames: ''
  292. package: 'Kernel-Announcements'!
  293. !PackageDirty commentStamp!
  294. I am emitted when a package becomes dirty.!
  295. PackageAnnouncement subclass: #PackageRemoved
  296. instanceVariableNames: ''
  297. package: 'Kernel-Announcements'!
  298. !PackageRemoved commentStamp!
  299. I am emitted when a `Package` is removed from the system.!
  300. SystemAnnouncement subclass: #ProtocolAnnouncement
  301. instanceVariableNames: 'theClass protocol'
  302. package: 'Kernel-Announcements'!
  303. !ProtocolAnnouncement commentStamp!
  304. I am the abstract superclass of protocol-related announcements.!
  305. !ProtocolAnnouncement methodsFor: 'accessing'!
  306. protocol
  307. ^ protocol
  308. !
  309. protocol: aString
  310. protocol := aString
  311. !
  312. theClass
  313. ^ theClass
  314. !
  315. theClass: aClass
  316. theClass := aClass
  317. ! !
  318. ProtocolAnnouncement subclass: #ProtocolAdded
  319. instanceVariableNames: ''
  320. package: 'Kernel-Announcements'!
  321. !ProtocolAdded commentStamp!
  322. I am emitted when a protocol is added to a class.!
  323. ProtocolAnnouncement subclass: #ProtocolRemoved
  324. instanceVariableNames: ''
  325. package: 'Kernel-Announcements'!
  326. !ProtocolRemoved commentStamp!
  327. I am emitted when a protocol is removed from a class.!