"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
"{ Package: 'stx:libbasic3' }"
OrderedCollection subclass:#ChangeSet
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'System-Changes'
!
!ChangeSet class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
documentation
"
used in the changes management to keep track of changes
[author:]
Claus Gittinger
"
! !
!ChangeSet class methodsFor:'instance creation'!
changesFromParseTree:aTree andStream:aStream lineNumber:initialLineNumberOrNil do:aBlock
"given a parse-tree (from parsing some changes source/chunk),
create changes and evaluate aBlock on each.
The block is invoked with the change and a lineNumberOrNil as
arg; the lineNumber is only valid, if the underlying stream
provides line-numbers; otherwise, nil is passed."
|changes sel className categoryName
methodSource methodSelector change parser
oldName newName priv receiver receiverVarName
receiverSelector receiverReceiver primSource
nameSpace lineNumberOrNil|
lineNumberOrNil := initialLineNumberOrNil.
"/ nameSpace := Class nameSpaceQuerySignal query.
"/ nameSpace isNil ifTrue:[nameSpace := Smalltalk].
sel := aTree selector.
receiver := aTree receiver.
receiver isMessage ifTrue:[
receiverSelector := receiver selector.
receiverReceiver := receiver receiver.
] ifFalse:[
receiver isVariable ifTrue:[
receiverVarName := receiver name
]
].
(sel == #'methodsFor:'
or:[(sel == #'ignoredMethodsFor:')]) ifTrue:[
(sel == #'ignoredMethodsFor:') ifTrue:[
priv := #ignored.
] ifFalse:[
priv := nil
].
(receiver isUnaryMessage
and:[receiverSelector == #class]) ifTrue:[
className := (receiverReceiver name) , ' class'.
] ifFalse:[
className := (receiver name).
].
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
categoryName := (aTree arguments at:1) evaluate.
aStream skipSeparators.
lineNumberOrNil := aStream lineNumber.
methodSource := aStream nextChunk.
changes := OrderedCollection new.
[methodSource notEmpty] whileTrue:[
parser := Parser
parseMethodArgAndVarSpecification:methodSource
in:nil
ignoreErrors:true
ignoreWarnings:true
parseBody:false.
parser isNil ifTrue:[
"/ something wierd ...
methodSelector := '????'.
] ifFalse:[
methodSelector := parser selector.
].
change := MethodChange new.
change
className:className
selector:methodSelector
source:methodSource
category:categoryName
privacy:priv.
aBlock value:change value:lineNumberOrNil.
aStream skipSeparators.
lineNumberOrNil := aStream lineNumber.
methodSource := aStream nextChunk.
].
^ true
].
sel == #'removeSelector:' ifTrue:[
(receiver isUnaryMessage
and:[receiverSelector == #class]) ifTrue:[
className := (receiverReceiver name) , ' class'.
] ifFalse:[
className := (receiver name).
].
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
methodSelector := (aTree arguments at:1) evaluate.
change := MethodRemoveChange new.
change
className:className
selector:methodSelector.
aBlock value:change value:lineNumberOrNil.
^ true
].
"/ any subclass definiton selector ?
(Behavior definitionSelectors includes:sel)
ifTrue:[
className := (aTree arguments at:1) evaluate.
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
change := ClassDefinitionChange new.
change
className:className;
source:(aTree printString).
aBlock value:change value:lineNumberOrNil.
^ true
].
sel == #'renameCategory:to:' ifTrue:[
(receiver isUnaryMessage
and:[receiverSelector == #class]) ifTrue:[
className := (receiverReceiver name) , ' class'.
] ifFalse:[
className := (receiver name).
].
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
change := MethodCategoryRenameChange new.
change
className:className;
oldCategoryName:(aTree arguments at:1) evaluate
newCategoryName:(aTree arguments at:2) evaluate.
aBlock value:change value:lineNumberOrNil.
^ true
].
(sel == #'category:'
or:[sel == #'privacy:']) ifTrue:[
(receiver isMessage
and:[receiverSelector == #'compiledMethodAt:']) ifTrue:[
(receiverReceiver isUnaryMessage
and:[receiverReceiver selector == #class]) ifTrue:[
className := (receiverReceiver receiver name) , ' class'.
] ifFalse:[
className := (receiverReceiver name).
].
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
methodSelector := (receiver arguments at:1) evaluate.
sel == #'category:' ifTrue:[
change := MethodCategoryChange new.
change
className:className
selector:methodSelector
category:(aTree arguments at:1) evaluate.
] ifFalse:[
change := MethodPrivacyChange new.
change
className:className
selector:methodSelector
privacy:(aTree arguments at:1) evaluate.
].
aBlock value:change value:lineNumberOrNil.
^ true
] ifFalse:[
self halt:'unexpected change'
].
].
sel == #'comment:' ifTrue:[
(receiver isUnaryMessage
and:[receiverSelector == #class]) ifTrue:[
className := (receiverReceiver name) , ' class'.
] ifFalse:[
className := (receiver name).
].
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
change := ClassCommentChange new.
change
className:className
comment:(aTree arguments at:1) evaluate.
change source:(aTree printString).
aBlock value:change value:lineNumberOrNil.
^ true
].
sel == #'instanceVariableNames:' ifTrue:[
(receiver isUnaryMessage
and:[receiverSelector == #class]) ifTrue:[
className := (receiverReceiver name) , ' class'.
] ifFalse:[
className := (receiver name).
].
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
change := ClassInstVarDefinitionChange new.
change className:className.
change source:(aTree printString).
aBlock value:change value:lineNumberOrNil.
^ true
].
sel == #'removeClass:' ifTrue:[
(receiverVarName == #Smalltalk) ifTrue:[
className := (aTree arguments at:1) name.
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
change := ClassRemoveChange new.
change className:className.
aBlock value:change value:lineNumberOrNil.
^ true
] ifFalse:[
self halt:'unexpected receiver in #name: message'
].
].
sel == #'renameClass:to:' ifTrue:[
(receiverVarName == #Smalltalk) ifTrue:[
oldName := (aTree arguments at:1) name.
newName := (aTree arguments at:2) evaluate.
change := ClassRenameChange new.
change oldName:oldName newName:newName.
aBlock value:change value:lineNumberOrNil.
^ true
] ifFalse:[
self halt:'unexpected receiver in #name: message'
].
].
sel == #'name:' ifTrue:[
((receiverVarName == #Namespace)
or:[receiverVarName == #NameSpace]) ifTrue:[
className := (aTree arguments at:1) evaluate.
change := NameSpaceCreationChange new.
change name:className.
aBlock value:change value:lineNumberOrNil.
^ true
] ifFalse:[
self halt:'unexpected receiver in #name: message'
].
].
(sel == #'primitiveDefinitions'
or:[sel == #'primitiveFunctions'
or:[sel == #'primitiveVariables']]) ifTrue:[
(receiver isUnaryMessage
and:[receiverSelector == #class]) ifTrue:[
className := (receiverReceiver name) , ' class'.
] ifFalse:[
className := (receiver name).
].
"/ nameSpace ~~ Smalltalk ifTrue:[
"/ className := nameSpace name , '::' , className
"/ ].
aStream skipSeparators.
primSource := aStream nextChunk.
sel == #'primitiveDefinitions' ifTrue:[
change := ClassPrimitiveDefinitionsChange new
] ifFalse:[
sel == #'primitiveFunctions' ifTrue:[
change := ClassPrimitiveFunctionsChange new
] ifFalse:[
change := ClassPrimitiveVariablesChange new
]
].
change class:className source:primSource.
aBlock value:change value:lineNumberOrNil.
^ true
].
^ false
"Created: / 16.2.1998 / 13:42:40 / cg"
"Modified: / 15.12.1999 / 00:29:06 / cg"
!
changesFromStream:aStream do:aBlock
"enumerate changes from a stream and invoke aBlock on each.
The block is invoked with the change and a lineNumberOrNil as
arg; the lineNumber is only valid, if the underlying stream
provides line-numbers; otherwise, nil is passed."
|chunk sawExcla lastTimeStamp s change nameSpace changes
lineNumber|
nameSpace := Smalltalk.
[aStream atEnd] whileFalse:[
aStream skipSeparators.
sawExcla := aStream peekFor:$!!.
lineNumber := aStream lineNumber.
chunk := aStream nextChunk.
(chunk notNil and:[chunk notEmpty]) ifTrue:[
Class nameSpaceQuerySignal answer:nameSpace do:[
|parser tree ns|
parser := Parser for:chunk.
tree := parser
parseExpressionWithSelf:nil
notifying:nil
ignoreErrors:true
ignoreWarnings:true
inNameSpace:nameSpace.
tree == #Error ifTrue:[
change := DoItChange new.
change source:chunk.
aBlock value:change value:lineNumber.
] ifFalse:[
(tree notNil and:[tree ~~ #Error]) ifTrue:[
"/ if there is any nameSpace directive in there, extract it.
((ns := parser currentNameSpace) notNil
and:[ns ~~ nameSpace]) ifTrue:[
"/ self halt.
nameSpace := ns
].
Class nameSpaceQuerySignal answer:nameSpace do:[
"/
"/ what type of chunk is this ...
"/
tree isConstant ifTrue:[
(s := tree evaluate) isString ifTrue:[
(s startsWith:'---- timestamp ') ifTrue:[
lastTimeStamp := s.
]
] ifFalse:[
self halt:'unexpected change-chunk'
]
] ifFalse:[
tree isMessage ifTrue:[
(self
changesFromParseTree:tree
andStream:aStream
lineNumber:lineNumber
do:aBlock) ifFalse:[
change := DoItChange new.
change source:chunk.
aBlock value:change value:lineNumber.
]
] ifFalse:[
self halt:'unexpected change-chunk'
]
]
]
]
]
]
]
].
"
ChangeSet fromStream:('changes' asFilename readStream)
ChangeSet fromStream:('patches' asFilename readStream)
ChangeSet fromStream:(Object source asString readStream)
"
"Created: / 16.2.1998 / 12:19:34 / cg"
"Modified: / 14.12.1999 / 15:23:16 / cg"
!
forExistingClass:aClass
"build a changeSet for some given class.
That does of course not give deltas, but instead reflects the current
state of the given class.
It is useful in conjunction with the other utility methods,
for example, when building patchLists etc."
|changeSet chunk sawExcla lastTimeStamp s change nameSpace|
changeSet := self new.
nameSpace := Smalltalk.
"/ first, a classDefinition change ...
changeSet addClassDefinitionChangeFor:aClass.
"/ are there any class-instVars ?
aClass class instVarNames size > 0 ifTrue:[
changeSet addInstVarDefinitionChangeFor:aClass class.
].
"/ a comment ?
aClass comment size > 0 ifTrue:[
changeSet addClassCommentChangeFor:aClass.
].
"/ class methods first ...
aClass class methodDictionary keysAndValuesDo:[:sel :mthd |
changeSet addMethodChange:mthd in:aClass class.
].
"/ instance methods ...
aClass methodDictionary keysAndValuesDo:[:sel :mthd |
changeSet addMethodChange:mthd in:aClass.
].
^ changeSet
"
ChangeSet forExistingClass:ChangeSet
"
"Created: / 16.2.1998 / 12:19:34 / cg"
"Modified: / 14.12.1999 / 15:23:16 / cg"
!
fromStream:aStream
"build a changeSet from a stream, containing chunks.
(i.e. either a classes sourceFile or a change-file).
Return the changeSet."
|changeSet|
changeSet := self new.
self changesFromStream:aStream do:[:aChange :lineNumberOrNil |
changeSet add:aChange
].
^ changeSet
"
ChangeSet fromStream:('changes' asFilename readStream)
ChangeSet fromStream:('patches' asFilename readStream)
ChangeSet fromStream:(Object source asString readStream)
"
"Created: / 16.2.1998 / 12:19:34 / cg"
"Modified: / 14.12.1999 / 15:23:16 / cg"
!
fromXMLStream:aStream
"build a changeSet from an XML stream, containing XML definitions.
Return the changeSet."
|changeSet builder nameSpace|
changeSet := self new.
nameSpace := Smalltalk.
builder := XML.SourceScannerNodeBuilder new.
builder scanFile:aStream
do:[:change | changeSet add: change. ].
^ changeSet
"
ChangeSet fromXMLStream:('../../goodies/xml-vw/xmlFileInTests/XMLParser.xml' asFilename readStream)
ChangeSetBrowser
openOn:(ChangeSet fromXMLStream:('../../goodies/xml-vw/xmlFileInTests/XMLParser.xml' asFilename readStream))
"
! !
!ChangeSet class methodsFor:'Compatibility - ST80'!
patches
^ #()
"Created: / 27.10.1997 / 13:52:54 / cg"
! !
!ChangeSet class methodsFor:'queries'!
current
"ST-80 compatibility: return the current changeSet"
|p|
(Project notNil and:[(p := Project current) notNil]) ifTrue:[
^ p changeSet
]
"
ChangeSet current
"
! !
!ChangeSet methodsFor:'Compatibility - ST80'!
changeClass:aClass
"dummy here"
"Created: / 4.2.2000 / 18:30:59 / cg"
!
reorganizeSystem
"dummy here"
"Created: / 6.2.2000 / 20:45:10 / cg"
! !
!ChangeSet methodsFor:'changes management'!
addClassCommentChangeFor:aClass
"add a classComment change to the receiver"
|newChange|
newChange := ClassCommentChange class:aClass.
newChange comment:aClass comment.
self add:newChange
"Modified: 15.7.1996 / 09:27:05 / cg"
!
addClassDefinitionChangeFor:aClass
"add a classDefinition change to the receiver"
|newChange|
newChange := ClassDefinitionChange class:aClass.
newChange source:aClass definition.
self add:newChange
"Modified: 15.7.1996 / 09:27:05 / cg"
!
addInstVarDefinitionChangeFor:aClass
"add an instVarDefinition change to the receiver"
|newChange|
newChange := ClassInstVarDefinitionChange class:aClass.
newChange source:(aClass name , ' instanceVariableNames:' , aClass instanceVariableString storeString).
self add:newChange
!
addMethodCategoryChange:aMethod category:newCategory in:aClass
"add a methodCategory change to the receiver"
|newChange|
newChange := MethodCategoryChange class:aClass
selector:(aClass selectorAtMethod:aMethod)
category:newCategory.
self add:newChange
"Modified: 15.7.1996 / 09:27:15 / cg"
!
addMethodChange:aMethod in:aClass
"add a method change to the receiver"
|newChange|
newChange := MethodChange class:aClass
selector:(aClass selectorAtMethod:aMethod)
source:aMethod source
category:aMethod category.
self add:newChange
"Modified: 15.7.1996 / 09:27:21 / cg"
!
addMethodPrivacyChange:aMethod in:aClass
"add a methodPrivacy change to the receiver"
|newChange|
newChange := MethodPrivacyChange class:aClass
selector:(aClass selectorAtMethod:aMethod)
privacy:aMethod privacy.
self add:newChange
"Modified: 27.8.1995 / 22:55:22 / claus"
"Modified: 15.7.1996 / 09:27:28 / cg"
!
addPrimitiveDefinitionsChangeFor:aClass
"add a primitiveDefinitions change to the receiver"
|newChange|
newChange := ClassPrimitiveDefinitionsChange new
class:aClass name source:aClass primitiveDefinitionsString.
self add:newChange
"Modified: 15.7.1996 / 09:27:40 / cg"
!
addPrimitiveFunctionsChangeFor:aClass
"add a primitiveFunctions change to the receiver"
|newChange|
newChange := ClassPrimitiveFunctionsChange new
class:aClass name source:aClass primitiveFunctionsString.
self add:newChange
"Modified: 15.7.1996 / 09:27:47 / cg"
!
addPrimitiveVariablesChangeFor:aClass
"add a primitiveVariables change to the receiver"
|newChange|
newChange := ClassPrimitiveVariablesChange new
class:aClass name source:aClass primitiveVariablesString.
self add:newChange
"Modified: 15.7.1996 / 09:27:55 / cg"
!
addRemoveSelectorChange:aSelector in:aClass
"add a method-remove change to the receiver"
|newChange|
newChange := MethodRemoveChange
class:aClass
selector:aSelector.
self add:newChange
"Modified: / 27.8.1995 / 22:55:22 / claus"
"Modified: / 15.7.1996 / 09:27:28 / cg"
"Created: / 16.2.1998 / 12:47:07 / cg"
!
addRenameCategoryChangeIn:aClass from:oldCategory to:newCategory
"add a category rename change to the receiver"
|newChange|
newChange := MethodCategoryRenameChange class:aClass.
newChange oldCategoryName:oldCategory newCategoryName:newCategory.
self add:newChange
"Modified: / 6.2.2000 / 02:30:30 / cg"
! !
!ChangeSet methodsFor:'misc'!
addPatch:nameOfPatch
"ignored for now - allows fileIn of ST-80 patch stuff .."
^ self
! !
!ChangeSet methodsFor:'utilities'!
apply
"apply all changes in the receivers changeSet"
self do:[:aChange |
aChange apply
]
!
condenseChangesForClass:aClass package:aPackageSymbol
"remove all changes for aClass and aPackageSymbol
(i.e. leave methodChanges for other packages"
|changesToRemove className metaClassName chgCls|
changesToRemove := OrderedCollection new.
className := aClass theNonMetaclass name.
metaClassName := aClass theMetaclass name.
self do:[:aChange | |chgClassName chgClass|
chgClassName := aChange className.
(chgClassName = className
or:[chgClassName = metaClassName]) ifTrue:[
changesToRemove add:aChange
] ifFalse:[
chgCls := aChange changeClass.
(chgCls notNil
and:[chgCls isPrivate
and:[chgCls owningClass == aClass]]) ifTrue:[
changesToRemove add:aChange
]
]
].
self removeAll:changesToRemove
!
diffSetsAgainst:anotherChangeSet
"walk over the receiver and anotherChangeSet,
add all changes to one of the tree lists:
onlyInReceiver, onlyInArg or changed,
each being a changeSet containing corresponding changes."
|onlyInReceiver onlyInArg changedMethods
indexFromChangedMethodsToA indexFromChangedMethodsToB
"info" ret|
onlyInReceiver := ChangeSet new.
onlyInArg := ChangeSet new.
changedMethods := ChangeSet new.
indexFromChangedMethodsToA := OrderedCollection new.
indexFromChangedMethodsToB := OrderedCollection new.
self keysAndValuesDo:[:idxA :aChangeInA |
|anyFound ch|
anyFound := false.
anotherChangeSet keysAndValuesDo:[:idxB :aChangeInB |
(aChangeInA isForSameAs:aChangeInB) ifTrue:[
anyFound := true.
"/ also in B - is it different ?
(aChangeInA sameAs:aChangeInB) ifFalse:[
changedMethods add:aChangeInA.
indexFromChangedMethodsToA add:idxA.
indexFromChangedMethodsToB add:idxB.
] ifTrue:[
aChangeInA isMethodChange ifTrue:[
aChangeInA methodCategory ~= aChangeInB methodCategory ifTrue:[
"/ only the category is different;
"/ make it a MethodCategory changes.
ch := MethodCategoryChange new
className:aChangeInA className
selector:aChangeInA selector
category:aChangeInA methodCategory.
self at:idxA put:ch.
ch := MethodCategoryChange new
className:aChangeInB className
selector:aChangeInB selector
category:aChangeInB methodCategory.
anotherChangeSet at:idxB put:ch.
changedMethods add:aChangeInA.
indexFromChangedMethodsToA add:idxA.
indexFromChangedMethodsToB add:idxB.
]
].
]
] ifFalse:[
(aChangeInA sameAs:aChangeInB) ifTrue:[
anyFound := true.
] ifFalse:[
]
]
].
anyFound ifFalse:[
onlyInReceiver add:aChangeInA.
]
].
anotherChangeSet keysAndValuesDo:[:idxB :aChangeInB |
|anyFound|
anyFound := false.
self do:[:aChangeInA |
|idxM|
(aChangeInA isForSameAs:aChangeInB) ifTrue:[
anyFound := true.
"/ also in B - is it different ?
(aChangeInA sameAs:aChangeInB) ifFalse:[
"/ already there ?
idxM := changedMethods findFirst:[:c | c isForSameAs:aChangeInB].
idxM == 0 ifTrue:[
changedMethods add:aChangeInB.
indexFromChangedMethodsToB add:idxB.
] ifFalse:[
indexFromChangedMethodsToB at:idxM put:idxB
]
]
] ifFalse:[
(aChangeInA sameAs:aChangeInB) ifTrue:[
anyFound := true.
] ifFalse:[
]
]
].
anyFound ifFalse:[
onlyInArg add:aChangeInB.
]
].
"/ info := OrderedCollection new:(changedMethods size).
"/ changedMethods keysAndValuesDo:[:idx :changedMethod |
"/ info add:(Array
"/ with:(indexFromChangedMethodsToA at:idx)
"/ with:(indexFromChangedMethodsToB at:idx)
"/ )
"/ ].
changedMethods := (1 to:changedMethods size) collect:[:idx |
|cA cB|
cA := self at:(indexFromChangedMethodsToA at:idx).
cB := anotherChangeSet at:(indexFromChangedMethodsToB at:idx).
Array with:cA with:cB
].
ret := IdentityDictionary new.
"/ ret at:#info put:info.
ret at:#changed put:changedMethods.
ret at:#onlyInReceiver put:onlyInReceiver.
ret at:#onlyInArg put:onlyInArg.
^ret
! !
!ChangeSet class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic3/ChangeSet.st,v 1.50 2000-08-11 20:48:49 cg Exp $'
! !