"{ 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: [ ^ baselineProjectSpec ].

    ^ configurationProjectSpec

!

lookupConfigurationSpec

    configurationProjectSpec ifNotNil: [ ^ configurationProjectSpec ].

    ^ baselineProjectSpec

!

lookupSpec: aProjectSpec

    | spec |

    (spec := self configurationProjectSpec)

        ifNotNil: [ 

            spec className = aProjectSpec className

                ifTrue: [ ^ spec ] ].

    (spec := self baselineProjectSpec)

        ifNotNil: [ 

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

! !