amber/st/Kernel-Announcements.st

Smalltalk current createPackage: 'Kernel-Announcements'!
Object subclass: #AnnouncementSubscription
	instanceVariableNames: 'valuable announcementClass'
	package: 'Kernel-Announcements'!
!AnnouncementSubscription commentStamp!
The subscription is a single entry in a subscription registry of an `Announcer`.
Several subscriptions by the same object is possible.!

!AnnouncementSubscription methodsFor: 'accessing'!

announcementClass
	^ announcementClass
!

announcementClass: aClass
	announcementClass := aClass
!

block
	"Use #valuable instead"
	
	self deprecatedAPI.
	^ self valuable
!

block: aValuable
	"Use #valuable instead"
	
	self deprecatedAPI.
	self valuable: aValuable
!

receiver
	^ self valuable receiver
!

valuable
	^ valuable
!

valuable: aValuable
	valuable := aValuable
! !

!AnnouncementSubscription methodsFor: 'announcing'!

deliver: anAnnouncement
	(self handlesAnnouncement: anAnnouncement)
		ifTrue: [self valuable value: anAnnouncement]
!

handlesAnnouncement: anAnnouncement
	"anAnnouncement might be announced from within another Amber environment"
	
	^ (Smalltalk current at: self announcementClass name)
		ifNil: [ ^ false ]
		ifNotNil: [ :class |
		class includesBehavior: (Smalltalk current at: anAnnouncement class theNonMetaClass name) ]
! !

Object subclass: #Announcer
	instanceVariableNames: 'registry subscriptions'
	package: 'Kernel-Announcements'!
!Announcer commentStamp!
The code is based on the announcements as [described by Vassili Bykov](http://www.cincomsmalltalk.com/userblogs/vbykov/blogView?searchCategory=Announcements%20Framework).
The Announcer holds annoncement subscriptions (`AnnouncementSubscription`) in a private registry.

Use `#on:do:` to register subscriptions.!

!Announcer methodsFor: 'announcing'!

announce: anAnnouncement
	subscriptions do: [ :each |
		each deliver: anAnnouncement ]
! !

!Announcer methodsFor: 'initialization'!

initialize
	super initialize.
	subscriptions := OrderedCollection new
! !

!Announcer methodsFor: 'subscribing'!

on: aClass do: aBlock
	subscriptions add: (AnnouncementSubscription new
		valuable: aBlock;
		announcementClass: aClass;
		yourself)
!

on: aClass send: aSelector to: anObject
	subscriptions add: (AnnouncementSubscription new
		valuable: (MessageSend new
			receiver: anObject;
			selector: aSelector;
			yourself);
		announcementClass: aClass;
		yourself)
!

unsubscribe: anObject
	subscriptions := subscriptions reject: [ :each |
		each receiver = anObject ]
! !

Announcer subclass: #SystemAnnouncer
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!
!SystemAnnouncer commentStamp!
My unique instance #current is the global announcer handling all Amber system-related announces!

SystemAnnouncer class instanceVariableNames: 'current'!

!SystemAnnouncer class methodsFor: 'accessing'!

current
	^ current ifNil: [ current := super new ]
! !

!SystemAnnouncer class methodsFor: 'instance creation'!

new
	self shouldNotImplement
! !

Object subclass: #SystemAnnouncement
	instanceVariableNames: 'theClass'
	package: 'Kernel-Announcements'!
!SystemAnnouncement commentStamp!
I am the superclass of all system announcements!

!SystemAnnouncement methodsFor: 'accessing'!

theClass
	^ theClass
!

theClass: aClass
	theClass := aClass
! !

SystemAnnouncement subclass: #ClassAnnouncement
	instanceVariableNames: 'theClass'
	package: 'Kernel-Announcements'!

!ClassAnnouncement methodsFor: 'accessing'!

theClass
	^ theClass
!

theClass: aClass
	theClass := aClass
! !

ClassAnnouncement subclass: #ClassAdded
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!
!ClassAdded commentStamp!
I am emitted when a class is added to the system.
See ClassBuilder >> #addSubclassOf:... methods!

ClassAnnouncement subclass: #ClassCommentChanged
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!
!ClassCommentChanged commentStamp!
I am emitted when the comment of a class changes. (Behavior >> #comment)!

ClassAnnouncement subclass: #ClassDefinitionChanged
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!
!ClassDefinitionChanged commentStamp!
I am emitted when the defintion of a class changes.
See ClassBuilder >> #class:instanceVariableNames:!

ClassAnnouncement subclass: #ClassMigrated
	instanceVariableNames: 'oldClass'
	package: 'Kernel-Announcements'!

!ClassMigrated methodsFor: 'accessing'!

oldClass
	^ oldClass
!

oldClass: aClass
	oldClass := aClass
! !

ClassAnnouncement subclass: #ClassMoved
	instanceVariableNames: 'oldPackage'
	package: 'Kernel-Announcements'!

!ClassMoved methodsFor: 'accessing'!

oldPackage
	^ oldPackage
!

oldPackage: aPackage
	oldPackage := aPackage
! !

ClassAnnouncement subclass: #ClassRemoved
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!
!ClassRemoved commentStamp!
I am emitted when a class is removed.
See Smalltalk >> #removeClass:!

ClassAnnouncement subclass: #ClassRenamed
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!
!ClassRenamed commentStamp!
I am emitted when a class is renamed.
See ClassBuilder >> #renameClass:to:!

SystemAnnouncement subclass: #MethodAnnouncement
	instanceVariableNames: 'method'
	package: 'Kernel-Announcements'!

!MethodAnnouncement methodsFor: 'accessing'!

method
	^ method
!

method: aCompiledMethod
	method := aCompiledMethod
! !

MethodAnnouncement subclass: #MethodAdded
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!

MethodAnnouncement subclass: #MethodModified
	instanceVariableNames: 'oldMethod'
	package: 'Kernel-Announcements'!

!MethodModified methodsFor: 'accessing'!

oldMethod
	^ oldMethod
!

oldMethod: aMethod
	oldMethod := aMethod
! !

MethodAnnouncement subclass: #MethodMoved
	instanceVariableNames: 'oldProtocol'
	package: 'Kernel-Announcements'!

!MethodMoved methodsFor: 'accessing'!

oldProtocol
	^ oldProtocol
!

oldProtocol: aString
	oldProtocol := aString
! !

MethodAnnouncement subclass: #MethodRemoved
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!

SystemAnnouncement subclass: #PackageAnnouncement
	instanceVariableNames: 'package'
	package: 'Kernel-Announcements'!

!PackageAnnouncement methodsFor: 'accessing'!

package
	^ package
!

package: aPackage
	package := aPackage
! !

PackageAnnouncement subclass: #PackageAdded
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!

PackageAnnouncement subclass: #PackageRemoved
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!

SystemAnnouncement subclass: #ProtocolAnnouncement
	instanceVariableNames: 'theClass protocol'
	package: 'Kernel-Announcements'!

!ProtocolAnnouncement methodsFor: 'accessing'!

protocol
	^ protocol
!

protocol: aString
	protocol := aString
!

theClass
	^ theClass
!

theClass: aClass
	theClass := aClass
! !

ProtocolAnnouncement subclass: #ProtocolAdded
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!

ProtocolAnnouncement subclass: #ProtocolRemoved
	instanceVariableNames: ''
	package: 'Kernel-Announcements'!