hg/stx-libbasic: comparison Class.st

equal deleted inserted replaced

-:411202bbbfbb
+:41c73cbee305
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
 "
-'From Smalltalk/X, Version:2.10.7 on 28-oct-1995 at 17:08:56'                   !
+'From Smalltalk/X, Version:2.10.8 on 29-oct-1995 at 19:51:30'                   !
 ClassDescription subclass:#Class
 	 instanceVariableNames:'classvars comment subclasses classFilename package revision
-history'
+		history'
 	 classVariableNames:'UpdatingChanges FileOutErrorSignal CatchMethodRedefinitions
-MethodRedefinitionSignal UpdateChangeFileQuerySignal'
+		MethodRedefinitionSignal UpdateChangeFileQuerySignal'
 	 poolDictionaries:''
 	 category:'Kernel-Classes'
 !
-Class comment:'
-COPYRIGHT (c) 1989 by Claus Gittinger
-	      All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Class.st,v 1.63 1995-10-28 16:44:51 cg Exp $
-'!
 !Class class methodsFor:'documentation'!
 version
 "
-$Header: /cvs/stx/stx/libbasic/Class.st,v 1.63 1995-10-28 16:44:51 cg Exp $
+$Header: /cvs/stx/stx/libbasic/Class.st,v 1.64 1995-10-29 19:26:30 cg Exp $
-"
+"!
-!
 documentation
 "
 Class adds more functionality to classes; minimum stuff has already
 been defined in Behavior and ClassDescription; this adds naming, categories etc.
 prev := UpdatingChanges.
 UpdatingChanges := aBoolean.
 ^ prev
 !
-updatingChanges
-"return true if changes are recorded"
-^ UpdatingChanges
-!
 catchMethodRedefinitions:aBoolean
 "turn on/off redefinition catching. Return the prior value of the flag."
 |prev|
 prev := CatchMethodRedefinitions.
 CatchMethodRedefinitions := aBoolean.
 ^ prev
+!
+updatingChanges
+"return true if changes are recorded"
+^ UpdatingChanges
 !
 catchMethodRedefinitions
 "return the redefinition catching flag."
 	   poolDictionaries:s
 	   category:'ST/V classes'
 ! !
 !Class methodsFor:'accessing'!
+allClassVarNames
+"return a collection of all the class variable name-strings
+this includes all superclass-class variables"
+^ self addAllClassVarNamesTo:(OrderedCollection new)
+"
+Float allClassVarNames
+"
+!
 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."
 	cat := categoryStringOrSymbol
 ].
 category := cat asSymbol
 !
-allClassVarNames
+revision
-"return a collection of all the class variable name-strings
+"return the revision-ID of the class.
-this includes all superclass-class variables"
+This is valid for stc-compiled classes only, and corresponds to the
+rcs-id of the source from which this class was compiled.
-^ self addAllClassVarNamesTo:(OrderedCollection new)
+To check if a source corresponds to a compiled binary, compare this
+ID with the one found in the version-methods comment."
-"
-Float allClassVarNames
+^ revision
+"
+Object revision
 "
 !
 classVariableString
 "return a string of the class variables names.
 "
 Object classVariableString
 Float classVariableString
 "
-!
-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
 !
 comment
 "return the comment (aString) of the class"
 "
 Object comment
 "
 !
+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."
 comment ~= aString ifTrue:[
 	oldComment := self comment.
 	comment := aString.
 	self changed:#comment with:oldComment.
+	self updateVersionString.
 	self addChangeRecordForClassComment:self.
 ]
+"Created: 29.10.1995 / 19:41:24 / cg"
 !
 package
 "return the package of the class"
 setPackage:aStringOrSymbol
 "set the package of the class."
 package := aStringOrSymbol
