"{ Package: 'stx:goodies/metacello' }"
Object subclass:#MetacelloProjectRegistration
instanceVariableNames:'projectName configurationProjectSpec baselineProjectSpec
loadedInImage locked mutable'
classVariableNames:'Registry'
poolDictionaries:''
category:'Metacello-Core-Scripts'
!
!MetacelloProjectRegistration class methodsFor:'instance creation'!
fromMCBaselineProjectSpec: aProjectSpec
^ self new
projectName: aProjectSpec name;
baselineProjectSpec: aProjectSpec;
yourself
!
fromMCConfigurationProjectSpec: aProjectSpec
^ self new
projectName: aProjectSpec name;
configurationProjectSpec: aProjectSpec;
yourself
! !
!MetacelloProjectRegistration class methodsFor:'accessing'!
baselineClasses
"Return a set of the Metacello baseline classes that have been loaded into the image."
"self baselineClasses"
^ BaselineOf allSubclasses
!
baselineProjectSpecs
"MetacelloProjectRegistration baselineProjectSpecs"
^ self registry baselineProjectSpecs
!
configurationClasses
"Return a set of the Metacello configuration classes that have been loaded into the image."
"self configurationClasses"
| answer |
answer := IdentitySet new.
ConfigurationOf allSubclasses
do: [ :cl |
(cl == BaselineOf or: [ cl inheritsFrom: BaselineOf ])
ifFalse: [ answer add: cl ] ].
Object allSubclasses
do: [ :cl |
(answer includes: cl)
ifFalse: [
(([ cl isMetacelloConfig ]
on: Error
do: [ :ex | ex return: false ]) and: [ cl name asString beginsWith: 'ConfigurationOf' ])
ifTrue: [ answer add: cl ] ] ].
^ answer
!
configurationProjectSpecs
"MetacelloProjectRegistration configurationProjectSpecs"
^ self registry configurationProjectSpecs
!
primeRegistryFromImage
"MetacelloProjectRegistration primeRegistryFromImage"
self registry primeRegistryFromImage
!
projectSpecs
"MetacelloProjectRegistration projectSpecs"
^ self configurationProjectSpecs , self baselineProjectSpecs
!
registry
Registry ifNil: [ Registry := MetacelloProjectRegistry new ].
^ Registry
!
registry: aMetacelloProjectRegistry
Registry := aMetacelloProjectRegistry
!
resetRegistry
Registry := nil
! !
!MetacelloProjectRegistration class methodsFor:'mutability'!
copyRegistryRestoreOnErrorWhile: aBlock
"install copy of registry for duration of <aBlock> execution."
"registrations will be copied on write during <aBlock> execution."
"if <aBlock> does not return control to this context, revert to the original
version of the registry. Otherwise leave the new copy installed."
| oldRegistry newRegistry |
oldRegistry := self registry.
newRegistry := self registry copy.
self registry: newRegistry.
aBlock
ensure: [
"install old version of registry"
self registry: oldRegistry ].
self registry: newRegistry "if control returned, install newRegistry"
!
copyRegistryWhile: aBlock
"install copy of registry for duration of <aBlock> execution."
"registrations will be copied on write during <aBlock> execution."
"Unconditionally revert to the original
version of the registry. Otherwise leave the new copy installed."
| oldRegistry newRegistry |
oldRegistry := self registry.
newRegistry := self registry copy.
self registry: newRegistry.
aBlock
ensure: [
"install old version of registry"
self registry: oldRegistry ]
! !
!MetacelloProjectRegistration class methodsFor:'querying'!
projectSpecForClassNamed: aClassName ifAbsent: absentBlock
^ self registry projectSpecForClassNamed: aClassName ifAbsent: absentBlock
!
registrationForClassNamed: aClassName ifAbsent: absentBlock
^ self registry registrationForClassNamed: aClassName ifAbsent: absentBlock
!
registrationForProjectSpec: aProjectSpec ifAbsent: absentBlock ifPresent: presentBlock
| newRegistration |
newRegistration := aProjectSpec asProjectRegistration.
self registry
registrationFor: newRegistration
ifPresent: [ :existing | ^ presentBlock value: existing value: newRegistration ]
ifAbsent: [ ^ absentBlock value: newRegistration ]
! !
!MetacelloProjectRegistration class methodsFor:'registration'!
registerProjectSpec: aProjectSpec ifPresent: presentBlock
| newRegistration |
newRegistration := aProjectSpec asProjectRegistration.
^ self registry
registrationFor: newRegistration
ifPresent: [ :existing | presentBlock value: existing value: newRegistration ]
ifAbsent: [ newRegistration registerProject ]
! !
!MetacelloProjectRegistration methodsFor:'accessing'!
baseName
^ MetacelloScriptEngine baseNameOf: (configurationProjectSpec ifNil: [ baselineProjectSpec ]) className
!
baselineProjectSpec
^ baselineProjectSpec
!
baselineProjectSpec: anObject
self shouldBeMutable.
baselineProjectSpec := anObject
!
baselineProjectSpecIfAbsent: absentBlock
^ baselineProjectSpec ifNil: absentBlock
!
baselineProjectSpecIfPresent: presentBlock ifAbsent: absentBlock
^ baselineProjectSpec ifNotNil: [ presentBlock cull: baselineProjectSpec ] ifNil: absentBlock
!
configurationProjectSpec
^ configurationProjectSpec
!
configurationProjectSpec: anObject
self shouldBeMutable.
configurationProjectSpec := anObject
!
configurationProjectSpecIfAbsent: absentBlock
^ configurationProjectSpec ifNil: absentBlock
!
configurationProjectSpecIfPresent: presentBlock ifAbsent: absentBlock
^ configurationProjectSpec ifNotNil: [ presentBlock cull: configurationProjectSpec ] ifNil: absentBlock
!
loadedInImage
loadedInImage ifNil: [ loadedInImage := false ].
^ loadedInImage
!
loadedInImage: anObject
self shouldBeMutable.
loadedInImage := anObject
!
locked
locked ifNil: [ locked := false ].
^ locked
!
locked: anObject
self shouldBeMutable.
locked := anObject
!
projectName
^ projectName
!
projectName: anObject
self shouldBeMutable.
projectName := anObject
!
repositoryDescriptions
^ (self configurationProjectSpecIfAbsent: [ self baselineProjectSpec ]) repositoryDescriptions
!
version
^ (self configurationProjectSpecIfAbsent: [ ^ MetacelloMCBaselineProject singletonVersionName ]) versionString
! !
!MetacelloProjectRegistration methodsFor:'comparision'!
= aRegistration
aRegistration class == self class
ifFalse: [ ^ false ].
^ (configurationProjectSpec registrationsCompareEqual: aRegistration configurationProjectSpec)
and: [ baselineProjectSpec registrationsCompareEqual: aRegistration baselineProjectSpec ]
!
hash
^ ((String stringHash: projectName initialHash: 0) bitXor: configurationProjectSpec metacelloRegistrationHash)
bitXor: baselineProjectSpec metacelloRegistrationHash
! !
!MetacelloProjectRegistration methodsFor:'copying'!
postCopy
super postCopy.
mutable := nil
! !
!MetacelloProjectRegistration methodsFor:'lookup'!
lookupBaselineSpec
baselineProjectSpec ifNotNil: [ :spec | ^ spec ].
^ configurationProjectSpec
!
lookupConfigurationSpec
configurationProjectSpec ifNotNil: [ :spec | ^ spec ].
^ baselineProjectSpec
!
lookupSpec: aProjectSpec
self configurationProjectSpec
ifNotNil: [ :spec |
spec className = aProjectSpec className
ifTrue: [ ^ spec ] ].
self baselineProjectSpec
ifNotNil: [ :spec |
spec className = aProjectSpec className
ifTrue: [ ^ spec ] ].
^ nil
! !
!MetacelloProjectRegistration methodsFor:'merging'!
merge: aProjectRegistration
"should only be called from MetacelloProjectRegistration class>>mergeRegistration:with: ... merge is done when a spec has been loaded into the image"
"nil specs are ignored in the merge, otherwise aProjectRegistration specs win"
"(self hasMergeConflicts: aProjectRegistration)
ifTrue: [ ^ self error: 'Attempt to merge registrations with conflicts' ]."
self shouldBeMutable.
configurationProjectSpec
ifNil: [ configurationProjectSpec := aProjectRegistration configurationProjectSpec ]
ifNotNil: [
aProjectRegistration configurationProjectSpec
ifNotNil: [ configurationProjectSpec := aProjectRegistration configurationProjectSpec ] ].
baselineProjectSpec
ifNil: [ baselineProjectSpec := aProjectRegistration baselineProjectSpec ]
ifNotNil: [ aProjectRegistration baselineProjectSpec ifNotNil: [ baselineProjectSpec := aProjectRegistration baselineProjectSpec ] ]
! !
!MetacelloProjectRegistration methodsFor:'mutability'!
copyOnWrite: aBlock
"assume that only registered projects are immutable ... otherwise you'll get an error"
| copy |
self class registry
registrationFor: self
ifPresent: [ :existing | ]
ifAbsent: [
aBlock value: self.
^ self ].
self unregisterProject.
copy := self copy.
aBlock value: copy.
copy registerProject.
^ copy
!
immutable
mutable := false
!
isMutable
mutable ifNil: [ ^ true ].
^ mutable
!
mutable
mutable := true
!
shouldBeMutable
self isMutable
ifTrue: [ ^ self ].
self error: 'Not allowed to modify an immutable object'
! !
!MetacelloProjectRegistration methodsFor:'printing'!
printOn: aStream
| label versionString descriptions |
self
configurationProjectSpecIfPresent: [ :spec |
label := spec className.
versionString := spec versionString ]
ifAbsent: [
"baseline"
label := self baselineProjectSpec className.
versionString := '[baseline]' ].
aStream
nextPutAll: label;
space;
nextPutAll: versionString.
(descriptions := self repositoryDescriptions) isEmpty
ifTrue: [ ^ self ].
aStream nextPutAll: ' from '.
descriptions size = 1
ifTrue: [ aStream nextPutAll: descriptions first ]
ifFalse: [
aStream nextPut: ${.
descriptions do: [ :description | aStream nextPutAll: description ].
aStream nextPut: $} ]
! !
!MetacelloProjectRegistration methodsFor:'querying'!
currentlyLoadedClassesInProject
| classes |
classes := Set new.
self
configurationProjectSpecIfPresent: [ :spec | classes addAll: spec currentlyLoadedClassesInVersion ]
ifAbsent: [ ].
self baselineProjectSpecIfPresent: [ :spec | classes addAll: spec currentlyLoadedClassesInVersion ] ifAbsent: [ ].
^ classes
! !
!MetacelloProjectRegistration methodsFor:'registration'!
registerProject
"unconditionally register <newRegistration> ... use with care"
self class registry registerProjectRegistration: self
!
unregisterProject
self class registry unregisterProjectRegistration: self
! !
!MetacelloProjectRegistration methodsFor:'testing'!
canDowngradeTo: aProjectRegistration
"true if there are no load conflicts
OR
if the load conflicts involved two cofigurations ONLY and a downgrade is allowed"
(self hasLoadConflicts: aProjectRegistration)
ifFalse: [ ^ true ].
configurationProjectSpec
ifNotNil: [
aProjectRegistration configurationProjectSpec
ifNotNil: [
configurationProjectSpec ensureProjectLoaded.
^ configurationProjectSpec canDowngradeTo: aProjectRegistration configurationProjectSpec ] ].
^ false
!
canUpgradeTo: aProjectRegistration
"true if there are no load conflicts
OR
if the load conflicts involved two cofigurations ONLY and an upgrade is allowed"
(self hasLoadConflicts: aProjectRegistration)
ifFalse: [ ^ true ].
configurationProjectSpec
ifNotNil: [
aProjectRegistration configurationProjectSpec
ifNotNil: [
configurationProjectSpec copy ensureProjectLoaded.
^ configurationProjectSpec canUpgradeTo: aProjectRegistration configurationProjectSpec ] ].
^ false
!
hasLoadConflicts: aProjectRegistration
"5 combinations of loads with no load conflicts:
No configs and baselines =
configs = and no baselines
configs = and baselines =
configs = and no baseline loaded (self) with a baseline to load (aProjectRegistration)
config loaded (self), no config to load (aProjectRegistration) and no baseline loaded(self) with a baseline to load (aProjectRegistration) "
self isValid
ifFalse: [ self error: 'Invalid projectRegistration: ' , self printString ].
aProjectRegistration isValid
ifFalse: [ self error: 'Invalid projectRegistration: ' , aProjectRegistration printString ].
configurationProjectSpec
ifNil: [
aProjectRegistration configurationProjectSpec notNil
ifTrue: [ ^ true ] ]
ifNotNil: [
aProjectRegistration configurationProjectSpec
ifNotNil: [
(aProjectRegistration configurationProjectSpec registrationsCompareEqual: configurationProjectSpec) not
ifTrue: [ ^ true ] ] ].
^ baselineProjectSpec
ifNil: [ false ]
ifNotNil: [ (baselineProjectSpec registrationsCompareEqual: aProjectRegistration baselineProjectSpec) not ]
!
isValid
" has a name and one or the other of the projectSpecs is non-nil"
projectName ifNil: [ ^ false ].
^ configurationProjectSpec notNil or: [ baselineProjectSpec notNil ]
! !
!MetacelloProjectRegistration class methodsFor:'documentation'!
version_SVN
^ '$Id:: $'
! !