1
0

Kernel-Announcements.st 9.5 KB

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