"
COPYRIGHT (c) 1989 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:libbasic' }"
ClassDescription subclass:#Class
instanceVariableNames:'name category classvars comment subclasses classFilename package
revision environment signature attributes'
classVariableNames:'DefaultCategoryForSTV DefaultCategoryForVAGE
DefaultCategoryForDolphin'
poolDictionaries:''
category:'Kernel-Classes'
!
Object subclass:#ClassAttributes
instanceVariableNames:'primitiveDefinitions primitiveVariables primitiveFunctions'
classVariableNames:''
poolDictionaries:''
privateIn:Class
!
!Class class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 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
"
Class adds more functionality to classes; minimum stuff has already
been defined in Behavior and ClassDescription; this adds naming, categories etc.
[Instance variables:]
name <Symbol> the classes name
category <Symbol> the classes category
classvars <String> the names of the class variables
comment <String> the classes comment; either a string,
a number specifying the offset in classFilename, or nil
subclasses <Collection> cached collection of subclasses
(currently unused - but will be soon)
classFilename <String> the file (or nil) where the classes
sources are found
package <Symbol> the package, in which the class was defined
(inserted by compilers)
revision <String> revision string - inserted by stc
environment <Symbol | nil> cached environment (i.e. Smalltalk or a namespace)
signature <SmallInteger> the classes signature (used to detect obsolete
or changed classes with binaryStorage)
This is filled in lazy - i.e. upon the first signature query.
attributes <Array | nil> describes primitiveIncludes, primitiveFunctions etc.
also a place to add additional attributes,
without a need to recompile all classes.
WARNING: layout known by compiler and runtime system
[author:]
Claus Gittinger
[see also:]
Behavior ClassDescription Metaclass
"
! !
!Class class methodsFor:'accessing-flags'!
tryLocalSourceFirst
^ TryLocalSourceFirst
"Created: 24.1.1996 / 19:55:35 / cg"
!
tryLocalSourceFirst:aBoolean
TryLocalSourceFirst := aBoolean
"Created: 24.1.1996 / 19:55:35 / cg"
!
updateChanges:aBoolean
"turn on/off changes management. Return the prior value of the flag.
This value is used as a default fallback - a querySignal handler may still
decide to return something else."
|prev|
prev := UpdatingChanges.
UpdatingChanges := aBoolean.
^ prev
!
updatingChanges
"return true if changes are recorded.
The value returned here is the default fallback - a querySignal handler may still
decide to return something else."
^ UpdatingChanges
! !
!Class class methodsFor:'helpers'!
revisionInfoFromString:aString
"{ Pragma: +optSpace }"
"return a dictionary filled with revision info.
This extracts the relevant info from aString, asking
the sourceCode manager (if there is one)"
|mgr|
"/
"/ mhmh - ask the default manager
"/
(mgr := SourceCodeManager) isNil ifTrue:[
"/
"/ fallBack - assume CVS header
"/
mgr := CVSSourceCodeManager
].
"/
"/ care for standAlone apps which have no CVS (libbasic3) included
"/
mgr isNil ifTrue:[
AbstractSourceCodeManager notNil ifTrue:[
^ AbstractSourceCodeManager revisionInfoFromRCSString:aString
].
^ nil
].
^ mgr revisionInfoFromString:aString.
!
revisionStringFromSource:aMethodSourceString
"{ Pragma: +optSpace }"
"extract a revision string from a methods source string"
|lines line|
lines := aMethodSourceString asCollectionOfLines.
lines do:[:l |
|i|
i := l indexOfSubCollection:'$Header: '.
i ~~ 0 ifTrue:[
line := l copyFrom:i.
i := line lastIndexOf:$$.
i > 1 ifTrue:[
line := line copyTo:i.
].
^ line
]
].
^ nil
"Created: 15.10.1996 / 18:57:57 / cg"
"Modified: 16.10.1996 / 16:54:40 / cg"
! !
!Class class methodsFor:'misc'!
template:aCategoryString
"return a class-definition template"
^ 'NameOfSuperclass subclass:#NameOfClass
instanceVariableNames:''instVarName1 instVarName2''
classVariableNames:''classVarName1 classVarName2''
poolDictionaries:''''
category:''' , aCategoryString , ''''
"Created: / 19.6.1998 / 02:09:06 / cg"
! !
!Class class methodsFor:'private'!
flushSubclassInfo
"throw away (forget) the cached subclass information, as created
by #subclassInfo.
This is private protocol"
SubclassInfo := nil.
"
Class flushSubclassInfo
"
"Modified: 22.1.1997 / 18:39:36 / cg"
!
subclassInfo
"build & return a dictionary, containing the set of subclass
for each class. This information is kept until explicitely flushed
by #flushSubclassInfo.
This cache is used internally, for enumerators like #allSubclasses
or #allSubclassesDo:, to avoid repeated recursive walks over the class
hierarchy.
This is private protocol."
|d|
SubclassInfo notNil ifTrue:[^ SubclassInfo].
d := IdentityDictionary new.
Smalltalk allClassesDo:[:aClass |
|superCls setToAddSubclass|
superCls := aClass superclass.
superCls notNil ifTrue:[
setToAddSubclass := d at:superCls ifAbsent:nil.
setToAddSubclass isNil ifTrue:[
d at:superCls put:(Set with:aClass).
] ifFalse:[
setToAddSubclass add:aClass
]
]
].
SubclassInfo := d.
^ d
"
Class subclassInfo
"
"Modified: 22.1.1997 / 18:44:59 / cg"
! !
!Class class methodsFor:'queries'!
defaultExternalEncoding
^ nil "/ for backward compatibility
"/ ^ #'utf-8'
!
isBuiltInClass
"return true if this class is known by the run-time-system.
Here, true is returned for myself, false for subclasses."
^ self == Class class or:[self == Class]
"Created: 15.4.1996 / 17:17:13 / cg"
"Modified: 23.4.1996 / 15:56:58 / cg"
! !
!Class methodsFor:'Compatibility-Dolphin'!
defaultCategoryForDolphinClasses
^ DefaultCategoryForDolphin ? 'Dolphin classes'.
!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s classInstanceVariableNames:classInstanceVariableNames
"{ Pragma: +optSpace }"
"this method allows fileIn of Dolphin classes "
^ self subclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:(self defaultCategoryForDolphinClasses)
classInstanceVariableNames:classInstanceVariableNames
"Modified: / 15.6.1998 / 21:31:34 / cg"
"Modified: / 18.3.1999 / 18:16:11 / stefan"
!
variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s classInstanceVariableNames:classInstanceVariableNames
"{ Pragma: +optSpace }"
"this method allows fileIn of Dolphin classes "
^ self variableSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:(self defaultCategoryForDolphinClasses)
classInstanceVariableNames:classInstanceVariableNames
"Modified: / 15.6.1998 / 21:31:34 / cg"
"Modified: / 18.3.1999 / 18:16:11 / stefan"
! !
!Class methodsFor:'Compatibility-ST/V and V''Age'!
defaultCategoryForSTVorVAGEClasses
|cat app|
DefaultApplicationQuerySignal isHandled ifTrue:[
app := DefaultApplicationQuerySignal query.
app notNil ifTrue:[
cat := 'Applications-' , app name.
] ifFalse:[
cat := DefaultCategoryForVAGE ? 'V''Age classes'.
].
] ifFalse:[
cat := DefaultCategoryForSTV ? 'ST/V classes'.
].
^ cat
!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
"{ Pragma: +optSpace }"
"this method allows fileIn of ST/V and V'Age classes
(which seem to have no category)"
^ self subclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:(self defaultCategoryForSTVorVAGEClasses)
"Modified: / 15.6.1998 / 21:31:34 / cg"
"Modified: / 18.3.1999 / 18:16:11 / stefan"
!
variableByteSubclass:t classVariableNames:d poolDictionaries:s
"{ Pragma: +optSpace }"
"this method allows fileIn of ST/V and V'Age variable byte classes
(which seem to have no category and no instvars)"
^ self variableByteSubclass:t
instanceVariableNames:''
classVariableNames:d
poolDictionaries:s
category:(self defaultCategoryForSTVorVAGEClasses)
"Modified: / 15.6.1998 / 21:31:38 / cg"
"Modified: / 18.3.1999 / 18:16:21 / stefan"
!
variableLongSubclass:t classVariableNames:d poolDictionaries:s
"{ Pragma: +optSpace }"
"this method allows fileIn of ST/V and V'Age variable long (32bit integers) classes
(which seem to have no category and no instvars)"
^ self variableLongSubclass:t
instanceVariableNames:''
classVariableNames:d
poolDictionaries:s
category:(self defaultCategoryForSTVorVAGEClasses)
!
variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
"{ Pragma: +optSpace }"
"this method allows fileIn of ST/V and V'Age variable pointer classes
(which seem to have no category)"
^ self variableSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:(self defaultCategoryForSTVorVAGEClasses)
"Modified: / 15.6.1998 / 21:31:41 / cg"
"Modified: / 18.3.1999 / 18:16:33 / stefan"
!
variableWordSubclass:t classVariableNames:d poolDictionaries:s
"{ Pragma: +optSpace }"
"this method allows fileIn of ST/V and V'Age variable word (16bit integers) classes
(which seem to have no category and no instvars)"
^ self variableWordSubclass:t
instanceVariableNames:''
classVariableNames:d
poolDictionaries:s
category:(self defaultCategoryForSTVorVAGEClasses)
! !
!Class methodsFor:'Compatibility-ST80'!
fileOutSourceOn:aStream
self fileOutOn:aStream withTimeStamp:false
"Created: 20.6.1997 / 17:18:14 / cg"
"Modified: 20.6.1997 / 17:18:26 / cg"
!
rename:newName
"same as renameTo: - for ST80 compatibility"
^ Smalltalk renameClass:self to:newName.
"/ ^ self renameTo:newName
"Created: / 18.6.1998 / 22:08:45 / cg"
! !
!Class methodsFor:'Compatibility-VW'!
isVisualStartable
"return true, if this is an application class,
which can be started via #open"
^ false
"Created: / 27.10.1997 / 16:42:05 / cg"
! !
!Class methodsFor:'accessing'!
addChangeRecordForClass:aClass andNotifyChangeOf:aspect
"writes a change record and notifies dependents."
|namespace|
self addChangeRecordForClass:aClass.
aClass changed:#definition.
namespace := aClass nameSpace.
namespace changed:#classDefinition with:aClass.
namespace ~~ Smalltalk ifTrue:[
Smalltalk changed:#classDefinition with:aClass.
].
namespace changed:aspect with:aClass.
namespace ~~ Smalltalk ifTrue:[
Smalltalk changed:aspect with:aClass.
].
!
addClassVarName:aString
"add a class variable if not already there and initialize it with nil.
Also writes a change record and notifies dependents."
(self classVarNames includes:aString) ifFalse:[
self classVariableString:(self classVariableString , ' ' , aString).
Class withoutUpdatingChangesDo:[
self withAllSubclasses do:[:cls|
cls recompileMethodsAccessingAnyClassvarOrGlobal:
(Array with:aString asSymbol)
].
].
self addChangeRecordForClass:self andNotifyChangeOf:#classVariables.
]
"Created: / 29.10.1995 / 19:40:51 / cg"
"Modified: / 23.1.1998 / 15:46:23 / stefan"
!
allPrivateClasses
"{ Pragma: +optSpace }"
"return a collection of all private classes and private-private classes.
The classes are in any order."
^ self privateClassesOrAll:true
!
category
"return the category of the class.
The returned value may be a string or symbol."
|owner|
(owner := self owningClass) notNil ifTrue:[^ owner category].
^ category
"
Point category
Dictionary category
"
"Modified: 15.10.1996 / 21:20:01 / cg"
"Created: 1.4.1997 / 15:23:47 / stefan"
!
category:aStringOrSymbol
"set the category of the class to be the argument, aStringOrSymbol"
|ns|
self setCategory:aStringOrSymbol.
Project addChangeRecordForClass:self.
ns := self nameSpace.
ns changed:#organization.
ns ~~ Smalltalk ifTrue:[
Smalltalk changed:#organization.
]
!
classFilename
"return the name of the file from which the class was compiled."
|owner|
(owner := self owningClass) notNil ifTrue:[^ owner classFilename].
^ classFilename
"Modified: 15.10.1996 / 18:53:21 / cg"
!
classVarAt:aSymbol
"return the value of a class variable.
Currently, this returns nil if there is no such classvar -
this may change."
"
this hides the (current) implementation of classVariables
from the outside world. Currently, classvars are stored in
the Smalltalk dictionary with a funny name, since there are
no classPools yet.
"
^ Smalltalk at:(self globalKeyForClassVar:aSymbol)
!
classVarAt:aSymbol ifAbsent:exceptionBlock
"return the value of a class variable.
Currently, this returns nil if there is no such classvar -
this may change."
"
this hides the (current) implementation of classVariables
from the outside world. Currently, classvars are stored in
the Smalltalk dictionary with a funny name, since there are
no classPools yet.
"
^ Smalltalk at:(self globalKeyForClassVar:aSymbol) ifAbsent:exceptionBlock
!
classVarAt:aSymbol put:something
"store something in a classvariable.
Currently this creates a global with a funny name if no such
classVar exists - this may change."
"
this hides the (current) implementation of classVariables
from the outside world. Currently, classvars are stored in
the Smalltalk dictionary with a funny name, since there are
no classPools yet.
"
Smalltalk at:(self globalKeyForClassVar:aSymbol) put:something.
!
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."
classvars isNil ifTrue:[
^ #()
].
classvars isString ifTrue:[
classvars := classvars asCollectionOfWords asArray collect:[:varName| varName asSymbol].
^ classvars
].
^ classvars
"
Object classVarNames
Float classVarNames
"
!
classVariableString
"return a string of the class variables names.
Only names of class variables defined in this class are in the
returned string."
classvars isNil ifTrue:[^ ''].
classvars isString ifTrue:[
^ classvars
].
^ classvars asStringWith:(Character space)
"
Object classVariableString
Float classVariableString
"
!
classVariableString:aString
"set the classes classvarnames string;
Initialize new class variables with nil, clear and remove old ones.
No change record is written and no classes are recompiled."
|prevVarNames varNames any|
(aString ~= self classVariableString) ifTrue:[
prevVarNames := self classVarNames asOrderedCollection.
classvars := aString.
varNames := self classVarNames.
"new ones get initialized to nil;
- old ones are nilled and removed from Smalltalk"
any := false.
varNames do:[:aName |
(prevVarNames includes:aName) ifFalse:[
"a new one"
self classVarAt:aName put:nil.
any := true.
] ifTrue:[
prevVarNames remove:aName
]
].
"left overs are gone"
prevVarNames do:[:aName |
self classVarAt:aName put:nil.
Smalltalk removeKey:(self name , ':' , aName) asSymbol.
].
any ifTrue:[
Smalltalk changed:#classVariables with:self
].
]
"Modified: 2.4.1997 / 00:16:05 / stefan"
!
comment
"return the comment (aString) of the class"
|stream string|
"the comment is either a string, or an integer specifying the
position within the classes sourcefile ...
"
comment isNumber ifTrue:[
classFilename notNil ifTrue:[
stream := self sourceStream.
stream notNil ifTrue:[
stream position1Based:comment.
string := String readFrom:stream onError:''.
stream close.
^ string
].
^ nil
]
].
^ comment
"
Object comment
RunArray comment
"
!
comment:aStringOrNil
"{ Pragma: +optSpace }"
"set the comment of the class to be the argument, aString;
create a change record and notify dependents."
|oldComment newComment|
newComment := aStringOrNil.
(aStringOrNil notNil and:[aStringOrNil withoutSeparators isEmpty]) ifTrue:[
newComment := nil
].
comment ~= newComment ifTrue:[
oldComment := self comment.
comment := newComment.
self addChangeRecordForClassComment:self.
self changed:#comment with:oldComment.
Smalltalk changed:#classComment with:self.
]
!
environment
"return the namespace I am contained in; ST-80 compatible name"
^ self nameSpace
!
globalKeyForClassVar:aStringOrSymbol
"this helps to encapsulate the (current) implementation of classVariables
from the outside world. Currently, classvars are stored in
the Smalltalk dictionary with a funny name, since there are
no classPools yet.
"
^ (self name , ':' , aStringOrSymbol) asSymbol
!
name
"return the name of the class.
This returns a symbol (but notice, that other smalltalks might return a string)."
^ name
"Created: 1.4.1997 / 15:24:32 / stefan"
!
nameSpace
"return the namespace I am contained in;
For private or anonymous classes, nil is returned -
for public classes, Smalltalk is returned."
|idx nsName e|
"/ cached in environment
environment isNil ifTrue:[
e := Smalltalk. "/ default
"/ due to the implementation, extract this from my name
"/ (physically, all classes are found in Smalltalk)
idx := name lastIndexOf:$:.
idx ~~ 0 ifTrue:[
(name at:idx-1) == $: ifTrue:[
nsName := name copyTo:(idx - 2).
e := Smalltalk at:nsName asSymbol.
]
].
environment := e.
].
^ environment
"Modified: / 20.7.1998 / 14:21:36 / cg"
!
package
"return the package-id of the class"
|owner|
(owner := self owningClass) notNil ifTrue:[^ owner package].
^ package ? ''
"
Object package
"
"Modified: / 29.12.1998 / 01:15:50 / cg"
!
package:aStringOrSymbol
"set the package of the class."
package := aStringOrSymbol
!
packageInfo
"return the package-info of the class - or nil.
The packageManager contains information relevant to the package,
to which this class belongs - especially, things like pathes to
resources, additional files etc. can be optioned this way.
A packageInfo loosely relates to ehat a classLoader is in Java.
Experimental."
|packageId prj handle t|
packageId := self package.
packageId notNil ifTrue:[
prj := Project projectWithId:packageId.
prj notNil ifTrue:[^ prj].
"/
"/ intermediate kludge (will be removed)
"/ search for a loaded class library and extract
"/ information from it ...
"/
handle := ObjectFileLoader loadedObjectHandles
detect:[:h | |cls|
cls := h classes firstIfEmpty:nil.
cls notNil and:[cls package = packageId]
]
ifNone:nil.
handle notNil ifTrue:[
prj := Project new.
prj name:packageId.
prj directory:(handle pathName asFilename directory pathName).
prj package:packageId.
t := packageId asCollectionOfSubstringsSeparatedByAny:'/\:'.
prj repositoryModule:(t first).
prj repositoryDirectory:(packageId copyFrom:t first size + 2).
prj isLoaded:true.
^ prj
]
].
^ nil
"
Object packageInfo
OSI::FTAMOperation packageInfo
"
!
primitiveDefinitions:aString
"{ Pragma: +optSpace }"
"set the primitiveDefinition string"
(self isPrivate) ifTrue:[
self error:'private classes cannot have their own primitiveDefinitions'.
].
self setPrimitiveDefinitions:aString.
self addChangeRecordForPrimitiveDefinitions:self.
"Created: 29.10.1995 / 19:41:39 / cg"
!
primitiveDefinitionsString
"{ Pragma: +optSpace }"
"return the primitiveDefinition string or nil"
|owner|
(owner := self owningClass) notNil ifTrue:[
^ owner primitiveDefinitionsString
].
^ self getSourceChunkAttribute:#primitiveDefinitions
"
Object primitiveDefinitionsString
String primitiveDefinitionsString
"
!
primitiveDefinitionsStringOrDefault
"return the primitiveDefinition string or a default"
^ self primitiveDefinitionsString ? '%{
/*
* includes, defines, structure definitions
* and typedefs come here.
*/
%}'
"
Object primitiveDefinitionsStringOrDefault
String primitiveDefinitionsStringOrDefault
ExternalStream primitiveDefinitionsStringOrDefault
"
!
primitiveFunctions:aString
"{ Pragma: +optSpace }"
"set the primitiveFunction string"
(self isPrivate) ifTrue:[
self error:'private classes cannot have their own primitiveFunctions'.
].
self setPrimitiveFunctions:aString.
self addChangeRecordForPrimitiveFunctions:self.
"Created: 29.10.1995 / 19:41:48 / cg"
!
primitiveFunctionsString
"{ Pragma: +optSpace }"
"return the primitiveFunctions string or nil"
|owner|
(owner := self owningClass) notNil ifTrue:[
^ owner primitiveFunctionsString
].
^ self getSourceChunkAttribute:#primitiveFunctions
!
primitiveFunctionsStringOrDefault
"return the primitiveFunction string or a default"
^ self primitiveFunctionsString ? '%{
/*
* any local C (helper) functions
* come here (please, define as static)
*/
%}'
"
Object primitiveFunctionsStringOrDefault
String primitiveFunctionsStringOrDefault
ExternalStream primitiveFunctionsStringOrDefault
"
!
primitiveVariables:aString
"{ Pragma: +optSpace }"
"set the primitiveVariable string"
(self isPrivate) ifTrue:[
self error:'private classes cannot have their own primitiveVariables'.
].
self setPrimitiveVariables:aString.
self addChangeRecordForPrimitiveVariables:self.
"Created: 29.10.1995 / 19:41:58 / cg"
!
primitiveVariablesString
"{ Pragma: +optSpace }"
"return the primitiveVariables string or nil"
|owner|
(owner := self owningClass) notNil ifTrue:[
^ owner primitiveVariablesString
].
^ self getSourceChunkAttribute:#primitiveVariables
!
primitiveVariablesStringOrDefault
"return the primitiveVariable string or a default"
^ self primitiveVariablesString ? '%{
/*
* any local C variables
* come here (please, define as static)
*/
%}'
"
Object primitiveVariablesStringOrDefault
String primitiveVariablesStringOrDefault
ExternalStream primitiveVariablesStringOrDefault
"
!
privateClasses
"{ Pragma: +optSpace }"
"return a collection of my private classes (if any).
The classes are in any order."
^ self privateClassesOrAll:false
"
Object privateClasses
ObjectMemory privateClasses
UILayoutTool privateClasses
"
"Modified: / 29.5.1998 / 23:23:18 / cg"
!
privateClassesAt:aClassNameStringOrSymbol
"{ Pragma: +optSpace }"
"return a private class if present; nil otherwise"
|nmSym|
nmSym := (self name , '::' , aClassNameStringOrSymbol) asSymbolIfInterned.
nmSym isNil ifTrue:[
"/ no such symbol - there cannot be a corresponding private class
^ nil
].
^ Smalltalk at:nmSym.
"Modified: 26.6.1997 / 11:44:04 / cg"
!
privateClassesAt:aClassNameStringOrSymbol put:aClass
"{ Pragma: +optSpace }"
"add a private class"
self classVarAt:(':' , aClassNameStringOrSymbol) put:aClass
"Modified: 26.6.1997 / 11:44:12 / cg"
!
privateClassesOrAll:allOfThem
"{ Pragma: +optSpace }"
"return a collection of my direct private classes (if any)
or direct plus indirect private classes (if allOfThem).
An empty collection if there are none.
The classes are in any order."
|classes myName myNamePrefix myNamePrefixLen|
myName := self name.
myNamePrefix := myName , '::'.
myNamePrefixLen := myNamePrefix size.
Smalltalk keysDo:[:nm |
|cls|
(nm startsWith:myNamePrefix) ifTrue:[
(allOfThem
or:[(nm indexOf:$: startingAt:myNamePrefixLen + 1) == 0]) ifTrue:[
cls := Smalltalk at:nm.
(cls isBehavior and:[cls isMeta not]) ifTrue:[
classes isNil ifTrue:[
classes := Set new:10.
].
classes add:cls.
]
]
]
].
^ classes ? #()
"
UILayoutTool privateClassesOrAll:true
UILayoutTool privateClassesOrAll:false
"
"Modified: / 29.5.1998 / 23:23:18 / cg"
!
privateClassesSorted
"{ Pragma: +optSpace }"
"return a collection of my private classes (if any).
The classes are sorted by inheritance."
|classes pivateClassesOf|
classes := self privateClasses.
(classes size > 0) 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.
"
Object privateClassesSorted
NewSystemBrowser privateClassesSorted
NewSystemBrowser privateClasses
"
"Created: 22.3.1997 / 16:10:42 / cg"
"Modified: 22.3.1997 / 16:11:20 / cg"
!
removeClassVarName:aString
"{ Pragma: +optSpace }"
"remove a class variable if not already there.
Also writes a change record and notifies dependents."
|names newNames|
names := self classVarNames.
(names includes:aString) ifTrue:[
newNames := ''.
names do:[:nm | nm ~= aString ifTrue:[newNames := newNames , nm , ' ']].
self classVariableString:newNames withoutSpaces.
Class withoutUpdatingChangesDo:[
self withAllSubclasses do:[:cls|
cls recompileMethodsAccessingAnyClassvarOrGlobal:
(Array with:aString asSymbol)
].
].
self addChangeRecordForClass:self andNotifyChangeOf:#classVariables.
]
"Created: / 29.10.1995 / 19:42:08 / cg"
"Modified: / 23.1.1998 / 15:46:33 / stefan"
!
setCategory:aStringOrSymbol
"set the category of the class to be the argument, aStringOrSymbol"
aStringOrSymbol isNil ifTrue:[
category := aStringOrSymbol
] ifFalse:[
category := aStringOrSymbol asSymbol
]
"Created: 1.4.1997 / 15:24:04 / stefan"
!
setClassFilename:aFilename
"set the classes filename.
This is a dangerous (low level) operation, since the
comment and primitiveSpecs may no longer be accessable, if a wrong filename
is set here."
classFilename := aFilename
"Modified: 8.9.1995 / 14:16:48 / claus"
!
setClassVariableString:aString
"set the classes classvarnames string.
This is a dangerous (low level) operation, since the
classvariables are not really created or updated. Also,
NO change record is written."
classvars := aString
!
setComment:aString
"set the comment of the class to be the argument, aString;
do NOT create a change record"
comment := aString
!
setComment:com category:categoryStringOrSymbol
"set the comment and category of the class;
do NOT create a change record"
|cat|
comment := com.
categoryStringOrSymbol isNil ifTrue:[
cat := ''
] ifFalse:[
cat := categoryStringOrSymbol
].
category := cat asSymbol
!
setEnvironment:aNamespace
"set the namespace I am contained in; ST-80 compatible name"
environment := aNamespace
!
setPackage:aStringOrSymbol
"set the package of the class."
package := aStringOrSymbol
!
source
"return the classes full source code"
|code aStream tmpFile|
" this is too slow for big classes ...
code := String new:1000.
aStream := WriteStream on:code.
self fileOutOn:aStream
"
tmpFile := '__temp' asFilename.
[
aStream := tmpFile newReadWriteStream.
] on:FileStream openErrorSignal do:[:ex|
self warn:'cannot create temporary file.'.
^ nil
].
FileOutErrorSignal handle:[:ex |
aStream nextPutAll:'"no source available"'.
] do:[
self fileOutOn:aStream.
].
aStream close.
aStream := tmpFile readStreamOrNil.
aStream isNil ifTrue:[
self warn:'oops - cannot reopen temp file'.
^ nil
].
code := aStream contents.
aStream close.
tmpFile remove.
^ code
!
sourceCodeManager
"return my source code manager.
For now, all classes return the same global manager.
But future versions may support mixed reporitories"
|owner|
(owner := self owningClass) notNil ifTrue:[^ owner sourceCodeManager].
^ Smalltalk at:#SourceCodeManager
"Created: 7.12.1995 / 13:16:46 / cg"
"Modified: 15.10.1996 / 18:54:02 / cg"
! !
!Class methodsFor:'adding & removing'!
removeFromSystem
"ST-80 compatibility
remove myself from the system"
^ Smalltalk removeClass:self
"Created: 6.2.1996 / 11:32:58 / stefan"
!
unload
"{ Pragma: +optSpace }"
"if the receiver was autoloaded, unload and reinstall it as
autoloaded. Can be used to get rid of no longer needed autoloaded
classes.
(maybe, autoloaded classes should unload themselfes when no
longer needed - for example, after some delay when the last instance
is gone ...)"
|nm newClass|
self wasAutoloaded ifFalse:[
"
can it be done ?
(all of my methods must have a source)
"
self instAndClassSelectorsAndMethodsDo:[:sel :aMethod |
aMethod source isNil ifTrue:[^false].
aMethod hasPrimitiveCode ifTrue:[^ false].
].
].
"/ cannot unload, if non-autoloaded subclasses exist ...
self allSubclassesDo:[:aClass |
aClass wasAutoloaded ifFalse:[
aClass isPrivate ifFalse:[
self warn:('cannot unload ' , self name , ' (' , aClass name , ' requires it)').
^ false.
]
]
].
self allSubclassesDo:[:aClass |
aClass wasAutoloaded ifTrue:[
aClass unload
] ifFalse:[
aClass removeFromSystem.
]
].
self privateClasses do:[:aClass |
aClass removeFromSystem.
].
Transcript showCR:'unloading ' , name , ' ...'.
"/ reinstall as autoloaded
Autoload removeClass:self.
nm := name.
Smalltalk at:nm put:nil.
ObjectMemory flushInlineCaches.
ObjectMemory flushMethodCache.
newClass := Autoload addClass:nm inCategory:category.
newClass notNil ifTrue:[
newClass package:package
].
Smalltalk flushCachedClasses.
^ true
"
Clock open.
Clock unload.
ClockView unload.
Clock open
"
"Modified: 7.6.1996 / 09:15:05 / stefan"
"Modified: 4.6.1997 / 14:48:02 / cg"
! !
!Class methodsFor:'binary storage'!
addGlobalsForBinaryStorageTo:globalDictionary
"
classPool == nil ifFalse: [
classPool associationsDo: [:assoc|
globalDictionary at: assoc put: self
]
]
"
"Created: 21.3.1997 / 15:40:45 / cg"
!
binaryClassDefinitionFrom:stream manager:manager
"retrieve a class as stored previously with
#storeBinaryClassOn:manager:
The namespace, where the class is to be installed is queries via the
NameSpaceQuerySignal - it should answer with nil, to suppress installation."
|superclassName name flags instvars classvars category classInstVars
comment package superclassSig rev
newClass superClass methods cmethods formatID environment
ownerName owner nPrivate privateClass cls|
"/ the following order must correlate to
"/ the storing in #storeBinaryClassOn:manager:
"/ retrieve
"/ formatID
"/ superclasses name,
"/ superclasses signature
"/ name,
"/ typeSymbol,
"/ instVarNames
"/ classVarNames
"/ category
"/ classInstVarNames
"/ comment
"/ revision
"/ package
"/ name of owner, or nil
"/ classes methodDictionary
"/ methodDictionary
"/ number of private classes
"/ private classes, if any
formatID := manager nextObject.
formatID isInteger ifFalse:[ "/ backward compatibilty
formatID := nil.
superclassName := formatID
] ifTrue:[
superclassName := manager nextObject.
].
superclassSig := manager nextObject.
superclassName notNil ifTrue:[
superClass := Smalltalk at:superclassName ifAbsent:nil.
superClass isNil ifTrue:[
BinaryIOManager nonexistingClassSignal
raiseRequestWith:'non existent superclass (in binaryLoad)'.
^ nil
].
"/ ('loading superclass: ' , superclassName ) printNL.
superClass autoload.
superClass := Smalltalk at:superclassName.
superclassSig ~= superClass signature ifTrue:[
BinaryIOManager changedInstLayoutSignal
raiseRequestWith:'incompatible superclass (in binaryLoad)'.
^ nil
]
].
name := manager nextObject.
flags := manager nextObject.
instvars := manager nextObject.
instvars isNil ifTrue:[instvars := ''].
classvars := manager nextObject.
classvars isNil ifTrue:[classvars := ''].
category := manager nextObject.
classInstVars := manager nextObject.
classInstVars isNil ifTrue:[classInstVars := ''].
comment := manager nextObject.
package := manager nextObject.
formatID == 1 ifTrue:[
rev := manager nextObject.
ownerName := manager nextObject.
ownerName notNil ifTrue:[
name := name copyFrom:(ownerName size + 2 + 1).
owner := Smalltalk at:ownerName.
]
].
"/ 'got superName:' print. superclassName printNL.
"/ 'got name:' print. name printNL.
"/ 'got flags: ' print. flags printNL.
"/ 'got instvars: ' print. instvars printNL.
"/ 'got classvars: ' print. classvars printNL.
"/ 'got category: ' print. category printNL.
"/ 'got classInstvars: ' print. classInstVars printNL.
"/ ('create class: ' , name ) printNL.
owner notNil ifTrue:[
environment := owner
] ifFalse:[
environment := Class nameSpaceQuerySignal query.
].
cls := superClass.
superClass isNil ifTrue:[
cls := Object
].
newClass := cls class
name:name asSymbol
inEnvironment:environment
subclassOf:cls
instanceVariableNames:instvars
variable:false
words:false
pointers:true
classVariableNames:classvars
poolDictionaries:''
category:category
comment:comment
changed:false
classInstanceVariableNames:classInstVars.
newClass isNil ifTrue:[
^ nil.
].
superClass isNil ifTrue:[
newClass setSuperclass:nil.
newClass class setSuperclass:Class.
].
"/ Transcript showCR:'loaded ' , name , ' in ' , environment name.
newClass flags:flags.
"/ retrieve class methods
cmethods := MethodDictionary binaryFullDefinitionFrom:stream manager:manager.
"/ retrieve inst methods
methods := MethodDictionary binaryFullDefinitionFrom:stream manager:manager.
formatID == 1 ifTrue:[
"/ privateClasses
nPrivate := manager nextObject.
nPrivate timesRepeat:[
Class nameSpaceQuerySignal
answer:newClass
do:[
privateClass := manager nextObject
]
]
].
(superClass isNil and:[superclassName notNil]) ifTrue:[^ nil].
newClass isNil ifTrue:[
^ nil
].
owner notNil ifTrue:[
newClass setCategory:nil.
] ifFalse:[
newClass setPackage:package.
].
newClass instAndClassSelectorsAndMethodsDo:[:sel :mthd | mthd setPackage:package].
newClass methodDictionary:methods.
newClass class methodDictionary:cmethods.
newClass initializeWithAllPrivateClasses.
^ newClass
"Created: / 8.10.1996 / 17:57:02 / cg"
"Modified: / 16.2.1999 / 10:09:22 / cg"
"Modified: / 18.3.1999 / 18:15:58 / stefan"
!
storeBinaryClassOn:stream manager:manager
"store a classes complete description (i.e. including methods).
However, the superclass chain is not stored - at load time, that must
be either present or autoloadable."
|s sig owner superclass privateClasses nPrivate|
stream nextPut: manager codeForClass.
"/ the following order must correlate to
"/ the storing in #binaryDefinitionFrom:manager:
"/ store
"/ format ID
"/ superclasses name
"/ superclasses signature
"/ name
"/ typeSymbol,
"/ instVarNames
"/ classVarNames
"/ category
"/ classInstVarNames
"/ comment
"/ package
"/ revision
"/ name of owner, or nil
"/ classes methodDictionary
"/ methodDictionary
"/ # of privateClass names
"/ privateClasses, if any
1 storeBinaryOn:stream manager:manager. "/ formatID
owner := self owningClass.
superclass := self superclass.
superclass isNil ifTrue:[
s := nil.
sig := 0.
] ifFalse:[
s := superclass name.
sig := superclass signature.
].
s storeBinaryOn:stream manager:manager.
sig storeBinaryOn:stream manager:manager.
name storeBinaryOn:stream manager:manager.
flags storeBinaryOn:stream manager:manager.
(instvars isNil or:[instvars isEmpty]) ifTrue:[
s := nil
] ifFalse:[
s := self instanceVariableString
].
s storeBinaryOn:stream manager:manager.
(classvars isNil or:[classvars isEmpty]) ifTrue:[
s := nil
] ifFalse:[
s := self classVariableString
].
s storeBinaryOn:stream manager:manager.
"/ the category
owner notNil ifTrue:[
nil storeBinaryOn:stream manager:manager.
] ifFalse:[
category storeBinaryOn:stream manager:manager.
].
"/ the classInstVarString
s := self class instanceVariableString.
(s notNil and:[s isEmpty]) ifTrue:[
s := nil
].
s storeBinaryOn:stream manager:manager.
"/ the comment
s := comment.
manager sourceMode == #discard ifTrue:[
s := nil
].
s storeBinaryOn:stream manager:manager.
"/ the revision, package & owner
owner notNil ifTrue:[
nil storeBinaryOn:stream manager:manager.
nil storeBinaryOn:stream manager:manager.
owner name storeBinaryOn:stream manager:manager.
] ifFalse:[
package storeBinaryOn:stream manager:manager.
revision storeBinaryOn:stream manager:manager.
nil storeBinaryOn:stream manager:manager.
].
"/
"/ store class method dictionary and methods
"/
self class methodDictionary storeFullBinaryDefinitionOn:stream manager:manager.
"/ store inst method dictionary and methods
self methodDictionary storeFullBinaryDefinitionOn:stream manager:manager.
"/
"/ names of private classes
"/
privateClasses := self privateClassesSorted.
(nPrivate := privateClasses size) storeBinaryOn:stream manager:manager.
nPrivate > 0 ifTrue:[
privateClasses do:[:aClass |
aClass storeBinaryClassOn:stream manager:manager
]
].
"
|bos|
bos := BinaryObjectStorage onNew: (Filename named: 'FBrowser.cls') writeStream.
bos nextPutClasses:(Array with:FileBrowser).
bos close.
"
"
|bos cls|
bos := BinaryObjectStorage onOld: (Filename named: 'FBrowser.cls') readStream.
cls := bos next.
bos close.
cls open.
"
"Modified: / 7.6.1996 / 13:39:02 / stefan"
"Modified: / 16.2.1999 / 07:07:00 / cg"
!
storeBinaryDefinitionOf: anAssociation on: stream manager: manager
"not usable at the moment - there are no classpools currently"
| string |
string := self name, ' classPool at: ', anAssociation key storeString.
stream nextNumber: 2 put: string size.
stream nextPutBytes:(string size) from:string startingAt:1.
"/ string do: [:char| stream nextPut: char asciiValue]
"Modified: 19.3.1997 / 18:49:54 / cg"
!
storeBinaryDefinitionOn: stream manager: manager
"store the receiver in a binary format on stream.
This is an internal interface for binary storage mechanism.
classes only store the name, signature and instvar names.
They restore by looking for that name in the Smalltalk dictionary.
However, using the signature, a check for being valid is made at
restore time.
This avoids a full recursive store of a class in the normal binary
storage - however, it also means that a classes semantics cannot
be stored with the basic storeBinary operation
(we depend on the class being present at binaryLoad time.
To store classes, use #storeBinaryClassOn:manager: or BOSS>>nextPutClasses:."
|varnames n sz|
"
output the signature
"
stream nextNumber:4 put:self signature.
"
output the instance variable name string
"
varnames := self allInstVarNames.
n := varnames size.
n == 0 ifTrue:[
sz := 0
] ifFalse:[
sz := varnames inject:0 into:[:sum :nm | sum + nm size].
sz := sz + n - 1.
].
stream nextNumber:2 put:sz.
varnames keysAndValuesDo:[:i :nm |
stream nextPutBytes:(nm size) from:nm startingAt:1.
"/ nm do:[:c |
"/ stream nextPut:c asciiValue
"/ ].
i ~~ n ifTrue:[stream nextPut:(Character space asciiValue)]
].
"
output my name
"
stream nextNumber:2 put:name size.
stream nextPutBytes:(name size) from:name startingAt:1.
"/ name do:[:c|
"/ stream nextPut:c asciiValue
"/ ]
"
|s|
s := WriteStream on:ByteArray new.
Rectangle storeBinaryOn:s.
Object readBinaryFrom:(ReadStream on:s contents)
"
"Modified: 19.3.1997 / 18:47:10 / cg"
! !
!Class methodsFor:'changes management'!
addChangeRecordForChangeCategory
"{ Pragma: +optSpace }"
"add a category change"
Class updateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addClassDefinitionChangeFor:self
]
]
!
addChangeRecordForClass:aClass
"{ Pragma: +optSpace }"
"add a class-definition-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForClass:to: with:aClass.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addClassDefinitionChangeFor:aClass
]
]
"Modified: / 24.1.1997 / 19:09:41 / cg"
"Modified: / 18.3.1999 / 18:14:04 / stefan"
!
addChangeRecordForClassCheckIn:aClass
"{ Pragma: +optSpace }"
"append a class-was-checkedIn-record to the changes file"
|rv|
UpdateChangeFileQuerySignal query ifTrue:[
rv := aClass revision.
rv isNil ifTrue:[rv := '???'].
self
writingChangeWithTimeStamp:false
perform:#addInfoRecord:to:
with:('checkin ' , aClass name , ' (' , rv , ')').
]
"Created: / 18.11.1995 / 17:04:58 / cg"
"Modified: / 24.1.1997 / 19:11:55 / cg"
"Modified: / 18.3.1999 / 18:14:14 / stefan"
!
addChangeRecordForClassComment:aClass
"{ Pragma: +optSpace }"
"add a class-comment-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForClassComment:to: with:aClass.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addClassCommentChangeFor:aClass
]
]
"Modified: / 24.1.1997 / 19:09:59 / cg"
"Modified: / 18.3.1999 / 18:14:23 / stefan"
!
addChangeRecordForClassContainerRemove:aClass
"{ Pragma: +optSpace }"
"append a container-was-removed-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self
writingChangeWithTimeStamp:false
perform:#addInfoRecord:to:
with:('removed source container of ' , aClass name).
]
"Created: / 11.9.1996 / 15:37:19 / cg"
"Modified: / 24.1.1997 / 19:12:05 / cg"
"Modified: / 18.3.1999 / 18:14:31 / stefan"
!
addChangeRecordForClassFileOut:aClass
"{ Pragma: +optSpace }"
"append a class-was-filedOut-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self
writingChangeWithTimeStamp:false
perform:#addInfoRecord:to:
with:('fileOut ' , aClass name).
]
"Modified: / 24.1.1997 / 19:12:14 / cg"
"Modified: / 18.3.1999 / 18:14:36 / stefan"
!
addChangeRecordForClassInstvars:aClass
"{ Pragma: +optSpace }"
"add a class-instvars-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForClassInstvars:to: with:aClass.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addInstVarDefinitionChangeFor:aClass class
]
]
"Modified: / 24.1.1997 / 19:10:18 / cg"
"Modified: / 18.3.1999 / 18:14:43 / stefan"
!
addChangeRecordForClassRemove
"{ Pragma: +optSpace }"
"add a class-remove-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForClassRemove:to: with:self.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addClassRemoveChange:self
]
]
"Modified: / 24.1.1997 / 19:10:25 / cg"
"Modified: / 18.3.1999 / 18:14:53 / stefan"
!
addChangeRecordForClassRemove:oldClassName
"{ Pragma: +optSpace }"
"add a class-remove-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForClassRemove:to: with:self.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addClassRemoveChange:self
]
]
"Modified: / 24.1.1997 / 19:10:25 / cg"
"Modified: / 18.3.1999 / 18:14:53 / stefan"
!
addChangeRecordForClassRename:oldName to:newName
"{ Pragma: +optSpace }"
"add a class-rename-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangeDo:[:aStream |
self addChangeRecordForClassRename:oldName to:newName to:aStream
]
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addClassRenameChangeFrom:oldName to:newName
]
]
"Modified: / 24.1.1997 / 19:10:35 / cg"
"Modified: / 18.3.1999 / 18:14:59 / stefan"
!
addChangeRecordForPrimitiveDefinitions:aClass
"{ Pragma: +optSpace }"
"add a primitiveDefinitions-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForPrimitiveDefinitions:to: with:aClass.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addPrimitiveDefinitionsChangeFor:aClass
]
]
"Modified: / 20.1.1997 / 12:36:10 / cg"
"Modified: / 18.3.1999 / 18:15:04 / stefan"
!
addChangeRecordForPrimitiveFunctions:aClass
"{ Pragma: +optSpace }"
"add a primitiveFunctions-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForPrimitiveFunctions:to: with:aClass.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addPrimitiveFunctionsChangeFor:aClass
]
]
"Modified: / 20.1.1997 / 12:36:13 / cg"
"Modified: / 18.3.1999 / 18:15:09 / stefan"
!
addChangeRecordForPrimitiveVariables:aClass
"{ Pragma: +optSpace }"
"add a primitiveVariables-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForPrimitiveVariables:to: with:aClass.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
UpdateChangeListQuerySignal query ifTrue:[
Project addPrimitiveVariablesChangeFor:aClass
]
]
"Modified: / 20.1.1997 / 12:36:16 / cg"
"Modified: / 18.3.1999 / 18:15:14 / stefan"
!
addChangeRecordForSnapshot:aFileName
"{ Pragma: +optSpace }"
"add a snapshot-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self
writingChangeWithTimeStamp:false
perform:#addChangeRecordForSnapshot:to:
with:aFileName.
]
"Modified: / 24.1.1997 / 19:12:25 / cg"
"Modified: / 18.3.1999 / 18:15:20 / stefan"
!
addChangeRecordForSnapshot:aFileName to:aStream
"{ Pragma: +optSpace }"
"add a snapshot-record to aStream"
self addInfoRecord:('snapshot ' , aFileName) to:aStream
"Modified: / 24.1.1997 / 19:11:08 / cg"
"Modified: / 18.3.1999 / 18:15:30 / stefan"
! !
!Class methodsFor:'enumerating'!
allPrivateClassesDo:aBlock
"evaluate aBlock on all of my private classes (if any).
Evaluation is in no particular order."
self allPrivateClasses do:aBlock
!
privateClassesDo:aBlock
"evaluate aBlock on all of my (immediate) private classes (if any).
Evaluation is in no particular order."
self privateClasses do:aBlock
!
subclassesDo:aBlock
"evaluate the argument, aBlock for all immediate subclasses.
This will only enumerate globally known classes - for anonymous
behaviors, you have to walk over all instances of Behavior."
|coll|
"/ use cached information (avoid class hierarchy search)
"/ if possible
SubclassInfo isNil ifTrue:[
Class subclassInfo
].
SubclassInfo notNil ifTrue:[
coll := SubclassInfo at:self ifAbsent:nil.
coll notNil ifTrue:[
coll do:aBlock.
].
^ self
].
Smalltalk allClassesDo:[:aClass |
(aClass superclass == self) ifTrue:[
aBlock value:aClass
]
]
"
Collection subclassesDo:[:c | Transcript showCR:(c name)]
"
"Modified: 22.1.1997 / 18:44:01 / cg"
!
withAllPrivateClassesDo:aBlock
"evaluate aBlock on myself and all of my private classes (if any).
This recurses into private classes of private classes.
Evaluation is in no particular order."
aBlock value:self.
self allPrivateClasses do:aBlock
! !
!Class methodsFor:'fileIn interface'!
primitiveDefinitions
"this method allows fileIn of classes with primitive code.
It returns a CCReader which reads the next chunks and installs the
unprocessed contents in the classes primitiveDefinitions section.
Thus, although the definitions are NOT processed, they are still visible,
editable and especially: not lost when filing out the class."
^ ClassCategoryReader class:self primitiveSpec:#primitiveDefinitions:
"Modified: 10.2.1996 / 12:47:12 / cg"
!
primitiveFunctions
"this method allows fileIn of classes with primitive code.
It returns a CCReader which reads the next chunks and installs the
unprocessed contents in the classes primitiveFunctions section.
Thus, although the functions are NOT processed, they are still visible,
editable and especially: not lost when filing out the class."
^ ClassCategoryReader class:self primitiveSpec:#primitiveFunctions:
"Modified: 10.2.1996 / 12:47:07 / cg"
!
primitiveVariables
"this method allows fileIn of classes with primitive code.
It returns a CCReader which reads the next chunks and installs the
unprocessed contents in the classes primitiveVariables section.
Thus, although the variables are NOT processed, they are still visible,
editable and especially: not lost when filing out the class."
^ ClassCategoryReader class:self primitiveSpec:#primitiveVariables:
"Modified: 10.2.1996 / 12:47:28 / cg"
! !
!Class methodsFor:'fileOut'!
basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace
"append an expression on aStream, which defines myself."
self
basicFileOutDefinitionOn:aStream
withNameSpace:forceNameSpace
withPackage:true
!
basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace withPackage:showPackage
"append an expression on aStream, which defines myself."
self class
basicFileOutDefinitionOf:self
on:aStream
withNameSpace:forceNameSpace withPackage:showPackage
!
basicFileOutInstvarTypeKeywordOn:aStream
"a helper for fileOutDefinition"
|isVar superclass|
superclass := self superclass.
superclass isNil ifTrue:[
isVar := self isVariable
] ifFalse:[
"I cant remember what this is for ?"
isVar := (self isVariable and:[superclass isVariable not])
].
aStream nextPutAll:(self firstDefinitionSelectorPart).
"Created: 11.10.1996 / 18:57:29 / cg"
!
fileOut
"create a file 'class.st' consisting of all methods in myself in
sourceForm, from which the class can be reconstructed (by filing in).
If the current project is not nil, create the file in the projects
directory. Care is taken, to not clobber any existing file in
case of errors (for example: disk full).
Also, since the classes methods need a valid sourcefile, the current
sourceFile may not be rewritten."
|dirName nm fileName|
nm := (Smalltalk fileNameForClass:self name) , '.st'.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
dirName := Project currentProjectDirectory
] ifFalse:[
dirName := Filename currentDirectory
].
fileName := (dirName asFilename construct:nm).
fileName makeLegalFilename.
self fileOutAs:fileName name.
"/ "
"/ add a change record; that way, administration is much easier,
"/ since we can see in that changeBrowser, which changes have
"/ already found their way into a sourceFile and which must be
"/ applied again
"/ "
"/ self addChangeRecordForClassFileOut:self
"Modified: / 7.6.1996 / 09:14:43 / stefan"
"Modified: / 27.8.1998 / 02:02:57 / cg"
!
fileOutAllDefinitionsOn:aStream
"append expressions on aStream, which defines myself and all of my private classes."
self fileOutDefinitionOn:aStream.
aStream nextPutChunkSeparator.
aStream cr; cr.
"/
"/ optional classInstanceVariables
"/
self class instanceVariableString isBlank ifFalse:[
self fileOutClassInstVarDefinitionOn:aStream.
aStream nextPutChunkSeparator.
aStream cr; cr
].
"/ here, the full nameSpace prefixes are output,
"/ to avoid confusing stc
"/ (which otherwise could not find the correct superclass)
"/
FileOutNameSpaceQuerySignal answer:false do:[
ForceNoNameSpaceQuerySignal answer:true do:[
self privateClassesSorted do:[:aClass |
aClass fileOutAllDefinitionsOn:aStream
]
]
].
"Created: 15.10.1996 / 11:15:19 / cg"
"Modified: 22.3.1997 / 16:11:56 / cg"
!
fileOutAllMethodsOn:aStream
self fileOutAllMethodsOn:aStream methodFilter:nil
"Created: 15.10.1996 / 11:13:00 / cg"
"Modified: 22.3.1997 / 16:12:17 / cg"
!
fileOutAllMethodsOn:aStream methodFilter:methodFilter
|collectionOfCategories|
collectionOfCategories := self class categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self class fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
aStream cr
]
].
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
aStream cr
]
].
self privateClassesSorted do:[:aClass |
aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter
].
"Created: 15.10.1996 / 11:13:00 / cg"
"Modified: 22.3.1997 / 16:12:17 / cg"
!
fileOutAs:fileNameString
"create a file consisting of all methods in myself in
sourceForm, from which the class can be reconstructed (by filing in).
The given fileName should be a full path, including suffix.
Care is taken, to not clobber any existing file in
case of errors (for example: disk full).
Also, since the classes methods need a valid sourcefile, the current
sourceFile may not be rewritten."
|aStream fileName newFileName savFilename needRename
mySourceFileName sameFile s mySourceFileID anySourceRef|
self isLoaded ifFalse:[
^ FileOutErrorSignal
raiseRequestWith:self
errorString:' - will not fileOut unloaded class: ', self name
].
fileName := fileNameString asFilename.
"
if file exists, copy the existing to a .sav-file,
create the new file as XXX.new-file,
and, if that worked rename afterwards ...
"
(fileName exists) ifTrue:[
sameFile := false.
"/ check carefully - maybe, my source does not really come from that
"/ file (i.e. all of my methods have their source as string)
anySourceRef := false.
self instAndClassMethodsDo:[:m |
m sourcePosition notNil ifTrue:[
anySourceRef := true
]
].
anySourceRef ifTrue:[
s := self sourceStream.
s notNil ifTrue:[
mySourceFileID := s pathName asFilename info id.
sameFile := (fileName info id) == mySourceFileID.
s close.
] ifFalse:[
classFilename notNil ifTrue:[
"
check for overwriting my current source file
this is not allowed, since it would clobber my methods source
file ... you have to save it to some other place.
This happens if you ask for a fileOut into the source-directory
(from which my methods get their source)
"
mySourceFileName := Smalltalk getSourceFileName:classFilename.
sameFile := (fileNameString = mySourceFileName).
sameFile ifFalse:[
mySourceFileName notNil ifTrue:[
sameFile := (fileName info id) == (mySourceFileName asFilename info id)
]
].
]
].
].
sameFile ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileNameString
errorString:(' - may not overwrite sourcefile:', fileNameString)
].
savFilename := Filename newTemporary.
fileName copyTo:savFilename.
newFileName := fileName withSuffix:'new'.
needRename := true
] ifFalse:[
"/ another possible trap: if my sourceFileName is
"/ the same as the written one AND the new files directory
"/ is along the sourcePath, we also need a temporary file
"/ first, to avoid accessing the newly written file.
anySourceRef := false.
self instAndClassMethodsDo:[:m |
|mSrc|
(mSrc := m sourceFilename) notNil ifTrue:[
mSrc asFilename baseName = fileName baseName ifTrue:[
anySourceRef := true
]
]
].
anySourceRef ifTrue:[
newFileName := fileName withSuffix:'new'.
needRename := true
] ifFalse:[
newFileName := fileName.
needRename := false
]
].
[
aStream := newFileName writeStream.
] on:FileStream openErrorSignal do:[:ex|
savFilename notNil ifTrue:[
savFilename delete
].
^ FileOutErrorSignal
raiseRequestWith:newFileName
errorString:(' - cannot create file:', newFileName name)
].
self fileOutOn:aStream.
aStream close.
"
finally, replace the old-file
be careful, if the old one is a symbolic link; in this case,
we have to do a copy ...
"
needRename ifTrue:[
newFileName copyTo:fileName.
newFileName delete
].
savFilename notNil ifTrue:[
savFilename delete
].
"
add a change record; that way, administration is much easier,
since we can see in that changeBrowser, which changes have
already found their way into a sourceFile and which must be
applied again
"
self addChangeRecordForClassFileOut:self
"Modified: / 7.6.1996 / 09:14:43 / stefan"
"Created: / 16.4.1997 / 20:44:05 / cg"
"Modified: / 12.8.1998 / 11:14:56 / cg"
!
fileOutClassInstVarDefinitionOn:aStream
"append an expression to define my classInstanceVariables on aStream"
self
fileOutClassInstVarDefinitionOn:aStream
withNameSpace:false
!
fileOutClassInstVarDefinitionOn:aStream withNameSpace:withNameSpace
"append an expression to define my classInstanceVariables on aStream"
|anySuperClassInstVar|
self isLoaded ifFalse:[
^ self basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace
].
withNameSpace ifTrue:[
self name printOn:aStream.
] ifFalse:[
self printClassNameOn:aStream.
].
aStream nextPutAll:' class instanceVariableNames:'''.
self class printInstVarNamesOn:aStream indent:8.
aStream nextPutAll:''''.
"mhmh - good idea; saw this in SmallDraw sourcecode ..."
anySuperClassInstVar := false.
self allSuperclassesDo:[:aSuperClass |
aSuperClass class instVarNames do:[:ignored | anySuperClassInstVar := true].
].
aStream cr; cr; nextPut:(Character doubleQuote); cr; space.
anySuperClassInstVar ifFalse:[
aStream
nextPutLine:'No other class instance variables are inherited by this class.'.
] ifTrue:[
aStream
nextPutLine:'The following class instance variables are inherited by this class:'.
aStream cr.
self allSuperclassesDo:[:aSuperClass |
aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
aStream nextPutLine:(aSuperClass class instanceVariableString).
].
].
aStream nextPut:(Character doubleQuote); cr.
"Created: / 10.12.1995 / 16:31:25 / cg"
"Modified: / 1.4.1997 / 16:00:33 / stefan"
"Modified: / 3.2.2000 / 23:05:28 / cg"
!
fileOutCommentOn:aStream
"append an expression on aStream, which defines my comment"
|comment s|
self printClassNameOn:aStream.
aStream nextPutAll:' comment:'.
(comment := self comment) isNil ifTrue:[
s := ''''''
] ifFalse:[
s := comment storeString
].
aStream nextPutAllAsChunk:s.
aStream nextPutChunkSeparator.
aStream cr
"Modified: 21.12.1996 / 13:36:01 / cg"
!
fileOutDefinitionOn:aStream
"append an expression on aStream, which defines myself."
^ self basicFileOutDefinitionOn:aStream withNameSpace:false
"Modified: 4.1.1997 / 20:55:18 / cg"
!
fileOutIn:aDirectoryName
"create a file 'class.st' consisting of all methods in self in
directory aDirectoryName (ignoring any directory setting in
the current project).
This is not logged in that change file (should it be ?)."
|aStream fileName|
fileName := (Smalltalk fileNameForClass:self name), '.st'.
[
aStream := (aDirectoryName asFilename construct:fileName) writeStream.
] on:FileStream openErrorSignal do:[:ex|
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:(' - cannot create file:', fileName)
].
self fileOutOn:aStream.
aStream close
"
self fileOutIn:'/tmp'
self fileOutIn:'/tmp/doesNotExistBla'
self fileOutIn:'/tmp' asFilename
"
"Modified: 19.9.1997 / 00:03:53 / stefan"
!
fileOutOn:aStream
"file out my definition and all methods onto aStream"
^ self fileOutOn:aStream withTimeStamp:true
"Created: 15.11.1995 / 12:53:32 / cg"
"Modified: 3.1.1997 / 17:50:28 / cg"
!
fileOutOn:aStream withTimeStamp:stampIt
"file out my definition and all methods onto aStream.
If stampIt is true, a timeStamp comment is prepended."
self fileOutOn:aStream withTimeStamp:stampIt withInitialize:true
"Modified: / 13.3.1998 / 12:23:02 / cg"
!
fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt
"file out my definition and all methods onto aStream.
If stampIt is true, a timeStamp comment is prepended.
If initIt is true, and the class implements a class-initialize method,
append a corresponding doIt expression for initialization."
self
fileOutOn:aStream
withTimeStamp:stampIt
withInitialize:initIt
withDefinition:true
methodFilter:nil
"Created: / 15.11.1995 / 12:53:06 / cg"
"Modified: / 1.4.1997 / 16:01:05 / stefan"
"Modified: / 13.3.1998 / 12:23:59 / cg"
!
fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter
"file out my definition and all methods onto aStream.
If stampIt is true, a timeStamp comment is prepended.
If initIt is true, and the class implements a class-initialize method,
append a corresponding doIt expression for initialization.
The order by which the fileOut is done is used to put the version string at the end.
Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
|encoding encoder|
encoding := Class defaultExternalEncoding.
encoding notNil ifTrue:[
encoder := CharacterEncoder encoderFor:encoding
].
^ self
fileOutOn:aStream
withTimeStamp:stampIt
withInitialize:initIt
withDefinition:withDefinition
methodFilter:methodFilter
encoder:encoder
!
fileOutOn:outStreamArg withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter encoder:encoderOrNil
"file out my definition and all methods onto aStream.
If stampIt is true, a timeStamp comment is prepended.
If initIt is true, and the class implements a class-initialize method,
append a corresponding doIt expression for initialization.
The order by which the fileOut is done is used to put the version string at the end.
Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
|collectionOfCategories copyrightMethod copyrightText comment versionMethod skippedMethods
meta classesImplementingInitialize outStream|
self isLoaded ifFalse:[
^ FileOutErrorSignal
raiseRequestWith:self
errorString:' - will not fileOut unloaded class: ', self name
].
encoderOrNil isNil ifTrue:[
outStream := outStreamArg.
] ifFalse:[
outStream := EncodedStream stream:outStreamArg encoder:encoderOrNil.
outStream nextPutAll:'"{ Encoding: ' , encoderOrNil nameOfEncoding , ' }"'; cr; cr.
].
meta := self theMetaclass.
"
if there is a copyright method, add a copyright comment
at the beginning, taking the string from the copyright method.
We cannot do this unconditionally - that would lead to my copyrights
being put on your code ;-).
On the other hand: I want every file created by myself to have the
copyright string at the beginning be preserved .... even if the
code was edited in the browser and filedOut.
"
(copyrightMethod := meta compiledMethodAt:#copyright) notNil ifTrue:[
"
get the copyright methods source,
and insert at beginning.
"
copyrightText := copyrightMethod source.
copyrightText isNil ifTrue:[
"
no source available - trigger an error
"
FileOutErrorSignal
raiseRequestWith:'no source for class ' , self name , ' available. Cannot fileOut'.
^ self
].
"
strip off the selector-line
"
copyrightText := copyrightText asCollectionOfLines asStringCollection.
copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
"/ copyrightText do:[:line | outStream nextPutAll:line. aStream cr.].
copyrightText := copyrightText asString.
outStream nextPutAllAsChunk:copyrightText.
].
stampIt ifTrue:[
"/
"/ first, a timestamp
"/
outStream nextPutAll:(Smalltalk timeStamp).
outStream nextPutChunkSeparator.
outStream cr; cr.
].
withDefinition ifTrue:[
"/
"/ then the definition(s)
"/
self fileOutAllDefinitionsOn:outStream.
"/
"/ a comment - if any
"/
(comment := self comment) notNil ifTrue:[
self fileOutCommentOn:outStream.
outStream cr.
].
"/
"/ primitive definitions - if any
"/
self fileOutPrimitiveSpecsOn:outStream.
].
"/
"/ methods from all categories in metaclass (i.e. class methods)
"/ EXCEPT: the version method is placed at the very end, to
"/ avoid sourcePosition-shifts when checked out later.
"/ (RCS expands this string, so its size is not constant)
"/
collectionOfCategories := meta categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
"/
"/ documentation first (if any), but not the version method
"/
(collectionOfCategories includes:'documentation') ifTrue:[
versionMethod := meta compiledMethodAt:(self nameOfVersionMethod).
versionMethod notNil ifTrue:[
skippedMethods := Array with:versionMethod
].
meta fileOutCategory:'documentation' except:skippedMethods only:nil methodFilter:methodFilter on:outStream.
outStream cr.
].
"/
"/ initialization next (if any)
"/
(collectionOfCategories includes:'initialization') ifTrue:[
meta fileOutCategory:'initialization' methodFilter:methodFilter on:outStream.
outStream cr.
].
"/
"/ instance creation next (if any)
"/
(collectionOfCategories includes:'instance creation') ifTrue:[
meta fileOutCategory:'instance creation' methodFilter:methodFilter on:outStream.
outStream cr.
].
collectionOfCategories do:[:aCategory |
((aCategory ~= 'documentation')
and:[(aCategory ~= 'initialization')
and:[aCategory ~= 'instance creation']]) ifTrue:[
meta fileOutCategory:aCategory methodFilter:methodFilter on:outStream.
outStream cr
]
]
].
"/
"/ methods from all categories in myself
"/
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self fileOutCategory:aCategory methodFilter:methodFilter on:outStream.
outStream cr
]
].
"/
"/ any private classes' methods
"/
self privateClassesSorted do:[:aClass |
aClass fileOutAllMethodsOn:outStream methodFilter:methodFilter
].
"/
"/ finally, the previously skipped version method
"/
versionMethod notNil ifTrue:[
meta fileOutCategory:'documentation' except:nil only:skippedMethods methodFilter:methodFilter on:outStream.
].
initIt ifTrue:[
"/
"/ optionally an initialize message
"/
classesImplementingInitialize := OrderedCollection new.
(meta includesSelector:#initialize) ifTrue:[
classesImplementingInitialize add:self
].
self privateClassesSorted do:[:aPrivateClass |
(aPrivateClass theMetaclass includesSelector:#initialize) ifTrue:[
classesImplementingInitialize add:aPrivateClass
]
].
classesImplementingInitialize size ~~ 0 ifTrue:[
classesImplementingInitialize topologicalSort:[:a :b | b isSubclassOf:a].
outStream cr.
classesImplementingInitialize do:[:eachClass |
eachClass printClassNameOn:outStream. outStream nextPutAll:' initialize'.
outStream nextPutChunkSeparator.
outStream cr.
].
].
]
"Created: / 15.11.1995 / 12:53:06 / cg"
"Modified: / 1.4.1997 / 16:01:05 / stefan"
"Modified: / 13.3.1998 / 12:23:59 / cg"
!
fileOutPrimitiveDefinitionsOn:aStream
"append primitive defs (if any) to aStream."
|s|
"
primitive definitions - if any
"
(s := self primitiveDefinitionsString) notNil ifTrue:[
aStream nextPutChunkSeparator.
self printClassNameOn:aStream.
aStream nextPutAll:' primitiveDefinitions';
nextPutChunkSeparator;
cr.
aStream nextPutAll:s.
aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
].
(s := self primitiveVariablesString) notNil ifTrue:[
aStream nextPutChunkSeparator.
self printClassNameOn:aStream.
aStream nextPutAll:' primitiveVariables';
nextPutChunkSeparator;
cr.
aStream nextPutAll:s.
aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
].
"Modified: 8.1.1997 / 17:45:40 / cg"
!
fileOutPrimitiveSpecsOn:aStream
"append primitive defs (if any) to aStream."
|s|
"
primitive definitions - if any
"
self fileOutPrimitiveDefinitionsOn:aStream.
"
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
].
"Modified: 8.1.1997 / 17:45:51 / cg"
! !
!Class methodsFor:'fileOut-binary'!
binaryFileOut
"create a file 'class.cls' (in the current projects fileOut-directory),
consisting of all methods in myself in a portable binary format.
The methods source is saved by reference
to the classes sourceFile if there is any.
That sourcefile needs to be present after reload in order to be
browsable."
self binaryFileOutWithSourceMode:#reference
"Modified: 5.1.1997 / 15:40:05 / cg"
!
binaryFileOutOn:aStream
"append a binary representation of myself to aStream"
self binaryFileOutOn:aStream sourceMode:#reference
!
binaryFileOutOn:aStream sourceMode:sourceMode
"append a binary representation of myself to aStream in
a portable binary format.
The argument controls how sources are to be saved:
#keep - include the source
#reference - include a reference to the sourceFile
#discard - dont save sources.
With #reference, the sourceFile needs to be present after reload
in order to be browsable."
|bos|
bos := BinaryObjectStorage onNew:aStream.
bos sourceMode:sourceMode.
bos nextPutClasses:(Array with:self).
bos close.
!
binaryFileOutWithSourceMode:sourceMode
"create a file 'class.cls' (in the current projects fileOut-directory),
consisting of all methods in myself in a portable binary format.
The argument controls how sources are to be saved:
#keep - include the source
#reference - include a reference to the sourceFile
#discard - dont save sources.
With #reference, the sourceFile needs to be present after reload
in order to be browsable."
|fileName dirName|
fileName := (Smalltalk fileNameForClass:self name) , '.cls'.
Project notNil ifTrue:[
dirName := Project currentProjectDirectory
] ifFalse:[
dirName := '.'
].
fileName := dirName asFilename construct:fileName.
fileName makeLegalFilename.
fileName := fileName name.
self binaryFileOutWithSourceMode:sourceMode as:fileName.
!
binaryFileOutWithSourceMode:sourceMode as:fileNameString
"create a file fileNameString,
consisting of all methods in myself in a portable binary format.
The argument controls how sources are to be saved:
#keep - include the source
#reference - include a reference to the sourceFile
#discard - dont save sources.
With #reference, the sourceFile needs to be present after reload
in order to be browsable."
|fileName aStream|
fileName := fileNameString asFilename.
fileName makeLegalFilename.
[
aStream := fileName newReadWriteStream.
] on:FileStream openErrorSignal do:[:ex|
^ FileOutErrorSignal
raiseRequestWith:fileName name
errorString:(' - cannot create file:', fileName name)
].
aStream binary.
self binaryFileOutOn:aStream sourceMode:sourceMode.
aStream close.
"Created: / 29.12.1998 / 21:38:38 / cg"
! !
!Class methodsFor:'fileOut-xml'!
fileOutXML
"create a file 'class.xml' consisting of all methods in myself in
XML sourceForm.
If the current project is not nil, create the file in the projects
directory. Care is taken, to not clobber any existing file in
case of errors (for example: disk full)"
|dirName nm fileName|
nm := (Smalltalk fileNameForClass:self name) , '.xml'.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
dirName := Project currentProjectDirectory
] ifFalse:[
dirName := Filename currentDirectory
].
fileName := (dirName asFilename construct:nm).
fileName makeLegalFilename.
self fileOutXMLAs:fileName.
"
Class fileOutXML
"
!
fileOutXMLAllDefinitionsOn:aStream
"append xml expressions on aStream, which defines myself and all of my private classes."
self fileOutXMLDefinitionOn:aStream.
"/ here, the full nameSpace prefixes are output,
"/ to avoid confusing stc
"/ (which otherwise could not find the correct superclass)
"/
FileOutNameSpaceQuerySignal answer:true do:[
self privateClassesSorted do:[:aClass |
aClass fileOutXMLAllDefinitionsOn:aStream
]
].
!
fileOutXMLAllMethodsOn:aStream methodFilter:methodFilter
|collectionOfCategories|
collectionOfCategories := self class categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self class fileOutXMLCategory:aCategory methodFilter:methodFilter on:aStream.
aStream cr
]
].
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self fileOutXMLCategory:aCategory methodFilter:methodFilter on:aStream.
aStream cr
]
].
self privateClassesSorted do:[:aClass |
aClass fileOutXMLAllMethodsOn:aStream methodFilter:methodFilter
].
!
fileOutXMLAs:fileNameOrString
"create a file consisting of all methods in myself in
XML sourceForm.
The given fileName should be a full path, including suffix."
|aStream fileName|
self isLoaded ifFalse:[
^ FileOutErrorSignal
raiseRequestWith:self
errorString:' - will not fileOut unloaded class: ', self name
].
fileName := fileNameOrString asFilename.
[
aStream := fileName writeStream.
] on:FileStream openErrorSignal do:[:ex|
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:(' - cannot create file: ', fileName name)
].
self fileOutXMLOn:aStream.
aStream close.
"
Class fileOutXMLAs:'test.xml'
Class fileOutXMLAs:'/blaDoesNotExist/test.xml'
"
!
fileOutXMLDefinitionOn:aStream
"append an xml expression on aStream, which defines myself."
|varNames|
aStream nextPutLine:'<class>'.
aStream nextPutAll:' <name>'.
aStream nextPutAll:(self nameWithoutPrefix).
aStream nextPutLine:'</name>'.
aStream nextPutAll:' <environment>'.
aStream nextPutAll:(self nameSpace name).
aStream nextPutLine:'</environment>'.
aStream nextPutAll:' <super>'.
aStream nextPutAll:(self theNonMetaclass superclass name).
aStream nextPutLine:'</super>'.
aStream nextPutAll:' <private>'.
aStream nextPutAll:(self isPrivate printString).
aStream nextPutLine:'</private>'.
aStream nextPutAll:' <indexed-type>'.
aStream nextPutAll:'none'.
aStream nextPutLine:'</indexed-type>'.
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 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 nextPutLine:'</class-inst-vars>'.
aStream nextPutAll:' <imports>'.
aStream nextPutAll:''.
aStream nextPutLine:'</imports>'.
aStream nextPutAll:' <category>'.
aStream nextPutAll:self category.
aStream nextPutLine:'</category>'.
aStream nextPutLine:'</class>'.
varNames := self classVarNames.
varNames size > 0 ifTrue:[
varNames 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>'.
].
].
!
fileOutXMLOn:aStream
"WARNING: untested first version. Not for general use (yet)
file out my definition and all methods onto aStream in XML format."
self
fileOutXMLOn:aStream
withTimeStamp:true
withInitialize:true
withDefinition:true
methodFilter:nil
!
fileOutXMLOn:aStream withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter
"WARNING: untested first version. Not for general use (yet)
file out my definition and all methods onto aStream in XML format.
If stampIt is true, a timeStamp comment is prepended.
If initIt is true, and the class implements a class-initialize method,
append a corresponding doIt expression for initialization.
The order by which the fileOut is done is used to put the version string at the end.
Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
|collectionOfCategories copyrightMethod copyrightText comment meta|
self isLoaded ifFalse:[
^ FileOutErrorSignal
raiseRequestWith:self
errorString:' - will not fileOut unloaded class: ', self name
].
meta := self class.
aStream nextPutLine:'<?xml version="1.0"?>'.
aStream nextPutLine:'<st-source>'.
"
if there is a copyright method, add a copyright element at the beginning,
taking the string from the copyright method.
We cannot do this unconditionally - that would lead to my copyrights
being put on your code ;-).
On the other hand: I want every file created by myself to have the
copyright string at the beginning be preserved .... even if the
code was edited in the browser and filedOut.
"
(copyrightMethod := meta compiledMethodAt:#copyright) notNil ifTrue:[
"
get the copyright methods source,
and insert at beginning.
"
copyrightText := copyrightMethod source.
copyrightText isNil ifTrue:[
"
no source available - trigger an error
"
FileOutErrorSignal
raiseRequestWith:' - no source for class: '.
^ self
].
"
strip off the selector-line
"
copyrightText := copyrightText asCollectionOfLines asStringCollection.
copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
[copyrightText last isEmpty] whileTrue:[
copyrightText := copyrightText copyWithoutLast:1.
].
(copyrightText first = '"') ifTrue:[
(copyrightText last = '"') ifTrue:[
copyrightText := copyrightText copyFrom:2 to:(copyrightText size - 1).
]
].
copyrightText := copyrightText asString.
aStream nextPutAll:'<copyright>'.
self fileOutXMLString:copyrightText on:aStream.
aStream nextPutLine:'</copyright>'.
].
stampIt ifTrue:[
"/
"/ first, a timestamp
"/
aStream nextPutAll:'<time-stamp>'.
self fileOutXMLString:(Smalltalk timeStampString) on:aStream.
aStream nextPutLine:'</time-stamp>'.
].
withDefinition ifTrue:[
"/
"/ then the definition
"/
self fileOutXMLAllDefinitionsOn:aStream.
"/
"/ a comment - if any
"/
(comment := self comment) notNil ifTrue:[
aStream nextPutLine:'<comment>'.
aStream nextPutAll:'<class-id>'.
aStream nextPutAll:(self name).
aStream nextPutLine:'</class-id>'.
aStream nextPutLine:'</comment>'.
].
"/
"/ primitive definitions - if any
"/
"/ self fileOutPrimitiveSpecsOn:aStream.
].
"/
"/ methods from all categories in metaclass (i.e. class methods)
"/ EXCEPT: the version method is placed at the very end, to
"/ avoid sourcePosition-shifts when checked out later.
"/ (RCS expands this string, so its size is not constant)
"/
collectionOfCategories := meta categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
meta fileOutXMLCategory:aCategory methodFilter:methodFilter on:aStream.
]
].
"/
"/ methods from all categories in myself
"/
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self fileOutXMLCategory:aCategory methodFilter:methodFilter on:aStream.
]
].
"/
"/ any private classes' methods
"/
self privateClassesSorted do:[:aClass |
aClass fileOutXMLAllMethodsOn:aStream methodFilter:methodFilter
].
initIt ifTrue:[
"/
"/ optionally an initialize message
"/
(meta includesSelector:#initialize) ifTrue:[
aStream nextPutLine:'<initialize>'.
aStream nextPutAll:'<class-id>'.
aStream nextPutAll:(self name).
aStream nextPutLine:'</class-id>'.
aStream nextPutLine:'</initialize>'.
]
].
aStream nextPutLine:'</st-source>'.
"
Class
fileOutXMLOn:'test.xml' asFilename writeStream
withTimeStamp:true
withInitialize:true
withDefinition:true
methodFilter:nil
"
! !
!Class methodsFor:'printOut'!
htmlDocumentation
self obsoleteMethodWarning:'use HTMLDocGenerator htmlDocOf:'.
^ HTMLDocGenerator htmlDocOf:self
"Created: 22.3.1997 / 14:18:23 / cg"
!
printClassVarNamesOn:aStream indent:indent
"print the class variable names indented and breaking at line end"
self printNameArray:(self classVarNames) on:aStream indent:indent
!
printFullHierarchyOn:aStream indent:indent
"print myself and all subclasses on aStream.
recursively calls itself to print subclasses.
Can be used to print hierarchy on the printer."
|nm|
nm := self name.
aStream spaces:indent; bold; nextPutAll:nm; normal; nextPutAll:' ('.
self printInstVarNamesOn:aStream indent:(indent + nm size + 2).
aStream nextPutLine:')'.
(self subclasses sort:[:a :b | a name < b name]) do:[:aSubclass |
aSubclass printFullHierarchyOn:aStream indent:(indent + 2)
]
"|printStream|
printStream := Printer new.
Object printFullHierarchyOn:printStream indent:0.
printStream close"
"Modified: 13.12.1996 / 14:13:06 / cg"
!
printOutDefinitionOn:aPrintStream
"print out my definition"
|comment s superclass|
aPrintStream nextPutAll:'class '; bold; nextPutLine:self name; normal.
aPrintStream nextPutAll:'superclass '.
superclass := self superclass.
superclass isNil ifTrue:[
s := 'Object'
] ifFalse:[
s := superclass name
].
aPrintStream nextPutLine:s.
aPrintStream nextPutAll:'instance Variables '.
self printInstVarNamesOn:aPrintStream indent:21.
aPrintStream cr.
aPrintStream nextPutAll:'class Variables '.
self printClassVarNamesOn:aPrintStream indent:21.
aPrintStream cr.
category notNil ifTrue:[
aPrintStream nextPutAll:'category ';
nextPutLine:(category printString).
].
(comment := self comment) notNil ifTrue:[
aPrintStream cr; nextPutLine:'comment:'; italic; nextPutLine:comment; normal
]
"Created: 10.12.1995 / 16:30:47 / cg"
"Modified: 9.11.1996 / 00:13:37 / cg"
"Modified: 1.4.1997 / 16:01:26 / stefan"
!
printOutOn:aPrintStream
"print out all methods on aPrintStream which should be a printStream"
|collectionOfCategories|
self printOutDefinitionOn:aPrintStream.
aPrintStream cr.
collectionOfCategories := self class categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutLine:'class protocol'.
aPrintStream cr.
collectionOfCategories do:[:aCategory |
self class printOutCategory:aCategory on:aPrintStream
]
].
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutLine:'instance protocol'.
aPrintStream cr.
collectionOfCategories do:[:aCategory |
self printOutCategory:aCategory on:aPrintStream
]
]
"Modified: / 25.11.1998 / 12:40:31 / cg"
!
storeOn:aStream
"append my name only - expects class to be there, when restoring"
aStream nextPutAll:self name
! !
!Class methodsFor:'private-accessing'!
attributes
"return the extra class attributes or nil"
attributes isArray ifTrue:[
attributes := ClassAttributes new fromSTCPrimitiveArray:attributes.
].
^ attributes
!
attributes:aClassAttributesObject
"set the extra class attributes"
attributes := aClassAttributesObject
!
classAttributes
"return the extra class attributes or nil"
attributes isArray ifTrue:[
attributes := ClassAttributes new fromSTCPrimitiveArray:attributes.
].
^ attributes
!
classAttributes:aClassAttributesObject
"set the extra class attributes"
attributes := aClassAttributesObject
!
getAttribute:aKey
"{ Pragma: +optSpace }"
"get an attribute (by symbolic key)"
attributes isNil ifTrue:[ ^ nil].
^ self classAttributes perform:aKey asSymbol
!
getSourceChunkAttribute:aKey
"{ Pragma: +optSpace }"
|pos stream string|
pos := self getAttribute:aKey.
"the attribute is either a string, or an integer specifying the
position within the classes sourcefile ..."
pos isNumber ifTrue:[
"/ classFilename notNil ifTrue:[
stream := self sourceStream.
stream notNil ifTrue:[
stream position0Based:pos.
string := stream nextChunk.
stream close.
^ string
].
"/ ].
^ nil
].
^ pos
!
setAttribute:key to:aValue
"{ Pragma: +optSpace }"
attributes isNil ifTrue:[
attributes := ClassAttributes new.
].
self classAttributes perform:(key , ':') asSymbol with:aValue
!
setPrimitiveDefinitions:aString
"{ Pragma: +optSpace }"
"set the primitiveDefinition string (no change notifications)"
^ self setAttribute:#primitiveDefinitions to:aString
!
setPrimitiveFunctions:aString
"{ Pragma: +optSpace }"
"set the primitiveFunction string (no change notifications)"
^ self setAttribute:#primitiveFunctions to:aString
!
setPrimitiveVariables:aString
"{ Pragma: +optSpace }"
"set the primitiveVariable string (no change notifications)"
^ self setAttribute:#primitiveVariables to:aString
!
setSuperclass:aClass
"set the superclass of the receiver.
this method is for special uses only - there will be no recompilation
and no change record written here. Also, if the receiver class has
already been in use, future operation of the system is not guaranteed to
be correct, since no caches are flushed.
Therefore: do NOT use it; use #superclass: (or flush the caches, at least)."
SubclassInfo := nil. "/ flush it
superclass := aClass
! !
!Class methodsFor:'private-changes management'!
addChangeRecordForChangeCategory:category to:aStream
"{ Pragma: +optSpace }"
"append a category change record to aStream"
self printClassNameOn:aStream.
aStream nextPutAll:(' category:' , category storeString).
aStream nextPutChunkSeparator.
"Created: 3.12.1995 / 13:43:33 / cg"
"Modified: 3.12.1995 / 14:10:34 / cg"
!
addChangeRecordForClass:aClass to:aStream
"{ Pragma: +optSpace }"
"append a class-definition-record to aStream"
aClass isLoaded ifTrue:[
aClass basicFileOutDefinitionOn:aStream withNameSpace:true.
aStream nextPutChunkSeparator.
]
"Created: 3.12.1995 / 13:57:44 / cg"
"Modified: 3.12.1995 / 14:11:26 / cg"
!
addChangeRecordForClassComment:aClass to:aStream
"{ Pragma: +optSpace }"
"append a class-comment-record to aStream"
aClass fileOutCommentOn:aStream.
"Modified: 4.3.1996 / 16:49:08 / cg"
!
addChangeRecordForClassInstvars:aClass to:aStream
"{ Pragma: +optSpace }"
"append an instvars-record to aStream"
aClass fileOutClassInstVarDefinitionOn:aStream withNameSpace:true.
aStream nextPutChunkSeparator.
!
addChangeRecordForClassRemove:oldClass to:aStream
"{ Pragma: +optSpace }"
"append a class-remove-record to aStream"
aStream nextPutAll:('Smalltalk removeClass:' , oldClass name).
aStream nextPutChunkSeparator.
!
addChangeRecordForClassRename:oldName to:newName to:aStream
"{ Pragma: +optSpace }"
"append a class-rename-record to aStream"
aStream nextPutAll:('Smalltalk renameClass:' , oldName, ' to:''' , newName , '''').
aStream nextPutChunkSeparator.
"Modified: 30.10.1996 / 20:27:02 / cg"
!
addChangeRecordForPrimitiveDefinitions:aClass to:aStream
"{ Pragma: +optSpace }"
"append a primitiveDefinitions-record to aStream"
aStream nextPutAll:aClass name; nextPutLine:' primitiveDefinitions:''';
nextPutAll:(aClass primitiveDefinitionsString storeString copyFrom:2).
aStream nextPutChunkSeparator.
"Modified: 9.11.1996 / 00:09:54 / cg"
!
addChangeRecordForPrimitiveFunctions:aClass to:aStream
"{ Pragma: +optSpace }"
"append a primitiveFunctions-record to aStream"
aStream nextPutAll:aClass name; nextPutLine:' primitiveFunctions:''';
nextPutAll:(aClass primitiveFunctionsString storeString copyFrom:2).
aStream nextPutChunkSeparator.
"Modified: 9.11.1996 / 00:10:02 / cg"
!
addChangeRecordForPrimitiveVariables:aClass to:aStream
"{ Pragma: +optSpace }"
"append a primitiveVariables-record to aStream"
aStream nextPutAll:aClass name; nextPutLine:' primitiveVariables:''';
nextPutAll:(aClass primitiveVariablesString storeString copyFrom:2).
aStream nextPutChunkSeparator.
"Modified: 9.11.1996 / 00:10:10 / cg"
! !
!Class methodsFor:'protocol printOut'!
printOutProtocolOn:aPrintStream
"{ Pragma: +optSpace }"
|collectionOfCategories|
self printOutDefinitionOn:aPrintStream.
aPrintStream cr.
collectionOfCategories := self class categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutLine:'class protocol'.
aPrintStream cr.
collectionOfCategories do:[:aCategory |
self class printOutCategoryProtocol:aCategory on:aPrintStream
]
].
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutLine:'instance protocol'.
aPrintStream cr.
collectionOfCategories do:[:aCategory |
self printOutCategoryProtocol:aCategory on:aPrintStream
]
]
"Modified: / 25.11.1998 / 12:40:38 / cg"
! !
!Class methodsFor:'queries'!
hasExtensions
"return true, if there are methods in the receiver, which belong to
a different package (i.e. package of class ~= package of method).
Those are class extensions, which must be treated specially when checking classes
into the sourceCode repository. (extensions are stored separate)"
|clsPkg defaultPkg|
defaultPkg := Project defaultProject package.
clsPkg := self package.
self instAndClassSelectorsAndMethodsDo:[:sel :mthd |
|mthdPkg|
mthdPkg := mthd package.
mthdPkg ~= clsPkg ifTrue:[
mthdPkg ~= defaultPkg ifTrue:[
^ true
]
].
].
^ false
"
Smalltalk allClasses select:[:each | each hasExtensions]
"
!
hasExtensionsFrom:aPackageID
"return true, if there are methods in the receiver, which belong to
the package with aPackageID (i.e. package of class ~= package of method).
Those are class extensions, which must be treated specially when checking classes
into the sourceCode repository. (extensions are stored separate)"
self instAndClassSelectorsAndMethodsDo:[:sel :mthd |
mthd package = aPackageID ifTrue:[^ true].
].
^ false
"
Smalltalk allClasses select:[:each | each hasExtensionsFrom:'stx:goodies/refactyBrowser']
"
!
isClass
"return true, if the receiver is some kind of class
(a real class, not just behavior);
true is returned here - the method is redefined from Object.
See also Behavior>>isBehavior."
^ true
"
Point isClass
1 isClass
Behavior new isBehavior
Behavior new isClass
Class new isBehavior
Class new isClass
"
!
isStartableWithMain
"return true, if this is an application class,
which can be started via #main"
^ self theMetaclass includesSelector:#main
"Created: / 2.11.2001 / 09:37:01 / cg"
"Modified: / 2.11.2001 / 09:48:05 / cg"
!
rootsOfTheWorld
"return a collection of classes which have a nil superclass"
|set|
set := IdentitySet new.
Smalltalk allClassesDo:[:aClass |
aClass superclass isNil ifTrue:[set add:aClass]
].
^ set asOrderedCollection
"
Class rootsOfTheWorld
"
"Modified: 18.4.1997 / 20:55:34 / cg"
!
subclasses
"return a collection of the direct subclasses of the receiver"
|newColl|
"/ use cached information (avoid class hierarchy search)
"/ if possible
SubclassInfo notNil ifTrue:[
newColl := SubclassInfo at:self ifAbsent:nil.
newColl notNil ifTrue:[^ newColl asOrderedCollection]
].
newColl := OrderedCollection new.
self subclassesDo:[:aClass |
newColl add:aClass
].
SubclassInfo notNil ifTrue:[
SubclassInfo at:self put:newColl.
].
^ newColl
"
Class flushSubclassInfo.
Collection subclasses
"
"Modified: 22.1.1997 / 18:43:52 / cg"
!
wasAutoloaded
"return true, if this class came into the system via an
autoload; false otherwise.
This is not an attribute of the class, but instead remembered in
Autoload. The interface here is for your convenience."
^ Autoload wasAutoloaded:self
"Modified: 21.3.1996 / 16:27:09 / cg"
!
whichClassDefinesClassVar:aVariableName
"return the class which defines the class variable
named aVariableName. This method should not be used for
repeated searches (i.e. in the compiler/parser), since it creates
many throw away intermediate objects."
|cls|
cls := self.
[cls notNil] whileTrue:[
(cls classVarNames includes:aVariableName) ifTrue:[ ^ cls].
cls := cls superclass
].
^ nil
"
StandardSystemView whichClassDefinesClassVar:'ErrorSignal'
StandardSystemView whichClassDefinesClassVar:'Foo'
"
! !
!Class methodsFor:'renaming'!
makePrivateIn:newOwner
"make a private class of newOwner from the receiver;
the receiver must be a public class.
Returns the new private class."
|sel newClass|
self owningClass notNil ifTrue:[
^ self
].
sel := self definitionSelectorPrivate.
newClass := self superclass
perform:sel
withArguments:(Array
with:(self nameWithoutPrefix asSymbol)
with:(self instanceVariableString)
with:(self classVariableString)
with:''
with:newOwner).
"/ copy over methods ...
ClassBuilder copyInvalidatedMethodsFrom:self class for:newClass class.
ClassBuilder copyInvalidatedMethodsFrom:self for:newClass.
newClass class recompileInvalidatedMethods.
newClass recompileInvalidatedMethods.
newOwner changed:#newClass with:newClass.
Smalltalk changed:#newClass with:newClass.
self removeFromSystem.
^ newClass
"Modified: / 29.5.1998 / 19:03:49 / cg"
!
makePublic
"make a public class from the receiver.
The receiver must be a private class.
Returns the new public class."
^ self makePublicIn:Smalltalk
!
makePublicIn:aNameSpace
"make a public class from the receiver.
The receiver must be a private class.
Returns the new public class."
|sel owner newName newClass|
owner := self topOwningClass.
owner isNil ifTrue:[^ self].
"/ first, create the public class ...
sel := self definitionSelector.
Class nameSpaceQuerySignal answer:aNameSpace
do:[
(aNameSpace isNil or:[aNameSpace == Smalltalk]) ifTrue:[
newName := self nameWithoutPrefix
] ifFalse:[
newName := aNameSpace name , '::' , self nameWithoutPrefix
].
newClass := self superclass
perform:sel
withArguments:(Array
with:(newName asSymbol)
with:(self instanceVariableString)
with:(self classVariableString)
with:''
with:(owner category)).
"/ copy over methods ...
ClassBuilder copyInvalidatedMethodsFrom:self class for:newClass class.
ClassBuilder copyInvalidatedMethodsFrom:self for:newClass.
newClass class recompileInvalidatedMethods.
newClass recompileInvalidatedMethods.
].
owner changed:#newClass with:newClass.
Smalltalk changed:#newClass with:newClass.
(aNameSpace notNil and:[aNameSpace ~~ Smalltalk]) ifTrue:[
aNameSpace changed:#newClass with:newClass.
].
self removeFromSystem.
^ newClass
"Created: 23.6.1997 / 13:28:52 / cg"
"Modified: 20.10.1997 / 21:43:38 / cg"
!
renameTo:newName
"change the name of the class. This does not write a change record."
<resource:#obsolete>
|oldSym newSym|
"/ the code below is obsolete - it does not deal with
"/ classVariables, private classes and does not
"/ recompile other classes in order to care for namespace
"/ changes.
"/ Please use Smalltalk>>renameClass:to:,
"/ which deals with all of that.
self obsoleteMethodWarning:'use Smalltalk>>renameClass:to:'.
oldSym := name asSymbol.
newSym := newName asSymbol.
self setName:newSym.
Smalltalk at:oldSym put:nil.
Smalltalk removeKey:oldSym. "26.jun 93"
Smalltalk at:newSym put:self.
"Created: / 1.4.1997 / 15:27:53 / stefan"
"Modified: / 31.7.1998 / 15:21:34 / cg"
! !
!Class methodsFor:'signature checking'!
classinstSizeFromSignature:aSignature
"for checking class compatibility: return some number based on
the classinstSize from a signature key (not always the real classinstsize)."
^ (aSignature bitShift:-7) bitAnd:7
"Created: 1.4.1997 / 15:23:01 / stefan"
!
instNameKeyFromSignature:aSignature
"for checking class compatibility: return a number based on the
names and order of the instance variables from a signature key."
^ (aSignature bitShift:-14) bitAnd:16rFFFF
"
Point instNameKeyFromSignature:Point signature.
Association instNameKeyFromSignature:Association signature.
"
"Created: 1.4.1997 / 15:23:07 / stefan"
!
instSizeFromSignature:aSignature
"for checking class compatibility: return the some number based on
the instSize from a signature key (not always the real instSize)."
^ aSignature bitAnd:16r7F
"
Class instSizeFromSignature:Point signature.
Class instSizeFromSignature:Association signature.
Class instSizeFromSignature:Dictionary signature.
"
"Created: 1.4.1997 / 15:23:15 / stefan"
!
instTypeFromSignature:aSignature
"for checking class compatibility: return some number based on
the instType (i.e. variableBytes/Pointers etc.) from a signature key."
^ (aSignature bitShift:-10) bitAnd:(Class maskIndexType)
"
Class instTypeFromSignature:Object signature.
Class instTypeFromSignature:Array signature.
Class instTypeFromSignature:String signature.
Class instTypeFromSignature:OrderedCollection signature.
"
"Created: 1.4.1997 / 15:23:20 / stefan"
!
signature
"return a signature number - this number is useful for a quick
check for changed classes, and is done in the binary-object loader,
and the dynamic class loader.
Do NOT change the algorithm here - others may depend on it.
Also, the algorithm may change - so never interpret the returned value
(if at all, use the access #XXXFromSignature: methods)"
|value "{ Class: SmallInteger }"
nameKey "{ Class: SmallInteger }" |
signature notNil ifTrue:[^ signature].
value := self flags bitAnd:(Class maskIndexType).
value := (value bitShift:3) + ((self class instSize - Class instSize) bitAnd:7).
value := (value bitShift:7) + (self instSize bitAnd:16r7F).
nameKey := 0.
self allInstVarNames do:[:name |
nameKey := nameKey bitShift:1.
(nameKey bitAnd:16r10000) ~~ 0 ifTrue:[
nameKey := nameKey bitXor:1.
nameKey := nameKey bitAnd:16rFFFF.
].
nameKey := (nameKey + (name at:1) asciiValue) bitAnd:16rFFFF.
].
value := value + (nameKey bitShift:14).
signature := value.
^ value
"
Array signature
ByteArray signature
View signature
"
"Created: 1.4.1997 / 15:23:24 / stefan"
! !
!Class methodsFor:'source management'!
binaryRevision
"return the revision-ID from which the class was stc-compiled;
nil if its an autoloaded or filedIn class.
If a classes binary is up-to-date w.r.t. the source repository,
the returned string is the same as the one returned by #revision."
|owner info c|
(owner := self owningClass) notNil ifTrue:[^ owner binaryRevision].
revision notNil ifTrue:[
c := revision first.
c == $$ ifTrue:[
info := Class revisionInfoFromString:revision.
info isNil ifTrue:[^ '0'].
^ info at:#revision ifAbsent:'0'.
].
c isDigit ifFalse:[
^ '0'
].
].
^ revision
"
Object binaryRevision
Object class binaryRevision
"
"
to find all classes which are not up-to-date:
|classes|
classes := Smalltalk allClasses
select:[:cls | cls binaryRevision notNil and:[cls binaryRevision ~= cls revision]].
SystemBrowser browseClasses:classes title:'classes which are not up-to-date'
"
"Created: 7.12.1995 / 10:58:47 / cg"
"Modified: 1.4.1997 / 23:33:01 / stefan"
"Modified: 9.9.1997 / 12:05:41 / cg"
!
currentSourceStream
"return an open stream on the current source of the receiver"
|theWriteStream theCurrentSource|
theWriteStream := '' writeStream.
Method flushSourceStreamCache.
self fileOutOn:theWriteStream withTimeStamp:false.
theCurrentSource := theWriteStream contents asString.
theWriteStream close.
^ theCurrentSource
"Modified: 15.10.1996 / 18:59:40 / cg"
"Modified: 1.4.1997 / 14:33:12 / stefan"
!
localSourceStreamFor:sourceFile
"return an open stream on a local sourcefile, nil if that is not available"
|fileName info module dir fn package packageDir zar entry|
"/
"/ old: look in 'source/<filename>'
"/ this is still kept in order to find user-private
"/ classes in her currentDirectory.
"/
fileName := Smalltalk getSourceFileName:sourceFile.
fileName notNil ifTrue:[
^ fileName asFilename readStreamOrNil.
].
(package := self package) notNil ifTrue:[
"/ newest sceme ...
packageDir := package copyReplaceAll:$: with:$/.
packageDir := Smalltalk getPackageFileName:packageDir.
packageDir notNil ifTrue:[
"/ present there ?
packageDir := packageDir asFilename.
(fn := packageDir construct:sourceFile) exists ifTrue:[
^ fn readStreamOrNil.
].
"/ a source subdirectory ?
fn := (packageDir construct:'source') construct:sourceFile.
fn exists ifTrue:[
^ fn readStreamOrNil.
].
"/ a zip-file ?
fn := (packageDir construct:'source.zip').
fn exists ifTrue:[
zar := ZipArchive oldFileNamed:fn.
zar notNil ifTrue:[
entry := zar extract:sourceFile.
entry notNil ifTrue:[
^ entry asString readStream
]
]
]
].
"/ will vanish ...
(package includes:$:) ifTrue:[
package := package asString copyReplaceAll:$: with:$/
] ifFalse:[
package := 'stx/' , package
].
fileName := Smalltalk getSourceFileName:(package , '/' , sourceFile).
fileName notNil ifTrue:[
^ fileName asFilename readStreamOrNil.
].
(package startsWith:'stx/') ifTrue:[
fileName := Smalltalk getSourceFileName:((package copyFrom:5) , '/' , sourceFile).
fileName notNil ifTrue:[
^ fileName asFilename readStreamOrNil.
]
]
].
"/
"/ new: look in 'source/<module>/<package>/<filename>
"/ this makes the symbolic links to (or copy of) the source files
"/ obsolete.
info := self packageSourceCodeInfo.
info notNil ifTrue:[
module := info at:#module ifAbsent:nil.
module notNil ifTrue:[
dir := info at:#directory ifAbsent:nil.
dir notNil ifTrue:[
fn := (module asFilename construct:dir) construct:sourceFile.
fileName := Smalltalk getSourceFileName:(fn name).
fileName notNil ifTrue:[
^ fileName asFilename readStreamOrNil.
].
"/ brand new: look for source/<module>/package.zip
"/ containing an entry for <filename>
fn := (module asFilename construct:dir) withSuffix:'zip'.
fileName := Smalltalk getSourceFileName:(fn name).
fileName notNil ifTrue:[
zar := ZipArchive oldFileNamed:fileName.
zar notNil ifTrue:[
entry := zar extract:sourceFile.
entry notNil ifTrue:[
^ entry asString readStream
]
]
].
"/ and also in source/source.zip ...
fileName := Smalltalk getSourceFileName:'source.zip'.
fileName notNil ifTrue:[
zar := ZipArchive oldFileNamed:fileName.
zar notNil ifTrue:[
entry := zar extract:sourceFile.
entry notNil ifTrue:[
^ entry asString readStream
]
]
].
]
]
].
^ nil
"Modified: / 18.7.1998 / 22:53:19 / cg"
!
nameOfVersionMethod
^ #version
!
packageSourceCodeInfo
"{ Pragma: +optSpace }"
"return the sourceCodeInfo, which defines the module and the subdirectory
in which the receiver class was built.
This info is extracted from the package id (which is added to stc-compiled classes).
This method is to be obsoleted soon, since the same info is now found
in the versionString.
The info returned consists of a dictionary
filled with (at least) values at: #module, #directory and #library.
If no such info is present in the class, nil is returned.
(this happens with autoloaded and filed-in classes)
Auotloaded classes set their package from the revisionInfo, if present.
By convention, this info is encoded in the classes package
string (which is given as argument to stc) as the last word in parenthesis.
The info consists of 1 to 3 subcomponents, separated by colons.
The first defines the classes module (i.e. some application identifier),
the second defines the subdirectory within that module, the third
defines the name of the class library.
If left blank, the module info defaults to 'stx',
the directory info defaults to library name.
The library name may not be left blank.
(this is done for backward compatibility,)
For example:
'....(libbasic)' -> module: stx directory: libbasic library: libbasic
'....(stx:libbasic)' -> module: stx directory: libbasic library: libbasic
'....(stx:foo:libbfoo)' -> module: stx directory: foo library: libfoo
'....(aeg:libIECInterface)' -> module: aeg directory: libIECInterface library:libIECInterface
'....(stx:goodies/persistency:libdbase)' -> module: stx directory: goodies/persistency library:libdbase
The way how the sourceCodeManager uses this to find the source location
depends on the scheme used. For CVS, the module is taken as the -d arg,
while the directory is prepended to the file name.
Other schemes may do things differently - these are not yet specified.
Caveat:
Encoding this info in the package string seems somewhat kludgy.
"
|owner sourceInfo packageString idx1 idx2
moduleString directoryString libraryString components component1 component2 dirComponents mgr|
(owner := self owningClass) notNil ifTrue:[^ owner packageSourceCodeInfo].
package isNil ifTrue:[^ nil].
packageString := package asString.
idx1 := packageString lastIndexOf:$(.
idx1 ~~ 0 ifTrue:[
idx2 := packageString indexOf:$) startingAt:idx1+1.
idx2 ~~ 0 ifTrue:[
sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1
]
] ifFalse:[
sourceInfo := packageString
].
sourceInfo isNil ifTrue:[^ nil].
components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
components size == 0 ifTrue:[
"/ moduleString := 'stx'.
"/ directoryString := libraryString := ''.
^ nil
].
component1 := components at:1.
components size == 1 ifTrue:[
"/ a single name given - the module becomes 'stx' or
"/ the very first directory component (if such a module exists).
"/ If the component includes slashes, its the directory
"/ otherwise the library.
"/
dirComponents := Filename concreteClass components:component1.
(dirComponents size > 1
and:[(mgr := self sourceCodeManager) notNil
and:[mgr checkForExistingModule:dirComponents first]]) ifTrue:[
moduleString := dirComponents first.
directoryString := libraryString := (Filename fromComponents:(dirComponents copyFrom:2)) asString.
] ifFalse:[
"/ non-existing; assume directory under the stx package.
moduleString := 'stx'.
(component1 startsWith:'stx/') ifTrue:[
component1 := component1 copyFrom:5
].
directoryString := libraryString := component1.
].
(libraryString includes:$/) ifTrue:[
libraryString := libraryString asFilename baseName
]
] ifFalse:[
component2 := components at:2.
components size == 2 ifTrue:[
"/ two components - assume its the module and the directory;
"/ the library is assumed to be named after the directory
"/ except, if slashes are in the name; then the libraryname
"/ is the last component.
"/
moduleString := component1.
directoryString := libraryString := component2.
(libraryString includes:$/) ifTrue:[
libraryString := libraryString asFilename baseName
]
] ifFalse:[
"/ all components given
moduleString := component1.
directoryString := component2.
libraryString := components at:3.
]
].
libraryString isEmpty ifTrue:[
directoryString notEmpty ifTrue:[
libraryString := directoryString asFilename baseName
].
libraryString isEmpty ifTrue:[
"/ lets extract the library from the liblist file ...
libraryString := Smalltalk libraryFileNameOfClass:self.
libraryString isNil ifTrue:[^ nil].
]
].
moduleString isEmpty ifTrue:[
moduleString := 'stx'.
].
directoryString isEmpty ifTrue:[
directoryString := libraryString.
].
^ IdentityDictionary
with:(#module->moduleString)
with:(#directory->directoryString)
with:(#library->libraryString)
"
Object packageSourceCodeInfo
View packageSourceCodeInfo
Model packageSourceCodeInfo
BinaryObjectStorage packageSourceCodeInfo
MemoryMonitor packageSourceCodeInfo
ClockView packageSourceCodeInfo
"
"Created: 4.11.1995 / 20:36:53 / cg"
"Modified: 19.9.1997 / 10:42:25 / cg"
!
resourceDirectory
"return the directory where my resource file is supposed to live.
Here, take the package and assume that a directory named 'resources' exists
in my package directory.
Return nil, if no such directory exists."
|prjDir rsrcDir|
prjDir := Smalltalk projectDirectoryForClass:self.
(prjDir notNil
and:[(prjDir := prjDir asFilename) exists
and:[(rsrcDir := prjDir construct:'resources') exists]]) ifTrue:[
^ rsrcDir
].
^ nil
"
Object resourceDirectory
View resourceDirectory
ApplicationModel resourceDirectory
"
!
resourcePackName
"return the name which is used as the fileNameBase of my resource file.
Notice, that this will undergo the same name translation process as
done with class-source file names. (see ResourcePack).
The default here is the classes name - this can be redefined in classes
which want use another classes resources (NewLauncher -> Launcher)."
^ self name
"Created: / 29.1.1998 / 22:20:12 / cg"
!
revision
"return the revision-ID of the class which corresponds to the
rcs-id of the source to which this class is equivalent.
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.
To check if a source corresponds to a compiled binary, compare this
ID with the one returned by #binaryRevision."
|info|
info := self revisionInfo.
info notNil ifTrue:[
^ info at:#revision ifAbsent:nil
].
^ self binaryRevision
"
Object revision
"
"Created: 11.11.1995 / 14:27:20 / cg"
"Modified: 12.12.1995 / 20:30:20 / cg"
"Modified: 26.3.1997 / 00:14:00 / stefan"
!
revisionDateString
"return the revision-Date of the class as a string.
This is extracted from the version string."
|info|
info := self revisionInfo.
info notNil ifTrue:[
^ info at:#date ifAbsent:'??/??/??'
].
^ '??/??/??'
"
Object revisionDateString
"
"Created: 23.4.1997 / 12:29:21 / cg"
!
revisionInfo
"return a dictionary filled with revision info.
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
"
|vsnString info mgr|
vsnString := self revisionString.
vsnString notNil ifTrue:[
mgr := self sourceCodeManager.
mgr notNil ifTrue:[
info := mgr revisionInfoFromString:vsnString
] ifFalse:[
info := Class revisionInfoFromString:vsnString.
].
info notNil ifTrue:[
info at:#binaryRevision put:self binaryRevision.
]
].
^ info
"
Object revisionString
Object revisionInfo
Image revisionInfo
"
"Created: 11.11.1995 / 14:27:20 / cg"
"Modified: 29.1.1997 / 18:59:12 / cg"
"Modified: 26.3.1997 / 00:13:17 / stefan"
!
revisionString
"{ Pragma: +optSpace }"
"return my revision string; that one is extracted from the
classes #version method. Either this is a method returning that string,
or its a comment-only method and the comment defines the version.
If the source is not accessable or no such method exists,
nil is returned."
|owner cls meta m src val|
(owner := self owningClass) notNil ifTrue:[^ owner revisionString].
thisContext isRecursive ifTrue:[^ nil ].
meta := self theMetaclass.
cls := self theNonMetaclass.
m := meta compiledMethodAt:(self nameOfVersionMethod).
m isNil ifTrue:[
"/ no - do NEVER care for a version method on the instance side
"/ m := cls compiledMethodAt:(self nameOfVersionMethod).
m isNil ifTrue:[^ nil].
].
m isExecutable ifTrue:[
"/
"/ if its a method returning the string,
"/ thats the returned value
"/
val := cls perform:(self nameOfVersionMethod).
val isString ifTrue:[^ val].
].
"/
"/ if its a method consisting of a comment only
"/ extract it - this may lead to a recursive call
"/ to myself (thats what the #isRecursive is for)
"/ in case we need to access the source code manager
"/ for the source ...
"/
src := m source.
src isNil ifTrue:[^ nil].
^ Class revisionStringFromSource:src
"
Smalltalk allClassesDo:[:cls |
Transcript showCR:cls revisionString
].
Number revisionString
FileDirectory revisionString
Metaclass revisionString
"
"Created: / 29.10.1995 / 19:28:03 / cg"
"Modified: / 1.4.1997 / 23:37:25 / stefan"
"Modified: / 7.2.2001 / 18:03:39 / ps"
"Modified: / 5.11.2001 / 16:35:56 / cg"
!
setBinaryRevision:aString
"set the revision-ID.
This should normally not be done in the running system, as the source-manager
will need this to validate sourcefiles being correct for a given binary
(and optionally: extracting the required sourcefile from the rcs source)"
revision := aString
"Created: 9.12.1995 / 17:05:17 / cg"
!
setPackageFromRevision
"{ Pragma: +optSpace }"
"set my package from the info found in the revisionString if present.
This is used to set some useful packageInfo after autoloading
(otherwise, autoloaded classes/methods would go into your current
package - which is probably not a good idea)"
|info mgr dir lib mod p|
self owningClass notNil ifTrue:[^ self].
mgr := self sourceCodeManager.
mgr notNil ifTrue:[
info := mgr sourceInfoOfClass:self
].
info notNil ifTrue:[
mod := info at:#module ifAbsent:nil. "/ stx, aeg, <your-organization>
dir := info at:#directory ifAbsent:nil. "/ libbasic, libtool ...
lib := info at:#library ifAbsent:dir.
p := ''.
mod notNil ifTrue:[
"/ mod ~= 'stx' ifTrue:[
p := p , mod
"/ ]
].
dir notNil ifTrue:[
p notEmpty ifTrue:[p := p , ':'].
p := p , dir.
] ifFalse:[
lib notNil ifTrue:[
p notEmpty ifTrue:[p := p , ':'].
p := p , lib.
].
].
(p notEmpty and:[p ~= package]) ifTrue:[
"/ package notNil ifTrue:[
"/ (name , ': changing packageID from ''' , package , ''' to ''' , p , '''') infoPrintCR.
"/ ].
package := p.
self methodDictionary do:[:aMethod |
aMethod package isNil ifTrue:[
aMethod setPackage:p
]
]
].
].
^ self
"
MemoryMonitor autoload.
MemoryMonitor setPackageFromRevision
"
"Modified: 12.6.1996 / 11:49:31 / stefan"
"Modified: 7.1.1997 / 12:01:08 / cg"
!
sourceStream
"return an open stream on my sourcefile, nil if that is not available"
|owner source|
(owner := self owningClass) notNil ifTrue:[^ owner sourceStream].
classFilename notNil ifTrue:[
source := classFilename
] ifFalse:[
source := (Smalltalk fileNameForClass:self) , '.st'
].
^ self sourceStreamFor:source
"Modified: 15.10.1996 / 18:59:40 / cg"
"Modified: 1.4.1997 / 14:33:12 / stefan"
!
sourceStreamFor:source
"return an open stream on a sourcefile, nil if that is not available"
|owner aStream mgr validated guessedFileName sep mod dir|
(owner := self owningClass) notNil ifTrue:[^ owner sourceStreamFor:source].
validated := false.
"/
"/ if there is no SourceCodeManager,
"/ or TryLocalSourceFirst is true,
"/ look in standard places first
"/
((mgr := self sourceCodeManager) isNil
or:[TryLocalSourceFirst == true]) ifTrue:[
aStream := self localSourceStreamFor:source.
].
aStream isNil ifTrue:[
"/ mhmh - still no source file.
"/ If there is a SourceCodeManager, ask it to aquire the
"/ the source for my class, and return an open stream on it.
"/ if that one does not know about the source, look in
"/ standard places
mgr notNil ifTrue:[
classFilename ~= source ifTrue:[
sep := self package indexOfAny:'/\:'.
sep ~~ 0 ifTrue:[
mod := package copyTo:sep - 1.
dir := package copyFrom:sep + 1.
aStream := mgr streamForClass:nil fileName:source revision:nil directory:dir module:mod cache:true.
].
].
aStream isNil ifTrue:[
classFilename isNil ifTrue:[
guessedFileName := (Smalltalk fileNameForClass:self) , '.st'.
self setClassFilename:guessedFileName.
].
source asFilename baseName = classFilename asFilename baseName ifTrue:[
aStream := mgr getSourceStreamFor:self.
]
].
aStream notNil ifTrue:[
(self validateSourceStream:aStream) ifFalse:[
('Class [info]: repositories source for `'
, (self theNonMetaclass name)
, ''' is invalid.') infoPrintCR.
aStream close.
aStream := nil
] ifTrue:[
validated := true.
].
].
]
].
aStream isNil ifTrue:[
"/
"/ hard case - there is no source file for this class
"/ (in the source-dir-path).
"/
"/
"/ look if my binary is from a dynamically loaded module,
"/ and, if so, look in the modules directory for the
"/ source file.
"/
ObjectFileLoader notNil ifTrue:[
ObjectFileLoader loadedObjectHandlesDo:[:h |
|f classes|
aStream isNil ifTrue:[
(classes := h classes) size > 0 ifTrue:[
(classes includes:self) ifTrue:[
f := h pathName.
f := f asFilename directory.
f := f construct:source.
f exists ifTrue:[
aStream := f readStreamOrNil.
].
].
].
]
].
].
].
"/
"/ try along sourcePath
"/
aStream isNil ifTrue:[
aStream := self localSourceStreamFor:source.
].
"/
"/ final chance: try current directory
"/
aStream isNil ifTrue:[
aStream := source asFilename readStreamOrNil.
].
(aStream notNil and:[validated not]) ifTrue:[
(self validateSourceStream:aStream) ifFalse:[
(Smalltalk releaseIdentification = 'ST/X_free_demo_vsn') ifTrue:[
"/ ('Class [info]: source for ''' , self name , ''' is not available in the demo version.') infoPrintCR
] ifFalse:[
('Class [warning]: source for ''' , self name , ''' is invalid or stripped. Take care.') errorPrintCR
]
].
].
(aStream notNil and:[aStream isFileStream]) ifTrue:[
guessedFileName notNil ifTrue:[
self setClassFilename:(aStream pathName asFilename baseName).
]
].
^ aStream
"
Object sourceStream
Clock sourceStream
Autoload sourceStream
"
"Created: / 10.11.1995 / 21:05:13 / cg"
"Modified: / 22.4.1998 / 19:20:50 / ca"
"Modified: / 5.11.2001 / 16:36:30 / cg"
!
updateVersionMethodFor:newRevisionString
"{ Pragma: +optSpace }"
"helper for the checkin procedure.
Update my #version method, to now return newRevisionString."
|cls mthd "vs m mgr"|
cls := self.
self isMeta ifFalse:[
cls := self class
].
"/ m := cls compiledMethodAt:(self nameOfVersionMethod).
"/ m isNil ifTrue:[^ false].
"/ vs := self revisionString.
"/ vs isNil ifTrue:[^ false].
"/
"/ (mgr := self sourceCodeManager) isNil ifTrue:[^ false].
"/ newString := mgr updatedRevisionStringOf:cls forRevision:newRevision with:vs.
"/ newString isNil ifTrue:[^ false].
Class methodRedefinitionSignal answer:#keep do:[
Class withoutUpdatingChangesDo:[
mthd := Compiler compile:(self nameOfVersionMethod) , '
^ ''' , newRevisionString , '''
'
forClass:cls
inCategory:#documentation
notifying:nil
install:true
skipIfSame:false
silent:true.
mthd notNil ifTrue:[
mthd setPackage:self package
]
]
].
"/ ('updated to :' , newRevisionString) printNL.
^ true
"Created: 7.12.1995 / 20:42:22 / cg"
"Modified: 7.11.1996 / 21:02:09 / cg"
!
validateSourceStream:aStream
"check if aStream really contains my source.
This is done by checking the version methods return value
against the version string as contained in the version method"
|cls meta cannotCheckReason versionMethod info
versionFromCode versionFromSource oldPos pos src rev
versionMethodsName|
meta := self theMetaclass.
cls := self theNonMetaclass.
cannotCheckReason := nil.
versionMethodsName := self nameOfVersionMethod.
versionMethod := meta compiledMethodAt:versionMethodsName.
(versionMethod isNil
or:[versionMethod isExecutable not]) ifTrue:[
versionMethod := cls compiledMethodAt:versionMethodsName.
(versionMethod isNil
or:[versionMethod isExecutable not]) ifTrue:[
cannotCheckReason := 'no valid version method'.
]
] ifFalse:[
"/
"/ if its a method returning the string,
"/ thats the returned value
"/
versionFromCode := cls perform:versionMethodsName.
versionFromCode isString ifFalse:[
cannotCheckReason := 'version method does not return a string'
].
].
"/
"/ if its a method consisting of a comment only
"/ extract it - this may lead to a recursive call
"/ to myself (thats what the #isRecursive is for)
"/ in case we need to access the source code manager
"/ for the source ...
"/
versionMethod notNil ifTrue:[
pos := versionMethod sourcePosition.
pos isInteger ifFalse:[
"/ mhmh - either no version method,
"/ or updated due to a checkin.
"/ in any case, this should be a good source.
^ true.
"/ cannotCheckReason := 'no source position for version-method'
]
].
cannotCheckReason notNil ifTrue:[
('Class [warning]: ' , cannotCheckReason , ' in ' , self name) infoPrintCR.
'Class [info]: cannot validate source; trusting source' infoPrintCR.
^ true
].
oldPos := aStream position.
Stream positionErrorSignal handle:[:ex |
'Class [info]: position error when accessing source' infoPrintCR.
^ false
] do:[
aStream position1Based:pos.
].
src := aStream nextChunk.
aStream position:oldPos.
(src isNil or:[src isEmpty]) ifTrue:[
'Class [info]: empty source for version-method' infoPrintCR.
^ false
].
versionFromSource := Class revisionStringFromSource:src.
versionFromSource = versionFromCode ifTrue:[^ true].
versionFromSource isNil ifTrue:[
'Class [info]: version-from source is nil' infoPrintCR.
^ false
].
"/ mhmh - check my binary version ...
info := Class revisionInfoFromString:versionFromSource.
info notNil ifTrue:[
rev := info at:#revision.
rev = self binaryRevision ifTrue:[^ true].
].
'Class [info]: source-version is different from binaryRevision' infoPrintCR.
^ false
"Modified: / 5.11.2001 / 16:36:54 / cg"
! !
!Class methodsFor:'special accessing'!
setName:aString
"set the classes name - be careful, it will be still
in the Smalltalk dictionary - under another key.
This is NOT for general use - see renameTo:"
environment := nil.
name := aString
"Created: 1.4.1997 / 15:46:01 / stefan"
! !
!Class::ClassAttributes methodsFor:'accessing'!
primitiveDefinitions
^ primitiveDefinitions
!
primitiveDefinitions:something
primitiveDefinitions := something.
!
primitiveFunctions
^ primitiveFunctions
!
primitiveFunctions:something
primitiveFunctions := something.
!
primitiveVariables
^ primitiveVariables
!
primitiveVariables:something
primitiveVariables := something.
! !
!Class::ClassAttributes methodsFor:'conversion'!
fromSTCPrimitiveArray:anArray
"for now, the stc compiler generates a 3-element primitive spec array
(it does not know anything about me).
This method is invoked to convert."
primitiveDefinitions := anArray at:1.
primitiveVariables := anArray at:2.
primitiveFunctions := anArray at:3.
! !
!Class class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.457 2004-03-04 20:01:41 cg Exp $'
! !