"{ Encoding: utf8 }"
"{ Package: 'stx:goodies/monticello' }"
"{ NameSpace: Smalltalk }"
Object subclass:#MCPackageLoader
instanceVariableNames:'requirements unloadableDefinitions overrideDefinitions
obsoletions additions removals errorDefinitions provisions'
classVariableNames:'Debugging'
poolDictionaries:''
category:'SCM-Monticello-Loading'
!
!MCPackageLoader class methodsFor:'initialization'!
new
^self basicNew initialize
! !
!MCPackageLoader class methodsFor:'as yet unclassified'!
installSnapshot: aSnapshot
self new
installSnapshot: aSnapshot;
load
!
unloadPackage: aPackage
self new
unloadPackage: aPackage;
loadWithNameLike: aPackage name, '-unload'
!
updatePackage: aPackage withSnapshot: aSnapshot
self new
updatePackage: aPackage withSnapshot: aSnapshot;
load
! !
!MCPackageLoader methodsFor:'accessing'!
overrideDefinitions
^ overrideDefinitions
!
unloadableDefinitions
^ unloadableDefinitions
! !
!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.
overrideDefinitions := additions select:[:e|e isOverrideDefinition].
additions := additions reject: [:e|e isOverrideDefinition].
sorter := self sorterForItems: removals.
removals := sorter orderedItems reversed.
"Modified: / 08-11-2010 / 17:34:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
basicLoad
| allowEmptyStatements allowSqueakExtensions |
allowEmptyStatements := ParserFlags allowEmptyStatements.
allowSqueakExtensions := ParserFlags allowSqueakExtensions.
ParserFlags allowEmptyStatements: true.
ParserFlags allowSqueakExtensions: true.
errorDefinitions := OrderedCollection new.
self warnAboutUnloadables.
[[
| oldErrorDefinitions |
additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Loading...'.
removals do: [:ea | ea unload] displayingProgress: 'Cleaning up...'.
self shouldWarnAboutErrors ifTrue: [self warnAboutErrors].
oldErrorDefinitions := errorDefinitions.
errorDefinitions := OrderedCollection new.
oldErrorDefinitions do: [:ea | self tryToLoad: ea] displayingProgress: 'Reloading...'.
additions do: [:ea | ea postloadOver: (self obsoletionFor: ea)] displayingProgress: 'Initializing...'.
self warnAboutOverrides.
self warnAboutErrors.
]
on: InMidstOfFileinNotification
do: [:n | n resume: true]]
ensure:
[self flushChangesFile.
ParserFlags allowEmptyStatements: allowEmptyStatements.
ParserFlags allowSqueakExtensions: allowSqueakExtensions.
]
"Modified: / 08-11-2010 / 23:49:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-08-2011 / 18:20:54 / cg"
!
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"
"Modified: / 11-09-2010 / 18:32:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
ifInteractive: aBlock
^self ifInteractive: aBlock else:[]
"Created: / 06-03-2011 / 20:32:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
ifInteractive: interactiveBlock else: noninteractiveBlock
MCInteractiveLoadingQuery query
ifTrue:[interactiveBlock value]
ifFalse:[noninteractiveBlock value].
"Created: / 06-03-2011 / 20:31:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
initialize
super 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: [:ex |
errorDefinitions add: aDefinition.
Debugging == true ifTrue:[
ex reject
].
Transcript showCR:'error during load (to debug, set MCPackageLoader:Debugging to true): '.
Transcript showCR:ex description.
].
"Modified: / 11-09-2012 / 09:55:23 / cg"
!
tryToLoadAll: definitions label: label
definitions do:[:e|self tryToLoad: e] displayingProgress: label.
"Created: / 09-11-2010 / 17:17:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
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].
"/JV @ 2010-09-11: Don't care about changes
"/newChanges := (ChangeSorter changeSetNamed: baseName) ifNil: [ ChangeSet new name: baseName ].
"/changeHolder newChanges: newChanges.
"/[aBlock value] ensure: [changeHolder newChanges: oldChanges].
"/ Class withoutUpdatingChangesDo: aBlock
aBlock value.
"Modified: / 08-11-2010 / 20:01:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 05-09-2011 / 15:56:36 / cg"
!
useNewChangeSetDuring: aBlock
^self useNewChangeSetNamedLike: 'MC' during: aBlock
!
useNewChangeSetNamedLike: baseName during: aBlock
^self useChangeSetNamed: (ChangeSet uniqueNameLike: baseName) during: aBlock
!
warnAboutDependencies
"
self notify: self dependencyWarning
"
"Modified: / 13-10-2010 / 15:44:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
warnAboutErrors
| changes |
errorDefinitions isNilOrEmptyCollection ifTrue:[^self].
changes := ChangeSet new.
errorDefinitions select:[:e|e notNil] thenDo:[:e|e addChangesTo:changes].
changes := Tools::ChangeSetBrowser2
openOn: changes
label:'Error definitions'.
"Created: / 08-11-2010 / 20:19:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 06-03-2011 / 20:39:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-08-2011 / 18:00:02 / cg"
!
warnAboutOverrides
| changes confirmedChanges definitions |
overrideDefinitions isNilOrEmptyCollection ifTrue:[^self].
self ifInteractive:[
changes := ChangeSet new.
overrideDefinitions do:[:e|e addChangesTo:changes].
self assert:(changes includes:nil) not.
confirmedChanges := Tools::ChangeSetBrowser2
confirmChanges: changes
label:'Overridden definitions. Load anyway?'.
confirmedChanges notEmpty ifTrue:[
confirmedChanges := confirmedChanges flatten.
definitions := confirmedChanges collect:[:e|e mcDefinition] thenSelect:[:e | e notNil].
"/ we might get nil in a roundTrip
"/ (eg. for mcDef --addChangesTo:--> classChange+commentChange --mcDefinition--> mcDef+nil)
"/ self assert:(definitions includes:nil) not.
self tryToLoadAll: definitions label: 'Loading overrides...'.
]
] else:[
self tryToLoadAll: overrideDefinitions label: 'Loading overrides...'.
]
"Created: / 08-11-2010 / 20:19:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 06-03-2011 / 20:33:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-08-2011 / 19:31:40 / cg"
!
warnAboutUnloadables
| changes confirmedChanges definitions |
unloadableDefinitions isNilOrEmptyCollection ifTrue:[^self].
self ifInteractive:[
changes := ChangeSet new.
unloadableDefinitions do:[:e|e addChangesTo:changes].
self assert:(changes includes:nil) not.
confirmedChanges := Tools::ChangeSetBrowser2
confirmChanges: changes
label:'Unsatisfied dependencies. Load anyway?'.
confirmedChanges notEmpty ifTrue:[
confirmedChanges := confirmedChanges flatten.
definitions := confirmedChanges collect:[:e|e mcDefinition] thenSelect:[:e | e notNil].
"/ we might get nil in a roundTrip
"/ (eg. for mcDef --addChangesTo:--> classChange+commentChange --mcDefinition--> mcDef+nil)
"/ self assert:(definitions includes:nil) not.
self tryToLoadAll: definitions label: 'Loading unloadables...'.
]
] else:[
self tryToLoadAll: unloadableDefinitions label: 'Loading unloadables...'.
]
"Created: / 08-11-2010 / 20:19:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 06-03-2011 / 20:36:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-08-2011 / 19:31:22 / cg"
! !
!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 |
MCStXPackageQuery
answer: aPackage name
do:[
packageSnap := aPackage snapshot.
patch := aSnapshot patchRelativeToBase: packageSnap.
patch applyTo: self.
packageSnap definitions do: [:ea | self provisions addAll: ea provisions]
]
"Modified: / 14-09-2010 / 22:09:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (format): / 07-09-2011 / 12:44:16 / cg"
! !
!MCPackageLoader class methodsFor:'documentation'!
version
^ '$Header$'
!
version_CVS
^ '$Header$'
!
version_SVN
^ '$Id$'
! !