Kernel-Announcements.st 8.9 KB

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