--- a/Class.st Tue Feb 04 21:09:59 2014 +0100
+++ b/Class.st Wed Apr 01 10:20:10 2015 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -11,12 +13,16 @@
"
"{ Package: 'stx:libbasic' }"
+"{ NameSpace: Smalltalk }"
+
ClassDescription subclass:#Class
instanceVariableNames:'name category classvars comment subclasses classFilename package
revision environment signature attributes'
classVariableNames:'DefaultCategoryForSTV DefaultCategoryForVAGE
DefaultCategoryForDolphin ValidateSourceOnlyOnce ValidatedClasses
- SubclassCacheSequenceNumber'
+ SubclassCacheSequenceNumber
+ DefaultCategoryForUncategorizedClasses
+ DefaultCategoryForUndeclaredClasses'
poolDictionaries:''
category:'Kernel-Classes'
!
@@ -195,106 +201,141 @@
!Class class methodsFor:'creating new classes'!
name:newName
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- category:categoryString
-
- "this new instance creation protocol will replace the traditional inst-creation messages"
+ "this new instance creation protocol may be used in scripts to replace the traditional inst-creation messages"
+
+ ^ self
+ name:newName
+ subclassOf:Object
+ instanceVariableNames:''
+ category:(self defaultCategoryForUncategorizedClasses)
+!
+
+name:newName instanceVariableNames:stringOfInstVarNames
+ "this new instance creation protocol may be used in scripts to replace the traditional inst-creation messages"
+
+ ^ self
+ name:newName
+ subclassOf:Object
+ instanceVariableNames:stringOfInstVarNames
+ category:(self defaultCategoryForUncategorizedClasses)
+!
+
+name:newName subclassOf:aClass
+ "this new instance creation protocol may be used in scripts to replace the traditional inst-creation messages"
^ self
- name:newName
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- classVariableNames:nil
- poolDictionaries:nil
- category:categoryString
+ name:newName
+ subclassOf:aClass
+ instanceVariableNames:''
+ category:(self defaultCategoryForUncategorizedClasses)
+!
+
+name:newName subclassOf:aClass instanceVariableNames:stringOfInstVarNames
+ "this new instance creation protocol may be used in scripts to replace the traditional inst-creation messages"
+
+ ^ self
+ name:newName
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ category:(self defaultCategoryForUncategorizedClasses)
+!
+
+name:newName subclassOf:aClass instanceVariableNames:stringOfInstVarNames category:categoryString
+ "this new instance creation protocol may be used in scripts to replace the traditional inst-creation messages"
+
+ ^ self
+ name:newName
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ classVariableNames:nil
+ poolDictionaries:nil
+ category:categoryString
!
name:newName
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- classVariableNames:stringOfClassVarNames
- category:categoryString
-
- "this new instance creation protocol will replace the traditional inst-creation messages"
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ classVariableNames:stringOfClassVarNames
+ category:categoryString
+
+ "this new instance creation protocol may be used in scripts to replace the traditional inst-creation messages"
^ self
- name:newName
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- classVariableNames:stringOfClassVarNames
- poolDictionaries:nil
- category:categoryString
+ name:newName
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ classVariableNames:stringOfClassVarNames
+ poolDictionaries:nil
+ category:categoryString
!
name:newName
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- classVariableNames:stringOfClassVarNames
- classInstanceVariableNames:stringOfClassInstVarNames
- poolDictionaries:stringOfPoolNames
- category:categoryString
-
- "this new instance creation protocol will replace the traditional inst-creation messages"
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ classVariableNames:stringOfClassVarNames
+ classInstanceVariableNames:stringOfClassInstVarNames
+ poolDictionaries:stringOfPoolNames
+ category:categoryString
+
+ "this new instance creation protocol may be used in scripts to replace the traditional inst-creation messages"
^ self class
- name:newName
- inEnvironment:Smalltalk
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- variable:false
- words:false
- pointers:false
- classVariableNames:stringOfClassVarNames
- poolDictionaries:stringOfPoolNames
- category:categoryString
- comment:nil
- changed:false
- classInstanceVariableNames:stringOfClassInstVarNames
+ name:newName
+ inEnvironment:Smalltalk
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ variable:false
+ words:false
+ pointers:false
+ classVariableNames:stringOfClassVarNames
+ poolDictionaries:stringOfPoolNames
+ category:categoryString
+ comment:nil
+ changed:false
+ classInstanceVariableNames:stringOfClassInstVarNames
"Modified: 16.6.1997 / 11:53:58 / cg"
!
name:newName
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- classVariableNames:stringOfClassVarNames
- poolDictionaries:stringOfPoolNames
- category:categoryString
-
- "this new instance creation protocol will replace the traditional inst-creation messages"
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ classVariableNames:stringOfClassVarNames
+ poolDictionaries:stringOfPoolNames
+ category:categoryString
+
+ "this new instance creation protocol may be used in scripts to replace the traditional inst-creation messages"
^ self class
- name:newName
- inEnvironment:Smalltalk
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- variable:false
- words:false
- pointers:false
- classVariableNames:stringOfClassVarNames
- poolDictionaries:stringOfPoolNames
- category:categoryString
- comment:nil
- changed:false
- classInstanceVariableNames:nil
+ name:newName
+ inEnvironment:Smalltalk
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ variable:false
+ words:false
+ pointers:false
+ classVariableNames:stringOfClassVarNames
+ poolDictionaries:stringOfPoolNames
+ category:categoryString
+ comment:nil
+ changed:false
+ classInstanceVariableNames:nil
"Modified: 16.6.1997 / 11:53:58 / cg"
!
undeclared: name
-
- "
- Creates an 'undeclared' class, a placeholder for
- superclass when loading/filing-in a class whose
- superclass does not exists.
- "
+ "Creates an 'undeclared' class, a placeholder for
+ superclass when loading/filing-in a class whose
+ superclass does not exist yet."
+
Transcript showCR:'Smalltalk [info]: Declaring undeclared class: ', name.
- ^Object subclass: name asSymbol
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'* undeclared classes!! *'
+ ^ Object
+ subclass: name asSymbol
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:(self defaultCategoryForUndeclaredClasses)
"Created: / 08-11-2010 / 16:08:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
@@ -311,10 +352,10 @@
idx := name lastIndexOf:$:.
[idx > 1 and:[ (name at:(idx-1)) ~~ $: ]] whileTrue:[
- idx := name lastIndexOf:$: startingAt:idx-2.
+ idx := name lastIndexOf:$: startingAt:idx-2.
].
idx == 0 ifTrue:[
- ^ name
+ ^ name
].
^ name copyFrom:idx+1.
@@ -347,10 +388,10 @@
"/ care for standAlone apps which have no CVS (libbasic3) included
"/
mgr isNil ifTrue:[
- AbstractSourceCodeManager notNil ifTrue:[
- ^ CVSVersionInfo fromRCSString:aString
- ].
- ^ nil
+ AbstractSourceCodeManager notNil ifTrue:[
+ ^ CVSVersionInfo fromRCSString:aString
+ ].
+ ^ nil
].
^ mgr revisionInfoFromString:aString.
@@ -433,7 +474,7 @@
This is private protocol"
aClass notNil ifTrue:[
- aClass flushSubclasses
+ aClass flushSubclasses
].
"
@@ -456,10 +497,11 @@
! !
-
!Class methodsFor:'Compatibility-Dolphin'!
defaultCategoryForDolphinClasses
+ "used only when filing in Dolphin classes (which do not provide a category in their inst creation message)"
+
^ DefaultCategoryForDolphin ? 'Dolphin classes'.
!
@@ -514,9 +556,13 @@
!Class methodsFor:'Compatibility-ST/V and V''Age'!
defaultCategoryForSTVorVAGEClasses
+ "used only when filing in ST/V and V'Age classes (which do not provide a category in their inst creation message)"
+
|cat app|
DefaultApplicationQuerySignal isHandled ifTrue:[
+ "/ while loading a package, this is answered...
+ "/ put the new class into a category named after the app
app := DefaultApplicationQuerySignal query.
app notNil ifTrue:[
cat := "'Applications-' ," app nameWithoutPrefix.
@@ -538,12 +584,12 @@
"this method allows fileIn of ST/V and V'Age classes"
^ self
- subclass:nm
- instanceVariableNames:iV
- classVariableNames:cV
- poolDictionaries:p
- category:(self defaultCategoryForSTVorVAGEClasses)
- classInstanceVariableNames:cIV
+ subclass:nm
+ instanceVariableNames:iV
+ classVariableNames:cV
+ poolDictionaries:p
+ category:(self defaultCategoryForSTVorVAGEClasses)
+ classInstanceVariableNames:cIV
!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
@@ -652,6 +698,11 @@
"Created: / 18.6.1998 / 22:08:45 / cg"
! !
+!Class methodsFor:'Compatibility-Squeak'!
+
+poolDictionaryNames
+ ^ self sharedPoolNames
+! !
!Class methodsFor:'accessing'!
@@ -835,13 +886,16 @@
classVarNames
"return a collection of the class variable name-strings.
Only names of class variables defined in this class are included
- in the returned collection - use allClassVarNames, to get all known names."
+ in the returned collection - use allClassVarNames, to get all known names.
+ Traditionally, this was called classVarNames, but newer versions of squeak
+ seem to have changed to use classVariableNames.
+ So you probably should use the alias"
classvars isNil ifTrue:[
^ #()
].
classvars isString ifTrue:[
- classvars := (classvars asCollectionOfWords collect:[:varName| varName asSymbol]) asArray.
+ classvars := classvars asCollectionOfWords collect:[:varName| varName asSymbol] as:Array.
^ classvars
].
@@ -971,7 +1025,7 @@
"/ (e at:self nameWithoutNamespacePrefix ifAbsent:nil)
"/ or
(Smalltalk at:name ifAbsent:nil) == self ifFalse:[
- ^ nil
+ ^ nil
].
^ e
!
@@ -986,7 +1040,10 @@
"generate the expected filename for this class - without suffix.
This may be different from the actual classFilename"
- ^ self theNonMetaclass name copyReplaceAll:$: with:$_
+ |nm|
+
+ nm := self theNonMetaclass name.
+ ^ nm copyReplaceAll:$: with:$_ ifNone:nm
"
Complex generateClassFilename
@@ -1040,11 +1097,11 @@
For private or anonymous classes, nil is returned -
for public classes, Smalltalk is returned.
For now, this also returns Smalltalk for classes which are actually anonymous;
- this is left in for a while (because many users f this method expect a non-nil return value).
+ this is left in for a while (because many users of this method expect a non-nil return value).
but will change in the future to return nil then.
In the meantime, use containingNameSpace, which provides the correct answer"
- |idx nsName e|
+ |idx nsName e restName i tryMore|
"/ cached in environment
environment isNil ifTrue:[
@@ -1064,8 +1121,30 @@
].
environment := e.
].
+ tryMore := true.
+ [tryMore] whileTrue:[
+ tryMore := false.
+ "/ sub namespace ?
+ restName := name copyFrom:environment name size + 3.
+ (i := restName indexOf:$:) ~~ 0 ifTrue:[
+ (restName at:i+1) == $: ifTrue:[
+ nsName := environment name , '::',(restName copyTo:i-1).
+ e := Smalltalk at:nsName asSymbol.
+ e isNameSpace ifTrue:[
+ "/ Transcript showCR:nsName.
+ "/ Transcript showCR:restName.
+ environment := e.
+ tryMore := true.
+ ].
+ ].
+ ].
+ ].
^ environment
+ "
+ Graphics::PDF::AttributeTests nameSpace
+ "
+
"Modified: / 20.7.1998 / 14:21:36 / cg"
!
@@ -1097,6 +1176,11 @@
].
package ~= newPackage ifTrue:[
oldPackage := package.
+ (Smalltalk
+ changeRequest:#packageOfClass
+ with:(Array with:self with:oldPackage with:newPackage)) ifFalse:[
+ ^ self
+ ].
package := newPackage.
self changed:#package.
@@ -1364,25 +1448,25 @@
classes := self privateClasses.
classes notEmpty ifTrue:[
- classes := classes asOrderedCollection.
- classes sort:[:a :b | a name < b name].
-
- pivateClassesOf := IdentityDictionary new.
- classes do:[:each | pivateClassesOf at:each put:(each allPrivateClasses)].
-
- classes topologicalSort:[:a :b |
- "/ a must come before b iff:
- "/ b is a subclass of a
- "/ b has a private class which is a subclass of a
-
- |mustComeBefore pivateClassesOfB|
- mustComeBefore := b isSubclassOf:a.
- pivateClassesOfB := pivateClassesOf at:b.
- pivateClassesOfB do:[:eachClassInB |
- mustComeBefore := mustComeBefore or:[eachClassInB isSubclassOf:a]
- ].
- mustComeBefore
- ].
+ classes := classes asOrderedCollection.
+ classes sort:[:a :b | a name < b name].
+
+ pivateClassesOf := IdentityDictionary new.
+ classes do:[:each | pivateClassesOf at:each put:(each allPrivateClasses)].
+
+ classes topologicalSort:[:a :b |
+ "/ a must come before b iff:
+ "/ b is a subclass of a
+ "/ b has a private class which is a subclass of a
+
+ |mustComeBefore pivateClassesOfB|
+ mustComeBefore := b isSubclassOf:a.
+ pivateClassesOfB := pivateClassesOf at:b.
+ pivateClassesOfB do:[:eachClassInB |
+ mustComeBefore := mustComeBefore or:[eachClassInB isSubclassOf:a]
+ ].
+ mustComeBefore
+ ].
].
^ classes.
@@ -1443,8 +1527,11 @@
^ poolNames
"
+ HGCommand sharedPoolNames
+ HGCommand realSharedPoolsNames
+ HGCommand sharedPoolNames
Croquet::OpenGL sharedPools
- Croquet::OpenGL realSharedPools
+ Croquet::OpenGL sharedPools
"
"Created: / 18-01-2011 / 18:02:25 / cg"
@@ -1717,9 +1804,7 @@
!
sourceCodeManager
- "return my source code manager.
- For now, all classes return the same global manager.
- But future versions may support mixed reporitories"
+ "Return my (configured) source code manager."
|owner|
@@ -1727,10 +1812,10 @@
"/ see if there is a package-specific manager
AbstractSourceCodeManager notNil ifTrue:[
- ^ AbstractSourceCodeManager sourceCodeManagerForPackage: package.
+ ^ AbstractSourceCodeManager sourceCodeManagerForPackage: self package.
].
- ^ Smalltalk at:#SourceCodeManager
+ ^ Smalltalk at:#SourceCodeManager "/ nil if SCM is disabled
"
Array sourceCodeManager
@@ -1739,6 +1824,7 @@
"Created: / 07-12-1995 / 13:16:46 / cg"
"Modified: / 05-12-2006 / 22:04:26 / cg"
+ "Modified (comment): / 04-08-2014 / 00:35:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
sourceCodeManagerFromBinaryRevision
@@ -1772,9 +1858,9 @@
- revision ifNil:[^self sourceCodeManager].
-
- AbstractSourceCodeManager availableManagers do:[:mgr|
+ revision isNil ifTrue:[^self sourceCodeManager].
+
+ AbstractSourceCodeManager availableManagers do:[:mgr |
(revision endsWith: mgr managerTypeNameShort) ifTrue:[
^mgr
]
@@ -1803,17 +1889,18 @@
"
"Created: / 06-10-2011 / 09:33:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 04-08-2014 / 00:32:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
subclasses
"return a collection of the direct subclasses of the receiver"
"/ use cached information (avoid class hierarchy search), if possible
- (subclasses isNil
+ (subclasses isNil
or:[ subclasses sequenceNumber ~= SubclassCacheSequenceNumber ]) ifTrue:[
- self updateAllCachedSubclasses.
- "subclasses may still be nil - obsolete classes may not be updated"
- ^ subclasses ? #().
+ self updateAllCachedSubclasses.
+ "subclasses may still be nil - obsolete classes may not be updated"
+ ^ subclasses ? #().
].
^ subclasses.
@@ -1832,7 +1919,7 @@
around anonymously to allow existing instances some life.
This may change in the future (adjusting existing instances)"
- |owner ns name|
+ |owner ns nm|
"must flush caches since lookup chain changes"
ObjectMemory flushCaches.
@@ -1842,28 +1929,29 @@
"/ full name and answering with Smalltalk to a nameSpace query.
(owner := self owningClass) notNil ifTrue:[
- ns := owner.
- name := self nameWithoutPrefix asSymbol
+ ns := owner.
+ nm := self nameWithoutPrefix asSymbol
] ifFalse:[
- ns := Smalltalk.
- name := self name
+ ns := Smalltalk.
+ nm := self name
].
Class classRedefinitionNotification answer:#keep do:[
- Class nameSpaceQuerySignal
- answer:ns
- do:[
- aClass
- perform:(self definitionSelector)
- withArguments:(Array with:name
- with:(self instanceVariableString)
- with:(self classVariableString)
- with:'' "/ pool
- with:(self category)).
- ]
+ Class nameSpaceQuerySignal
+ answer:ns
+ do:[
+ aClass
+ perform:(self definitionSelector)
+ withArguments:(Array with:nm
+ with:(self instanceVariableString)
+ with:(self classVariableString)
+ with:(self sharedPoolNames asStringWith: ' ')
+ with:(self category)).
+ ]
]
- "Modified: / 20.6.1998 / 18:17:37 / cg"
+ "Modified: / 20-06-1998 / 18:17:37 / cg"
+ "Modified: / 24-06-2014 / 17:02:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
withAllPrivateClasses
@@ -1880,7 +1968,6 @@
"Created: / 18-07-2011 / 09:14:38 / cg"
! !
-
!Class methodsFor:'adding & removing'!
removeFromSystem
@@ -1977,14 +2064,14 @@
"add a category change"
UpdateChangeFileQuerySignal query ifTrue:[
- self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
+ self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
- UpdateChangeListQuerySignal query ifTrue:[
- Project addClassDefinitionChangeFor:self
- ]
+ UpdateChangeListQuerySignal query ifTrue:[
+ Project addClassDefinitionChangeFor:self
+ ]
]
!
@@ -2684,9 +2771,9 @@
self printClassNameOn:aStream.
aStream nextPutAll:' comment:'.
(comment := self comment) isNil ifTrue:[
- s := ''''''
+ s := ''''''
] ifFalse:[
- s := comment storeString
+ s := comment storeString
].
aStream nextPutAllAsChunk:s.
aStream nextPutChunkSeparator.
@@ -2798,6 +2885,7 @@
|encoder any16Bit|
+ "/ check if we need UTF8 encoding
any16Bit := self withAllPrivateClasses contains:[:cls |
cls instAndClassMethods contains:[:m |
(methodFilter isNil or:[ (methodFilter value:m) ])
@@ -2878,13 +2966,13 @@
primitive functions - if any
"
(s := self primitiveFunctionsString) notNil ifTrue:[
- aStream nextPutChunkSeparator.
- self printClassNameOn:aStream.
- aStream nextPutAll:' primitiveFunctions';
- nextPutChunkSeparator;
- cr.
- aStream nextPutAll:s.
- aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+ aStream nextPutChunkSeparator.
+ self printClassNameOn:aStream.
+ aStream nextPutAll:' primitiveFunctions';
+ nextPutChunkSeparator;
+ cr.
+ aStream nextPutAll:s.
+ aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
].
!
@@ -2901,7 +2989,7 @@
primitive functions - if any
"
(s := self primitiveFunctionsString) notNil ifTrue:[
- self fileOutPrimitiveFunctionsOn:aStream
+ self fileOutPrimitiveFunctionsOn:aStream
].
"Modified: 8.1.1997 / 17:45:51 / cg"
@@ -3139,26 +3227,26 @@
aStream nextPutAll:' <inst-vars>'.
varNames := self instVarNames.
varNames size > 0 ifTrue:[
- aStream cr.
- varNames do:[:nm |
- aStream nextPutAll:' <name>'.
- aStream nextPutAll:nm.
- aStream nextPutLine:'</name>'.
- ].
- aStream nextPutAll:' '.
+ aStream cr.
+ varNames do:[:nm |
+ aStream nextPutAll:' <name>'.
+ aStream nextPutAll:nm.
+ aStream nextPutLine:'</name>'.
+ ].
+ aStream nextPutAll:' '.
].
aStream nextPutLine:'</inst-vars>'.
aStream nextPutAll:' <class-inst-vars>'.
varNames := self class instVarNames.
varNames size > 0 ifTrue:[
- aStream cr.
- varNames do:[:nm |
- aStream nextPutAll:' <name>'.
- aStream nextPutAll:nm.
- aStream nextPutLine:'</name>'.
- ].
- aStream nextPutAll:' '.
+ aStream cr.
+ varNames do:[:nm |
+ aStream nextPutAll:' <name>'.
+ aStream nextPutAll:nm.
+ aStream nextPutLine:'</name>'.
+ ].
+ aStream nextPutAll:' '.
].
aStream nextPutLine:'</class-inst-vars>'.
@@ -3173,14 +3261,14 @@
aStream nextPutLine:'</class>'.
self classVarNames do:[:nm |
- aStream nextPutLine:'<static>'.
- aStream nextPutAll:' <name>'.
- aStream nextPutAll:nm.
- aStream nextPutLine:'</name>'.
- aStream nextPutAll:' <environment>'.
- aStream nextPutAll:self name.
- aStream nextPutLine:'</environment>'.
- aStream nextPutLine:'</static>'.
+ aStream nextPutLine:'<static>'.
+ aStream nextPutAll:' <name>'.
+ aStream nextPutAll:nm.
+ aStream nextPutLine:'</name>'.
+ aStream nextPutAll:' <environment>'.
+ aStream nextPutAll:self name.
+ aStream nextPutLine:'</environment>'.
+ aStream nextPutLine:'</static>'.
].
!
@@ -3575,7 +3663,7 @@
setAttribute:key to:aValue
"{ Pragma: +optSpace }"
- self classAttributes perform:(key , ':') asSymbol with:aValue
+ self classAttributes perform:key asMutator with:aValue
!
setName:aString
@@ -3636,25 +3724,25 @@
subclassesPerClass := Dictionary new.
Smalltalk allClassesDo:[:each |
- |cls superclass|
-
- cls := each theNonMetaclass.
- (superclass := each superclass) notNil ifTrue:[
- (subclassesPerClass at:superclass ifAbsentPut:makeNewSet) add:cls
- ].
- subclassesPerClass at:cls ifAbsentPut:makeNewSet.
+ |cls superclass|
+
+ cls := each theNonMetaclass.
+ (superclass := each superclass) notNil ifTrue:[
+ (subclassesPerClass at:superclass ifAbsentPut:makeNewSet) add:cls
+ ].
+ subclassesPerClass at:cls ifAbsentPut:makeNewSet.
].
SubclassCacheSequenceNumber isNil ifTrue:[
- SubclassCacheSequenceNumber := 0.
+ SubclassCacheSequenceNumber := 0.
].
seqNr := SubclassCacheSequenceNumber.
subclassesPerClass keysAndValuesDo:[:cls :subclasses |
- |coll|
-
- coll := ArrayWithSequenceNumberValidation withAll:subclasses.
- coll sequenceNumber:seqNr.
- cls setSubclasses:coll.
+ |coll|
+
+ coll := ArrayWithSequenceNumberValidation withAll:subclasses.
+ coll sequenceNumber:seqNr.
+ cls setSubclasses:coll.
].
"
@@ -3719,10 +3807,10 @@
"append a class-remove-record to aStream"
- aStream
- nextPutAll:'Smalltalk removeClass:';
- nextPutAll:oldClass name;
- nextPutChunkSeparator.
+ aStream
+ nextPutAll:'Smalltalk removeClass:';
+ nextPutAll:oldClass name;
+ nextPutChunkSeparator.
!
addChangeRecordForClassRename:oldName to:newName to:aStream
@@ -3730,13 +3818,13 @@
"append a class-rename-record to aStream"
- aStream
- nextPutAll:'Smalltalk renameClass:';
- nextPutAll:oldName;
- nextPutAll:' to:''';
- nextPutAll:newName;
- nextPutAll:'''';
- nextPutChunkSeparator.
+ aStream
+ nextPutAll:'Smalltalk renameClass:';
+ nextPutAll:oldName;
+ nextPutAll:' to:''';
+ nextPutAll:newName;
+ nextPutAll:'''';
+ nextPutChunkSeparator.
"Modified: / 01-06-2012 / 09:44:04 / cg"
!
@@ -3801,8 +3889,19 @@
"Modified: / 18-09-2006 / 20:37:16 / cg"
!
+defaultCategoryForUncategorizedClasses
+ "used only when the short scripting class creation messages are used"
+
+ ^ DefaultCategoryForUncategorizedClasses ? 'Uncategorized classes'.
+!
+
+defaultCategoryForUndeclaredClasses
+ ^ DefaultCategoryForUndeclaredClasses ? '* undeclared classes *'
+!
+
extensions
- "return a collection of extension-methods from any other package, or empty if there are none.
+ "return a collection of extension-methods (both class and inst) from any other package,
+ or empty if there are none.
Unassigned methods are ignored"
|classPackage defaultPkg|
@@ -3824,7 +3923,7 @@
!
extensionsFrom:aPackageID
- "return the set of extension-methods from the given package."
+ "return the set of extension-methods (both class and inst) from the given package."
aPackageID = self package ifTrue:[^ #() ].
^ self methodsForWhich:[:mthd | mthd package = aPackageID]
@@ -3861,7 +3960,7 @@
"
Time millisecondsToRun:[
Smalltalk allClasses select:[:each | each hasExtensions]
- ]. 190 130 260
+ ].
Dictionary
withAssociations:
@@ -3885,15 +3984,15 @@
aPackageID = clsPkg ifTrue:[^ false].
self instAndClassMethodsDo:[:mthd |
- mthd package = aPackageID ifTrue:[ ^ true].
+ mthd package = aPackageID ifTrue:[ ^ true].
].
^ false
"
Smalltalk allClasses
- select:[:each | each hasExtensionsFrom:'stx:goodies/refactyBrowser']
+ select:[:each | each hasExtensionsFrom:'stx:goodies/refactyBrowser']
Smalltalk allClasses
- select:[:each | each hasExtensionsFrom:'stx:libboss']
+ select:[:each | each hasExtensionsFrom:'stx:libboss']
"
"Modified: / 06-03-2007 / 11:55:39 / cg"
@@ -3978,7 +4077,7 @@
!
methodsForWhich:aFilter
- "return a collection of methods for which aFilter returns true"
+ "return a collection of methods (both class and inst) for which aFilter returns true"
|matching|
@@ -3993,6 +4092,26 @@
^ matching ? #()
!
+methodsWithAnyResource:aResourceSymbolCollection
+ |methods|
+
+ methods := OrderedCollection new.
+
+ self withAllSuperclassesDo:[:eachClass|
+ eachClass instAndClassMethodsDo:[:eachMethod|
+ (eachMethod hasAnyResource:aResourceSymbolCollection) ifTrue:[
+ methods add:eachMethod.
+ ].
+ ].
+ ].
+
+ ^ methods
+
+ "
+ ApplicationModel methodsWithAnyResource:#(fontSpec)
+ "
+!
+
packageDirectory
"return the packageDirectory of this classes package.
That is usually the directory where my source is, and where package specific additional
@@ -4431,41 +4550,41 @@
(owner := self owningClass) notNil ifTrue:[^ owner findVersionMethodOfManager:aSourceCodemanagerOrNil].
tryVersionFromVersionMethod :=
- [:versionMethodsName |
- |aVersionMethod val|
-
- aVersionMethod := meta compiledMethodAt:versionMethodsName.
- (aVersionMethod notNil and:[aVersionMethod isExecutable]) ifTrue:[
- "/
- "/ if it's a method returning the version string,
- "/ that's the returned value
- "/
- val := cls perform:versionMethodsName.
- val isString ifTrue:[^ aVersionMethod].
- ].
- ].
+ [:versionMethodsName |
+ |aVersionMethod val|
+
+ aVersionMethod := meta compiledMethodAt:versionMethodsName.
+ (aVersionMethod notNil and:[aVersionMethod isExecutable]) ifTrue:[
+ "/
+ "/ if it's a method returning the version string,
+ "/ that's the returned value
+ "/
+ val := cls perform:versionMethodsName.
+ val isString ifTrue:[^ aVersionMethod].
+ ].
+ ].
meta := self theMetaclass.
cls := self theNonMetaclass.
- prefixOfVersionMethodSelector :=
- AbstractSourceCodeManager notNil
- ifTrue: [AbstractSourceCodeManager prefixOfVersionMethodSelector ]
- ifFalse:[ 'version_' ]. "/ sigh - for standalone apps without libbasic3
+ prefixOfVersionMethodSelector :=
+ AbstractSourceCodeManager notNil
+ ifTrue: [AbstractSourceCodeManager prefixOfVersionMethodSelector ]
+ ifFalse:[ 'version_' ]. "/ sigh - for standalone apps without libbasic3
allVersionMethodNames := meta methodDictionary keys select:[:sel | sel startsWith:prefixOfVersionMethodSelector].
aSourceCodemanagerOrNil notNil ifTrue:[
- nameOfVersionMethodForManager := aSourceCodemanagerOrNil nameOfVersionMethodInClasses.
- (allVersionMethodNames includes:nameOfVersionMethodForManager) ifTrue:[
- tryVersionFromVersionMethod value:nameOfVersionMethodForManager
- ].
-
- "/ only trust the oldVersion method, iff there is no other scv-version
- "/ (i.e. do not misuse an svn-checked-in #version as a version_cvs)
- (allVersionMethodNames copyWithout:nameOfVersionMethodForManager) notEmpty ifTrue:[
- ^ nil
- ].
+ nameOfVersionMethodForManager := aSourceCodemanagerOrNil nameOfVersionMethodInClasses.
+ (allVersionMethodNames includes:nameOfVersionMethodForManager) ifTrue:[
+ tryVersionFromVersionMethod value:nameOfVersionMethodForManager
+ ].
+
+ "/ only trust the oldVersion method, iff there is no other scv-version
+ "/ (i.e. do not misuse an svn-checked-in #version as a version_cvs)
+ (allVersionMethodNames copyWithout:nameOfVersionMethodForManager) notEmpty ifTrue:[
+ ^ nil
+ ].
].
nameOfOldVersionMethod := self nameOfOldVersionMethod.
@@ -4475,7 +4594,7 @@
"
Smalltalk allClassesDo:[:cls |
- Transcript show:cls name; show:' -> '; showCR:cls findVersionMethod
+ Transcript show:cls name; show:' -> '; showCR:cls findVersionMethod
].
Number findVersionMethod
@@ -4774,7 +4893,7 @@
!
projectDirectory
- "return my projects directory - thats where the sources, binaries, classLib,
+ "return my package's/project's directory - that's where the sources, binaries, classLib,
resources etc. are typically found."
^ Smalltalk projectDirectoryForClass:self
@@ -4826,6 +4945,7 @@
revision
"return the revision-ID of the class which corresponds to the
scm-version-id of the source to which this class is equivalent.
+ The class's default source code manager is asked here.
Initially, this is the same as #binaryRevision; however, once changes have
been checked into a source repository, the binary continues to remain based upon
the old revision, while logically, the class has the new (checked-in) revision.
@@ -4891,36 +5011,38 @@
!
revisionInfoOfManager:aSourceCodemanagerOrNil
- "return an object filled with revision info.
+ "return an object filled with revision info for a given scm manager (or the default manager, if nil)
This extracts the relevant info from the revisionString.
The revisionInfo contains all or a subset of:
- binaryRevision - the revision upon which the binary of this class is based
- revision - the revision upon which the class is based logically
- (different, if a changed class was checked in, but not yet recompiled)
- user - the user who checked in the logical revision
- date - the date when the logical revision was checked in
- time - the time when the logical revision was checked in
- fileName - the classes source file name
- repositoryPath - the classes source container
+ binaryRevision - the revision upon which the binary of this class is based
+ revision - the revision upon which the class is based logically
+ (different, if a changed class was checked in, but not yet recompiled)
+ user - the user who checked in the logical revision
+ date - the date when the logical revision was checked in
+ time - the time when the logical revision was checked in
+ fileName - the classes source file name
+ repositoryPath - the classes source container
"
|vsnString info|
aSourceCodemanagerOrNil notNil ifTrue:[
- vsnString := self revisionStringOfManager:aSourceCodemanagerOrNil.
+ vsnString := self revisionStringOfManager:aSourceCodemanagerOrNil.
].
vsnString isNil ifTrue:[
- vsnString := self revisionStringOfManager:nil.
+ "/ cg: I am not sure if this is the correct thing to do, iff the passed in scm-manager
+ "/ was not nil. It will return another manager's revision info. Please check.
+ vsnString := self revisionStringOfManager:nil.
+ vsnString isNil ifTrue:[^ nil].
].
- vsnString isNil ifTrue:[^ nil].
aSourceCodemanagerOrNil notNil ifTrue:[
- info := aSourceCodemanagerOrNil revisionInfoFromString:vsnString inClass:self
+ info := aSourceCodemanagerOrNil revisionInfoFromString:vsnString inClass:self
] ifFalse:[
- info := Class revisionInfoFromString:vsnString.
+ info := Class revisionInfoFromString:vsnString.
].
info notNil ifTrue:[
- info binaryRevision:self binaryRevision.
+ info binaryRevision:self binaryRevision.
].
^ info
@@ -4937,6 +5059,7 @@
revisionOfManager:aSourceCodemanagerOrNil
"return the revision-ID of the class which corresponds to the
scm-version-id of the source to which this class is equivalent.
+ The passed in source code manager (or the default manager, if nil) is asked here.
Initially, this is the same as #binaryRevision; however, once changes have
been checked into a source repository, the binary continues to remain based upon
the old revision, while logically, the class has the new (checked-in) revision.
@@ -4947,7 +5070,7 @@
info := self revisionInfoOfManager:aSourceCodemanagerOrNil.
info notNil ifTrue:[
- ^ info revision
+ ^ info revision
].
^ nil "/ ^ self binaryRevision
@@ -5380,6 +5503,7 @@
"Created: / 16-08-2009 / 12:57:53 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
+
!Class::ArrayWithSequenceNumberValidation methodsFor:'accessing'!
sequenceNumber
@@ -5522,8 +5646,12 @@
The reason is that stc-compiled code should be allowed to access classVars
in a similar fashion to globals.
- Whenever a classes classPool is requested, an instance of myself is
- created, which forwards at: and at:put: messages to the original class.
+ Whenever a classes classPool is requested (by code imported from visualworks),
+ an instance of myself is created, which forwards at: and at:put: messages
+ to the original class.
+ Notice that classPools are never asked for by smalltalk/x
+ code - especially not by the browser. However, imported code (like the refactory browser)
+ may do so.
This is an additional goody class; therefore:
@@ -5540,9 +5668,8 @@
SUCH DAMAGE.
[author:]
- Claus Gittinger
+ Claus Gittinger
"
-
! !
!Class::SimulatedClassPool methodsFor:'accessing'!
@@ -5635,6 +5762,7 @@
documentation
"
Instances are returned from the simulated classPool for VW compatibility.
+ See the documentation in SimulatedClassPool for more info.
"
! !
@@ -5649,16 +5777,11 @@
!Class class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.632 2013-11-21 15:02:57 stefan Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.654 2015-03-25 14:29:49 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.632 2013-11-21 15:02:57 stefan Exp $'
-!
-
-version_HG
-
- ^ '$Changeset: <not expanded> $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.654 2015-03-25 14:29:49 cg Exp $'
!
version_SVN