"
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.
"
ClassDescription subclass:#Class
instanceVariableNames:'classvars comment subclasses classFilename package revision hook'
classVariableNames:'UpdatingChanges LockChangesFile FileOutErrorSignal
CatchMethodRedefinitions MethodRedefinitionSignal
UpdateChangeFileQuerySignal TryLocalSourceFirst
ChangeFileAccessLock NameSpaceQuerySignal'
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.
Also change management and recompilation is defined here (since the superclasses
do not have enough symbolic information to support compilation).
[Instance variables:]
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
hook <any> reserved: a place to add additional attributes,
without a need to recompile all classes.
Currently unused.
[Class variables:]
UpdatingChanges <Boolean> true if the changes-file shall be updated
(except during startup and when filing in, this flag
is usually true)
LockChangesFile <Boolean> if true, the change file is locked for updates.
Required when multiple users operate on a common
change file.
This is an experimental new feature, being evaluated.
UpdateChangeFileQuerySignal used as an upQuery from the change management.
Whenever a changeRecord is to be written,
this signal is raised and a handler (if present)
is supposed to return true or false.
If unhandled, the value of the global
UpdatingChanges is returned for backward
compatibility (which means that the old
mechanism is used if no query-handler
is present).
FileOutErrorSignal raised when an error occurs during fileOut
CatchMethodRedefinitions if true, classes protect themself
MethodRedefinitionSignal (by raising MethodRedefinitionSignal)
from redefining any existing methods,
which are defined in another package.
(i.e. a signal will be raised, if you
fileIn something which redefines an
existing method and the packages do not
match).
The default is (currently) true.
TryLocalSourceFirst If true, local source files are tried
first BEFORE the sourceCodeManager is
consulted. If false, the sourceCodeManager
is asked first.
Should be turned on, if you run an image from
local sources which have not yet been checked in.
WARNING: layout known by compiler and runtime system
[author:]
Claus Gittinger
[see also:]
Behavior ClassDescription Metaclass
"
! !
!Class class methodsFor:'initialization'!
initialize
"the classvariable 'UpdatingChanges' controls if changes are put
into the changes-file; normally this variable is set to true, but
(for example) during fileIn or when changes are applied, it is set to false
to avoid putting too much junk into the changes-file."
UpdatingChanges := true.
LockChangesFile := false.
CatchMethodRedefinitions := true.
TryLocalSourceFirst := false.
FileOutErrorSignal isNil ifTrue:[
FileOutErrorSignal := ErrorSignal newSignalMayProceed:false.
FileOutErrorSignal nameClass:self message:#fileOutErrorSignal.
FileOutErrorSignal notifierString:'error during fileOut'.
MethodRedefinitionSignal := ErrorSignal newSignalMayProceed:true.
MethodRedefinitionSignal nameClass:self message:#methodRedefinitionSignal.
MethodRedefinitionSignal notifierString:'attempt to redefine method from different package'.
UpdateChangeFileQuerySignal := QuerySignal new mayProceed:true.
UpdateChangeFileQuerySignal nameClass:self message:#updateChangeFileQuerySignal.
UpdateChangeFileQuerySignal notifierString:'asking if changeFile update is wanted'.
UpdateChangeFileQuerySignal handlerBlock:[:ex | ex proceedWith:UpdatingChanges].
NameSpaceQuerySignal := QuerySignal new mayProceed:true.
NameSpaceQuerySignal nameClass:self message:#updateChangeFileQuerySignal.
NameSpaceQuerySignal notifierString:'asking for nameSpace'.
NameSpaceQuerySignal handlerBlock:[:ex | ex proceedWith:Smalltalk currentNameSpace].
ChangeFileAccessLock := Semaphore forMutualExclusion.
]
"Modified: 14.10.1996 / 21:00:34 / cg"
! !
!Class class methodsFor:'Signal constants'!
fileOutErrorSignal
"return the signal raised when an error occurs while fileing out.
This is signalled to allow browsers some user feed back in case
a fileout fails (for example due to disk-full errors)"
^ FileOutErrorSignal
!
methodRedefinitionSignal
"return the signal raised when a method is about to be installed
which redefines an existing method and the methods packages are not
equal. This helps when filing in alien code, to prevent existing
methods to be overwritten or redefined by incompatible methods"
^ MethodRedefinitionSignal
!
nameSpaceQuerySignal
"return the signal used as an upQuery for the current nameSpace.
Will be used when filing in code"
^ NameSpaceQuerySignal
"
Class nameSpaceQuerySignal raise
"
"Modified: 14.10.1996 / 21:01:30 / cg"
!
updateChangeFileQuerySignal
"return the signal used as an upQuery if the changeFile should be updated.
If unhandled, the value of UpdatingChanges is returned by the signals
static handler."
^ UpdateChangeFileQuerySignal
"
Class updateChangeFileQuerySignal raise
"
"Modified: 14.10.1996 / 21:01:43 / cg"
! !
!Class class methodsFor:'accessing - flags'!
catchMethodRedefinitions
"return the redefinition catching flag."
^ CatchMethodRedefinitions
!
catchMethodRedefinitions:aBoolean
"turn on/off redefinition catching. Return the prior value of the flag."
|prev|
prev := CatchMethodRedefinitions.
CatchMethodRedefinitions := aBoolean.
^ prev
!
lockChangesFile
"return true, if the change file is locked during update"
^ LockChangesFile
!
lockChangesFile:aBoolean
"turn on/off change-file-locking. Return the previous value of the flag."
|prev|
prev := LockChangesFile.
LockChangesFile := aBoolean.
^ prev
!
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:'enumeration '!
allClassesInCategory:aCategory do:aBlock
"evaluate aBlock for all classes in aCategory;
no specific order is defined."
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = aCategory) ifTrue:[
aBlock value:aClass
]
].
]
"
Class allClassesInCategory:'Kernel-Classes'
do:[:class |Transcript showCR:class name]
"
!
allClassesInCategory:aCategory inOrderDo:aBlock
"evaluate aBlock for all classes in aCategory;
superclasses come first - then subclasses."
|classes|
classes := OrderedCollection new.
Smalltalk allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass category = aCategory) ifTrue:[
classes add:aClass
]
]
].
classes topologicalSort:[:a :b | b isSubclassOf:a].
classes do:aBlock
! !
!Class class methodsFor:'helpers'!
revisionInfoFromString:aString
"{ Pragma: +optSpace }"
"return a dictionary filled with revision info.
This extracts the relevant info from aString.
For now, this is a bad design - should always ask the
SCM to extract the parts (knowing about the details of RCS headers
here is a bad design ...)"
|words info nm mgr|
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 at:3) = '$' ifFalse:[
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
].
((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
].
].
"/
"/ mhmh - maybe its some other source code system
"/
(mgr := Smalltalk at:SourceCodeManager) notNil ifTrue:[
^ mgr revisionInfoFromString:aString
].
^ nil
"Created: 15.11.1995 / 14:58:35 / cg"
"Modified: 13.12.1995 / 17:11:28 / 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:'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:'ST/V subclass creation'!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
"this method allows fileIn of ST/V classes
(which seem to have no category)"
^ self subclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:'ST/V classes'
!
variableByteSubclass:t classVariableNames:d poolDictionaries:s
"this method allows fileIn of ST/V variable byte classes
(which seem to have no category and no instvars)"
^ self variableByteSubclass:t
instanceVariableNames:''
classVariableNames:d
poolDictionaries:s
category:'ST/V classes'
!
variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
"this method allows fileIn of ST/V variable pointer classes
(which seem to have no category)"
^ self variableSubclass:t
instanceVariableNames:f
classVariableNames:d
poolDictionaries:s
category:'ST/V classes'
! !
!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.
BUG: Currently, no recompilation is done - this will change."
(self classVarNames includes:aString) ifFalse:[
self classVariableString:(self classVariableString , ' ' , aString).
self addChangeRecordForClass:self.
self changed:#definition.
]
"Created: 29.10.1995 / 19:40:51 / cg"
!
classFilename
"return the name of the file from which the class was compiled.
This is currently NOT used."
|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|
"ignore for metaclasses except the one"
(self isMeta) ifTrue:[
(self == Metaclass) ifFalse:[
^ self
]
].
(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
].
]
!
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.
]
!
definition
"return an expression-string to define myself"
|s|
s := WriteStream on:(String new).
self fileOutDefinitionOn:s.
^ s contents
"
Object definition
Point definition
"
!
package
"return the package of the class"
|owner|
(owner := self owningClass) notNil ifTrue:[^ owner package].
^ package
"
Object package
"
"Modified: 15.10.1996 / 18:53:36 / cg"
!
package:aStringOrSymbol
"set the package of the class."
package := aStringOrSymbol
!
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); nil otherwise"
|classes myName|
classes := IdentitySet new.
myName := self name.
Smalltalk keysAndValuesDo:[:aName :aValue|
(aName startsWith:(myName , '::')) ifTrue:[
"/ care for private-privateClasses
(aName indexOf:$: startingAt:myName size + 3) == 0 ifTrue:[
classes add:aValue.
]
]
].
classes size == 0 ifTrue:[
^ nil
].
^ classes
"
Object privateClasses
"
"Modified: 15.10.1996 / 11:08:01 / cg"
!
privateClassesAt:aClassNameSymbol
"{ Pragma: +optSpace }"
"return a private class if present; nil otherwise"
|class|
class := self classVarAt:(':' , aClassNameSymbol) asSymbol.
^ class
"Created: 11.10.1996 / 19:05:39 / cg"
"Modified: 14.10.1996 / 17:23:30 / cg"
!
privateClassesAt:aClassNameSymbol put:aClass
"{ Pragma: +optSpace }"
"return a private class if present"
self classVarAt:(':' , aClassNameSymbol) asSymbol put:aClass
"Created: 11.10.1996 / 17:53:06 / cg"
"Modified: 14.10.1996 / 17:23:36 / 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.
self addChangeRecordForClass:self.
self changed:#definition.
]
"Created: 29.10.1995 / 19:42:08 / cg"
!
renameCategory:oldCategory to:newCategory
"{ Pragma: +optSpace }"
"rename a category (changes category of those methods).
Appends a change record and notifies dependents."
|any|
any := false.
self methodDictionary do:[:aMethod |
aMethod category = oldCategory ifTrue:[
aMethod category:newCategory.
any := true.
]
].
any ifTrue:[
self addChangeRecordForRenameCategory:oldCategory to:newCategory.
self changed:#methodCategory.
]
"Created: 29.10.1995 / 19:42:15 / cg"
"Modified: 12.6.1996 / 11:49:08 / 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
!
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'!
addSelector:newSelector withMethod:newMethod
"add the method given by 2nd argument under the selector given by
1st argument to the methodDictionary.
Append a change record to the changes file and tell dependents."
|oldMethod|
CatchMethodRedefinitions ifTrue:[
"check for attempts to redefine a method
in a different package. Signal a resumable error if so.
This allows tracing redefinitions of existing system methods
when filing in alien code ....
(which we may want to forbit sometimes)
"
oldMethod := self compiledMethodAt:newSelector.
oldMethod notNil ifTrue:[
oldMethod package ~= newMethod package ifTrue:[
"
attempt to redefine an existing method, which was
defined in another package.
If you continue in the debugger, the new method gets installed.
Otherwise, the existing (old) method remains valid.
You can turn of the catching of redefinitions by setting
CatchMethodRedefinitions to false
(also found in the Launchers 'settings-misc' menu)
"
MethodRedefinitionSignal
raiseErrorString:('redefinition of ' , name , '>>' , newSelector)
]
]
].
(super addSelector:newSelector withMethod:newMethod) ifTrue:[
self addChangeRecordForMethod:newMethod.
]
"Created: 29.10.1995 / 19:42:42 / cg"
"Modified: 9.9.1996 / 22:39:32 / stefan"
!
removeSelector:aSelector
"remove the selector, aSelector and its associated method
from the methodDictionary.
Append a change record to the changes file and tell dependents."
(super removeSelector:aSelector) ifTrue:[
self addChangeRecordForRemoveSelector:aSelector.
self changed:#methodDictionary with:aSelector.
]
"Created: 29.10.1995 / 19:42:47 / cg"
!
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|
self wasAutoloaded ifFalse:[
"
can it be done ?
"
self 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.
"/ name := (nm , ' (leftover)') asSymbol.
ObjectMemory flushInlineCaches.
ObjectMemory flushMethodCache.
Autoload addClass:nm inCategory:category.
"/ category := #unloaded.
Smalltalk flushCachedClasses.
^ true
"
Clock open.
Clock unload.
ClockView unload.
Clock open
"
"Modified: 18.5.1996 / 15:41:49 / cg"
"Modified: 7.6.1996 / 09:15:05 / stefan"
! !
!Class methodsFor:'binary storage'!
addGlobalsTo: globalDictionary manager: manager
"
classPool == nil ifFalse: [
classPool associationsDo: [:assoc|
globalDictionary at: assoc put: self
]
]
"
!
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 raise.
].
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
"Modified: 7.6.1996 / 13:43:06 / stefan"
"Created: 8.10.1996 / 17:57:02 / cg"
"Modified: 22.10.1996 / 20:31:38 / cg"
!
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|
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 notNil and:[instvars isEmpty]) ifTrue:[
s := nil
] ifFalse:[
s := instvars
].
s storeBinaryOn:stream manager:manager.
(classvars notNil and:[classvars isEmpty]) ifTrue:[
s := nil
] ifFalse:[
s := classvars
].
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 privateClasses.
privateClasses size storeBinaryOn:stream manager:manager.
privateClasses size > 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: 15.10.1996 / 21:13:32 / 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.
string do: [:char| stream nextPut: char asciiValue]
!
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 |
nm do:[:c |
stream nextPut:c asciiValue
].
i ~~ n ifTrue:[stream nextPut:(Character space asciiValue)]
].
"
output my name
"
stream nextNumber:2 put:name size.
name do:[:c|
stream nextPut:c asciiValue
]
"
|s|
s := WriteStream on:ByteArray new.
Rectangle storeBinaryOn:s.
Object readBinaryFrom:(ReadStream on:s contents)
"
"Modified: 23.4.1996 / 09:30:36 / cg"
! !
!Class methodsFor:'c function interfacing'!
cInterfaceFunction:selector calling:cFunctionNameString args:argTypeArray returning:returnType
"create an interface to an existing (i.e. already linked in) c function.
The function can be called by sending selector to the receiver class.
The c-function has the name cFunctionNameString, and expects parameters as specified in
argTypeArray. The functions return value has a type as specified by returnType.
WARNING:
this interface is EXPERIMENTAL - it may change or even be removed."
StubGenerator isNil ifTrue:[
^ self error:'this system does not support dynamic C Interface functions'.
].
StubGenerator
createStubFor:selector
calling:cFunctionNameString
args:argTypeArray
returning:returnType
in:self
"
Object subclass:#CInterface
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'Examples'.
CInterface cInterfaceFunction:#printfOn:format:withFloat:
calling:'fprintf'
args:#(ExternalStream String Float)
returning:#SmallInteger.
CInterface printfOn:Stdout format:'this is a float: %g' withFloat:(Float pi). Stdout cr
"
! !
!Class methodsFor:'changes management'!
addChangeRecordForChangeCategory
"{ Pragma: +optSpace }"
"add a category change record to the changes file"
self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
!
addChangeRecordForClass:aClass
"{ Pragma: +optSpace }"
"add a class-definition-record to the changes file"
self writingChangePerform:#addChangeRecordForClass:to: with:aClass.
!
addChangeRecordForClassCheckIn:aClass
"{ Pragma: +optSpace }"
"append a class-was-checkedIn-record to the changes file"
self addInfoRecord:('checkin ' , aClass name , ' (' , aClass revision , ')')
"Created: 18.11.1995 / 17:04:58 / cg"
"Modified: 7.12.1995 / 23:45:01 / cg"
!
addChangeRecordForClassComment:aClass
"{ Pragma: +optSpace }"
"add a class-comment-record to the changes file"
self writingChangePerform:#addChangeRecordForClassComment:to: with:aClass.
!
addChangeRecordForClassContainerRemove:aClass
"{ Pragma: +optSpace }"
"append a container-was-removed-record to the changes file"
self addInfoRecord:('removed source container of ' , aClass name)
"Modified: 7.12.1995 / 23:45:01 / cg"
"Created: 11.9.1996 / 15:37:19 / cg"
!
addChangeRecordForClassFileOut:aClass
"{ Pragma: +optSpace }"
"append a class-was-filedOut-record to the changes file"
self addInfoRecord:('fileOut ' , aClass name)
!
addChangeRecordForClassInstvars:aClass
"{ Pragma: +optSpace }"
"add a class-instvars-record to the changes file"
self writingChangePerform:#addChangeRecordForClassInstvars:to: with:aClass.
!
addChangeRecordForClassRemove:oldName
"{ Pragma: +optSpace }"
"add a class-remove-record to the changes file"
self writingChangePerform:#addChangeRecordForClassRemove:to: with:oldName.
!
addChangeRecordForClassRename:oldName to:newName
"{ Pragma: +optSpace }"
"add a class-rename-record to the changes file"
self writingChangeDo:[:aStream |
self addChangeRecordForClassRename:oldName to:newName to:aStream
]
!
addChangeRecordForMethod:aMethod
"{ Pragma: +optSpace }"
"add a method-change-record to the changes file"
self askIfUpdatingChanges ifTrue:[
self writingChangePerform:#addChangeRecordForMethod:to: with:aMethod.
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addMethodChange:aMethod in:self
]
]
!
addChangeRecordForMethodCategory:aMethod category:aString
"{ Pragma: +optSpace }"
"add a methodCategory-change-record to the changes file"
self askIfUpdatingChanges ifTrue:[
self writingChangeDo:[:aStream |
self addChangeRecordForMethodCategory:aMethod category:aString to:aStream.
].
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addMethodCategoryChange:aMethod category:aString in:self
]
]
!
addChangeRecordForMethodPrivacy:aMethod
"{ Pragma: +optSpace }"
"add a method-privacy-change-record to the changes file"
self askIfUpdatingChanges ifTrue:[
self writingChangePerform:#addChangeRecordForMethodPrivacy:to: with:aMethod.
"this test allows a smalltalk without Projects/ChangeSets"
Project notNil ifTrue:[
Project addMethodPrivacyChange:aMethod in:self
]
]
"Modified: 27.8.1995 / 22:47:32 / claus"
!
addChangeRecordForPrimitiveDefinitions:aClass
"{ Pragma: +optSpace }"
"add a primitiveDefinitions-record to the changes file"
self askIfUpdatingChanges ifTrue:[
self writingChangePerform:#addChangeRecordForPrimitiveDefinitions:to: with:aClass.
Project notNil ifTrue:[
Project addPrimitiveDefinitionsChangeFor:aClass
]
]
!
addChangeRecordForPrimitiveFunctions:aClass
"{ Pragma: +optSpace }"
"add a primitiveFunctions-record to the changes file"
self askIfUpdatingChanges ifTrue:[
self writingChangePerform:#addChangeRecordForPrimitiveFunctions:to: with:aClass.
Project notNil ifTrue:[
Project addPrimitiveFunctionsChangeFor:aClass
]
]
!
addChangeRecordForPrimitiveVariables:aClass
"{ Pragma: +optSpace }"
"add a primitiveVariables-record to the changes file"
self askIfUpdatingChanges ifTrue:[
self writingChangePerform:#addChangeRecordForPrimitiveVariables:to: with:aClass.
Project notNil ifTrue:[
Project addPrimitiveVariablesChangeFor:aClass
]
]
!
addChangeRecordForRemoveSelector:aSelector
"{ Pragma: +optSpace }"
"add a method-remove-record to the changes file"
self writingChangePerform:#addChangeRecordForRemoveSelector:to: with:aSelector.
!
addChangeRecordForRenameCategory:oldCategory to:newCategory
"{ Pragma: +optSpace }"
"add a category-rename record to the changes file"
self writingChangeDo:[:aStream |
self addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream.
]
!
addChangeRecordForSnapshot:aFileName
"{ Pragma: +optSpace }"
"add a snapshot-record to the changes file"
self addInfoRecord:('snapshot ' , aFileName)
!
addChangeRecordForSnapshot:aFileName to:aStream
"{ Pragma: +optSpace }"
"add a snapshot-record to aStream"
self addInfoRecord:('snapshot ' , aFileName) to:aStream
!
addChangeTimeStampTo:aStream
"{ Pragma: +optSpace }"
"a timestamp - prepended to any change, except infoRecords"
|info|
info := 'timestamp ' , OperatingSystem getLoginName , '@' , OperatingSystem getHostName.
self addInfoRecord:info to:aStream. aStream cr.
"Created: 18.11.1995 / 15:41:01 / cg"
!
addInfoRecord:aMessage
"add an info-record (snapshot, class fileOut etc.) to the changes file"
self writingChangeWithTimeStamp:false perform:#addInfoRecord:to: with:aMessage.
"Modified: 18.11.1995 / 15:45:10 / cg"
!
changesStream
"return a Stream for the writing changes file - or nil if no update is wanted"
|streamType aStream fileName|
self askIfUpdatingChanges ifTrue:[
fileName := ObjectMemory nameForChanges.
LockChangesFile ifTrue:[
streamType := LockedFileStream.
] ifFalse:[
streamType := FileStream.
].
aStream := streamType oldFileNamed:fileName.
aStream isNil ifTrue:[
aStream := streamType newFileNamed:fileName.
aStream isNil ifTrue:[
self warn:'cannot create/update the changes file'.
^ nil
]
].
aStream setToEnd
].
^ aStream
"Created: 28.10.1995 / 16:53:43 / cg"
"Modified: 28.10.1995 / 16:55:03 / cg"
!
sourcesStream
"return a stream for writing the sources file.
Notice, in ST/X, it is noncommon to use a single
source file; typically each classes source is kept
in a separate file."
|aStream fileName|
fileName := ObjectMemory nameForSources.
aStream := FileStream oldFileNamed:fileName.
aStream isNil ifTrue:[
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
Transcript showCR:'cannot update sources file'.
^ nil
]
].
aStream setToEnd.
^ aStream
"Created: 28.10.1995 / 16:53:17 / cg"
"Modified: 18.5.1996 / 15:41:47 / cg"
!
withoutUpdatingChangesDo:aBlock
"turn off change file update while evaluating aBlock.
This method makes sure, that the update-flag is correctly restored
in case of an abort or other error."
UpdateChangeFileQuerySignal handle:[:ex |
ex proceedWith:false
] do:[
aBlock value
].
! !
!Class methodsFor:'compiling'!
compile:code
"compile code, aString for this class;
if successful update the method dictionary.
Returns the new method or nil (on failure)."
^ self compilerClass
compile:code
forClass:self
"Modified: 13.12.1995 / 10:56:00 / cg"
!
compile:code classified:category
"compile code, aString for this class;
if successful update the method dictionary.
The method is classified under category.
Returns the new method or nil (on failure)."
^ self compile:code classified:category logged:true
"Modified: 20.4.1996 / 12:30:51 / cg"
!
compile:code classified:category logged:logged
"compile code, aString for this class;
if successful update the method dictionary.
The method is classified under category.
If logged is true, a changeRecord is written.
Returns the new method or nil (on failure)."
logged ifFalse:[
self withoutUpdatingChangesDo:[
^ self compilerClass
compile:code
forClass:self
inCategory:category
]
] ifTrue:[
^ self compilerClass
compile:code
forClass:self
inCategory:category
].
"Modified: 13.12.1995 / 11:02:34 / cg"
"Created: 20.4.1996 / 12:30:35 / cg"
!
compile:code notifying:requestor
"compile code, aString for this class; on any error, notify
requestor, anObject with the error reason.
Returns the new method or nil (on failure)."
^ self compilerClass
compile:code
forClass:self
notifying:requestor
"Modified: 13.12.1995 / 11:02:40 / cg"
!
recompile
"recompile all methods
used when a class changes instances and therefore all methods
have to be recompiled"
self methodDictionary keys do:[:aSelector |
self recompile:aSelector
]
"Modified: 12.6.1996 / 11:51:15 / stefan"
!
recompile:aSelector
"recompile the method associated with the argument, aSelector;
used when a superclass changes instances and we have to recompile
subclasses"
|cat code|
Class withoutUpdatingChangesDo:[
MethodRedefinitionSignal ignoreIn:[
cat := (self compiledMethodAt:aSelector) category.
code := self sourceCodeAt:aSelector.
self compilerClass compile:code forClass:self inCategory:cat
]
]
"Modified: 20.2.1996 / 20:23:21 / cg"
!
recompileAll
"recompile this class and all subclasses"
|classes|
classes := self subclasses.
self recompile.
classes do:[:aClass |
aClass recompileAll
]
!
recompileInvalidatedMethods:trap
"recompile all invalidated methods"
|trapCode trapByteCode|
trapCode := trap code.
trapByteCode := trap byteCode.
self methodDictionary keys do:[:aSelector |
|m|
m := self compiledMethodAt:aSelector.
((m code = trapCode) and:[m byteCode == trapByteCode]) ifTrue:[
self recompile:aSelector
]
]
"Modified: 12.6.1996 / 11:52:09 / stefan"
!
recompileMethodsAccessingAny:setOfNames
"recompile all methods accessing a variable from setOfNames"
self recompileMethodsAccessingAny:setOfNames orSuper:false
!
recompileMethodsAccessingAny:setOfNames orSuper:superBoolean
"recompile all methods accessing a variable from setOfNames,
or super (if superBoolean is true)"
|p|
self methodDictionary keys do:[:aSelector |
|m|
m := self compiledMethodAt:aSelector.
p := Parser parseMethod:(m source) in:self.
(p isNil
or:[(p usedVars notNil and:[p usedVars includesAny:setOfNames])
or:[superBoolean and:[p usesSuper]]]) ifTrue:[
self recompile:aSelector
]
]
"Modified: 12.6.1996 / 11:52:35 / stefan"
! !
!Class methodsFor:'enumerating'!
privateClassesDo:aBlock
"evaluate aBlock on all of my private classes (if any)"
|classes|
(classes := self privateClasses) notNil ifTrue:[
classes do:aBlock
].
"Created: 26.10.1996 / 12:28:57 / cg"
! !
!Class methodsFor:'fileIn interface'!
ignoredMethodsFor:aCategory
"this is a speciality of ST/X - it allows quick commenting of methods
from a source-file by replacing the 'methodsFor:' by 'ignoredMethodsFor:'.
Returns a ClassCategoryReader to read in and skip methods."
^ (self methodsFor:aCategory) ignoredProtocol
"Modified: 10.2.1996 / 12:53:25 / cg"
!
methods
"this method allows fileIn of ST/V methods -
return a ClassCategoryReader to read in and compile methods for me.
Since ST/V does not support method categories, the loaded methods are
categorized as 'ST/V methods'."
^ ClassCategoryReader class:self category:'ST/V methods'
"Modified: 10.2.1996 / 12:44:21 / cg"
!
methodsFor:aCategory
"return a ClassCategoryReader to read in and compile methods for me."
^ ClassCategoryReader class:self category:aCategory
"Modified: 10.2.1996 / 12:44:43 / cg"
!
methodsForUndefined:categoryString
"ST-80 compatibility.
I dont yet know what this does - it was encountered by some tester.
For now, simply forward it."
^ self methodsFor:categoryString
!
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"
!
privateMethodsFor:aCategory
"this method allows fileIn of ENVY and ST/X private methods.
The following methods are only allowed to be executed if sent from a method
within the current class. Subclass sends or out-of-class sends will raise
a privatMethodError exception."
^ (self methodsFor:aCategory) privateProtocol
"Modified: 10.2.1996 / 12:48:44 / cg"
!
protectedMethodsFor:aCategory
"this method allows fileIn of ENVY and ST/X protected methods.
The following methods are only allowed to be executed if sent from a method
within the current class or a subclass. Out-of-class sends will raise
a privatMethodError exception."
^ (self methodsFor:aCategory) protectedProtocol
"Modified: 10.2.1996 / 12:49:18 / cg"
!
publicMethodsFor:aCategory
"this method allows fileIn of ENVY methods
The publicMethods keyword is for documentation only; my default, methods
are public anyway (for backward compatibility)."
^ self methodsFor:aCategory
"Modified: 10.2.1996 / 12:50:11 / cg"
! !
!Class methodsFor:'fileOut'!
basicFileOutDefinitionOn:aStream
"append an expression on aStream, which defines myself."
|s owner|
owner := self owningClass.
"take care of nil-superclass"
superclass isNil ifTrue:[
s := 'nil'
] ifFalse:[
s := (superclass name)
].
aStream nextPutAll:s.
aStream space.
self basicFileOutInstvarTypeKeywordOn:aStream.
owner isNil ifTrue:[
aStream nextPutAll:name storeString.
] ifFalse:[
aStream nextPut:$#; nextPutAll:(self nameWithoutPrefix).
].
aStream crtab.
aStream nextPutAll:'instanceVariableNames:'''.
self printInstVarNamesOn:aStream indent:16.
aStream nextPutAll:''''.
aStream crtab.
aStream nextPutAll:'classVariableNames:'''.
self printClassVarNamesOn:aStream indent:16.
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:'.
aStream nextPutAll:owner name.
].
aStream cr
"Modified: 15.10.1996 / 20:01:23 / cg"
!
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])
].
isVar ifTrue:[
self isBytes ifTrue:[
s := 'variableByteSubclass:'
] ifFalse:[
self isWords ifTrue:[
s := 'variableWordSubclass:'
] ifFalse:[
self isLongs ifTrue:[
s := 'variableLongSubclass:'
] ifFalse:[
self isFloats ifTrue:[
s := 'variableFloatSubclass:'
] ifFalse:[
self isDoubles ifTrue:[
s := 'variableDoubleSubclass:'
] ifFalse:[
self isSignedWords ifTrue:[
s := 'variableSignedWordSubclass:'
] ifFalse:[
self isSignedLongs ifTrue:[
s := 'variableSignedLongSubclass:'
] ifFalse:[
s := 'variableSubclass:'
]
]
]
]
]
]
]
] ifFalse:[
s := 'subclass:'
].
aStream nextPutAll:s.
"Created: 11.10.1996 / 18:57:29 / cg"
!
binaryFileOut
"create a file 'class.cls' 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
!
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' 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|
baseName := (Smalltalk fileNameForClass:self name).
fileName := baseName , '.cls'.
aStream := FileStream newFileNamed:fileName.
aStream binary.
self binaryFileOutOn:aStream sourceMode:sourceMode.
aStream close.
!
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."
|aStream baseName dirName fileNameString fileName newFileName needRename
mySourceFileName sameFile s mySourceFileID anySourceRef|
baseName := (Smalltalk fileNameForClass:self name).
fileNameString := baseName , '.st'.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
dirName := Project currentProjectDirectory
] ifFalse:[
dirName := ''
].
fileNameString := dirName , fileNameString.
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 at:#id.
sameFile := (fileName info at:#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 at:#id) == (mySourceFileName asFilename info at:#id)
]
].
]
].
].
sameFile ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileNameString
errorString:('may not overwrite sourcefile:', fileNameString)
].
fileName copyTo:('/tmp/' , baseName , '.sav').
newFileName := dirName , baseName , '.new'.
needRename := true
] ifFalse:[
newFileName := fileNameString.
needRename := false
].
aStream := FileStream newFileNamed:newFileName.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:newFileName
errorString:('cannot create file:', newFileName)
].
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 asFilename copyTo:fileNameString.
newFileName asFilename 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: 19.3.1996 / 19:43:17 / cg"
"Modified: 7.6.1996 / 09:14:43 / stefan"
!
fileOutAllDefinitionsOn:aStream
"append expressions on aStream, which defines myself and all of my private classes."
|privateClasses|
self fileOutDefinitionOn:aStream.
aStream nextPutChunkSeparator.
aStream cr; cr.
"/
"/ optional classInstanceVariables
"/
self class instanceVariableString isBlank ifFalse:[
self fileOutClassInstVarDefinitionOn:aStream.
aStream nextPutChunkSeparator.
aStream cr; cr
].
(privateClasses := self privateClasses) notNil ifTrue:[
privateClasses do:[:aClass |
aClass fileOutAllDefinitionsOn:aStream
]
]
"Created: 15.10.1996 / 11:15:19 / cg"
"Modified: 15.10.1996 / 11:26:30 / cg"
!
fileOutAllMethodsOn:aStream
|collectionOfCategories privateClasses|
collectionOfCategories := self class categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self class fileOutCategory:aCategory on:aStream.
aStream cr
]
].
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self fileOutCategory:aCategory on:aStream.
aStream cr
]
].
(privateClasses := self privateClasses) notNil ifTrue:[
privateClasses do:[:aClass |
aClass fileOutAllMethodsOn:aStream
]
].
"Created: 15.10.1996 / 11:13:00 / cg"
!
fileOutCategory:aCategory
"create a file 'class-category.st' consisting of all methods in aCategory.
If the current project is not nil, create the file in the projects
directory."
|aStream fileName|
fileName := name , '-' , aCategory , '.st'.
fileName replaceAll:(Character space) by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:('cannot create file:', fileName)
].
self fileOutCategory:aCategory on:aStream.
aStream close
!
fileOutCategory:aCategory except:skippedMethods only:savedMethods on:aStream
"file out all methods belonging to aCategory, aString onto aStream.
If skippedMethods is nonNil, those are not saved.
If savedMethods is nonNil, only those are saved.
If both are nil, all are saved. See version-method handling in
fileOut for what this is needed."
|dict source sortedSelectors first privacy interestingMethods|
dict := self methodDictionary.
dict notNil ifTrue:[
interestingMethods := OrderedCollection new.
dict do:[:aMethod |
|wanted|
(aCategory = aMethod category) ifTrue:[
skippedMethods notNil ifTrue:[
wanted := (skippedMethods includesIdentical:aMethod) not
] ifFalse:[
savedMethods notNil ifTrue:[
wanted := (savedMethods includesIdentical:aMethod).
] ifFalse:[
wanted := true
]
].
wanted ifTrue:[interestingMethods add:aMethod].
]
].
interestingMethods notEmpty ifTrue:[
first := true.
privacy := nil.
"/
"/ sort by selector
"/
sortedSelectors := interestingMethods collect:[:m | self selectorAtMethod:m].
sortedSelectors sortWith:interestingMethods.
interestingMethods do:[:aMethod |
first ifFalse:[
privacy ~~ aMethod privacy ifTrue:[
first := true.
aStream space.
aStream nextPutChunkSeparator.
].
aStream cr; cr
].
privacy := aMethod privacy.
first ifTrue:[
aStream nextPutChunkSeparator.
self printClassNameOn:aStream.
privacy ~~ #public ifTrue:[
aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'''.
] ifFalse:[
aStream nextPutAll:' methodsFor:'''.
].
aCategory notNil ifTrue:[
aStream nextPutAll:aCategory
].
aStream nextPut:$'; nextPutChunkSeparator; cr; cr.
first := false.
].
source := aMethod source.
source isNil ifTrue:[
FileOutErrorSignal
raiseRequestWith:self
errorString:'no source for method: ', (aMethod displayString)
] ifFalse:[
aStream nextChunkPut:source.
].
].
aStream space.
aStream nextPutChunkSeparator.
aStream cr
]
]
"Modified: 28.8.1995 / 14:30:41 / claus"
"Modified: 12.6.1996 / 11:37:33 / stefan"
"Modified: 12.7.1996 / 23:36:21 / cg"
!
fileOutCategory:aCategory on:aStream
"file out all methods belonging to aCategory, aString onto aStream"
self fileOutCategory:aCategory except:nil only:nil on:aStream
!
fileOutClassInstVarDefinitionOn:aStream
"append an expression to define my classInstanceVariables on aStream"
aStream nextPutAll:(name , ' class instanceVariableNames:''').
self class printInstVarNamesOn:aStream indent:8.
aStream nextPutAll:''''.
"mhmh - good idea; saw this in SmallDraw sourcecode ..."
aStream cr; cr; nextPut:(Character doubleQuote); cr.
aStream space;
nextPutAll:'The following class instance variables are inherited by this class:';
cr; cr.
self allSuperclassesDo:[:aSuperClass |
aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
aStream nextPutAll:(aSuperClass class instanceVariableString); cr.
].
aStream nextPut:(Character doubleQuote); cr.
"Created: 10.12.1995 / 16:31:25 / cg"
"Modified: 10.12.1995 / 16:31:44 / cg"
!
fileOutCommentOn:aStream
"append an expression on aStream, which defines my comment"
|comment s|
aStream nextPutAll:name; nextPutAll:' comment:'.
(comment := self comment) isNil ifTrue:[
s := ''''''
] ifFalse:[
s := comment storeString
].
aStream nextPutAllAsChunk:s.
aStream nextPutChunkSeparator.
aStream cr
"Modified: 4.3.1996 / 16:49:23 / cg"
!
fileOutDefinitionOn:aStream
"append an expression on aStream, which defines myself."
^ self basicFileOutDefinitionOn:aStream
!
fileOutIn:aFileDirectory
"create a file 'class.st' consisting of all methods in self in
directory aFileDirectory (ignoring any directory setting in
the current porject).
This is not logged in that change file (should it be ?)."
|aStream fileName|
fileName := (Smalltalk fileNameForClass:self name) , '.st'.
aStream := FileStream newFileNamed:fileName in:aFileDirectory.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:('cannot create file:', fileName)
].
self fileOutOn:aStream.
aStream close
!
fileOutMethod:aMethod
"create a file 'class-method.st' consisting of the method, aMethod.
If the current project is not nil, create the file in the projects
directory."
|aStream fileName selector|
selector := self selectorAtMethod:aMethod.
selector notNil ifTrue:[
fileName := name , '-' , selector, '.st'.
fileName replaceAll:$: by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
^ FileOutErrorSignal
raiseRequestWith:fileName
errorString:('cannot create file:', fileName)
].
self fileOutMethod:aMethod on:aStream.
aStream close
]
!
fileOutMethod:aMethod on:aStream
"file out the method, aMethod onto aStream"
|dict cat source privacy|
dict := self methodDictionary.
dict notNil ifTrue:[
aStream nextPutChunkSeparator.
self printClassNameOn:aStream.
(privacy := aMethod privacy) ~~ #public ifTrue:[
aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'''.
] ifFalse:[
aStream nextPutAll:' methodsFor:'''.
].
cat := aMethod category.
cat notNil ifTrue:[
aStream nextPutAll:cat
].
aStream nextPut:$'; nextPutChunkSeparator; cr; cr.
source := aMethod source.
source isNil ifTrue:[
FileOutErrorSignal
raiseRequestWith:self
errorString:('no source for method: ' ,
self name , '>>' ,
(self selectorAtMethod:aMethod))
] ifFalse:[
aStream nextChunkPut:source.
].
aStream space.
aStream nextPutChunkSeparator.
aStream cr
]
"Modified: 27.8.1995 / 01:23:19 / claus"
"Modified: 12.6.1996 / 11:44:41 / 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"
!
fileOutOn:aStream withTimeStamp:stampIt
"file out my definition and all methods onto aStream"
|collectionOfCategories copyrightMethod copyrightText comment versionMethod skippedMethods
meta privateClasses|
self isLoaded ifFalse:[
^ FileOutErrorSignal
raiseRequestWith:self
errorString:'will not fileOut unloaded classes'
].
privateClasses := self privateClasses.
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 ' , 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.
].
"/
"/ then the definition
"/
self fileOutAllDefinitionsOn:aStream.
"/
"/ a comment - if any
"/
(comment := self comment) notNil ifTrue:[
self fileOutCommentOn:aStream.
aStream cr.
"/ aStream nextPutAll:name; nextPutAll:' comment:'.
"/ aStream nextPutAll:(comment storeString).
"/ aStream nextPutChunkSeparator.
"/ aStream cr; 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.
"/
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 on:aStream.
aStream cr.
].
"/
"/ initialization next (if any)
"/
(collectionOfCategories includes:'initialization') ifTrue:[
meta fileOutCategory:'initialization' on:aStream.
aStream cr.
].
"/
"/ instance creation next (if any)
"/
(collectionOfCategories includes:'instance creation') ifTrue:[
meta fileOutCategory:'instance creation' on:aStream.
aStream cr.
].
collectionOfCategories do:[:aCategory |
((aCategory ~= 'documentation')
and:[(aCategory ~= 'initialization')
and:[aCategory ~= 'instance creation']]) ifTrue:[
meta fileOutCategory:aCategory on:aStream.
aStream cr
]
]
].
"/
"/ methods from all categories in myself
"/
collectionOfCategories := self categories asSortedCollection.
collectionOfCategories notNil ifTrue:[
collectionOfCategories do:[:aCategory |
self fileOutCategory:aCategory on:aStream.
aStream cr
]
].
"/
"/ any private classes' methods
"/
privateClasses notNil ifTrue:[
privateClasses do:[:aClass |
aClass fileOutAllMethodsOn:aStream
].
].
"/
"/ finally, the previously skipped version method
"/
versionMethod notNil ifTrue:[
meta fileOutCategory:'documentation' except:nil only:skippedMethods on:aStream.
].
"/
"/ optionally an initialize message
"/
(meta implements:#initialize) ifTrue:[
aStream nextPutAll:(name , ' initialize').
aStream nextPutChunkSeparator.
aStream cr
]
"Created: 15.11.1995 / 12:53:06 / cg"
"Modified: 15.10.1996 / 11:25:59 / cg"
!
fileOutPrimitiveDefinitionsOn:aStream
"append primitive defs (if any) to aStream."
|s|
"
primitive definitions - if any
"
(s := self primitiveDefinitionsString) notNil ifTrue:[
aStream nextPutChunkSeparator;
nextPutAll:name; nextPutAll:' primitiveDefinitions';
nextPutChunkSeparator;
cr.
aStream nextPutAll:s.
aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
].
(s := self primitiveVariablesString) notNil ifTrue:[
aStream nextPutChunkSeparator;
nextPutAll:name; nextPutAll:' primitiveVariables';
nextPutChunkSeparator;
cr.
aStream nextPutAll:s.
aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
].
!
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;
nextPutAll:name; nextPutAll:' primitiveFunctions';
nextPutChunkSeparator;
cr.
aStream nextPutAll:s.
aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
].
! !
!Class methodsFor:'printOut'!
nameWithoutPrefix
"helper for fileOut and others - return my names printString,
without any privacy or nameSpace prefix"
|nm idx|
nm := self name.
idx := nm lastIndexOf:$:.
^ nm copyFrom:idx+1.
"Created: 15.10.1996 / 20:01:39 / cg"
"Modified: 15.10.1996 / 20:02:13 / cg"
!
printClassNameOn:aStream
"helper for fileOut - print my name if I am not a Metaclass;
otherwise my name without -class followed by space-class"
|nm|
self isMeta ifTrue:[
nm := self name.
(nm endsWith:' class') ifTrue:[
nm := nm copyWithoutLast:6.
aStream nextPutAll:nm; nextPutAll:' class'
] ifFalse:[
aStream nextPutAll:nm
].
] ifFalse:[
name printOn:aStream
]
"Modified: 14.10.1996 / 17:36:01 / 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."
aStream spaces:indent; bold; nextPutAll:name; normal; nextPutAll:' ('.
self printInstVarNamesOn:aStream indent:(indent + name size + 2).
aStream nextPutAll:')'.
aStream cr.
(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"
!
printHierarchyAnswerIndentOn:aStream
"print my class hierarchy on aStream - return indent
recursively calls itself to print superclass and use returned indent
for my description - used in the browser"
|indent|
indent := 0.
(superclass notNil) ifTrue:[
indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2
].
aStream spaces:indent.
aStream nextPutAll:name; nextPutAll:' ('.
self printInstVarNamesOn:aStream indent:(indent + name size + 2).
aStream nextPutAll:')'.
aStream cr.
^ indent
!
printHierarchyOn:aStream
"print my class hierarchy on aStream"
self printHierarchyAnswerIndentOn:aStream
!
printInstVarNamesOn:aStream indent:indent
"print the instance variable names indented and breaking at line end"
self printNameArray:(self instVarNames) on:aStream indent:indent
!
printNameArray:anArray on:aStream indent:indent
"print an array of strings separated by spaces; when the stream
defines a lineLength, break when this limit is reached; indent
every line; used to printOut instance variable names"
|thisName nextName arraySize lenMax pos mustBreak line spaces|
arraySize := anArray size.
arraySize ~~ 0 ifTrue:[
pos := indent.
lenMax := aStream lineLength.
thisName := anArray at:1.
line := ''.
1 to:arraySize do:[:index |
line := line , thisName.
pos := pos + thisName size.
(index == arraySize) ifFalse:[
nextName := anArray at:(index + 1).
mustBreak := false.
(lenMax > 0) ifTrue:[
((pos + nextName size) > lenMax) ifTrue:[
mustBreak := true
]
].
mustBreak ifTrue:[
aStream nextPutAll:line withTabs.
aStream cr.
spaces isNil ifTrue:[
spaces := String new:indent
].
line := spaces.
pos := indent
] ifFalse:[
line := line , ' '.
pos := pos + 1
].
thisName := nextName
]
].
aStream nextPutAll:line withTabs
]
"Created: 10.12.1995 / 16:34:23 / cg"
!
printOutCategory:aCategory on:aPrintStream
"print out all methods in aCategory on aPrintStream should be a PrintStream"
|dict any|
dict := self methodDictionary.
dict notNil ifTrue:[
any := false.
dict do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
any := true
]
].
any ifTrue:[
aPrintStream italic.
aPrintStream nextPutAll:aCategory.
aPrintStream normal.
aPrintStream cr; cr.
dict do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
self printOutSource:(aMethod source) on:aPrintStream.
aPrintStream cr; cr
]
].
aPrintStream cr
]
]
"Modified: 12.6.1996 / 11:47:36 / stefan"
!
printOutDefinitionOn:aPrintStream
"print out my definition"
|comment s|
aPrintStream nextPutAll:'class '; bold; nextPutAll:name; normal; cr.
aPrintStream nextPutAll:'superclass '.
superclass isNil ifTrue:[
s := 'Object'
] ifFalse:[
s := superclass name
].
aPrintStream nextPutAll:s.
aPrintStream cr.
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 '; nextPutAll:(category printString).
aPrintStream cr
].
(comment := self comment) notNil ifTrue:[
aPrintStream cr; nextPutAll:'comment:'; cr; italic; nextPutAll:comment; normal; cr
]
"Created: 10.12.1995 / 16:30:47 / cg"
"Modified: 10.12.1995 / 16:32:01 / cg"
!
printOutOn:aPrintStream
"print out all methods on aPrintStream which should be a printStream"
|collectionOfCategories|
self printOutDefinitionOn:aPrintStream.
aPrintStream cr.
collectionOfCategories := self class categories.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'class protocol'.
aPrintStream cr; cr.
collectionOfCategories do:[:aCategory |
self class printOutCategory:aCategory on:aPrintStream
]
].
collectionOfCategories := self categories.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'instance protocol'.
aPrintStream cr; cr.
collectionOfCategories do:[:aCategory |
self printOutCategory:aCategory on:aPrintStream
]
]
!
printOutSource:aString on:aPrintStream
"print out a source-string; the message-specification is printed bold,
comments are printed italic"
|text textIndex textSize line lineIndex lineSize inComment aCharacter|
text := aString asStringCollection.
aPrintStream bold.
aPrintStream nextPutAll:(text at:1).
aPrintStream normal.
aPrintStream cr.
inComment := false.
textSize := text size.
textIndex := 2.
[textIndex <= textSize] whileTrue:[
line := text at:textIndex.
((line occurrencesOf:Character doubleQuote) == 0) ifTrue:[
aPrintStream nextPutAll:line
] ifFalse:[
lineSize := line size.
lineIndex := 1.
[lineIndex <= lineSize] whileTrue:[
aCharacter := line at:lineIndex.
(aCharacter == Character doubleQuote) ifTrue:[
inComment ifTrue:[
aPrintStream normal.
aPrintStream nextPut:aCharacter.
inComment := false
] ifFalse:[
aPrintStream nextPut:aCharacter.
aPrintStream italic.
inComment := true
]
] ifFalse:[
aPrintStream nextPut:aCharacter
].
lineIndex := lineIndex + 1
]
].
aPrintStream cr.
textIndex := textIndex + 1
]
! !
!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.
"Modified: 4.3.1996 / 16:49:08 / cg"
!
addChangeRecordForClassInstvars:aClass to:aStream
"{ Pragma: +optSpace }"
"append a class-instvars-record to aStream"
aClass fileOutClassInstVarDefinitionOn:aStream.
aStream nextPutChunkSeparator.
!
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.
!
addChangeRecordForMethod:aMethod to:aStream
"{ Pragma: +optSpace }"
"append a method-change-record to aStream"
self fileOutMethod:aMethod on:aStream.
!
addChangeRecordForMethodCategory:aMethod category:newCategory to:aStream
"{ Pragma: +optSpace }"
"append a methodCategory-change-record to aStream"
|selector|
selector := aMethod selector.
selector notNil ifTrue:[
aStream nextPutAll:'('.
self printClassNameOn:aStream.
aStream nextPutAll:(' compiledMethodAt:' , selector storeString).
aStream nextPutAll:(') category:' , newCategory storeString).
aStream nextPutChunkSeparator.
]
!
addChangeRecordForMethodPrivacy:aMethod to:aStream
"{ Pragma: +optSpace }"
"append a method-privacy-change-record to aStream"
|selector|
selector := aMethod selector.
selector notNil ifTrue:[
aStream nextPutAll:'('.
self printClassNameOn:aStream.
aStream nextPutAll:(' compiledMethodAt:' , selector storeString).
aStream nextPutAll:(') privacy:' , aMethod privacy storeString).
aStream nextPutChunkSeparator.
]
"Modified: 27.8.1995 / 22:59:56 / claus"
!
addChangeRecordForPrimitiveDefinitions:aClass to:aStream
"{ Pragma: +optSpace }"
"append a primitiveDefinitions-record to aStream"
aStream nextPutAll:aClass name; nextPutAll:' primitiveDefinitions:'''; cr;
nextPutAll:(aClass primitiveDefinitionsString storeString copyFrom:2).
aStream nextPutChunkSeparator.
!
addChangeRecordForPrimitiveFunctions:aClass to:aStream
"{ Pragma: +optSpace }"
"append a primitiveFunctions-record to aStream"
aStream nextPutAll:aClass name; nextPutAll:' primitiveFunctions:'''; cr;
nextPutAll:(aClass primitiveFunctionsString storeString copyFrom:2).
aStream nextPutChunkSeparator.
!
addChangeRecordForPrimitiveVariables:aClass to:aStream
"{ Pragma: +optSpace }"
"append a primitiveVariables-record to aStream"
aStream nextPutAll:aClass name; nextPutAll:' primitiveVariables:'''; cr;
nextPutAll:(aClass primitiveVariablesString storeString copyFrom:2).
aStream nextPutChunkSeparator.
!
addChangeRecordForRemoveSelector:aSelector to:aStream
"{ Pragma: +optSpace }"
"append a method-remove-record to aStream"
self printClassNameOn:aStream.
aStream nextPutAll:(' removeSelector:' , aSelector asSymbol storeString).
aStream nextPutChunkSeparator.
"Modified: 1.7.1996 / 21:27:55 / cg"
!
addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream
"{ Pragma: +optSpace }"
"append a category-rename record to aStream"
self printClassNameOn:aStream.
aStream nextPutAll:(' renameCategory:' , oldCategory storeString).
aStream nextPutAll:(' to:' , newCategory storeString).
aStream nextPutChunkSeparator.
!
addInfoRecord:aMessage to:aStream
"{ Pragma: +optSpace }"
"append an info-record (snapshot, class fileOut etc.) to aStream"
aStream nextPutAll:('''---- ' , aMessage , ' ',
Date today printString , ' ' ,
Time now printString ,
' ----''').
aStream nextPutChunkSeparator.
!
writingChangeDo:aBlock
"{ Pragma: +optSpace }"
"common helper to write a change record.
Opens the changefile and executes aBlock passing the stream
as argument. WriteErrors are cought and will lead to a warning.
The changefile is not kept open, to force the change to go to disk
as soon as possible - thus, in case of a crash, no changes should
be lost due to buffering."
self writingChangeWithTimeStamp:true do:aBlock
"Modified: 18.11.1995 / 15:43:36 / cg"
!
writingChangePerform:aSelector with:anArgument
"{ Pragma: +optSpace }"
self writingChangeWithTimeStamp:true perform:aSelector with:anArgument
"Created: 28.10.1995 / 16:50:48 / cg"
"Modified: 18.11.1995 / 15:44:53 / cg"
!
writingChangeWithTimeStamp:doStampIt do:aBlock
"{ Pragma: +optSpace }"
"common helper to write a change record.
Opens the changefile and executes aBlock passing the stream
as argument. WriteErrors are cought and will lead to a warning.
The changefile is not kept open, to force the change to go to disk
as soon as possible - thus, in case of a crash, no changes should
be lost due to buffering."
ChangeFileAccessLock critical:[
|aStream|
aStream := self changesStream.
aStream notNil ifTrue:[
FileStream writeErrorSignal handle:[:ex |
self warn:('could not update the changes-file\\' , ex errorString) withCRs.
ex return
] do:[
doStampIt ifTrue:[self addChangeTimeStampTo:aStream].
aBlock value:aStream.
aStream cr.
].
aStream close
]
]
"Created: 18.11.1995 / 15:36:02 / cg"
"Modified: 21.3.1996 / 16:32:30 / cg"
!
writingChangeWithTimeStamp:stampIt perform:aSelector with:anArgument
"{ Pragma: +optSpace }"
self writingChangeWithTimeStamp:stampIt do:[:stream |
self perform:aSelector with:anArgument with:stream.
]
"Created: 18.11.1995 / 15:44:28 / cg"
! !
!Class methodsFor:'private helpers'!
addAllCategoriesTo:aCollection
"helper - add categories and all superclasses categories
to the argument, aCollection"
(superclass notNil) ifTrue:[
superclass addAllCategoriesTo:aCollection
].
self addCategoriesTo:aCollection
!
addCategoriesTo:aCollection
"helper - add categories to the argument, aCollection"
self methodDictionary do:[:aMethod |
|cat|
cat := aMethod category.
(aCollection includes:cat) ifFalse:[
aCollection add:cat
]
]
"Modified: 12.6.1996 / 11:46:24 / stefan"
!
askIfUpdatingChanges
UpdateChangeFileQuerySignal isHandled ifFalse:[^ UpdatingChanges].
^ UpdateChangeFileQuerySignal raise
!
getPrimitiveSpecsAt:index
"{ Pragma: +optSpace }"
"return a primitiveSpecification component as string or nil"
|pos stream string|
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
!
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'!
printOutCategoryProtocol:aCategory on:aPrintStream
"{ Pragma: +optSpace }"
|dict any|
dict := self methodDictionary.
dict notNil ifTrue:[
any := false.
dict do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
any := true
]
].
any ifTrue:[
aPrintStream italic.
aPrintStream nextPutAll:aCategory.
aPrintStream normal.
aPrintStream cr; cr.
dict do:[:aMethod |
(aCategory = aMethod category) ifTrue:[
self printOutMethodProtocol:aMethod on:aPrintStream.
aPrintStream cr; cr
]
].
aPrintStream cr
]
]
"Modified: 20.4.1996 / 18:20:26 / cg"
"Modified: 12.6.1996 / 11:48:46 / stefan"
!
printOutMethodProtocol:aMethod on:aPrintStream
"{ Pragma: +optSpace }"
"given the source in aString, print the methods message specification
and any method comments - without source; used to generate documentation
pages"
|text comment|
text := aMethod source asStringCollection.
(text size < 1) ifTrue:[^self].
aPrintStream bold.
aPrintStream nextPutAll:(text at:1).
aPrintStream cr.
(text size >= 2) ifTrue:[
(comment := aMethod comment) notNil ifTrue:[
aPrintStream italic.
aPrintStream spaces:((text at:2) indexOfNonSeparatorStartingAt:1).
aPrintStream nextPutAll:aMethod comment.
aPrintStream cr.
]
].
aPrintStream normal
"
Float printOutProtocolOn:Stdout
"
"Modified: 20.4.1996 / 17:54:50 / cg"
"Created: 20.4.1996 / 18:20:31 / cg"
!
printOutProtocolOn:aPrintStream
"{ Pragma: +optSpace }"
|collectionOfCategories|
self printOutDefinitionOn:aPrintStream.
aPrintStream cr.
collectionOfCategories := self class categories.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'class protocol'.
aPrintStream cr; cr.
collectionOfCategories do:[:aCategory |
self class printOutCategoryProtocol:aCategory on:aPrintStream
]
].
collectionOfCategories := self categories.
collectionOfCategories notNil ifTrue:[
aPrintStream nextPutAll:'instance protocol'.
aPrintStream cr; cr.
collectionOfCategories do:[:aCategory |
self printOutCategoryProtocol:aCategory on:aPrintStream
]
]
"Modified: 20.4.1996 / 17:55:42 / cg"
! !
!Class methodsFor:'queries'!
allCategories
"Return a collection of all method-categories known in class
and all superclasses. This does NOT include the metaclass categories.
The returned collection is not sorted by any order."
|coll|
coll := OrderedCollection new.
self addAllCategoriesTo:coll.
^ coll
"
Point categories
Point allCategories
Point class categories
Point class allCategories
"
"Modified: 21.3.1996 / 16:28:57 / cg"
!
categories
"Return a collection of all method-categories known in the receiver class.
This does NOT include the metaclasses categories or the superclass categories.
The returned collection is not sorted by any order."
|newList cat|
newList := OrderedCollection new.
self methodDictionary do:[:aMethod |
cat := aMethod category.
newList indexOf:cat ifAbsent:[newList add:cat]
].
^ newList
"
Point categories
Point class categories
"
"Modified: 16.4.1996 / 18:06:11 / cg"
"Modified: 12.6.1996 / 11:25:59 / stefan"
!
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
"
!
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'
"
!
whichClassDefinesInstVar:aVariableName
"return the class which defines the instance 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 instVarNames includes:aVariableName) ifTrue:[ ^ cls].
cls := cls superclass
].
^ nil
"
StandardSystemView whichClassDefinesInstVar:'label'
StandardSystemView whichClassDefinesInstVar:'paint'
StandardSystemView whichClassDefinesInstVar:'foo'
"
! !
!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|
(owner := self owningClass) notNil ifTrue:[^ owner binaryRevision].
self isMeta ifTrue:[
^ self soleInstance binaryRevision
].
^ 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: 15.10.1996 / 18:55:28 / 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
'....(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|
(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
]
].
sourceInfo isNil ifTrue:[^ nil].
components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
components size == 0 ifTrue:[
moduleString := 'stx'.
directoryString := libraryString := ''.
^ nil
] ifFalse:[
components size == 1 ifTrue:[
"/ a single name given - the module becomes 'stx',
"/ if the component includes slashes, its the directory
"/ otherwise the library
"/
moduleString := 'stx'.
directoryString := libraryString := components at:1.
(libraryString includes:$/) ifTrue:[
libraryString := libraryString asFilename baseName
]
] ifFalse:[
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 := components at:1.
directoryString := libraryString := components at:2.
(libraryString includes:$/) ifTrue:[
libraryString := libraryString asFilename baseName
]
] ifFalse:[
"/ all components given
moduleString := components at:1.
directoryString := components at:2.
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: 15.10.1996 / 18:56:03 / 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
].
^ revision
"
Object revision
"
"Created: 11.11.1995 / 14:27:20 / cg"
"Modified: 12.12.1995 / 20:30:20 / 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|
vsnString := self revisionString.
vsnString notNil ifTrue:[
info := Class revisionInfoFromString:vsnString.
info notNil ifTrue:[
info at:#binaryRevision put:revision.
]
].
^ info
"
Object revisionString
Object revisionInfo
Image revisionInfo
"
"Created: 11.11.1995 / 14:27:20 / cg"
"Modified: 15.10.1996 / 18:56:44 / cg"
!
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
"
"Created: 29.10.1995 / 19:28:03 / cg"
"Modified: 23.10.1996 / 18:23:56 / cg"
!
setBinaryRevision:aString
"set the revision-ID.
This should normally not be done in the running system, as the source-manager
will need this to validate sourcefiles being correct for a given binary
(and optionally: extracting the required sourcefile from the rcs source)"
revision := aString
"Created: 9.12.1995 / 17:05:17 / cg"
!
setPackageFromRevision
"{ Pragma: +optSpace }"
"set my package from the info found in the revisionString if present.
This is used to set some useful packageInfo after autoloading
(otherwise, autoloaded classes/methods would go into your current
package - which is probably not a good idea)"
|info mgr dir lib mod p|
self owningClass notNil ifTrue:[^ self].
mgr := self sourceCodeManager.
mgr notNil ifTrue:[
info := mgr sourceInfoOfClass:self
].
info notNil ifTrue:[
mod := info at:#module ifAbsent:nil. "/ stx, aeg, <your-organization>
dir := info at:#directory ifAbsent:nil. "/ libbasic, libtool ...
lib := info at:#library ifAbsent:dir.
p := ''.
mod notNil ifTrue:[
mod ~= 'stx' ifTrue:[
p := p , mod
]
].
dir notNil ifTrue:[
p notEmpty ifTrue:[p := p , ':'].
p := p , dir.
].
lib notNil ifTrue:[
lib ~= dir ifTrue:[
p notEmpty ifTrue:[p := p , ':'].
p := p , lib.
]
].
p notEmpty ifTrue:[
"/ p := '(' , p , ')'.
package notNil ifTrue:[
(name , ': changing packageID 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: 15.10.1996 / 19:38:24 / cg"
!
sourceStream
"return an open stream on my sourcefile, nil if that is not available"
|owner source cls|
(owner := self owningClass) notNil ifTrue:[^ owner sourceStream].
self isMeta ifTrue:[
cls := self soleInstance
] ifFalse:[
cls := self
].
classFilename notNil ifTrue:[
source := classFilename
] ifFalse:[
source := (Smalltalk fileNameForClass:cls) , '.st'
].
^ cls sourceStreamFor:source
"Modified: 15.10.1996 / 18:59:40 / cg"
!
sourceStreamFor:source
"return an open stream on a sourcefile, nil if that is not available"
|owner fileName aStream mgr|
(owner := self owningClass) notNil ifTrue:[^ owner sourceStreamFor:source].
"/
"/ if there is no SourceCodeManager,
"/ or TryLocalSourceFirst is true,
"/ look in standard places first
"/
((mgr := self sourceCodeManager) isNil
or:[TryLocalSourceFirst == true]) ifTrue:[
fileName := Smalltalk getSourceFileName:source.
fileName notNil ifTrue:[
aStream := fileName asFilename readStream.
]
].
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) notNil ifTrue:[
(classes includes:self) ifTrue:[
f := h pathName.
f := f asFilename directory.
f := f construct:source.
f exists ifTrue:[
aStream := f readStream.
].
].
].
]
].
].
].
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:[
aStream := mgr getSourceStreamFor:self.
(self validateSourceStream:aStream) ifFalse:[
('CLASS: repositories source for `'
, (self isMeta ifTrue:[self soleInstance name]
ifFalse:[name])
, ''' is invalid') infoPrintCR.
aStream close.
aStream := nil
].
aStream isNil ifTrue:[
fileName := Smalltalk getSourceFileName:source.
fileName notNil ifTrue:[
aStream := fileName asFilename readStream.
]
].
].
"/
"/ final chance: try current directory
"/
aStream isNil ifTrue:[
aStream := source asFilename readStream.
].
].
^ aStream
"
Object sourceStream
Clock sourceStream
Autoload sourceStream
"
"Created: 10.11.1995 / 21:05:13 / cg"
"Modified: 18.10.1996 / 13:28:29 / cg"
!
updateVersionMethodFor:newRevisionString
"{ Pragma: +optSpace }"
"helper for the checkin procedure.
Update my #version method, to now return newRevisionString."
|cls "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 withoutUpdatingChangesDo:[
Compiler compile:'version
^ ''' , newRevisionString , '''
'
forClass:cls inCategory:#documentation notifying:nil
install:true skipIfSame:false silent:true.
].
"/ ('updated to :' , newRevisionString) printNL.
^ true
"Created: 7.12.1995 / 20:42:22 / cg"
"Modified: 15.10.1996 / 18:59:58 / 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 version method'.
]
].
"/
"/ 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 ...
"/
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: ' , cannotCheckReason) infoPrintCR.
'CLASS: cannot validate source; trusting source' infoPrintCR.
^ true
].
oldPos := aStream position.
aStream position:pos.
src := aStream nextChunk.
aStream position:oldPos.
(src isNil or:[src isEmpty]) ifTrue:[
"/ 'empty source for version-method' printCR.
^ false
].
versionFromSource := Class revisionStringFromSource:src.
versionFromSource = versionFromCode ifTrue:[^ true].
versionFromSource isNil ifTrue:[^ false].
"/ mhmh - check my binary version ...
info := Class revisionInfoFromString:versionFromSource.
info notNil ifTrue:[
rev := info at:#revision.
rev = self binaryRevision ifTrue:[^ true].
].
^ false
"Modified: 18.10.1996 / 21:56:21 / cg"
! !
!Class class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.199 1996-10-29 23:37:41 cg Exp $'
! !
Class initialize!