"{ 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 $'

! !