-!
-revision
-"return the revision-ID of the class.
-This is valid for stc-compiled classes only, and corresponds to the
-rcs-id of the source from which this class was compiled.
-To check if a source corresponds to a compiled binary, compare this
-ID with the one found in the version-methods comment."
-^ revision
-"
-Object revision
-"
 !
 revision:aString
 "set the revision-ID.
 This should normally not be done in the running system, as the source-manager
 "set the history of the class."
 history  := aString
 !
+primitiveDefinitionsString
+"return the primitiveDefinition string or nil"
+^ self getPrimitiveSpecsAt:1
+"
+Object primitiveDefinitionsString
+String primitiveDefinitionsString
+"
+!
+primitiveVariablesString
+"return the primitiveVariables string or nil"
+^ self getPrimitiveSpecsAt:2
+!
+primitiveFunctionsString
+"return the primitiveFunctions string or nil"
+^ self getPrimitiveSpecsAt:3
+!
 history:aString
 "set the history of the class."
 history  := aString
 !
 "return the primitiveSpec or nil"
 ^  primitiveSpec
 !
-primitiveDefinitionsString
-"return the primitiveDefinition string or nil"
-^ self getPrimitiveSpecsAt:1
-"
-Object primitiveDefinitionsString
-String primitiveDefinitionsString
-"
-!
-primitiveVariablesString
-"return the primitiveVariables string or nil"
-^ self getPrimitiveSpecsAt:2
-!
-primitiveFunctionsString
-"return the primitiveFunctions string or nil"
-^ self getPrimitiveSpecsAt:3
-!
 primitiveSpec:anArrayOf3ElementsOrNil
 "set the primitiveSpec or nil"
 primitiveSpec := anArrayOf3ElementsOrNil
 !
 primitiveDefinitions:aString
 "set the primitiveDefinition string"
 self setPrimitiveSpecsAt:1 to:aString.
-self addChangeRecordForPrimitiveDefinitions:self
+self addChangeRecordForPrimitiveDefinitions:self.
+self updateVersionString.
+"Created: 29.10.1995 / 19:41:39 / cg"
 !
 primitiveVariables:aString
 "set the primitiveVariable string"
 self setPrimitiveSpecsAt:2 to:aString.
-self addChangeRecordForPrimitiveVariables:self
+self addChangeRecordForPrimitiveVariables:self.
+self updateVersionString.
+"Created: 29.10.1995 / 19:41:58 / cg"
 !
 primitiveFunctions:aString
 "set the primitiveFunction string"
 self setPrimitiveSpecsAt:3 to:aString.
-self addChangeRecordForPrimitiveFunctions:self
+self addChangeRecordForPrimitiveFunctions:self.
+self updateVersionString.
+"Created: 29.10.1995 / 19:41:48 / cg"
 !
 classFilename
 "return the name of the file from which the class was compiled.
 This is currently NOT used."
 aStream close.
 OperatingSystem removeFile:'__temp'.
 ^ code
 !
-sharedPools
-"ST/X does not (currently) support pools"
-^ #()
-!
 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 updateVersionString.
 	self changed:#definition.
 ]
+"Created: 29.10.1995 / 19:40:51 / cg"
+!
+sharedPools
+"ST/X does not (currently) support pools"
+^ #()
 !
 setClassVariableString:aString
 "set the classes classvarnames string.
 This is a dangerous (low level) operation, since the
 (names includes:aString) ifTrue:[
 	newNames := ''.
 	names do:[:nm | nm ~= aString ifTrue:[newNames := newNames , nm , ' ']].
 	self classVariableString:newNames withoutSpaces.
 	self addChangeRecordForClass:self.
+	self updateVersionString.
 	self changed:#definition.
 ]
+"Created: 29.10.1995 / 19:42:08 / cg"
 !
 renameCategory:oldCategory to:newCategory
 "rename a category (changes category of those methods).
 Appends a change record and notifies dependents."
 	    any := true.
 	]
 ].
 any ifTrue:[
 	self addChangeRecordForRenameCategory:oldCategory to:newCategory.
+	self updateVersionString.
 	self changed:#methodCategory.
 ]
