"{ 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;

                ifFalse: [ new ] ].

    ^ registration lookupSpec: aProjectSpec

!

validateProjectSpecForScript

    | issues |

    issues := self projectSpec

        validateForScriptLoad: self

        withDefaultVersionString: self defaultVersionString

        withDefaultRepositoryDecription: self defaultRepositoryDescription.

    issues isEmpty

        ifTrue: [ ^ self ].

! !

!MetacelloScriptEngine class methodsFor:'documentation'!

version_SVN

    ^ '$Id::                                                                                                                        $'

! !