"{ Package: 'stx:goodies/monticello' }"

Object subclass:#MCPackageLoader
	instanceVariableNames:'requirements unloadableDefinitions obsoletions additions removals
		errorDefinitions provisions'
	classVariableNames:''
	poolDictionaries:''
	category:'Monticello-Loading'
!


!MCPackageLoader class methodsFor:'as yet unclassified'!

installSnapshot: aSnapshot
	self new
		installSnapshot: aSnapshot;
		load
!

new
	^ self basicNew initialize
!

unloadPackage: aPackage
	self new
		unloadPackage: aPackage;
		loadWithNameLike: aPackage name, '-unload'
!

updatePackage: aPackage withSnapshot: aSnapshot
	self new
		updatePackage: aPackage withSnapshot: aSnapshot;
		load
! !

!MCPackageLoader methodsFor:'patch ops'!

addDefinition: aDefinition
	additions add: aDefinition
!

modifyDefinition: old to: new
	self addDefinition: new.
	obsoletions at: new put: old.
!

removeDefinition: aDefinition
	removals add: aDefinition
! !

!MCPackageLoader methodsFor:'private'!

analyze
	| sorter |
	sorter _ self sorterForItems: additions.
	additions _ sorter orderedItems.
	requirements _ sorter externalRequirements.
	unloadableDefinitions _ sorter itemsWithMissingRequirements asSortedCollection.
	
	sorter _ self sorterForItems: removals.
	removals _ sorter orderedItems reversed.
!

basicLoad
	errorDefinitions _ OrderedCollection new.
	[[additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Loading...'.
	removals do: [:ea | ea unload] displayingProgress: 'Cleaning up...'.
	self shouldWarnAboutErrors ifTrue: [self warnAboutErrors].
	errorDefinitions do: [:ea | ea loadOver: (self obsoletionFor: ea)] displayingProgress: 'Reloading...'.
	additions do: [:ea | ea postloadOver: (self obsoletionFor: ea)] displayingProgress: 'Initializing...']
		on: InMidstOfFileinNotification 
		do: [:n | n resume: true]]
			ensure: [self flushChangesFile]
!

dependencyWarning
	^ String streamContents:
		[:s |
		s nextPutAll: 'This package depends on the following classes:'; cr.
		requirements do: [:ea | s space; space; nextPutAll: ea; cr].
		s nextPutAll: 'You must resolve these dependencies before you will be able to load these definitions: '; cr.
		unloadableDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] 
!

errorDefinitionWarning
	^ String streamContents:
		[:s |
		s nextPutAll: 'The following definitions had errors while loading.  Press Proceed to try to load them again (they may work on a second pass):'; cr.
		errorDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] 
!

flushChangesFile
	"The changes file is second in the SourceFiles array"

	(SourceFiles at: 2) flush
!

initialize
	additions _ OrderedCollection new.
	removals _ OrderedCollection new.
	obsoletions _ Dictionary new.
!

obsoletionFor: aDefinition
	^ obsoletions at: aDefinition ifAbsent: [nil]
!

orderDefinitionsForLoading: aCollection
	^ (self sorterForItems: aCollection) orderedItems
!

orderedAdditions
	^ additions
!

provisions
	^ provisions ifNil: [provisions _ Set withAll: Smalltalk keys]
!

shouldWarnAboutErrors
	^ errorDefinitions isEmpty not and: [false "should make this a preference"]
!

sorterForItems: aCollection
	| sorter |
	sorter _ MCDependencySorter items: aCollection.
	sorter addExternalProvisions: self provisions.
	^ sorter
!

tryToLoad: aDefinition
	[aDefinition loadOver: (self obsoletionFor: aDefinition)] on: Error do: [errorDefinitions add: aDefinition].
!

useChangeSetNamed: baseName during: aBlock
	"Use the named change set, or create one with the given name."
	| changeHolder oldChanges newChanges |
	changeHolder _ (ChangeSet respondsTo: #newChanges:)
						ifTrue: [ChangeSet]
						ifFalse: [Smalltalk].
	oldChanges _ (ChangeSet respondsTo: #current)
						ifTrue: [ChangeSet current]
						ifFalse: [Smalltalk changes].

	newChanges _ (ChangeSorter changeSetNamed: baseName) ifNil: [ ChangeSet new name: baseName ].
	changeHolder newChanges: newChanges.
	[aBlock value] ensure: [changeHolder newChanges: oldChanges].
!

useNewChangeSetDuring: aBlock
	^self useNewChangeSetNamedLike: 'MC' during: aBlock
!

useNewChangeSetNamedLike: baseName during: aBlock
	^self useChangeSetNamed: (ChangeSet uniqueNameLike: baseName) during: aBlock
!

warnAboutDependencies 
	self notify: self dependencyWarning
!

warnAboutErrors
	self notify: self errorDefinitionWarning.
! !

!MCPackageLoader methodsFor:'public'!

installSnapshot: aSnapshot
	| patch |
	patch _ aSnapshot patchRelativeToBase: MCSnapshot empty.
	patch applyTo: self.
!

load
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useNewChangeSetDuring: [self basicLoad]
!

loadWithName: baseName
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useChangeSetNamed: baseName during: [self basicLoad]
!

loadWithNameLike: baseName
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useNewChangeSetNamedLike: baseName during: [self basicLoad]
!

unloadPackage: aPackage
	self updatePackage: aPackage withSnapshot: MCSnapshot empty
!

updatePackage: aPackage withSnapshot: aSnapshot
	|  patch packageSnap |
	packageSnap _ aPackage snapshot.
	patch _ aSnapshot patchRelativeToBase: packageSnap.
	patch applyTo: self.
	packageSnap definitions do: [:ea | self provisions addAll: ea provisions]
! !

!MCPackageLoader class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/goodies/monticello/MCPackageLoader.st,v 1.1 2006-11-22 13:12:56 cg Exp $'
! !