+"Created: 29.10.1995 / 19:42:15 / cg"
 ! !
 !Class methodsFor:'adding/removing'!
 addSelector:newSelector withMethod:newMethod
 		    raiseErrorString:(' ' , name , '>>' , newSelector)
 	    ]
 	]
 ].
 (super addSelector:newSelector withMethod:newMethod) ifTrue:[
-	self addChangeRecordForMethod:newMethod
+	self updateVersionString.
-]
+	self addChangeRecordForMethod:newMethod.
+]
+"Created: 29.10.1995 / 19:42:42 / cg"
 !
 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 updateVersionString.
 	self changed:#methodDictionary with:aSelector.
 ]
+"Created: 29.10.1995 / 19:42:47 / cg"
 !
 unload
 "if the receiver was autoloaded, unload and reinstall it as
 autoloaded. Can be used to get rid of no longer needed autoloaded
 "
 ! !
 !Class methodsFor:'changes management'!
-withoutUpdatingChangesDo:aBlock
+addChangeRecordForMethod:aMethod to:aStream
-"turn off change file update while evaluating aBlock.
+"append a method-change-record to aStream"
-This method makes sure, that the update-flag is correctly restored
-in case of an abort or other error."
+self fileOutMethod:aMethod on:aStream.
-UpdateChangeFileQuerySignal handle:[:ex |
-	ex proceedWith:false
-] do:[
-	aBlock value
-].
 !
 changesStream
 "return a Stream for the writing changes file - or nil if no update is wanted"
 |aStream fileName|
 (UpdateChangeFileQuerySignal raise) ifTrue:[
-fileName := ObjectMemory nameForChanges.
+	fileName := ObjectMemory nameForChanges.
-aStream := FileStream oldFileNamed:fileName.
+	aStream := FileStream oldFileNamed:fileName.
-aStream isNil ifTrue:[
+	aStream isNil ifTrue:[
-aStream := FileStream newFileNamed:fileName.
+	    aStream := FileStream newFileNamed:fileName.
-aStream isNil ifTrue:[
+	    aStream isNil ifTrue:[
-self warn:'cannot create/update the changes file'.
+		self warn:'cannot create/update the changes file'.
-^ nil
+		^ nil
-]
+	    ]
-].
+	].
-aStream setToEnd
+	aStream setToEnd
 ].
 ^ aStream
 "Created: 28.10.1995 / 16:53:43 / cg"
 "Modified: 28.10.1995 / 16:55:03 / cg"
-!
-writingChangePerform:aSelector with:anArgument
-|aStream|
-self writingChangeDo:[:stream |
-self perform:aSelector with:anArgument with:stream.
-]
-"Created: 28.10.1995 / 16:50:48 / cg"
-!
-addChangeRecordForMethod:aMethod to:aStream
-"append a method-change-record to aStream"
-self fileOutMethod:aMethod on:aStream.
 !
 writingChangeDo:aBlock
 "common helper to write a change record.
 Opens the changefile and executes aBlock passing the stream
 	].
 	aStream close
 ]
 !
+writingChangePerform:aSelector with:anArgument
+|aStream|
+self writingChangeDo:[:stream |
+	self perform:aSelector with:anArgument with:stream.
+]
+"Created: 28.10.1995 / 16:50:48 / 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
+].
+!
+addChangeRecordForMethod:aMethod
+"add a method-change-record to the changes file"
+(UpdateChangeFileQuerySignal raise) "UpdatingChanges" ifTrue:[
+	self writingChangePerform:#addChangeRecordForMethod:to: with:aMethod.
+	"this test allows a smalltalk without Projects/ChangeSets"
+	Project notNil ifTrue:[
+	    Project addMethodChange:aMethod in:self
+	]
+]
+!
 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 := FileStream newFileNamed:fileName.
