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

Object subclass:#MetacelloScriptEngine
	instanceVariableNames:'root projectSpec options'
	classVariableNames:'DefaultRepositoryDescription DefaultVersionString'
	poolDictionaries:''
	category:'Metacello-Core-Scripts'
!


!MetacelloScriptEngine class methodsFor:'defaults'!

defaultRepositoryDescription
    DefaultRepositoryDescription
        ifNil: [ DefaultRepositoryDescription := MetacelloPlatform current defaultRepositoryDescription ].
    ^ DefaultRepositoryDescription
!

defaultVersionString
    DefaultVersionString ifNil: [ DefaultVersionString := #'stable' ].
    ^ DefaultVersionString
! !

!MetacelloScriptEngine class methodsFor:'utility'!

baseNameOf: className
    ^ (className indexOfSubCollection: 'BaselineOf') = 0
        ifTrue: [ 
            (className indexOfSubCollection: 'ConfigurationOf') = 0
                ifTrue: [ className ]
                ifFalse: [ className copyFrom: 'ConfigurationOf' size + 1 to: className size ] ]
        ifFalse: [ className copyFrom: 'BaselineOf' size + 1 to: className size ]
!

baselineNameFrom: baseName
    "Return the fully-qualified configuration class name."

    ^ (baseName indexOfSubCollection: 'BaselineOf') > 0
        ifTrue: [ baseName ]
        ifFalse: [ 'BaselineOf' , baseName ]
!

baselineProjectNameOf: baselineClassName
    ^ (baselineClassName indexOfSubCollection: 'BaselineOf') = 0
        ifTrue: [ baselineClassName ]
        ifFalse: [ baselineClassName copyFrom: 'BaselineOf' size + 1 to: baselineClassName size ]
!

configurationNameFrom: baseName
    "Return the fully-qualified configuration class name."

    ^ (baseName indexOfSubCollection: 'ConfigurationOf') > 0
        ifTrue: [ baseName ]
        ifFalse: [ 'ConfigurationOf' , baseName ]
!

configurationProjectNameOf: configurationClassName
    ^ (configurationClassName indexOfSubCollection: 'ConfigurationOf') = 0
        ifTrue: [ configurationClassName ]
        ifFalse: [ configurationClassName copyFrom: 'ConfigurationOf' size + 1 to: configurationClassName size ]
! !

!MetacelloScriptEngine methodsFor:'accessing'!

options
    options ifNil: [ options := Dictionary new ].
    ^ options
!

options: aDictionary
    options := aDictionary
!

projectName
    ^ self projectSpec name
!

projectSpec
    ^ projectSpec
!

projectSpec: aProjectSpec
    projectSpec := aProjectSpec
!

repositories
    ^ self projectSpec repositories
!

root
	^ root
!

root: anObject
	root := anObject
! !

!MetacelloScriptEngine methodsFor:'actions api'!

fetch: required
    self
        fetchRecord: [ :version | 
            required isEmpty
                ifTrue: [ version fetch ]
                ifFalse: [ version fetch: required ] ]
        required: required
!

fetchRecord: fetchRecordBlock required: required
    MetacelloProjectRegistration
        copyRegistryWhile: [ 
            self
                handleNotificationsForAction: [ 
                    | version loadedSpec |
                    self validateProjectSpecForScript.
                    [ loadedSpec := self lookupProjectSpecFor: self projectSpec ]
                        on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade
                        do: [ :notification | 
                            notification
                                handleOnDownGrade: [ :ex :existing :new | ex allowEvenIfLocked ]
                                onUpgrade: [ :ex :existing :new | ex allowEvenIfLocked ] ].
                    version := loadedSpec versionForScriptEngine: self.
                    self root: (fetchRecordBlock value: version) loadDirective ] ]
!

get
    " load a fresh copy from repo"

    | spec projectPackage |
    MetacelloProjectRegistration
        copyRegistryRestoreOnErrorWhile: [ 
            self validateProjectSpecForScript.
            spec := self projectSpec.
            projectPackage := spec projectPackage.
            projectPackage repositorySpecs do: [ :repoSpec | repoSpec createRepository flushForScriptGet ].
            projectPackage load.
            self root: (Smalltalk at: spec className asSymbol) project.
            MetacelloProjectRegistration
                registrationForProjectSpec: spec
                ifAbsent: [ :new | new registerProject ]
                ifPresent: [ :existing :new | 
                    existing
                        copyOnWrite: [ :existingCopy | 
                            spec
                                copyForRegistration: existingCopy
                                onWrite: [ :specCopy | specCopy ifNil: [ existingCopy merge: new ] ifNotNil: [ specCopy mergeScriptRepository: spec ] ] ] ] ]
!

list
    self validateProjectSpecForScript.
    self root: self projectSpec
!

load: required
    self
        load: required
        onProjectDownGrade: [ :ex :existing :new | ex allowEvenIfLocked ]
        onProjectUpgrade: [ :ex :existing :new | ex allowEvenIfLocked ]
!

load: required onProjectDownGrade: onDownGradeBlock onProjectUpgrade: onUpgradeBlock
    MetacelloProjectRegistration
        copyRegistryRestoreOnErrorWhile: [ 
            self
                handleNotificationsForAction: [ 
                    | version loadedSpec |
                    self validateProjectSpecForScript.
                    [ loadedSpec := self lookupProjectSpecFor: self projectSpec ]
                        on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade
                        do: [ :ex | ex handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock ].
                    version := loadedSpec versionForScriptEngine: self.
                    self
                        root:
                            (required isEmpty
                                ifTrue: [ version load ]
                                ifFalse: [ version load: required ]) loadDirective.
                    loadedSpec loads: required.
                    MetacelloProjectRegistration
                        registrationForProjectSpec: loadedSpec
                        ifAbsent: [ :new | 
                            new
                                loadedInImage: true;
                                registerProject ]
                        ifPresent: [ :existing :new | 
                            existing
                                copyOnWrite: [ :existingCopy | 
                                    existingCopy
                                        loadedInImage: true;
                                        merge: new ] ] ] ]
!

lock
    | spec |
    MetacelloProjectRegistration
        copyRegistryRestoreOnErrorWhile: [ 
            self validateProjectSpecForScript.
            spec := self projectSpec.
            MetacelloProjectRegistration
                registrationForProjectSpec: spec
                ifAbsent: [ :new | 
                    new
                        locked: true;
                        registerProject ]
                ifPresent: [ :existing :new | 
                    existing
                        copyOnWrite: [ :existingCopy | 
                            existingCopy locked: true.
                            spec
                                copyForRegistration: existingCopy
                                onWrite: [ :specCopy | 
                                    specCopy
                                        ifNil: [ existingCopy merge: new ]
                                        ifNotNil: [ 
                                            specCopy mergeScriptRepository: spec.
                                            spec := specCopy ] ] ] ].
            self root: spec ]
!

record: required
    self
        fetchRecord: [ :version | 
            required isEmpty
                ifTrue: [ version record ]
                ifFalse: [ version record: required ] ]
        required: required
!

unlock
    | spec |
    MetacelloProjectRegistration
        copyRegistryRestoreOnErrorWhile: [ 
            self validateProjectSpecForScript.
            spec := self projectSpec.
            MetacelloProjectRegistration
                registrationForProjectSpec: spec
                ifAbsent: [ :ignored |  ]
                ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | existingCopy locked: false ] ].
            self root: spec ]
