--- a/Class.st Wed Aug 23 16:03:23 2006 +0200
+++ b/Class.st Wed Aug 23 16:03:52 2006 +0200
@@ -1381,395 +1381,6 @@
"Modified: 4.6.1997 / 14:48:02 / cg"
! !
-!Class methodsFor:'binary storage'!
-
-addGlobalsForBinaryStorageTo:globalDictionary
-"
- classPool == nil ifFalse: [
- classPool associationsDo: [:assoc|
- globalDictionary at: assoc put: self
- ]
- ]
-"
-
- "Created: 21.3.1997 / 15:40:45 / cg"
-!
-
-binaryClassDefinitionFrom:stream manager:manager
- "retrieve a class as stored previously with
- #storeBinaryClassOn:manager:
- The namespace, where the class is to be installed is queries via the
- NameSpaceQuerySignal - it should answer with nil, to suppress installation."
-
- |superclassName name flags instvars classvars category classInstVars
- comment package superclassSig rev
- newClass superClass methods cmethods formatID environment
- ownerName owner nPrivate privateClass cls|
-
- "/ the following order must correlate to
- "/ the storing in #storeBinaryClassOn:manager:
-
- "/ retrieve
- "/ formatID
- "/ superclasses name,
- "/ superclasses signature
- "/ name,
- "/ typeSymbol,
- "/ instVarNames
- "/ classVarNames
- "/ category
- "/ classInstVarNames
- "/ comment
- "/ revision
- "/ package
- "/ name of owner, or nil
- "/ classes methodDictionary
- "/ methodDictionary
- "/ number of private classes
- "/ private classes, if any
-
- formatID := manager nextObject.
- formatID isInteger ifFalse:[ "/ backward compatibilty
- formatID := nil.
- superclassName := formatID
- ] ifTrue:[
- superclassName := manager nextObject.
- ].
- superclassSig := manager nextObject.
-
- superclassName notNil ifTrue:[
- superClass := Smalltalk at:superclassName ifAbsent:nil.
-
- superClass isNil ifTrue:[
- BinaryIOManager nonexistingClassSignal
- raiseRequestWith:'non existent superclass (in binaryLoad)'.
- ^ nil
- ].
-
- "/ ('loading superclass: ' , superclassName ) printNL.
- superClass autoload.
- superClass := Smalltalk at:superclassName.
-
- superclassSig ~= superClass signature ifTrue:[
- BinaryIOManager changedInstLayoutSignal
- raiseRequestWith:'incompatible superclass (in binaryLoad)'.
- ^ nil
- ]
- ].
-
- name := manager nextObject.
- flags := manager nextObject.
- instvars := manager nextObject.
- instvars isNil ifTrue:[instvars := ''].
- classvars := manager nextObject.
- classvars isNil ifTrue:[classvars := ''].
- category := manager nextObject.
- classInstVars := manager nextObject.
- classInstVars isNil ifTrue:[classInstVars := ''].
- comment := manager nextObject.
- package := manager nextObject.
- formatID == 1 ifTrue:[
- rev := manager nextObject.
- ownerName := manager nextObject.
- ownerName notNil ifTrue:[
- name := name copyFrom:(ownerName size + 2 + 1).
- owner := Smalltalk at:ownerName.
- ]
- ].
-
-"/ 'got superName:' print. superclassName printNL.
-"/ 'got name:' print. name printNL.
-"/ 'got flags: ' print. flags printNL.
-"/ 'got instvars: ' print. instvars printNL.
-"/ 'got classvars: ' print. classvars printNL.
-"/ 'got category: ' print. category printNL.
-"/ 'got classInstvars: ' print. classInstVars printNL.
-
-"/ ('create class: ' , name ) printNL.
-
- owner notNil ifTrue:[
- environment := owner
- ] ifFalse:[
- environment := Class nameSpaceQuerySignal query.
- ].
-
- cls := superClass.
- superClass isNil ifTrue:[
- cls := Object
- ].
-
- newClass := cls class
- name:name asSymbol
- inEnvironment:environment
- subclassOf:cls
- instanceVariableNames:instvars
- variable:false
- words:false
- pointers:true
- classVariableNames:classvars
- poolDictionaries:''
- category:category
- comment:comment
- changed:false
- classInstanceVariableNames:classInstVars.
-
- newClass isNil ifTrue:[
- ^ nil.
- ].
-
- superClass isNil ifTrue:[
- newClass setSuperclass:nil.
- newClass class setSuperclass:Class.
- ].
-
-"/ Transcript showCR:'loaded ' , name , ' in ' , environment name.
-
- newClass flags:flags.
-
- "/ retrieve class methods
- cmethods := MethodDictionary binaryFullDefinitionFrom:stream manager:manager.
- "/ retrieve inst methods
- methods := MethodDictionary binaryFullDefinitionFrom:stream manager:manager.
-
- formatID == 1 ifTrue:[
- "/ privateClasses
- nPrivate := manager nextObject.
- nPrivate timesRepeat:[
- Class nameSpaceQuerySignal
- answer:newClass
- do:[
- privateClass := manager nextObject
- ]
- ]
- ].
-
- (superClass isNil and:[superclassName notNil]) ifTrue:[^ nil].
- newClass isNil ifTrue:[
- ^ nil
- ].
-
- owner notNil ifTrue:[
- newClass setCategory:nil.
- ] ifFalse:[
- newClass setPackage:package.
- ].
- newClass instAndClassSelectorsAndMethodsDo:[:sel :mthd | mthd setPackage:package].
-
- newClass methodDictionary:methods.
- newClass class methodDictionary:cmethods.
-
- newClass initializeWithAllPrivateClasses.
-
- ^ newClass
-
- "Created: / 8.10.1996 / 17:57:02 / cg"
- "Modified: / 16.2.1999 / 10:09:22 / cg"
- "Modified: / 18.3.1999 / 18:15:58 / stefan"
-!
-
-storeBinaryClassOn:stream manager:manager
- "store a classes complete description (i.e. including methods).
- However, the superclass chain is not stored - at load time, that must
- be either present or autoloadable."
-
- |s sig owner superclass privateClasses nPrivate|
-
- stream nextPut: manager codeForClass.
-
- "/ the following order must correlate to
- "/ the storing in #binaryDefinitionFrom:manager:
-
- "/ store
- "/ format ID
- "/ superclasses name
- "/ superclasses signature
- "/ name
- "/ typeSymbol,
- "/ instVarNames
- "/ classVarNames
- "/ category
- "/ classInstVarNames
- "/ comment
- "/ package
- "/ revision
- "/ name of owner, or nil
- "/ classes methodDictionary
- "/ methodDictionary
- "/ # of privateClass names
- "/ privateClasses, if any
-
- 1 storeBinaryOn:stream manager:manager. "/ formatID
-
- owner := self owningClass.
-
- superclass := self superclass.
- superclass isNil ifTrue:[
- s := nil.
- sig := 0.
- ] ifFalse:[
- s := superclass name.
- sig := superclass signature.
- ].
- s storeBinaryOn:stream manager:manager.
- sig storeBinaryOn:stream manager:manager.
-
- name storeBinaryOn:stream manager:manager.
- flags storeBinaryOn:stream manager:manager.
- (instvars isEmptyOrNil) ifTrue:[
- s := nil
- ] ifFalse:[
- s := self instanceVariableString
- ].
- s storeBinaryOn:stream manager:manager.
-
- (classvars isEmptyOrNil) ifTrue:[
- s := nil
- ] ifFalse:[
- s := self classVariableString
- ].
- s storeBinaryOn:stream manager:manager.
-
- "/ the category
- owner notNil ifTrue:[
- nil storeBinaryOn:stream manager:manager.
- ] ifFalse:[
- category storeBinaryOn:stream manager:manager.
- ].
-
- "/ the classInstVarString
- s := self class instanceVariableString.
- (s notNil and:[s isEmpty]) ifTrue:[
- s := nil
- ].
- s storeBinaryOn:stream manager:manager.
-
- "/ the comment
- s := comment.
- manager sourceMode == #discard ifTrue:[
- s := nil
- ].
- s storeBinaryOn:stream manager:manager.
-
- "/ the revision, package & owner
- owner notNil ifTrue:[
- nil storeBinaryOn:stream manager:manager.
- nil storeBinaryOn:stream manager:manager.
- owner name storeBinaryOn:stream manager:manager.
- ] ifFalse:[
- package storeBinaryOn:stream manager:manager.
- revision storeBinaryOn:stream manager:manager.
- nil storeBinaryOn:stream manager:manager.
- ].
-
- "/
- "/ store class method dictionary and methods
- "/
- self class methodDictionary storeFullBinaryDefinitionOn:stream manager:manager.
- "/ store inst method dictionary and methods
- self methodDictionary storeFullBinaryDefinitionOn:stream manager:manager.
-
- "/
- "/ names of private classes
- "/
- privateClasses := self privateClassesSorted.
- (nPrivate := privateClasses size) storeBinaryOn:stream manager:manager.
- nPrivate > 0 ifTrue:[
- privateClasses do:[:aClass |
- aClass storeBinaryClassOn:stream manager:manager
- ]
- ].
-
- "
- |bos|
-
- bos := BinaryObjectStorage onNew: (Filename named: 'FBrowser.cls') writeStream.
- bos nextPutClasses:(Array with:FileBrowser).
- bos close.
- "
- "
- |bos cls|
-
- bos := BinaryObjectStorage onOld: (Filename named: 'FBrowser.cls') readStream.
- cls := bos next.
- bos close.
- cls open.
- "
-
- "Modified: / 7.6.1996 / 13:39:02 / stefan"
- "Modified: / 16.2.1999 / 07:07:00 / cg"
-!
-
-storeBinaryDefinitionOf: anAssociation on: stream manager: manager
- "not usable at the moment - there are no classpools currently"
-
- | string |
-
- string := self name, ' classPool at: ', anAssociation key storeString.
- stream nextNumber: 2 put: string size.
- stream nextPutBytes:(string size) from:string startingAt:1.
-"/ string do: [:char| stream nextPut: char asciiValue]
-
- "Modified: 19.3.1997 / 18:49:54 / cg"
-!
-
-storeBinaryDefinitionOn: stream manager: manager
- "store the receiver in a binary format on stream.
- This is an internal interface for binary storage mechanism.
- classes only store the name, signature and instvar names.
- They restore by looking for that name in the Smalltalk dictionary.
- However, using the signature, a check for being valid is made at
- restore time.
- This avoids a full recursive store of a class in the normal binary
- storage - however, it also means that a classes semantics cannot
- be stored with the basic storeBinary operation
- (we depend on the class being present at binaryLoad time.
- To store classes, use #storeBinaryClassOn:manager: or BOSS>>nextPutClasses:."
-
- |varnames n sz|
-
- "
- output the signature
- "
- stream nextNumber:4 put:self signature.
-
- "
- output the instance variable name string
- "
- varnames := self allInstVarNames.
- n := varnames size.
- n == 0 ifTrue:[
- sz := 0
- ] ifFalse:[
- sz := varnames inject:0 into:[:sum :nm | sum + nm size].
- sz := sz + n - 1.
- ].
- stream nextNumber:2 put:sz.
- varnames keysAndValuesDo:[:i :nm |
- stream nextPutBytes:(nm size) from:nm startingAt:1.
-"/ nm do:[:c |
-"/ stream nextPut:c codePoint
-"/ ].
- i ~~ n ifTrue:[stream nextPut:(Character space codePoint)]
- ].
-
- "
- output my name
- "
- stream nextNumber:2 put:name size.
- stream nextPutBytes:(name size) from:name startingAt:1.
-"/ name do:[:c|
-"/ stream nextPut:c asciiValue
-"/ ]
-
- "
- |s|
- s := WriteStream on:ByteArray new.
- Rectangle storeBinaryOn:s.
- Object readBinaryFrom:(ReadStream on:s contents)
- "
-
- "Modified: 19.3.1997 / 18:47:10 / cg"
-! !
!Class methodsFor:'changes management'!
@@ -4967,5 +4578,5 @@
!Class class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.496 2006-08-21 12:58:26 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.497 2006-08-23 14:03:52 cg Exp $'
! !