-aStream isNil ifTrue:[
+	aStream isNil ifTrue:[
-Transcript showCr:'cannot update sources file'.
+	    Transcript showCr:'cannot update sources file'.
-^ nil
+	    ^ nil
-]
+	]
 ].
 aStream setToEnd.
 ^ aStream
 "Created: 28.10.1995 / 16:53:17 / cg"
 aStream nextPutAll:(' renameCategory:' , oldCategory storeString).
 aStream nextPutAll:(' to:' , newCategory storeString).
 aStream nextPutChunkSeparator.
 !
-addChangeRecordForMethod:aMethod
-"add a method-change-record to the changes file"
-(UpdateChangeFileQuerySignal raise) "UpdatingChanges" ifTrue:[
-	self writingChangePerform:#addChangeRecordForMethod:to: with:aMethod.
-	"this test allows a smalltalk without Projects/ChangeSets"
-	Project notNil ifTrue:[
-	    Project addMethodChange:aMethod in:self
-	]
-]
-!
-addChangeRecordForChangeCategory:category to:aStream
-"append a category change record to aStream"
-self printClassNameOn:aStream.
-aStream nextPutAll:(' category:' , category storeString).
-aStream nextPutChunkSeparator.
-!
 addInfoRecord:aMessage to:aStream
 "append an info-record (snapshot, class fileOut etc.) to aStream"
 aStream nextPutAll:('''---- ' , aMessage , ' ',
 			Date today printString , ' ' ,
 			Time now printString ,
 			' ----''').
 aStream nextPutChunkSeparator.
 !
+addChangeRecordForChangeCategory:category to:aStream
+"append a category change record to aStream"
+self printClassNameOn:aStream.
+aStream nextPutAll:(' category:' , category storeString).
+aStream nextPutChunkSeparator.
+!
+addChangeRecordForClass:aClass
+"add a class-definition-record to the changes file"
+self writingChangePerform:#addChangeRecordForClass:to: with:aClass.
+!
 addChangeRecordForSnapshot:aFileName to:aStream
 "add a snapshot-record to aStream"
 self addInfoRecord:('snapshot ' , aFileName) to:aStream
-!
-addChangeRecordForClass:aClass
-"add a class-definition-record to the changes file"
-self writingChangePerform:#addChangeRecordForClass:to: with:aClass.
 !
 addChangeRecordForRemoveSelector:aSelector
 "add a method-remove-record to the changes file"
 "add a class-remove-record to the changes file"
 self writingChangePerform:#addChangeRecordForClassRemove:to: with:oldName.
 !
+addInfoRecord:aMessage
+"add an info-record (snapshot, class fileOut etc.) to the changes file"
+self writingChangePerform:#addInfoRecord:to: with:aMessage.
+!
 addChangeRecordForRenameCategory:oldCategory to:newCategory
 "add a category-rename record to the changes file"
 self writingChangeDo:[:aStream |
 	self addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream.
 ]
 !
+addChangeRecordForClassFileOut:aClass
+"append a class-was-filedOut-record to the changes file"
+self addInfoRecord:('fileOut ' , aClass name)
+!
 addChangeRecordForChangeCategory
 "add a category change record to the changes file"
 self writingChangePerform:#addChangeRecordForChangeCategory:to: with:category.
 !
-addInfoRecord:aMessage
-"add an info-record (snapshot, class fileOut etc.) to the changes file"
-self writingChangePerform:#addInfoRecord:to: with:aMessage.
-!
 addChangeRecordForSnapshot:aFileName
 "add a snapshot-record to the changes file"
 self addInfoRecord:('snapshot ' , aFileName)
-!
-addChangeRecordForClassFileOut:aClass
-"append a class-was-filedOut-record to the changes file"
-self addInfoRecord:('fileOut ' , aClass name)
 ! !
 !Class methodsFor:'compiling'!
 compile:code
 ] ifFalse:[
 	s := category asString storeString
 ].
 aStream nextPutAll:s.
 aStream cr