! !

!MetacelloScriptEngine methodsFor:'defaults'!

defaultRepositoryDescription
    ^ self class defaultRepositoryDescription
!

defaultVersionString
    ^ self class defaultVersionString
! !

!MetacelloScriptEngine methodsFor:'handlers'!

handleConflict: exception
    ^ (self options at: #'onConflict' ifAbsent: [ ^ exception pass ])
        cull: exception
        cull: exception existingProjectRegistration
        cull: exception newProjectRegistration
!

handleDowngrade: exception
    ^ (self options at: #'onDowngrade' ifAbsent: [ ^ exception pass ])
        cull: exception
        cull: exception existingProjectRegistration
        cull: exception newProjectRegistration
!

handleEnsureProjectLoadedForDevelopment: exception
    "if useCurrentVersion resume with true, else resume with false"

    ^ exception resume: self useCurrentVersion
!

handleLookupBaselineSpecForEnsureLoad: exception
	"if existing and new don't compare equal, then ensure the new baseline is loaded"

	| existing new |
	new := exception projectSpec.
	existing := self lookupBaselineSpecForEnsure: exception projectSpec.
	^ exception resume: (existing registrationsCompareEqual: new) not
!

handleLookupProjectSpec: exception
    ^ exception
        resume:
            ((self lookupProjectSpecFor: exception projectSpec) ifNil: [ ^ exception resume: exception projectSpec ])
!

handleLookupProjectSpecForLoad: exception
    "if overrideProjectSpec is nil, use currentVersion in image, ignoreImage is false"

    | existing new override |
    existing := exception projectSpec.
    override := self useCurrentVersion
        ifTrue: [ 
            "don't do lookup in registry if we expect to use the #currentVersion calculation"
            nil ]
        ifFalse: [ 
            new := self lookupProjectSpecFor: exception projectSpec.
            (new compareEqual: existing)
                ifFalse: [ 
                    "counts as override, only if they differ in some aspect"
                    override := new ] ].
    ^ exception
        resume:
            (MetacelloProjectSpecForLoad new
                projectSpec: existing;
                useDetermineVersionForLoad: self useCurrentVersion;
                overrideProjectSpec: override;
                yourself)
!

handleNotificationsForAction: actionBlock
	[ 
	actionBlock
		on:
			MetacelloLookupProjectSpec , MetacelloLookupProjectSpecForLoad , MetacelloProjectSpecLoadedNotification
				, MetacelloScriptEnsureProjectLoadedForDevelopment , MetacelloLookupBaselineSpecForEnsureLoad
		do: [ :ex | 
			"lookup and registration handlers need to be innermost set of handlers ...they may throw option notifications"
			ex handleResolutionFor: self ] ]
		on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade , MetacelloAllowConflictingProjectUpgrade
		do: [ :ex | 
			"option handlers need to be outermost set of handlers ... last line of defense before users are involved"
			ex handleResolutionFor: self ]
!

handleProjectSpecLoaded: exception
    MetacelloProjectRegistration
        registrationForProjectSpec: exception projectSpec
        ifAbsent: [ :new | 
            new
                loadedInImage: true;
                registerProject ]
        ifPresent: [ :existing :new | 
            "unconditionally merge new with existing (updates registration)"
            existing
                copyOnWrite: [ :existingCopy | 
                    existingCopy
                        loadedInImage: true;
                        merge: new ] ].
    exception resume
!

handleUpgrade: exception
    ^ (self options at: #'onUpgrade' ifAbsent: [ ^ exception pass ])
        cull: exception
        cull: exception existingProjectRegistration
        cull: exception newProjectRegistration
! !

!MetacelloScriptEngine methodsFor:'options'!

cacheRepository
    ^ (MetacelloMCProject new repositorySpec description: (self options at: #'cacheRepository' ifAbsent: [ ^ nil ]))
        createRepository
!

ignoreImage
    ^ self options at: #'ignoreImage' ifAbsent: [ false ]
!

repositoryOverrides
    ^ (self options at: #'repositoryOverrides' ifAbsent: [ ^ nil ])
        collect: [ :description | (MetacelloMCProject new repositorySpec description: description) createRepository ]
!

silently
    ^ self options at: #'silently' ifAbsent: [ false ]
!

useCurrentVersion
    "private option used to implement the classic mode"

    ^ self options at: #'useCurrentVersion' ifAbsent: [ false ]
! !

!MetacelloScriptEngine methodsFor:'project lookup'!

getBaselineProjectUnconditionalLoad: unconditionalLoad
    | project |
    project := (self getBaselineUnconditionalLoad: unconditionalLoad) project.
    project version spec repositories: self repositories copy.
    ^ project
!

getBaselineUnconditionalLoad: unconditionalLoad
    | spec |
    spec := self projectSpec.
    Smalltalk
        at: spec className asSymbol
        ifPresent: [ :cl | 
            unconditionalLoad
                ifFalse: [ ^ cl ] ].
    (spec := self lookupProjectSpecFor: spec) projectPackage load.
    ^ Smalltalk at: spec className asSymbol
!

getConfigurationProjectUnconditionalLoad: unconditionalLoad
    ^ (self getConfigurationUnconditionalLoad: unconditionalLoad) project
!

getConfigurationUnconditionalLoad: unconditionalLoad
    | spec |
    spec := self projectSpec.
    Smalltalk
        at: spec className asSymbol
        ifPresent: [ :cl | 
            unconditionalLoad
                ifFalse: [ ^ cl ] ].
    (spec := self lookupProjectSpecFor: spec) projectPackage load.
    ^ Smalltalk at: spec className asSymbol
!

lookupBaselineSpecForEnsure: aProjectSpec
	| registration loadedSpec |
	registration := MetacelloProjectRegistration
		registrationForProjectSpec: aProjectSpec
		ifAbsent: [ :new | new ]
		ifPresent: [ :existing :new | existing ].
	^ registration lookupSpec: aProjectSpec
!

lookupProjectSpecFor: aProjectSpec
    | registration loadedSpec |
    registration := MetacelloProjectRegistration
        registrationForProjectSpec: aProjectSpec
        ifAbsent: [ :new | new ]
        ifPresent: [ :existing :new | 
            (existing hasLoadConflicts: new)
                ifTrue: [ 
                    ((existing canUpgradeTo: new)
                        ifTrue: [ MetacelloAllowProjectUpgrade new ]
                        ifFalse: [ 
                            (existing canDowngradeTo: new)
                                ifTrue: [ MetacelloAllowProjectDowngrade new ]
                                ifFalse: [ MetacelloAllowConflictingProjectUpgrade new ] ])
                        existingProjectRegistration: existing;
                        newProjectRegistration: new;
                        signal ]
                ifFalse: [ new ] ].
    ^ registration lookupSpec: aProjectSpec
!

validateProjectSpecForScript
    | issues |
    issues := self projectSpec
        validateForScriptLoad: self
        withDefaultVersionString: self defaultVersionString
        withDefaultRepositoryDecription: self defaultRepositoryDescription.
    issues isEmpty
        ifTrue: [ ^ self ].
    (MetacelloValidationFailure issues: issues message: 'Project spec validation failure') signal
! !

!MetacelloScriptEngine class methodsFor:'documentation'!

version_SVN
    ^ '$Id::                                                                                                                        $'
! !