--- a/ChangesBrowser.st Tue Nov 27 18:33:23 2001 +0100
+++ b/ChangesBrowser.st Tue Nov 27 19:00:27 2001 +0100
@@ -20,7 +20,7 @@
changeFileSize changeFileTimestamp checkBlock changeTimeStamps
tabSpec autoUpdate editingClassSource lastSearchType
lastSearchString applyInOriginalNameSpace lastSaveFileName
- readOnly enforcedPackage updateChangeSet'
+ readOnly enforcedPackage enforcedNameSpace updateChangeSet'
classVariableNames:'CompressSnapshotInfo NoColoring ShowWarningDialogs DefaultIcon'
poolDictionaries:''
category:'Interface-Browsers'
@@ -543,6 +543,12 @@
#translateLabel: true
#value: #setEnforcedPackage
)
+ #(#MenuItem
+ #label: 'Apply into NameSpace...'
+ #translateLabel: true
+ #value: #setEnforcedNameSpace
+ #enabled: #applyNotInOriginalNameSpace
+ )
)
nil
nil
@@ -588,6 +594,10 @@
^ applyInOriginalNameSpace
!
+applyNotInOriginalNameSpace
+ ^ applyInOriginalNameSpace value not
+!
+
autoCompare
^ autoCompare
!
@@ -1328,10 +1338,44 @@
^ s
!
+extractClassAndClassNameFromParseTree:rec
+ |isUnaryMessage className changeClass|
+
+ isUnaryMessage := rec isUnaryMessage.
+
+ isUnaryMessage ifTrue:[
+ className := rec receiver name.
+ ] ifFalse:[
+ className := rec name.
+ ].
+
+ enforcedNameSpace notNil ifTrue:[
+ changeClass := enforcedNameSpace classNamed:className.
+ ].
+ changeClass isNil ifTrue:[
+ changeClass := Smalltalk classNamed:className.
+ ].
+ isUnaryMessage ifTrue:[
+ changeClass notNil ifTrue:[
+ changeClass := changeClass class.
+ ].
+ className := className , ' class'.
+ ].
+
+ ^ className -> changeClass
+!
+
isChangeSetBrowser
^ false
!
+nameSpaceForApply
+ applyInOriginalNameSpace value ifFalse:[
+ ^ enforcedNameSpace ? Class nameSpaceQuerySignal query.
+ ].
+ ^ Smalltalk.
+!
+
newLabel:how
|l|
@@ -1568,12 +1612,11 @@
words changeStream fullParseTree ownerTree ownerName oldDollarSetting|
changeNr isNil ifTrue:[^ nil].
-
"
first look, if not already known
"
"/ name := changeClassNames at:changeNr.
- name notNil ifTrue:[^ name].
+"/ name notNil ifTrue:[^ name].
prevMethodDefNr := changeNr.
[changeIsFollowupMethodChange at:prevMethodDefNr] whileTrue:[
@@ -1614,7 +1657,7 @@
oldDollarSetting := Parser allowDollarInIdentifier.
[
Parser allowDollarInIdentifier:true.
- Class nameSpaceQuerySignal answer:Smalltalk
+ Class nameSpaceQuerySignal answer:(self nameSpaceForApply)
do:[
aParseTree := Parser parseExpression:chunk.
].
@@ -1628,7 +1671,6 @@
] valueNowOrOnUnwindDo:[
Parser allowDollarInIdentifier:oldDollarSetting
].
-
(aParseTree isNil or:[aParseTree == #Error]) ifTrue:[
^ nil "seems strange ... (could be a comment)"
].
@@ -1663,6 +1705,8 @@
#'commentStamp:prior:' "/ Squeak support
#'addClassVarName:' "/ Squeak support
#methodsFor "/ Dolphin support
+ #categoriesForClass "/ Dolphin support
+ #categoriesFor: "/ Dolphin support
#methods "/ STV support
) includes:sel) ifTrue:[
"
@@ -1985,10 +2029,10 @@
s changeClass sawExcla category
chunkPos sel headerLine cls p rec clsName
myProcess myPriority myPrioRange
- done first className text methodPos
- singleJunkOnly methodChunks singleInfo
+ done first text methodPos
+ singleJunkOnly methodChunks classCategoryChunks methodCategoryChunks singleInfo
ownerTree ownerName
- m currentText t1 t2|
+ m currentText t1 t2 methodSelector nameAndClass|
editingClassSource := false.
askedForEditingClassSource := false.
@@ -2127,10 +2171,11 @@
changeType := '(???)'.
]
].
+
(sel == #comment:) ifTrue:[
changeType := '(comment)'.
clsName := rec name.
- changeClass := (Smalltalk classNamed:clsName).
+ changeClass := (self nameSpaceForApply) classNamed:clsName.
changeClassNames at:changeClassNames size put:clsName.
NoColoring ~~ true ifTrue:[
changeType := changeType allItalic.
@@ -2150,16 +2195,11 @@
].
(sel == #removeSelector:) ifTrue:[
- rec isUnaryMessage ifTrue:[
- cls := rec receiver name.
- changeClass := (Smalltalk classNamed:cls) class.
- cls := cls , ' class'.
- ] ifFalse:[
- cls := rec name.
- changeClass := (Smalltalk classNamed:cls)
- ].
+ nameAndClass := self extractClassAndClassNameFromParseTree:rec.
+ clsName := nameAndClass key. changeClass := nameAndClass value.
+
sel := (p args at:1) evaluate.
- changeClassNames at:changeClassNames size put:cls.
+ changeClassNames at:changeClassNames size put:clsName.
autoCompare value ifTrue:[
(changeClass isNil or:[changeClass isLoaded not]) ifTrue:[
@@ -2173,26 +2213,22 @@
]
].
changeType := '(remove)'.
- changeString := self contractClass:cls selector:sel to:maxLen.
+ changeString := self contractClass:clsName selector:sel to:maxLen.
sel := nil.
].
+
(p ~~ #Error
and:[p isMessage
and:[rec isMessage
and:[rec selector == #compiledMethodAt:]]]) ifTrue:[
- rec receiver isUnaryMessage ifTrue:[
- cls := rec receiver receiver name.
- changeClass := (Smalltalk classNamed:cls) class.
- cls := cls , ' class'.
- ] ifFalse:[
- cls := rec receiver name.
- changeClass := (Smalltalk classNamed:cls)
- ].
+ nameAndClass := self extractClassAndClassNameFromParseTree:rec receiver.
+ clsName := nameAndClass key. changeClass := nameAndClass value.
+
(sel == #category:) ifTrue:[
sel := (rec args at:1) evaluate.
changeType := '(category change)'.
- changeString := self contractClass:cls selector:sel to:maxLen.
- changeClassNames at:changeClassNames size put:cls.
+ changeString := self contractClass:clsName selector:sel to:maxLen.
+ changeClassNames at:changeClassNames size put:clsName.
changeClass notNil ifTrue:[
m := changeClass compiledMethodAt:sel asSymbol.
m notNil ifTrue:[
@@ -2205,11 +2241,12 @@
(sel == #privacy:) ifTrue:[
sel := (rec args at:1) evaluate.
changeType := '(privacy change)'.
- changeString := self contractClass:cls selector:sel to:maxLen.
- changeClassNames at:changeClassNames size put:cls.
+ changeString := self contractClass:clsName selector:sel to:maxLen.
+ changeClassNames at:changeClassNames size put:clsName.
].
sel := nil.
].
+
(Class definitionSelectors includes:sel) ifTrue:[
changeType := '(class definition)'.
clsName := (p args at:1) evaluate.
@@ -2229,11 +2266,16 @@
].
autoCompare value ifTrue:[
- cls := Smalltalk at:clsName asSymbol ifAbsent:nil.
+ cls := (self nameSpaceForApply) at:clsName asSymbol ifAbsent:nil.
cls isNil ifTrue:[
changeDelta := '+'.
] ifFalse:[
- cls definitionSelector = sel ifTrue:[
+ (cls definitionSelector = sel
+ or:[
+ "/ could be an ST/V, VAge or Dolphin definition
+ cls definitionSelector = (sel , 'category:')
+ ])
+ ifTrue:[
((cls superclass isNil
and:[p receiver isConstant
and:[p receiver evaluate isNil]])
@@ -2245,16 +2287,22 @@
cls instanceVariableString asCollectionOfWords = (p args at:2) evaluate asCollectionOfWords ifTrue:[
cls classVariableString asCollectionOfWords = (p args at:3) evaluate asCollectionOfWords ifTrue:[
(p args at:4) evaluate isEmpty ifTrue:[
- cls category = (p args at:5) evaluate ifTrue:[
+ cls definitionSelector = (sel , 'category:')
+ ifTrue:[
+ "/ ST/V, VAge or Dolphin definition
changeDelta := '='.
] ifFalse:[
- changeType := '(class category change)'.
+ cls category = (p args at:5) evaluate ifTrue:[
+ changeDelta := '='.
+ ] ifFalse:[
+ changeType := '(class category change)'.
+ ]
]
]
]
]
]
- ].
+ ]
]
].
sel := nil.
@@ -2271,7 +2319,7 @@
and:[rec isMessage
and:[rec selector == #class]]) ifTrue:[
clsName := rec receiver name.
- changeClass := (Smalltalk classNamed:clsName).
+ changeClass := (self nameSpaceForApply) classNamed:clsName.
changeType := '(class definition)'.
changeClassNames at:changeClassNames size put:clsName.
@@ -2288,11 +2336,11 @@
]
]
].
-
]
] ifTrue:[ "sawExcla"
singleJunkOnly := false.
methodChunks := false.
+ classCategoryChunks := methodCategoryChunks := false.
singleInfo := false.
"
@@ -2302,10 +2350,11 @@
The system only writes one chunk,
and we cannot handle more in this ChangesBrowser ....
"
- className := nil.
- p := Parser parseExpression:chunkText inNameSpace:Smalltalk.
+ clsName := nil.
+ p := Parser parseExpression:chunkText inNameSpace:(self nameSpaceForApply).
(p notNil and:[p ~~ #Error]) ifTrue:[
+ rec := p receiver.
sel := p selector.
(#(
#methodsFor:
@@ -2316,27 +2365,38 @@
#methodsFor:stamp: "/ Squeak support
#'commentStamp:prior:' "/ Squeak support
#methodsFor "/ Dolphin support
+ #categoriesForClass "/ Dolphin support
+ #categoriesFor: "/ Dolphin support
#methods "/ STV support
)
includes:sel) ifTrue:[
methodChunks := true.
- p receiver isUnaryMessage ifTrue:[
- className := p receiver receiver name.
- changeClass := (Smalltalk classNamed:className) class.
- className := className , ' class'.
+ nameAndClass := self extractClassAndClassNameFromParseTree:rec.
+ clsName := nameAndClass key. changeClass := nameAndClass value.
+
+ sel == #categoriesForClass ifTrue:[
+ methodChunks := false.
+ classCategoryChunks := true.
+ changeType := '(class category change)'.
] ifFalse:[
- className := p receiver name.
- changeClass := Smalltalk classNamed:className
+ sel == #categoriesFor: ifTrue:[
+ methodChunks := false.
+ methodCategoryChunks := true.
+ changeType := '(category change)'.
+ methodSelector := (p args at:1) evaluate.
+ ] ifFalse:[
+ (sel == #'methodsFor') ifTrue:[
+ category := 'Dolphin methods'.
+ ] ifFalse:[
+ (sel == #methods) ifTrue:[
+ category := 'STV methods'.
+ ] ifFalse:[
+ category := (p args at:1) evaluate.
+ ]
+ ].
+ ].
].
- (sel == #'methodsFor') ifTrue:[
- category := 'Dolphin methods'.
- ] ifFalse:[
- (sel == #methods) ifTrue:[
- category := 'STV methods'.
- ] ifFalse:[
- category := (p args at:1) evaluate.
- ]
- ].
+
sel == #'methodsFor:stamp:' ifTrue:[
"/ Squeak timeStamp
timeStampInfo := (p args at:2) evaluate.
@@ -2362,15 +2422,12 @@
methodPos := aStream position.
text := aStream nextChunk.
- text isNil ifTrue:[
- done := true
- ] ifFalse:[
- done := text isEmpty
- ].
+ done := text isNil or:[text isEmpty].
+
done ifFalse:[
first ifFalse:[
changeChunks add:chunkText.
- changeClassNames add:className.
+ changeClassNames add:clsName.
changePositions add:methodPos.
changeTimeStamps add:timeStampInfo.
changeIsFollowupMethodChange add:true.
@@ -2384,64 +2441,82 @@
askedForEditingClassSource := true.
]
] ifTrue:[
- changeClassNames at:changeClassNames size put:className.
+ changeClassNames at:changeClassNames size put:clsName.
].
first := false.
- "
- try to find the selector
- "
- sel := nil.
- className notNil ifTrue:[
- methodChunks ifTrue:[
- p := Parser
- parseMethodSpecification:text
- in:nil
- ignoreErrors:true
- ignoreWarnings:true.
- (p notNil and:[p ~~ #Error]) ifTrue:[
- sel := p selector.
- ]
- ]
- ].
-
- sel isNil ifTrue:[
- changeString := (chunkText contractTo:maxLen).
- changeType := '(change)'.
- headerLine := chunkText , ' (change)'.
+
+ (classCategoryChunks or:[methodCategoryChunks]) ifTrue:[
+ text := text asCollectionOfLines first asString.
+ classCategoryChunks ifTrue:[
+ changeClass isNil ifTrue:[
+ changeDelta := '?'.
+ ] ifFalse:[
+ changeClass category = text ifTrue:[
+ changeDelta := '='.
+ ]
+ ].
+ changeString := clsName , ' category: ' , text storeString.
+ ]ifFalse:[
+ changeString := '(' , clsName , ' compiledMethodAt:' , methodSelector storeString , ') category: ' , text storeString.
+ ].
] ifFalse:[
- changeString := self contractClass:className selector:sel to:maxLen.
- changeType := '{ ' , category , ' }'.
- headerLine := className , ' ' , sel , ' ' , '(change category: ''' , category , ''')'.
- ].
-
- autoCompare value ifTrue:[
- changeClass isNil ifFalse:[
- cls := changeClass theNonMetaclass
+ "
+ try to find the selector
+ "
+ methodSelector := nil.
+ clsName notNil ifTrue:[
+ methodChunks ifTrue:[
+ p := Parser
+ parseMethodSpecification:text
+ in:nil
+ ignoreErrors:true
+ ignoreWarnings:true.
+ (p notNil and:[p ~~ #Error]) ifTrue:[
+ methodSelector := p selector.
+ ]
+ ]
].
- (changeClass isNil or:[sel isNil or:[cls isLoaded not]]) ifTrue:[
- changeDelta := '?'
+ methodSelector isNil ifTrue:[
+ changeString := (chunkText contractTo:maxLen).
+ changeType := '(change)'.
+ headerLine := chunkText , ' (change)'.
] ifFalse:[
- (changeClass implements:sel asSymbol) ifFalse:[
- changeDelta := '+'.
- ] ifTrue:[
- m := changeClass compiledMethodAt:sel asSymbol.
- currentText := m source.
- currentText notNil ifTrue:[
- text asString string withoutTrailingSeparators = currentText asString string withoutTrailingSeparators ifTrue:[
- changeDelta := '='
- ] ifFalse:[
- t1 := currentText asCollectionOfLines collect:[:s | s withTabsExpanded].
- t2 := text asCollectionOfLines collect:[:s | s withTabsExpanded].
- t1 = t2 ifTrue:[
+ changeString := self contractClass:clsName selector:methodSelector to:maxLen.
+ changeType := '{ ' , category , ' }'.
+ headerLine := clsName , ' ' , methodSelector , ' ' , '(change category: ''' , category , ''')'.
+ ].
+
+ autoCompare value ifTrue:[
+ changeClass isNil ifFalse:[
+ cls := changeClass theNonMetaclass
+ ].
+
+ (changeClass isNil or:[methodSelector isNil or:[cls isLoaded not]]) ifTrue:[
+ changeDelta := '?'
+ ] ifFalse:[
+ (changeClass implements:methodSelector asSymbol) ifFalse:[
+ changeDelta := '+'.
+ ] ifTrue:[
+ m := changeClass compiledMethodAt:methodSelector asSymbol.
+ currentText := m source.
+ currentText notNil ifTrue:[
+ text asString string withoutTrailingSeparators = currentText asString string withoutTrailingSeparators ifTrue:[
changeDelta := '='
+ ] ifFalse:[
+ t1 := currentText asCollectionOfLines collect:[:s | s withTabsExpanded].
+ t2 := text asCollectionOfLines collect:[:s | s withTabsExpanded].
+ t1 = t2 ifTrue:[
+ changeDelta := '='
+ ]
]
]
]
]
- ]
+ ].
].
+
entry := MultiColListEntry new.
entry tabulatorSpecification:tabSpec.
entry colAt:1 put:changeDelta.
@@ -2699,7 +2774,8 @@
className := self classNameOfChange:changeNr.
className notNil ifTrue:[
- changeClass := Smalltalk at:(className asSymbol) ifAbsent:[].
+ className := className asSymbol.
+ changeClass := Smalltalk at:className ifAbsent:[].
changeClass notNil ifTrue:[
changeClass isLoaded ifFalse:[
changeClass autoload
@@ -2716,11 +2792,7 @@
sig := AbortOperationRequest
].
sig catch:[
- applyInOriginalNameSpace value ifFalse:[
- nameSpace := Class nameSpaceQuerySignal query.
- ] ifTrue:[
- nameSpace := Smalltalk.
- ].
+ nameSpace := self nameSpaceForApply.
pkg := enforcedPackage ? Class packageQuerySignal query.
Class packageQuerySignal answer:pkg
@@ -2756,10 +2828,10 @@
].
].
(nameSpace notNil and:[nameSpace ~~ Smalltalk]) ifTrue:[
- changeClass := nameSpace at:(className asSymbol) ifAbsent:[].
+ changeClass := nameSpace at:className ifAbsent:[].
].
changeClass isNil ifTrue:[
- changeClass := Smalltalk at:(className asSymbol) ifAbsent:[].
+ changeClass := Smalltalk at:className ifAbsent:[].
].
[changeClass isNil] whileTrue:[
shortName := className copyFrom:(className lastIndexOf:$:) + 1.
@@ -2840,7 +2912,7 @@
sawExcla ifFalse:[
outcome := 'cannot compare this change\\(i.e. this is not a method change).'.
- Class nameSpaceQuerySignal answer:Smalltalk
+ Class nameSpaceQuerySignal answer:(self nameSpaceForApply)
do:[
parseTree := Parser parseExpression:chunk.
].
@@ -2932,7 +3004,7 @@
superClass isBehavior ifTrue:[
(self checkClassIsLoaded:superClass) ifTrue:[
thisClassSym := (parseTree arguments at:1) evaluate.
- thisClass := Smalltalk at:thisClassSym ifAbsent:nil.
+ thisClass := (self nameSpaceForApply) at:thisClassSym ifAbsent:nil.
thisClass notNil ifTrue:[
(isLoaded := self checkClassIsLoaded:thisClass) ifFalse:[
outcome := 'Cannot compare this change\\(compare requires class to be loaded).'.
@@ -2980,7 +3052,7 @@
]
]
] ifTrue:[
- Class nameSpaceQuerySignal answer:Smalltalk
+ Class nameSpaceQuerySignal answer:(self nameSpaceForApply)
do:[
parseTree := Parser parseExpression:chunk.
].
@@ -3018,7 +3090,7 @@
].
newSource := aStream nextChunk.
- Class nameSpaceQuerySignal answer:Smalltalk
+ Class nameSpaceQuerySignal answer:(self nameSpaceForApply)
do:[
parser := Parser parseMethod:newSource in:thisClass.
].
@@ -3620,7 +3692,12 @@
className := className copyWithoutLast:6.
isMeta := true.
].
- (cls := Smalltalk classNamed:className) isNil ifTrue:[
+
+ (cls := (self nameSpaceForApply) classNamed:className) isNil ifTrue:[
+ cls := Smalltalk classNamed:className
+ ].
+
+ cls isNil ifTrue:[
self warn:('Class not found: ''' , className , '''').
^ nil
].
@@ -4665,6 +4742,26 @@
"Modified: 25.5.1996 / 12:26:44 / cg"
!
+setEnforcedNameSpace
+ |nsName listOfKnownNameSpaces|
+
+ listOfKnownNameSpaces := Set new.
+ NameSpace
+ allNamespaces
+ do:[:eachNameSpace |
+ listOfKnownNameSpaces add:eachNameSpace name
+ ].
+ listOfKnownNameSpaces := listOfKnownNameSpaces asOrderedCollection sort.
+
+ nsName := Dialog
+ request:'When applying, new classes are created in nameSpace:'
+ initialAnswer:(enforcedNameSpace ? Class nameSpaceQuerySignal query name)
+ list:listOfKnownNameSpaces.
+ nsName size ~~ 0 ifTrue:[
+ enforcedNameSpace := NameSpace name:nsName
+ ]
+!
+
setEnforcedPackage
|pkg listOfKnownPackages|
@@ -4680,7 +4777,7 @@
listOfKnownPackages := listOfKnownPackages asOrderedCollection sort.
pkg := Dialog
- request:'When Applying, changes go into package:'
+ request:'When applying, changes go into package:'
initialAnswer:(enforcedPackage ? Class packageQuerySignal query)
list:listOfKnownPackages.
pkg size ~~ 0 ifTrue:[
@@ -4691,5 +4788,5 @@
!ChangesBrowser class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.249 2001-11-20 09:43:55 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.250 2001-11-27 18:00:27 cg Exp $'
! !