"
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 primitiveSpec environment signature hook'
classVariableNames:''
poolDictionaries:''
category:'Kernel-Classes'
!
!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
primitiveSpec <Array | nil> describes primitiveIncludes, primitiveFunctions etc.
environment <Symbol | nil> cached environment (i.e. Smalltalk or a namespace)
of class
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.
hook <any> reserved: a place to add additional attributes,
without a need to recompile all classes.
Currently unused.
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)"
"
For now, this is a bad design - since the sourceCodeManager
is not always delivered, here, a fallBack is provided.
(should probably deliver some RCS-header extractor in any case,
even if no AbstractSourceCodeManager is present)
(knowing about the details of RCS headers here is a bad design ...)
"
|words info nm mgr|
"/
"/ mhmh - ask the default manager
"/
(mgr := Smalltalk at:#SourceCodeManager) notNil ifTrue:[
info := mgr revisionInfoFromString:aString.
info notNil ifTrue:[
^ info
]
].
"/
"/ fallBack - handles some RCS headers only
"/ is this really needed ?
"/
info := IdentityDictionary new.
words := aString asCollectionOfWords.
words notEmpty ifTrue:[
"/
"/ supported formats:
"/
"/ $-Header: pathName rev date time user state $
"/ $-Revision: rev $
"/ $-Id: fileName rev date time user state $
"/
((words at:1) = '$Header:') ifTrue:[
nm := words at:2.
info at:#repositoryPathName put:nm.
(nm endsWith:',v') ifTrue:[
nm := nm copyWithoutLast:2
].
info at:#fileName put:nm asFilename baseName.
words size > 2 ifTrue:[
(words at:3) = '$' ifFalse:[
info at:#revision put:(words at:3).
(words at:4) = '$' ifFalse:[
info at:#date put:(words at:4).
info at:#time put:(words at:5).
info at:#user put:(words at:6).
info at:#state put:(words at:7).
]
].
].
^ info
].
((words at:1) = '$Revision:') ifTrue:[
info at:#revision put:(words at:2).
^ info
].
((words at:1) = '$Id:') ifTrue:[
info at:#fileName put:(words at:2).
info at:#revision put:(words at:3).
info at:#date put:(words at:4).
info at:#time put:(words at:5).
info at:#user put:(words at:6).
info at:#state put:(words at:7).
^ info
].
].
^ nil
"Created: 15.11.1995 / 14:58:35 / cg"
"Modified: 29.1.1997 / 19:36:31 / cg"
!
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:'queries'!
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 - ST80'!
fileOutSourceOn:aStream
self fileOutOn:aStream withTimeStamp:false
"Created: 20.6.1997 / 17:18:14 / cg"
"Modified: 20.6.1997 / 17:18:26 / cg"
!
isVisualStartable
"return true, if this is an application class,
which can be started via #open"
^ false
"Created: / 27.10.1997 / 16:42:05 / cg"
!
rename:newName
"same as renameTo: - for ST80 compatibility"
^ self renameTo:newName
"Created: / 18.6.1998 / 22:08:45 / cg"
! !
!Class methodsFor:'ST/V subclass creation'!
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)"
|cat app|
DefaultApplicationQuerySignal isHandled ifTrue:[
app := DefaultApplicationQuerySignal query.
app notNil ifTrue:[
cat := 'Applications-' , app name.
] ifFalse:[
cat := 'V''Age classes'.
].
] ifFalse:[
cat := 'ST/V classes'.
].
^ self subclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:cat
"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)"
|cat app|
DefaultApplicationQuerySignal isHandled ifTrue:[
app := DefaultApplicationQuerySignal query.
app notNil ifTrue:[
cat := 'Applications-' , app name.
] ifFalse:[
cat := 'V''Age classes'.
]
] ifFalse:[
cat := 'ST/V classes'.
].
^ self variableByteSubclass:t
instanceVariableNames:''
classVariableNames:d
poolDictionaries:s
category:cat
"Modified: / 15.6.1998 / 21:31:38 / cg"
"Modified: / 18.3.1999 / 18:16:21 / stefan"
!
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)"
|cat app|
DefaultApplicationQuerySignal isHandled ifTrue:[
app := DefaultApplicationQuerySignal query.
app notNil ifTrue:[
cat := 'Applications-' , app name.
] ifFalse:[
cat := 'V''Age classes'.
]
] ifFalse:[
cat := 'ST/V classes'.
].
^ self variableSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:cat
"Modified: / 15.6.1998 / 21:31:41 / cg"
"Modified: / 18.3.1999 / 18:16:33 / stefan"
! !
!Class methodsFor:'accessing'!
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.
self changed:#definition.
]
"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"
aStringOrSymbol isNil ifTrue:[
category := aStringOrSymbol
] ifFalse:[
category := aStringOrSymbol asSymbol
]
"Created: 1.4.1997 / 15:24:04 / stefan"
!
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 name , ':' , aSymbol) asSymbol
!
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 name , ':' , aSymbol) asSymbol 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:[
^ OrderedCollection new
].
^ classvars asCollectionOfWords
"
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
"
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|
(classvars = aString) ifFalse:[
prevVarNames := self classVarNames.
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 position:comment.
string := String readFrom:stream onError:''.
stream close.
^ string
].
^ nil
]
].
^ comment
"
Object comment
"
!
comment:aString
"{ Pragma: +optSpace }"
"set the comment of the class to be the argument, aString;
create a change record and notify dependents."
|oldComment newComment|
newComment := aString.
(aString notNil and:[aString isEmpty]) ifTrue:[
newComment := nil
].
comment ~= newComment ifTrue:[
oldComment := self comment.
comment := newComment.
self changed:#comment with:oldComment.
self addChangeRecordForClassComment:self.
]
!
environment
"return the namespace I am contained in; ST-80 compatible name"
^ self nameSpace
!
name
"return the name of the class. In the current implementation,
this returns a string, but will be changed to Symbol soon."
^ 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|
environment notNil ifTrue:[^ environment].
environment := 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).
environment := Smalltalk at:nsName asSymbol.
]
].
^ 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 setPrimitiveSpecsAt:1 to:aString.
self addChangeRecordForPrimitiveDefinitions:self.
"Created: 29.10.1995 / 19:41:39 / cg"
!
primitiveDefinitionsString
"{ Pragma: +optSpace }"
"return the primitiveDefinition string or nil"
^ self getPrimitiveSpecsAt:1
"
Object primitiveDefinitionsString
String primitiveDefinitionsString
"
!
primitiveFunctions:aString
"{ Pragma: +optSpace }"
"set the primitiveFunction string"
self setPrimitiveSpecsAt:3 to:aString.
self addChangeRecordForPrimitiveFunctions:self.
"Created: 29.10.1995 / 19:41:48 / cg"
!
primitiveFunctionsString
"{ Pragma: +optSpace }"
"return the primitiveFunctions string or nil"
^ self getPrimitiveSpecsAt:3
!
primitiveSpec
"{ Pragma: +optSpace }"
"return the primitiveSpec or nil"
^ primitiveSpec
!
primitiveSpec:anArrayOf3ElementsOrNil
"{ Pragma: +optSpace }"
"set the primitiveSpec or nil"
primitiveSpec := anArrayOf3ElementsOrNil
!
primitiveVariables:aString
"{ Pragma: +optSpace }"
"set the primitiveVariable string"
self setPrimitiveSpecsAt:2 to:aString.
self addChangeRecordForPrimitiveVariables:self.
"Created: 29.10.1995 / 19:41:58 / cg"
!
primitiveVariablesString
"{ Pragma: +optSpace }"
"return the primitiveVariables string or nil"
^ self getPrimitiveSpecsAt:2
!
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 := IdentitySet 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|
classes := self privateClasses.
(classes size > 0) ifTrue:[
classes := classes asOrderedCollection topologicalSort:[:a :b | b isSubclassOf:a].
].
^ classes.
"
Object privateClassesSorted
"
"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.
BUG: Currently, no recompilation is done - this will change."
|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.
self changed:#definition.
]
"Created: / 29.10.1995 / 19:42:08 / cg"
"Modified: / 23.1.1998 / 15:46:33 / 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
!
sharedPools
"ST/X does not (currently) support pools"
^ #()
!
source
"return the classes full source code"
|code aStream|
" this is too slow for big classes ...
code := String new:1000.
aStream := WriteStream on:code.
self fileOutOn:aStream
"
aStream := FileStream newFileNamed:'__temp'.
aStream isNil ifTrue:[
self notify:'cannot create temporary file.'.
^ nil
].
FileOutErrorSignal handle:[:ex |
aStream nextPutAll:'"no source available"'.
] do:[
self fileOutOn:aStream.
].
aStream close.
aStream := FileStream oldFileNamed:'__temp'.
aStream isNil ifTrue:[
self notify:'oops - cannot reopen temp file'.
^ nil
].
code := aStream contents.
aStream close.
OperatingSystem removeFile:'__temp'.
^ 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 methodDictionary do:[:aMethod |
aMethod source isNil ifTrue:[^false].
aMethod hasPrimitiveCode ifTrue:[^ false].
].
self class methodDictionary do:[:aMethod |
aMethod source isNil ifTrue:[^false].
aMethod hasPrimitiveCode ifTrue:[^ false].
].
].
self allSubclassesDo:[:aClass |
aClass unload
].
Transcript showCR:'unloading ' , name , ' ...'.
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
in: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 category:nil.
] ifFalse:[
newClass package: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 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 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 := instvars isString ifTrue:[instvars] ifFalse:[instvars asStringCollection asString]
].
s storeBinaryOn:stream manager:manager.
(classvars notNil and:[classvars isEmpty]) ifTrue:[
s := nil
] ifFalse:[
s := classvars isString ifTrue:[classvars] ifFalse:[classvars asStringCollection asString]
].
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 record to the changes file"
Class updateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
]
"Modified: / 4.6.1997 / 14:56:13 / cg"
"Modified: / 18.3.1999 / 18:13:53 / stefan"
!
addChangeRecordForClass:aClass
"{ Pragma: +optSpace }"
"add a class-definition-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForClass:to: with: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.
]
"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.
]
"Modified: / 24.1.1997 / 19:10:18 / cg"
"Modified: / 18.3.1999 / 18:14:43 / stefan"
!
addChangeRecordForClassRemove:oldName
"{ Pragma: +optSpace }"
"add a class-remove-record to the changes file"
UpdateChangeFileQuerySignal query ifTrue:[
self writingChangePerform:#addChangeRecordForClassRemove:to: with:oldName.
]
"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
]
]
"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.
Project notNil 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.
Project notNil 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.
Project notNil 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:#addInfoRecord:to:
with:('snapshot ' , 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"
UpdateChangeFileQuerySignal query ifTrue:[
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 private classes (if any).
Evaluation is in no particular order."
self privateClasses 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."
|s owner ns nsName fullName superName cls topOwner
syntaxHilighting|
UserPreferences isNil ifTrue:[
syntaxHilighting := false
] ifFalse:[
syntaxHilighting := UserPreferences current syntaxColoring.
].
owner := self owningClass.
owner isNil ifTrue:[
ns := self nameSpace.
] ifFalse:[
ns := self topOwningClass nameSpace
].
fullName := FileOutNameSpaceQuerySignal query == true.
owner isNil ifTrue:[
aStream nextPutAll:'"{ Package: '''.
aStream nextPutAll:self package asString.
aStream nextPutAll:''' }"'; cr; cr.
].
((owner isNil and:[fullName not])
or:[owner notNil and:[forceNameSpace and:[fullName not]]]) ifTrue:[
(ns notNil and:[ns ~~ Smalltalk]) ifTrue:[
nsName := ns name.
(nsName includes:$:) ifTrue:[
nsName := '''' , nsName , ''''
].
"/ aStream nextPutLine:'"{ NameSpace: ' , nsName , ' }"'; cr.
aStream nextPutAll:'"{ NameSpace: '.
syntaxHilighting ifTrue:[aStream bold].
aStream nextPutAll:nsName.
syntaxHilighting ifTrue:[aStream normal].
aStream nextPutAll:' }"'; cr; cr.
]
].
"take care of nil-superclass"
superclass isNil ifTrue:[
s := 'nil'
] ifFalse:[
fullName ifTrue:[
superclass == owner ifTrue:[
s := superclass nameWithoutNameSpacePrefix
] ifFalse:[
s := superclass name
]
] ifFalse:[
(ns == superclass nameSpace
and:[superclass owningClass isNil]) ifTrue:[
"/ superclass is in the same namespace;
"/ still prepend namespace prefix, to avoid
"/ confusing stc, which needs that information ...
s := superclass nameWithoutPrefix
] ifFalse:[
"/ a very special (rare) situation:
"/ my superclass resides in another nameSpace,
"/ but there is something else named like this
"/ to be found in my nameSpace (or a private class)
superName := superclass nameWithoutNameSpacePrefix asSymbol.
cls := self privateClassesAt:superName.
cls isNil ifTrue:[
(topOwner := self topOwningClass) isNil ifTrue:[
ns := self nameSpace.
ns notNil ifTrue:[
cls := ns privateClassesAt:superName
] ifFalse:[
"/ self error:'unexpected nil namespace'
]
] ifFalse:[
cls := topOwner nameSpace at:superName.
]
].
(cls notNil and:[cls ~~ superclass]) ifTrue:[
s := superclass nameSpace name , '::' , superName
] ifFalse:[
"/ no class with that name found in my namespace ...
"/ if the superclass resides in Smalltalk,
"/ suppress prefix; otherwise, use full prefix.
(superclass nameSpace notNil
and:[superclass nameSpace ~~ Smalltalk]) ifTrue:[
(owner notNil
and:[owner nameSpace == superclass owningClass nameSpace])
ifTrue:[
s := superclass nameWithoutNameSpacePrefix
] ifFalse:[
s := superclass name
]
] ifFalse:[
s := superName
]
]
]
]
].
syntaxHilighting ifTrue:[aStream bold].
aStream nextPutAll:s. "/ superclass
syntaxHilighting ifTrue:[aStream normal].
aStream space.
self basicFileOutInstvarTypeKeywordOn:aStream.
(fullName and:[owner isNil]) ifTrue:[
aStream nextPutAll:'#'''.
syntaxHilighting ifTrue:[aStream bold].
aStream nextPutAll:(self name).
syntaxHilighting ifTrue:[aStream normal].
aStream nextPutAll:''''.
] ifFalse:[
aStream nextPut:$#.
syntaxHilighting ifTrue:[aStream bold].
aStream nextPutAll:(self nameWithoutPrefix).
syntaxHilighting ifTrue:[aStream normal].
].
aStream crtab.
aStream nextPutAll:'instanceVariableNames:'''.
syntaxHilighting ifTrue:[aStream bold].
self printInstVarNamesOn:aStream indent:16.
syntaxHilighting ifTrue:[aStream normal].
aStream nextPutAll:''''.
aStream crtab.
aStream nextPutAll:'classVariableNames:'''.
syntaxHilighting ifTrue:[aStream bold].
self printClassVarNamesOn:aStream indent:16.
syntaxHilighting ifTrue:[aStream normal].
aStream nextPutAll:''''.
aStream crtab.
aStream nextPutAll:'poolDictionaries:'''''.
aStream crtab.
owner isNil ifTrue:[
"/ a public class
aStream nextPutAll:'category:'.
category isNil ifTrue:[
s := ''''''
] ifFalse:[
s := category asString storeString
].
aStream nextPutAll:s.
] ifFalse:[
"/ a private class
aStream nextPutAll:'privateIn:'.
syntaxHilighting ifTrue:[aStream bold].
"/ fullName ifTrue:[
"/ s := owner name.
"/ ] ifFalse:[
"/ s := owner nameWithoutNameSpacePrefix.
"/ ].
s := owner nameWithoutNameSpacePrefix.
aStream nextPutAll:s.
syntaxHilighting ifTrue:[aStream normal].
].
aStream cr
"Created: / 4.1.1997 / 20:38:16 / cg"
"Modified: / 8.8.1997 / 10:59:50 / cg"
"Modified: / 18.3.1999 / 18:15:46 / stefan"
!
basicFileOutInstvarTypeKeywordOn:aStream
"a helper for fileOutDefinition"
|isVar s|
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"
!
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."
|baseName fileName aStream dirName|
baseName := (Smalltalk fileNameForClass:self name).
fileName := baseName , '.cls'.
Project notNil ifTrue:[
dirName := Project currentProjectDirectory
] ifFalse:[
dirName := '.'
].
fileName := dirName asFilename construct:fileName.
fileName makeLegalFilename.
fileName := fileName name.
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:('cannot create file:', fileName)
].
aStream binary.
self binaryFileOutOn:aStream sourceMode:sourceMode.
aStream close.
"Modified: / 27.8.1998 / 02:07:59 / cg"
!
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.
fileName := fileName name.
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:('cannot create file:', fileName)
].
aStream binary.
self binaryFileOutOn:aStream sourceMode:sourceMode.
aStream close.
"Created: / 29.12.1998 / 21:38:38 / 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."
|baseName dirName nm fileName|
baseName := (Smalltalk fileNameForClass:self name).
nm := baseName asFilename withSuffix:'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: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.
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."
|aStream fileName newFileName savFilename needRename
mySourceFileName sameFile s mySourceFileID anySourceRef|
self isLoaded ifFalse:[
^ FileOutErrorSignal
raiseRequestWith:self
errorString:'will not fileOut unloaded classes'
].
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 methodDictionary do:[:m|
m sourcePosition notNil ifTrue:[
anySourceRef := true
]
].
self class methodDictionary do:[: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 methodDictionary do:[:m|
|mSrc|
(mSrc := m sourceFilename) notNil ifTrue:[
mSrc asFilename baseName = fileName baseName ifTrue:[
anySourceRef := true
]
]
].
self class methodDictionary do:[: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.
aStream isNil ifTrue:[
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.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:('cannot create file:', fileName)
].
self fileOutOn:aStream.
aStream close
"
self fileOutIn:'/tmp'
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."
|collectionOfCategories copyrightMethod copyrightText comment versionMethod skippedMethods
meta|
self isLoaded ifFalse:[
^ FileOutErrorSignal
raiseRequestWith:self
errorString:'will not fileOut unloaded classes'
].
meta := self class.
"
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 | aStream nextPutAll:line. aStream cr.].
copyrightText := copyrightText asString.
aStream nextPutAllAsChunk:copyrightText.
].
stampIt ifTrue:[
"/
"/ first, a timestamp
"/
aStream nextPutAll:(Smalltalk timeStamp).
aStream nextPutChunkSeparator.
aStream cr; cr.
].
withDefinition ifTrue:[
"/
"/ then the definition
"/
self fileOutAllDefinitionsOn:aStream.
"/
"/ a comment - if any
"/
(comment := self comment) notNil ifTrue:[
self fileOutCommentOn:aStream.
aStream cr.
].
"/
"/ 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:[
"/
"/ documentation first (if any), but not the version method
"/
(collectionOfCategories includes:'documentation') ifTrue:[
versionMethod := meta compiledMethodAt:#version.
versionMethod notNil ifTrue:[
skippedMethods := Array with:versionMethod
].
meta fileOutCategory:'documentation' except:skippedMethods only:nil methodFilter:methodFilter on:aStream.
aStream cr.
].
"/
"/ initialization next (if any)
"/
(collectionOfCategories includes:'initialization') ifTrue:[
meta fileOutCategory:'initialization' methodFilter:methodFilter on:aStream.
aStream cr.
].
"/
"/ instance creation next (if any)
"/
(collectionOfCategories includes:'instance creation') ifTrue:[
meta fileOutCategory:'instance creation' methodFilter:methodFilter on:aStream.
aStream cr.
].
collectionOfCategories do:[:aCategory |
((aCategory ~= 'documentation')
and:[(aCategory ~= 'initialization')
and:[aCategory ~= 'instance creation']]) ifTrue:[
meta fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
aStream cr
]
]
].
"/
"/ methods from all categories in myself
"/
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
aStream cr
]
].
"/
"/ any private classes' methods
"/
self privateClassesSorted do:[:aClass |
aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter
].
"/
"/ finally, the previously skipped version method
"/
versionMethod notNil ifTrue:[
meta fileOutCategory:'documentation' except:nil only:skippedMethods methodFilter:methodFilter on:aStream.
].
initIt ifTrue:[
"/
"/ optionally an initialize message
"/
(meta implements:#initialize) ifTrue:[
self printClassNameOn:aStream. aStream nextPutAll:' initialize'.
aStream nextPutChunkSeparator.
aStream 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:'printOut'!
htmlDocumentation
^ 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|
aPrintStream nextPutAll:'class '; bold; nextPutLine:self name; normal.
aPrintStream nextPutAll:'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"
! !
!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.
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addClassDefinitionChangeFor:self
]
"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 fileOutDefinitionOn:aStream.
aStream nextPutChunkSeparator.
Project notNil ifTrue:[
Project addClassDefinitionChangeFor:aClass
]
]
"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.
Project notNil ifTrue:[
Project addClassCommentChangeFor:aClass
]
"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.
Project notNil ifTrue:[
Project addInstVarDefinitionChangeFor:aClass class
]
!
addChangeRecordForClassRemove:oldName to:aStream
"{ Pragma: +optSpace }"
"append a class-remove-record to aStream"
aStream nextPutAll:('Smalltalk removeClass:' , oldName).
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:'private helpers'!
getPrimitiveSpecsAt:index
"{ Pragma: +optSpace }"
"return a primitiveSpecification component as string or nil"
|owner pos stream string|
(owner := self owningClass) notNil ifTrue:[^ owner getPrimitiveSpecsAt:index].
primitiveSpec isNil ifTrue:[^ nil].
pos := primitiveSpec at:index.
pos isNil ifTrue:[^ nil].
"the primitiveSpec 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 position:pos+1.
string := stream nextChunk.
stream close.
^ string
]
].
^ nil
].
^ pos
"Modified: 15.1.1997 / 15:29:30 / stefan"
!
setPrimitiveSpecsAt:index to:aString
"{ Pragma: +optSpace }"
"set a primitiveSpecification component to aString"
primitiveSpec isNil ifTrue:[
primitiveSpec := Array new:3
].
primitiveSpec at:index put:aString
! !
!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'!
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
"
!
rootsOfTheWorld
"return a collection of classes which have a nil superclass"
|set|
set := IdentitySet new.
Smalltalk allBehaviorsDo:[:aClass |
aClass superclass isNil ifTrue:[set add:aClass]
].
^ set asOrderedCollection
"
Class rootsOfTheWorld
"
"Modified: 18.4.1997 / 20:55:34 / 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 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 ...
self class copyInvalidatedMethodsFrom:self class for:newClass class.
self class 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."
|sel owner newClass|
owner := self topOwningClass.
owner isNil ifTrue:[^ self].
"/ first, create the public class ...
sel := self definitionSelector.
Class nameSpaceQuerySignal answer:Smalltalk
do:[
newClass := self superclass
perform:sel
withArguments:(Array
with:(self nameWithoutPrefix asSymbol)
with:(self instanceVariableString)
with:(self classVariableString)
with:''
with:(owner category)).
"/ copy over methods ...
self class copyInvalidatedMethodsFrom:self class for:newClass class.
self class copyInvalidatedMethodsFrom:self for:newClass.
newClass class recompileInvalidatedMethods.
newClass recompileInvalidatedMethods.
].
owner changed:#newClass with:newClass.
Smalltalk 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."
|oldSym newSym|
"/ the code below is obsolete - it does not deal with
"/ classVariables, private classes and does not
"/ recompile other classes in order to car 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 := String new 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 readStream.
].
(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 readStream.
].
"/ a source subdirectory ?
fn := (packageDir construct:'source') construct:sourceFile.
fn exists ifTrue:[
^ fn readStream.
].
"/ 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 readStream.
].
(package startsWith:'stx/') ifTrue:[
fileName := Smalltalk getSourceFileName:((package copyFrom:5) , '/' , sourceFile).
fileName notNil ifTrue:[
^ fileName asFilename readStream.
]
]
].
"/
"/ 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 readStream.
].
"/ 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"
!
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"
!
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 ].
self isMeta ifTrue:[
meta := self. cls := self soleInstance
] ifFalse:[
cls := self. meta := self class
].
m := meta compiledMethodAt:#version.
m isNil ifTrue:[
m := cls compiledMethodAt:#version.
m isNil ifTrue:[^ nil].
].
m isExecutable ifTrue:[
"/
"/ if its a method returning the string,
"/ thats the returned value
"/
val := cls version.
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: 23.10.1996 / 18:23:56 / cg"
"Modified: 1.4.1997 / 23:37:25 / stefan"
!
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 package: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 fileName 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:[
classFilename := guessedFileName := (Smalltalk fileNameForClass:self) , '.st'.
].
source asFilename baseName = classFilename asFilename baseName ifTrue:[
aStream := mgr getSourceStreamFor:self.
]
].
aStream notNil ifTrue:[
(self validateSourceStream:aStream) ifFalse:[
('Class [info]: repositories source for `'
, (self isMeta ifTrue:[self soleInstance name]
ifFalse:[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 readStream.
].
].
].
]
].
].
].
"/
"/ try along sourcePath
"/
aStream isNil ifTrue:[
aStream := self localSourceStreamFor:source.
].
"/
"/ final chance: try current directory
"/
aStream isNil ifTrue:[
aStream := source asFilename readStream.
].
(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:[
classFilename := 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: / 23.4.1998 / 15:53:54 / 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:#version.
"/ 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:'version
^ ''' , newRevisionString , '''
'
forClass:cls
inCategory:#documentation
notifying:nil
install:true
skipIfSame:false
silent:true.
mthd notNil ifTrue:[
mthd package: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|
self isMeta ifTrue:[
meta := self. cls := self soleInstance
] ifFalse:[
cls := self. meta := self class
].
cannotCheckReason := nil.
versionMethod := meta compiledMethodAt:#version.
(versionMethod isNil
or:[versionMethod isExecutable not]) ifTrue:[
versionMethod := cls compiledMethodAt:#version.
(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 version.
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 position: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: / 9.4.1998 / 12:36:28 / 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 class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.369 2000-03-29 16:25:25 cg Exp $'
! !