1
0

Kernel-Announcements.st 10.0 KB

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