"{ Package: 'stx:goodies/metacello/core' }"

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::                                                                                                                        $'
! !