-!
-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 nextPutAll:s.
-aStream cr
-!
-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
-].
 !
 fileOutMethod:aMethod on:aStream
 "file out the method, aMethod onto aStream"
 ]
 "Modified: 28.8.1995 / 14:30:41 / claus"
 !
-fileOutClassInstVarDefinitionOn:aStream
+fileOutPrimitiveDefinitionsOn:aStream
-"append an expression to define my classInstanceVariables on aStream"
+"append primitive defs (if any) to aStream."
-aStream nextPutAll:(name , ' class instanceVariableNames:''').
+|s|
-self class printInstVarNamesOn:aStream indent:8.
-aStream nextPutAll:''''.
+"
+primitive definitions - if any
-"mhmh - good idea; saw this in SmallDraw sourcecode ..."
+"
+(s := self primitiveDefinitionsString) notNil ifTrue:[
-aStream cr; cr; nextPut:(Character doubleQuote); cr.
+	aStream nextPutChunkSeparator;
-aStream space;
+		nextPutAll:name; nextPutAll:' primitiveDefinitions';
-	    nextPutAll:'The following class instance variables are inherited by this class:';
+		nextPutChunkSeparator;
-	    cr; cr.
+		cr.
-self allSuperclassesDo:[:aSuperClass |
+	aStream nextPutAll:s.
-	aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
+	aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
-	aStream nextPutAll:(aSuperClass class instanceVariableString); cr.
+].
-].
+(s := self primitiveVariablesString) notNil ifTrue:[
-aStream nextPut:(Character doubleQuote); cr.
+	aStream nextPutChunkSeparator;
+		nextPutAll:name; nextPutAll:' primitiveVariables';
+		nextPutChunkSeparator;
+		cr.
+	aStream nextPutAll:s.
+	aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
+].
+!
+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 nextPutAll:s.
+aStream 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
+].
 !
 fileOutOn:aStream
 "file out my definition and all methods onto aStream"
 	aStream nextPutChunkSeparator.
 	aStream cr
 ]
 !
-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
-!
 fileOut
 "create a file 'class.st' consisting of all methods in myself.
 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).
 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
+!
+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.
+!
+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
 !
 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
 ]
 ! !
 !Class methodsFor:'private'!
+updateVersionString
+"update my version string, to reflect a change w.r.t.
+the original source.
+The original version string is kept as a reference i.e.
+Header: /files/CVS/stx/libbasic/Class.st,v 1.63 1995/10/28 16:44:51 cg Exp $
+is changed into:
+Header: /files/CVS/stx/libbasic/Class.st,v 1.63mod 1995/10/28 16:44:51 cg Exp $
+"
+|cls vs m idx leftPart rightPart vsnString|
+cls := self.
+self isMeta ifFalse:[
+	cls := self class
+].
+m := cls compiledMethodAt:#version.
+m isNil ifTrue:[^ self].
+vs := self versionString.
+vs isNil ifTrue:[^ self].
+"/ search for ,v
+idx := vs indexOfSubCollection:'.st,v'.
+idx == 0 ifTrue:[^ self].
+leftPart := vs copyTo:(idx - 1 + 5).
+rightPart := (vs copyFrom:(idx + 5)) withoutSpaces.
+idx := rightPart indexOfSeparator.
+idx == 0 ifTrue:[^ self].
+vsnString := rightPart copyTo:idx - 1.
+rightPart := rightPart copyFrom:idx + 1.
+vsnString ~= self revision ifTrue:[
+	"/ alread a modified class
+"/        ('already modified: ' , vsnString) printNL.
+	^ self
+].
+m source:'version
+"
+' , leftPart , ' ' , vsnString , 'mod' , ' ' , rightPart , '
+"'.
+"/ ('updated to :' , vsnString , 'mod') printNL.
+"
+Class updateVersionString
+Number updateVersionString
+ProcessMonitor updateVersionString
+"
+"Created: 29.10.1995 / 19:25:15 / cg"
+"Modified: 29.10.1995 / 19:39:38 / cg"
+!
+versionString
+"return my version string; that one is extracted from the
+classes #version methods source code.
+If the source is not accessable or no such method exists,
+nil is returned."
+|cls m src lines idx|
+cls := self.
+self isMeta ifFalse:[
+	cls := self class
+].
+m := cls compiledMethodAt:#version.
+m isNil ifTrue:[^ nil].
+src := m source.
+src isNil ifTrue:[^ nil].
+lines := src asCollectionOfLines.
+idx := lines findFirst:[:l |
+	l withoutSpaces startsWith:'$Header'
+].
+idx == 0 ifTrue:[^ nil].
+^ lines at:idx.
+"
+Smalltalk allClassesDo:[:cls |
+	Transcript showCr:cls versionString
+].
+Number versionString
+"
+"Created: 29.10.1995 / 19:28:03 / cg"
+!
 addAllClassVarNamesTo:aCollection
 "helper - add the name-strings of the class variables and of the class-vars
 of all superclasses to the argument, aCollection. Return aCollection"
 (superclass notNil) ifTrue:[
 ].
 classvars notNil ifTrue:[
 	aCollection addAll:(classvars asCollectionOfWords).
 ].
 ^ aCollection
-!
-addCategoriesTo:aCollection
-"helper - add categories to the argument, aCollection"
-methodArray do:[:aMethod |
-	|cat|
-	cat := aMethod category.
-	(aCollection includes:cat) ifFalse:[
-	    aCollection add:cat
-	]
-]
 !
 getPrimitiveSpecsAt:index
 "return a primitiveSpecification component as string or nil"
 	^ nil
 ].
 ^ pos
 !
+addCategoriesTo:aCollection
+"helper - add categories to the argument, aCollection"
+methodArray do:[:aMethod |
+	|cat|
+	cat := aMethod category.
+	(aCollection includes:cat) ifFalse:[
+	    aCollection add:cat
+	]
+]
+!
 addAllCategoriesTo:aCollection
 "helper - add categories and all superclasses categories
 to the argument, aCollection"
 (superclass notNil) ifTrue:[
 ].
 primitiveSpec at:index put:aString
 ! !
 !Class methodsFor:'queries'!
-categories
-"Return a Collection of all method-category strings known in class.
-The returned collection is not sorted by any order."
-|newList cat|
-newList := OrderedCollection new.
-methodArray do:[:aMethod |
-	cat := aMethod category.
-	newList indexOf:cat ifAbsent:[newList add:cat]
-].
-^ newList
-"
-Point categories
-"
-!
 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.
 Class new isBehavior
 Class new isClass
 "
 !
-allCategories
+categories
-"Return a Collection of all method-category strings known in class
+"Return a Collection of all method-category strings known in class.
-and all superclasses. The returned collection is not sorted by any order."
+The returned collection is not sorted by any order."
-|coll|
+|newList cat|
-coll := OrderedCollection new.
+newList := OrderedCollection new.
-self addAllCategoriesTo:coll.
+methodArray do:[:aMethod |
-^ coll
+	cat := aMethod category.
+	newList indexOf:cat ifAbsent:[newList add:cat]
+].
+^ newList
 "
 Point categories
-Point allCategories
 "
 !
 whichClassDefinesClassVar:aVariableName
 "return the class which defines the class variable
 autoload; false otherwise.
 This is not an attribute of the class, but instead remembered in
 Autoload. The interface here is for covenience."
 ^ Autoload wasAutoloaded:self
+!
+allCategories
+"Return a Collection of all method-category strings known in class
+and all superclasses. The returned collection is not sorted by any order."
+|coll|
+coll := OrderedCollection new.
+self addAllCategoriesTo:coll.
+^ coll
+"
+Point categories
+Point allCategories
+"
 !
 whichClassDefinesInstVar:aVariableName
 "return the class which defines the instance variable
 named aVariableName. This method should not be used for

changeset 457	41c73cbee305
parent 453	57381f377c3f
child 484	12f066c0ac29