--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/MetacelloScriptEngine.st Mon Sep 03 11:13:41 2012 +0000
@@ -0,0 +1,459 @@
+"{ Package: 'stx:goodies/metacello' }"
+
+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:: $'
+! !