From 05394790f02f670031e5bb24796a13cc012f6f3e Mon Sep 17 00:00:00 2001 From: Gwenael Casaccio Date: Tue, 2 Aug 2011 17:26:09 +0200 Subject: [PATCH] migrate ObjectDumper and fix a bug when load from versionned proxies --- configure.ac | 1 + kernel/Makefile.frag | 2 +- kernel/ObjDumper.st | 1115 ---------------------------- libgst/files.c | 1 - packages.xml | 1 - packages/object-dumper/Init.st | 9 + packages/object-dumper/Makefile.frag | 5 + packages/object-dumper/ObjDumper.st | 834 +++++++++++++++++++++ packages/object-dumper/ObjectDumperTest.st | 83 ++ packages/object-dumper/Proxy.st | 313 ++++++++ packages/object-dumper/package.xml | 12 + packages/sandstonedb/Makefile.frag | 2 +- packages/sandstonedb/package.xml | 3 + packages/sockets/package.xml | 2 + snprintfv/snprintfv/filament.h | 4 +- snprintfv/snprintfv/printf.h | 8 +- snprintfv/snprintfv/stream.h | 4 +- tests/Makefile.am | 2 +- tests/objdump.ok | 25 - tests/objdump.st | 91 --- tests/testsuite.at | 2 +- 21 files changed, 1274 insertions(+), 1245 deletions(-) delete mode 100644 kernel/ObjDumper.st create mode 100644 packages/object-dumper/Init.st create mode 100644 packages/object-dumper/Makefile.frag create mode 100644 packages/object-dumper/ObjDumper.st create mode 100644 packages/object-dumper/ObjectDumperTest.st create mode 100644 packages/object-dumper/Proxy.st create mode 100644 packages/object-dumper/package.xml create mode 100644 packages/object-dumper/stamp-classes delete mode 100644 tests/objdump.ok delete mode 100644 tests/objdump.st diff --git a/configure.ac b/configure.ac index b70af7f..e45cda3 100644 --- a/configure.ac +++ b/configure.ac @@ -404,6 +404,7 @@ GST_PACKAGE_ENABLE([Complex], [complex]) GST_PACKAGE_ENABLE([Continuations], [continuations]) GST_PACKAGE_ENABLE([CParser], [cpp]) GST_PACKAGE_ENABLE([DebugTools], [debug]) +GST_PACKAGE_ENABLE([ObjectDumper], [object-dumper]) GST_PACKAGE_ENABLE([DBD-MySQL], [dbd-mysql]) AC_MSG_CHECKING([whether to run MySQL tests]) diff --git a/kernel/Makefile.frag b/kernel/Makefile.frag index c94ea1a..03e848d 100644 --- a/kernel/Makefile.frag +++ b/kernel/Makefile.frag @@ -1,3 +1,3 @@ $(srcdir)/kernel/stamp-classes: \ -kernel/Array.st kernel/CompildMeth.st kernel/LookupTable.st kernel/RunArray.st kernel/Iterable.st kernel/ArrayColl.st kernel/CompiledBlk.st kernel/Magnitude.st kernel/Semaphore.st kernel/DeferBinding.st kernel/Association.st kernel/HomedAssoc.st kernel/ContextPart.st kernel/MappedColl.st kernel/SeqCollect.st kernel/Autoload.st kernel/DLD.st kernel/Memory.st kernel/Set.st kernel/Bag.st kernel/Date.st kernel/Message.st kernel/SharedQueue.st kernel/Behavior.st kernel/Delay.st kernel/Metaclass.st kernel/SmallInt.st kernel/BlkClosure.st kernel/Continuation.st kernel/Generator.st kernel/Dictionary.st kernel/MethodDict.st kernel/SortCollect.st kernel/BlkContext.st kernel/DirMessage.st kernel/MethodInfo.st kernel/Stream.st kernel/Boolean.st kernel/Directory.st kernel/MthContext.st kernel/String.st kernel/UniString.st kernel/ExcHandling.st kernel/Namespace.st kernel/SymLink.st kernel/VFS.st kernel/VFSZip.st kernel/Builtins.st kernel/False.st kernel/Number.st kernel/Symbol.st kernel/ByteArray.st kernel/FilePath.st kernel/File.st kernel/ObjDumper.st kernel/SysDict.st kernel/ScaledDec.st kernel/FileSegment.st kernel/Object.st kernel/Time.st kernel/FileStream.st kernel/Security.st kernel/OrderColl.st kernel/CCallable.st kernel/CCallback.st kernel/CFuncs.st kernel/Float.st kernel/PkgLoader.st kernel/Transcript.st kernel/CObject.st kernel/Fraction.st kernel/Point.st kernel/True.st kernel/CStruct.st kernel/IdentDict.st kernel/PosStream.st kernel/UndefObject.st kernel/CType.st kernel/IdentitySet.st kernel/ProcSched.st kernel/ProcEnv.st kernel/ValueAdapt.st kernel/CharArray.st kernel/Integer.st kernel/Process.st kernel/CallinProcess.st kernel/WeakObjects.st kernel/Character.st kernel/UniChar.st kernel/Interval.st kernel/RWStream.st kernel/OtherArrays.st kernel/Class.st kernel/LargeInt.st kernel/Random.st kernel/WriteStream.st kernel/ClassDesc.st kernel/Link.st kernel/ReadStream.st kernel/ObjMemory.st kernel/Collection.st kernel/LinkedList.st kernel/Rectangle.st kernel/AnsiDates.st kernel/CompildCode.st kernel/LookupKey.st kernel/BindingDict.st kernel/AbstNamespc.st kernel/RootNamespc.st kernel/SysExcept.st kernel/DynVariable.st kernel/HashedColl.st kernel/FileDescr.st kernel/FloatD.st kernel/FloatE.st kernel/FloatQ.st kernel/URL.st kernel/VarBinding.st kernel/RecursionLock.st kernel/Getopt.st kernel/Regex.st kernel/StreamOps.st +kernel/Array.st kernel/CompildMeth.st kernel/LookupTable.st kernel/RunArray.st kernel/Iterable.st kernel/ArrayColl.st kernel/CompiledBlk.st kernel/Magnitude.st kernel/Semaphore.st kernel/DeferBinding.st kernel/Association.st kernel/HomedAssoc.st kernel/ContextPart.st kernel/MappedColl.st kernel/SeqCollect.st kernel/Autoload.st kernel/DLD.st kernel/Memory.st kernel/Set.st kernel/Bag.st kernel/Date.st kernel/Message.st kernel/SharedQueue.st kernel/Behavior.st kernel/Delay.st kernel/Metaclass.st kernel/SmallInt.st kernel/BlkClosure.st kernel/Continuation.st kernel/Generator.st kernel/Dictionary.st kernel/MethodDict.st kernel/SortCollect.st kernel/BlkContext.st kernel/DirMessage.st kernel/MethodInfo.st kernel/Stream.st kernel/Boolean.st kernel/Directory.st kernel/MthContext.st kernel/String.st kernel/UniString.st kernel/ExcHandling.st kernel/Namespace.st kernel/SymLink.st kernel/VFS.st kernel/VFSZip.st kernel/Builtins.st kernel/False.st kernel/Number.st kernel/Symbol.st kernel/ByteArray.st kernel/FilePath.st kernel/File.st kernel/SysDict.st kernel/ScaledDec.st kernel/FileSegment.st kernel/Object.st kernel/Time.st kernel/FileStream.st kernel/Security.st kernel/OrderColl.st kernel/CCallable.st kernel/CCallback.st kernel/CFuncs.st kernel/Float.st kernel/PkgLoader.st kernel/Transcript.st kernel/CObject.st kernel/Fraction.st kernel/Point.st kernel/True.st kernel/CStruct.st kernel/IdentDict.st kernel/PosStream.st kernel/UndefObject.st kernel/CType.st kernel/IdentitySet.st kernel/ProcSched.st kernel/ProcEnv.st kernel/ValueAdapt.st kernel/CharArray.st kernel/Integer.st kernel/Process.st kernel/CallinProcess.st kernel/WeakObjects.st kernel/Character.st kernel/UniChar.st kernel/Interval.st kernel/RWStream.st kernel/OtherArrays.st kernel/Class.st kernel/LargeInt.st kernel/Random.st kernel/WriteStream.st kernel/ClassDesc.st kernel/Link.st kernel/ReadStream.st kernel/ObjMemory.st kernel/Collection.st kernel/LinkedList.st kernel/Rectangle.st kernel/AnsiDates.st kernel/CompildCode.st kernel/LookupKey.st kernel/BindingDict.st kernel/AbstNamespc.st kernel/RootNamespc.st kernel/SysExcept.st kernel/DynVariable.st kernel/HashedColl.st kernel/FileDescr.st kernel/FloatD.st kernel/FloatE.st kernel/FloatQ.st kernel/URL.st kernel/VarBinding.st kernel/RecursionLock.st kernel/Getopt.st kernel/Regex.st kernel/StreamOps.st touch $(srcdir)/kernel/stamp-classes diff --git a/kernel/ObjDumper.st b/kernel/ObjDumper.st deleted file mode 100644 index 5901baf..0000000 --- a/kernel/ObjDumper.st +++ /dev/null @@ -1,1115 +0,0 @@ -"====================================================================== -| -| ObjectDumper Method Definitions -| -| - ======================================================================" - -"====================================================================== -| -| Copyright 1999, 2000, 2001, 2002, 2003, 2006, 2008, 2009 -| Free Software Foundation, Inc. -| Written by Paolo Bonzini. -| -| This file is part of the GNU Smalltalk class library. -| -| The GNU Smalltalk class library is free software; you can redistribute it -| and/or modify it under the terms of the GNU Lesser General Public License -| as published by the Free Software Foundation; either version 2.1, or (at -| your option) any later version. -| -| The GNU Smalltalk class library is distributed in the hope that it will be -| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser -| General Public License for more details. -| -| You should have received a copy of the GNU Lesser General Public License -| along with the GNU Smalltalk class library; see the file COPYING.LIB. -| If not, write to the Free Software Foundation, 59 Temple Place - Suite -| 330, Boston, MA 02110-1301, USA. -| - ======================================================================" - - - -Stream subclass: ObjectDumper [ - | toObjects fromObjects stream | - - - - - SpecialCaseDump := nil. - SpecialCaseLoad := nil. - Proxies := nil. - - ObjectDumper class >> example [ - "This is a real torture test: it outputs recursive objects, - identical objects multiple times, classes, metaclasses, - integers, characters and proxies (which is also a test of more - complex objects)!" - - - | file test dumper method | - Transcript - nextPutAll: 'Must print true without errors.'; - nl. - file := FileStream open: 'dumptest' mode: FileStream write. - test := Array new: 1. - test at: 1 put: test. - method := thisContext method. - (ObjectDumper on: file) - dump: 'asdf'; - dump: #('asdf' 1 2 $a); - dump: Array; - dump: 'asdf'; - dump: Array class; - dump: test; - dump: Processor; - dump: Processor; - dump: method; - dump: method. "String" "Array" "Class" "String (must be identical to the first)" "Metaclass" "Circular reference" "SingletonProxy" "SingletonProxy" "PluggableProxy" "PluggableProxy" - file close. - file := FileStream open: 'dumptest' mode: FileStream read. - dumper := ObjectDumper on: file. - ((test := dumper load) = 'asdf') printNl. - (dumper load = #('asdf' 1 2 $a)) printNl. - (dumper load == Array) printNl. - (dumper load == test) printNl. - (dumper load == Array class) printNl. - test := dumper load. - (test == (test at: 1)) printNl. - (dumper load == Processor) printNl. - (dumper load == Processor) printNl. - (dumper load == method) printNl. - (dumper load == method) printNl. - file close - ] - - ObjectDumper class >> hasProxyFor: aClass [ - "Answer whether a proxy class has been registered for instances - of aClass." - - - Proxies keysDo: - [:any | - (aClass inheritsFrom: any) ifTrue: [^true]. - aClass == any ifTrue: [^true]]. - ^false - ] - - ObjectDumper class >> disableProxyFor: aClass [ - "Disable proxies for instances of aClass and its descendants" - - - self registerProxyClass: NullProxy for: aClass - ] - - ObjectDumper class >> registerProxyClass: aProxyClass for: aClass [ - "Register the proxy class aProxyClass - descendent of DumperProxy - - to be used for instances of aClass and its descendants" - - - (aProxyClass acceptUsageForClass: aClass) - ifFalse: [self error: 'registration request denied']. - Proxies at: aClass put: aProxyClass - ] - - ObjectDumper class >> proxyFor: anObject [ - "Answer a valid proxy for an object, or the object itself if none could - be found" - - - Proxies - keysAndValuesDo: [:key :value | (anObject isKindOf: key) ifTrue: [^value on: anObject]]. - ^anObject - ] - - ObjectDumper class >> proxyClassFor: anObject [ - "Answer the class of a valid proxy for an object, or nil if none could - be found" - - - Proxies - keysAndValuesDo: [:key :value | (anObject isKindOf: key) ifTrue: [^value]]. - ^nil - ] - - ObjectDumper class >> specialCaseIf: aBlock dump: dumpBlock load: loadBlock [ - "Private - This method establishes a condition on which a particular - method must be used to save an object. - An application should not use this method, since it might cause - failure to load file that set the special-case blocks differently; - instead, you should use ObjectDumper's higher level proxy feature, - i.e. its #registerProxyClass:for: method - which builds on the - low-level feature enabled by this method but without its inherent - problems." - - - SpecialCaseDump addLast: aBlock -> dumpBlock. - SpecialCaseLoad addLast: loadBlock - ] - - ObjectDumper class >> initialize [ - "Initialize the ObjectDumper class" - - - Proxies := IdentityDictionary new. - SpecialCaseDump := OrderedCollection new. - SpecialCaseLoad := OrderedCollection new. - - "We can only use #isNil, #==, #class here" - self - specialCaseIf: [:object | object == nil] - dump: [:client :object | ] - load: [:client | nil]; - specialCaseIf: [:object | object == true] - dump: [:client :object | ] - load: [:client | true]; - specialCaseIf: [:object | object == false] - dump: [:client :object | ] - load: [:client | false]; - specialCaseIf: [:object | object class == SmallInteger] - dump: [:client :object | client nextPutLong: object] - load: [:client | client nextLong]; - specialCaseIf: [:object | object class == Character] - dump: [:client :object | client stream nextPut: object] - load: [:client | client stream next]; - specialCaseIf: [:object | object class class == Metaclass] - dump: [:client :object | client storeGlobal: object] - load: [:client | client loadGlobal]; - specialCaseIf: [:object | object class == Metaclass] - dump: [:client :object | client storeGlobal: object asClass] - load: [:client | client loadGlobal class]; - specialCaseIf: [:object | object == Smalltalk] - dump: [:client :object | ] - load: [:client | Smalltalk]; - specialCaseIf: [:object | object class == Namespace] - dump: [:client :object | client storeGlobal: object] - load: [:client | client loadGlobal]; - specialCaseIf: [:object | object class == RootNamespace] - dump: [:client :object | client storeGlobal: object] - load: [:client | client loadGlobal]; - specialCaseIf: [:object | object class == Symbol] - dump: - [:client :object | - client stream nextPutAll: object. - client nextPutByte: 0] - load: [:client | client nextAsciiz asSymbol]; - specialCaseIf: [:object | self hasProxyFor: object class] - dump: - [:client :object | - | class | - (client lookup: object) - ifFalse: - [client storeGlobal: (class := self proxyClassFor: object). - (class on: object) dumpTo: client. - client register: object]] - load: - [:client | - "Special-case metaclasses and other objects" - - | index | - index := client nextLong. - index = 0 - ifTrue: [client register: (client loadGlobal loadFrom: client)] - ifFalse: [client lookupIndex: index]]; - specialCaseIf: [:object | object class == UnicodeCharacter] - dump: [:client :object | client nextPutLong: object codePoint] - load: [:client | client nextLong asCharacter] - ] - - ObjectDumper class >> on: aFileStream [ - "Answer an ObjectDumper working on aFileStream." - - - ^self basicNew initializeStream: aFileStream - ] - - ObjectDumper class >> new [ - - self shouldNotImplement - ] - - ObjectDumper class >> dump: anObject to: aFileStream [ - "Dump anObject to aFileStream. Answer anObject" - - - ^(self on: aFileStream) dump: anObject - ] - - ObjectDumper class >> loadFrom: aFileStream [ - "Load an object from aFileStream and answer it" - - - ^(self on: aFileStream) load - ] - - atEnd [ - "Answer whether the underlying stream is at EOF" - - - ^stream atEnd - ] - - next [ - "Load an object from the underlying stream" - - - ^self load - ] - - nextPut: anObject [ - "Store an object on the underlying stream" - - - self dump: anObject - ] - - dump: anObject [ - "Dump anObject on the stream associated with the receiver. Answer - anObject" - - - (self lookup: anObject) ifTrue: [^anObject]. - (self specialCaseDump: anObject) - ifFalse: - [anObject preStore. - [self primDump: anObject] ensure: [anObject postStore]] - ] - - load [ - "Load an object from the stream associated with the receiver and answer - it" - - - "Special-case metaclasses and other objects" - - | index | - stream atEnd ifTrue: [^self pastEnd]. - index := self nextLong. - ^index < 0 - ifTrue: [self specialCaseLoad: index] - ifFalse: [self primLoad: index] - ] - - flush [ - "`Forget' any information on previously stored objects." - - - toObjects := OrderedCollection new. - fromObjects := IdentityDictionary new - ] - - stream [ - "Answer the ByteStream to which the ObjectDumper will write - and from which it will read." - - - ^stream - ] - - stream: aByteStream [ - "Set the ByteStream to which the ObjectDumper will write - and from which it will read." - - - stream := aByteStream - ] - - lookup: anObject [ - - | index | - index := fromObjects at: anObject ifAbsent: [0]. - self nextPutLong: index. - ^index > 0 - ] - - lookupIndex: index [ - "Private - If index is a valid index into the toObjects map, evaluate - return the object associated to it. Else, fail." - - - ^toObjects at: index - ] - - register: anObject [ - "Private - Register the anObject in the fromObjects and toObjects maps. - Assumes that anObject is absent in these maps. Answer anObject" - - "(fromObject includesKey: anObject) ifTrue: [ - ^self error: 'Huh?!? Assertion failed' ]." - - - toObjects addLast: anObject. - fromObjects at: anObject put: toObjects size. - ^anObject - ] - - dumpContentsOf: anObject [ - "Dump anObject on the stream associated with the receiver. Answer - anObject" - - - | index | - (self lookup: anObject) ifTrue: [^anObject]. - anObject preStore. - [self primDump: anObject] ensure: [anObject postStore]. - ^self register: anObject - ] - - initializeStream: aStream [ - "Private - Initialize the receiver's instance variables" - - - stream := aStream. - self flush. - ^self - ] - - isClass: loadedClass [ - "Private - Answer whether loadedClass is really a class; only use - optimized selectors to avoid mess with objects that do not inherit - from Object." - - - ^loadedClass class class == Metaclass - ] - - loadClass [ - "Private - Load the next object's class from stream" - - - | isMeta loadedClass | - isMeta := self nextByte = 0. - loadedClass := self loadGlobal. - (self isClass: loadedClass) ifFalse: [^self error: 'Bad class']. - ^isMeta ifTrue: [loadedClass class] ifFalse: [loadedClass] - ] - - loadGlobal [ - "Private - Load a global object from the stream" - - - | object space index | - index := self nextLong. - index > 0 ifTrue: [^self lookupIndex: index]. - space := self load. - space isNil ifTrue: [space := Smalltalk]. - object := space at: self nextAsciiz asGlobalKey - ifAbsent: [^self error: 'Unknown global referenced']. - ^self register: object - ] - - load: anObject through: aBlock [ - "Private - Fill anObject's indexed instance variables from the stream. - To get a variable, evaluate aBlock. Answer anObject" - - - 1 to: anObject basicSize do: [:i | anObject basicAt: i put: aBlock value]. - ^anObject - postLoad; - yourself - ] - - loadFixedPart: class [ - "Private - Load the fixed instance variables of a new instance of class" - - - | object | - object := class isVariable - ifTrue: [class basicNew: self nextLong] - ifFalse: [class basicNew]. - self register: object. - 1 to: class instSize do: [:i | object instVarAt: i put: self load]. - ^object - ] - - nextAsciiz [ - "Private - Get a Null-terminated string from stream and answer it" - - - | ch answer | - answer := WriteStream on: (String new: 30). "Hopefully large enough" - - [ch := stream next. - ch asciiValue = 0] whileFalse: [answer nextPut: ch]. - ^answer contents - ] - - primDump: anObject [ - "Private - Basic code to dump anObject on the stream associated with the - receiver, without using proxies and the like." - - - | class shape | - self storeClass: (class := anObject class). - self register: anObject. - class isVariable ifTrue: [self nextPutLong: anObject basicSize]. - 1 to: class instSize do: [:i | self dump: (anObject instVarAt: i)]. - class isVariable ifFalse: [^self]. - class isPointers - ifTrue: [^self store: anObject through: [:obj | self dump: obj]]. - shape := class shape. - shape == #character - ifTrue: [^self store: anObject through: [:char | stream nextPut: char]]. - (shape == #byte or: [shape == #int8]) - ifTrue: [^self store: anObject through: [:byte | self nextPutByte: byte]]. - (shape == #short or: [shape == #ushort]) - ifTrue: [^self store: anObject through: [:short | self nextPutShort: short]]. - (shape == #int or: [shape == #int]) - ifTrue: [^self store: anObject through: [:int | self nextPutLong: int]]. - (shape == #int64 or: [shape == #uint64]) - ifTrue: [^self store: anObject through: [:int64 | self nextPutInt64: int64]]. - shape == #utf32 - ifTrue: - [^self store: anObject through: [:char | self nextPutLong: char codePoint]]. - shape == #float - ifTrue: [^self store: anObject through: [:float | self nextPutFloat: float]]. - shape == #double - ifTrue: - [^self store: anObject through: [:double | self nextPutFloat: double]]. - self notYetImplemented - ] - - loadFromVersion: version fixedSize: instSize [ - "Private - Basic code to load an object from a stream associated with - the receiver, calling the class' - #convertFromVersion:withFixedVariables:instanceVariables:for: method. - version will be the first parameter to that method, while instSize - will be the size of the second parameter. The object returned by - that method is registered and returned." - - - | object class realSize size fixed indexed placeholder index shape | - index := self nextLong. - index > 0 ifTrue: [^self lookupIndex: index]. - self register: (placeholder := Object new). - class := self loadClass. - class isVariable ifTrue: [size := self nextUlong]. - realSize := instSize isNil - ifTrue: [class nonVersionedInstSize] - ifFalse: [instSize]. - (1 to: realSize) collect: [:i | self load]. - class isVariable - ifTrue: - [class isPointers - ifTrue: [indexed := (1 to: size) collect: [:i | self load]]. - shape := class shape. - shape == #character - ifTrue: [indexed := (1 to: size) collect: [:i | Character value: self nextByte]]. - (shape == #byte and: [indexed isNil]) - ifTrue: [indexed := (1 to: size) collect: [:i | self nextByte]]. - shape == #int8 - ifTrue: [indexed := (1 to: size) collect: [:i | self nextSignByte]]. - shape == #short - ifTrue: [indexed := (1 to: size) collect: [:i | self nextShort]]. - shape == #ushort - ifTrue: [indexed := (1 to: size) collect: [:i | self nextUshort]]. - shape == #int - ifTrue: [indexed := (1 to: size) collect: [:i | self nextLong]]. - shape == #uint - ifTrue: [indexed := (1 to: size) collect: [:i | self nextUlong]]. - shape == #int64 - ifTrue: [indexed := (1 to: size) collect: [:i | self nextInt64]]. - shape == #uint64 - ifTrue: [indexed := (1 to: size) collect: [:i | self nextUint64]]. - shape == #utf32 - ifTrue: [indexed := (1 to: size) collect: [:i | self nextLong asCharacter]]. - shape == #float - ifTrue: [indexed := (1 to: size) collect: [:i | self nextFloat]]. - shape == #double - ifTrue: [indexed := (1 to: size) collect: [:i | self nextDouble]]. - indexed isNil ifTrue: [self shouldNotImplement]]. - placeholder become: (class - convertFromVersion: version - withFixedVariables: fixed - indexedVariables: indexed - for: self). - ^placeholder - ] - - primLoad: index [ - "Private - Basic code to load an object from the stream associated with the - receiver, assuming it doesn't use proxies and the like. The first four - bytes of the encoding are in index" - - - | object class shape | - index > 0 ifTrue: [^self lookupIndex: index]. - class := self loadClass. - class isMetaclass ifTrue: [^class instanceClass]. - object := self loadFixedPart: class. - class isVariable ifFalse: [^object postLoad; yourself]. - class isPointers ifTrue: [^self load: object through: [self load]]. - shape := class shape. - shape == #character ifTrue: [^self load: object through: [Character value: self nextByte]]. - shape == #byte ifTrue: [^self load: object through: [self nextByte]]. - shape == #int8 ifTrue: [^self load: object through: [self nextSignByte]]. - shape == #short ifTrue: [^self load: object through: [self nextShort]]. - shape == #ushort ifTrue: [^self load: object through: [self nextUshort]]. - shape == #int ifTrue: [^self load: object through: [self nextLong]]. - shape == #uint ifTrue: [^self load: object through: [self nextUlong]]. - shape == #int64 ifTrue: [^self load: object through: [self nextInt64]]. - shape == #uint64 ifTrue: [^self load: object through: [self nextUint64]]. - shape == #utf32 - ifTrue: [^self load: object through: [self nextLong asCharacter]]. - shape == #float ifTrue: [^self load: object through: [self nextFloat]]. - shape == #double ifTrue: [^self load: object through: [self nextDouble]]. - self shouldNotImplement - ] - - specialCaseDump: anObject [ - "Private - Store special-cased objects. These include booleans, integers, - nils, characters, classes and Processor. Answer true if object belongs - to one of these categories, else do nothing and answer false" - - - SpecialCaseDump keysAndValuesDo: - [:index :each | - (each key value: anObject) - ifTrue: - [stream skip: -4. - self nextPutLong: index negated. - each value value: self value: anObject. - self register: anObject. - ^true]]. - ^false - ] - - specialCaseLoad: index [ - "Private - The first 4 bytes in the file were less than 0. - Load the remaining info about the object and answer it." - - - | object | - index > SpecialCaseLoad size ifTrue: [^self error: 'error in file']. - object := (SpecialCaseLoad at: index negated) value: self. - ^self register: object - ] - - storeClass: aClass [ - "Private - Store the aClass class in stream. The format is: - - for a metaclass, a 0 followed by the asciiz name of its instance - - for a class, a 1 followed by its asciiz name" - - "We don't register metaclasses; instead we register their instance - (the class) and use a byte to distinguish between the two cases." - - - aClass isMetaclass - ifTrue: [self nextPutByte: 0] - ifFalse: [self nextPutByte: 1]. - self storeGlobal: aClass asClass - ] - - storeGlobal: anObject [ - - | namespace | - (self lookup: anObject) ifTrue: [^anObject]. - (anObject respondsTo: #environment) - ifTrue: [namespace := anObject environment] - ifFalse: - [(anObject respondsTo: #superspace) - ifTrue: [namespace := anObject superspace] - ifFalse: [namespace := nil "read as `Smalltalk' upon load."]]. - self - dump: namespace; - register: anObject. - stream nextPutAll: anObject name. - self nextPutByte: 0 - ] - - store: anObject through: aBlock [ - "Private - Store anObject's indexed instance variables into the stream. - To store a variable, pass its value to aBlock." - - - 1 to: anObject basicSize do: [:i | aBlock value: (anObject basicAt: i)]. - ^anObject - ] - - nextByte [ - "Return the next byte in the byte array" - - - ^stream next asInteger - ] - - nextByteArray: numBytes [ - "Return the next numBytes bytes in the byte array" - - - ^(stream next: numBytes) asByteArray - ] - - nextSignedByte [ - "Return the next byte in the byte array, interpreted as a 8 bit signed number" - - - ^self nextBytes: 1 signed: true - ] - - nextDouble [ - "Return the next 64-bit float in the byte array" - - - ^(FloatD new: 8) - at: 1 put: self nextByte; - at: 2 put: self nextByte; - at: 3 put: self nextByte; - at: 4 put: self nextByte; - at: 5 put: self nextByte; - at: 6 put: self nextByte; - at: 7 put: self nextByte; - at: 8 put: self nextByte - ] - - nextFloat [ - "Return the next 32-bit float in the byte array" - - - ^(FloatE new: 4) - at: 1 put: self nextByte; - at: 2 put: self nextByte; - at: 3 put: self nextByte; - at: 4 put: self nextByte - ] - - nextUint64 [ - "Return the next 8 bytes in the byte array, interpreted as a 64 bit unsigned int" - - - ^self nextBytes: 8 signed: false - ] - - nextLongLong [ - "Return the next 8 bytes in the byte array, interpreted as a 64 bit signed int" - - - ^self nextBytes: 8 signed: true - ] - - nextUlong [ - "Return the next 4 bytes in the byte array, interpreted as a 32 bit unsigned int" - - - ^self nextBytes: 4 signed: false - ] - - nextLong [ - "Return the next 4 bytes in the byte array, interpreted as a 32 bit signed int" - - - ^self nextBytes: 4 signed: true - ] - - nextUshort [ - "Return the next 2 bytes in the byte array, interpreted as a 16 bit unsigned int" - - - ^self nextBytes: 2 signed: false - ] - - nextShort [ - "Return the next 2 bytes in the byte array, interpreted as a 16 bit signed int" - - - ^self nextBytes: 2 signed: true - ] - - nextPutDouble: aDouble [ - "Store aDouble as a 64-bit float in the byte array" - - - | d | - d := aDouble asFloatD. - self nextPutByte: (d at: 1). - self nextPutByte: (d at: 2). - self nextPutByte: (d at: 3). - self nextPutByte: (d at: 4). - self nextPutByte: (d at: 5). - self nextPutByte: (d at: 6). - self nextPutByte: (d at: 7). - self nextPutByte: (d at: 8) - ] - - nextPutFloat: aFloat [ - "Return the next 32-bit float in the byte array" - - - | f | - f := aFloat asFloatE. - self nextPutByte: (f at: 1). - self nextPutByte: (f at: 2). - self nextPutByte: (f at: 3). - self nextPutByte: (f at: 4) - ] - - nextPutByte: anInteger [ - "Store anInteger (range: -128..255) on the byte array" - - - | int | - int := anInteger < 0 - ifTrue: [256 + anInteger] - ifFalse: [anInteger]. - ^stream nextPut: (Character value: int) - ] - - nextPutByteArray: aByteArray [ - "Store aByteArray on the byte array" - - - ^self nextPutAll: aByteArray - ] - - nextPutInt64: anInteger [ - "Store anInteger (range: -2^63..2^64-1) on the byte array as 4 bytes" - - - self nextPutBytes: 8 of: anInteger - ] - - nextPutLong: anInteger [ - "Store anInteger (range: -2^31..2^32-1) on the byte array as 4 bytes" - - - self nextPutBytes: 4 of: anInteger - ] - - nextPutShort: anInteger [ - "Store anInteger (range: -32768..65535) on the byte array as 2 bytes" - - - self nextPutBytes: 2 of: anInteger - ] - - nextBytes: n signed: signed [ - "Private - Get an integer out of the next anInteger bytes in the stream" - - - | int msb | - int := 0. - 0 to: n * 8 - 16 - by: 8 - do: [:i | int := int + (self nextByte bitShift: i)]. - msb := self nextByte. - (signed and: [msb > 127]) ifTrue: [msb := msb - 256]. - ^int + (msb bitShift: n * 8 - 8) - ] - - nextPutBytes: n of: anInteger [ - "Private - Store the n least significant bytes of int in little-endian format" - - - | int | - int := anInteger. - n timesRepeat: - [self nextPutByte: (int bitAnd: 255). - int := int bitShift: -8. - (int = 0 and: [anInteger < 0]) ifTrue: [int := 255]] - ] - -] - - - -Object subclass: DumperProxy [ - - - - - DumperProxy class >> loadFrom: anObjectDumper [ - "Reload a proxy stored in anObjectDumper and reconstruct the object" - - - ^anObjectDumper load object - ] - - DumperProxy class >> acceptUsageForClass: aClass [ - "The receiver was asked to be used as a proxy for the class aClass. - Answer whether the registration is fine. By default, answer true" - - - ^true - ] - - DumperProxy class >> on: anObject [ - "Answer a proxy to be used to save anObject. This method - MUST be overridden and anObject must NOT be stored in the - object's instance variables unless you override #dumpTo:, - because that would result in an infinite loop!" - - - self subclassResponsibility - ] - - dumpTo: anObjectDumper [ - "Dump the proxy to anObjectDumper -- the #loadFrom: class method - will reconstruct the original object." - - - anObjectDumper dump: self - ] - - object [ - "Reconstruct the object stored in the proxy and answer it" - - - self subclassResponsibility - ] -] - - - -DumperProxy subclass: AlternativeObjectProxy [ - | object | - - - - - AlternativeObjectProxy class >> acceptUsageForClass: aClass [ - "The receiver was asked to be used as a proxy for the class aClass. - Answer whether the registration is fine. By default, answer true - except if AlternativeObjectProxy itself is being used." - - - ^self ~~ AlternativeObjectProxy - ] - - AlternativeObjectProxy class >> on: anObject [ - "Answer a proxy to be used to save anObject. IMPORTANT: this method - MUST be overridden so that the overridden version sends #on: to super - passing an object that is NOT the same as anObject (alternatively, - you can override #dumpTo:, which is what NullProxy does), because that - would result in an infinite loop! This also means that - AlternativeObjectProxy must never be used directly -- only as - a superclass." - - - ^self new object: anObject - ] - - object [ - "Reconstruct the object stored in the proxy and answer it. A - subclass will usually override this" - - - ^object - ] - - primObject [ - "Reconstruct the object stored in the proxy and answer it. This - method must not be overridden" - - - ^object - ] - - object: theObject [ - "Set the object to be dumped to theObject. This should not be - overridden." - - - object := theObject - ] -] - - - -AlternativeObjectProxy subclass: NullProxy [ - - - - - NullProxy class >> loadFrom: anObjectDumper [ - "Reload the object stored in anObjectDumper" - - - ^anObjectDumper load - ] - - dumpTo: anObjectDumper [ - "Dump the object stored in the proxy to anObjectDumper" - - - anObjectDumper dumpContentsOf: self object - ] -] - - - -AlternativeObjectProxy subclass: PluggableProxy [ - - - - - PluggableProxy class >> on: anObject [ - "Answer a proxy to be used to save anObject. The proxy - stores a different object obtained by sending to anObject - the #binaryRepresentationObject message (embedded - between #preStore and #postStore as usual)." - - - anObject preStore. - ^[super on: anObject binaryRepresentationObject] - ensure: [anObject postStore] - ] - - object [ - "Reconstruct the object stored in the proxy and answer it; - the binaryRepresentationObject is sent the - #reconstructOriginalObject message, and the resulting - object is sent the #postLoad message." - - - ^(super object reconstructOriginalObject) - postLoad; - yourself - ] -] - - - -NullProxy subclass: VersionableObjectProxy [ - - - - - VersionableObjectProxy class >> loadFrom: anObjectDumper [ - "Retrieve the object. If the version number doesn't match the - #binaryRepresentationVersion answered by the class, call the class' - #convertFromVersion:withFixedVariables:instanceVariables:for: method. - The stored version number will be the first parameter to that method - (or nil if the stored object did not employ a VersionableObjectProxy), - the remaining parameters will be respectively the fixed instance - variables, the indexed instance variables (or nil if the class is - fixed), and the ObjectDumper itself. - If no VersionableObjectProxy, the class is sent #nonVersionedInstSize - to retrieve the number of fixed instance variables stored for the - non-versioned object." - - - | version object instSize | - version := anObjectDumper nextLong. - version := version >= 0 - ifTrue: - ["The version was actually an object index -- move back in the stream." - - anObjectDumper stream skip: -4. - instSize := nil. - nil] - ifFalse: - [instSize := anObjectDumper nextUlong. - -1 - version]. - ^version == self object class binaryRepresentationVersion - ifTrue: [anObjectDumper load] - ifFalse: [anObjectDumper loadFromVersion: version fixedSize: instSize] - ] - - dumpTo: anObjectDumper [ - "Save the object with extra versioning information." - - - anObjectDumper - nextPutLong: -1 - self object class binaryRepresentationVersion; - nextPutLong: self object class instSize. - super dumpTo: anObjectDumper - ] -] - - - -AlternativeObjectProxy subclass: SingletonProxy [ - - - - - SingletonProxy class [ - | singletons | - - ] - - SingletonProxy class >> singletons [ - - ^singletons isNil - ifTrue: [singletons := IdentityDictionary new] - ifFalse: [singletons] - ] - - SingletonProxy class >> acceptUsageForClass: aClass [ - "The receiver was asked to be used as a proxy for the class aClass. - The registration is fine if the class is actually a singleton." - - - | singleton | - singleton := aClass someInstance. - singleton nextInstance isNil ifFalse: [^false]. - self singletons at: aClass put: singleton. - ^true - ] - - SingletonProxy class >> on: anObject [ - "Answer a proxy to be used to save anObject. The proxy - stores the class and restores the object by looking into - a dictionary of class -> singleton objects." - - - (self singletons includesKey: anObject class) - ifTrue: [^super on: anObject class]. - self error: 'class not registered within SingletonProxy' - ] - - object [ - "Reconstruct the object stored in the proxy and answer it; - the binaryRepresentationObject is sent the - #reconstructOriginalObject message, and the resulting - object is sent the #postLoad message." - - - ^self class singletons at: super object - ifAbsent: [self error: 'class not registered within SingletonProxy'] - ] -] - - - -Eval [ - ObjectDumper - initialize; - registerProxyClass: PluggableProxy for: CompiledMethod; - registerProxyClass: PluggableProxy for: CompiledBlock; - registerProxyClass: SingletonProxy for: Processor class -] diff --git a/libgst/files.c b/libgst/files.c index f687f74..3e7b309 100644 --- a/libgst/files.c +++ b/libgst/files.c @@ -286,7 +286,6 @@ static const char standard_files[] = { "Getopt.st\0" "Generator.st\0" "StreamOps.st\0" - "ObjDumper.st\0" "Regex.st\0" "PkgLoader.st\0" "Autoload.st\0" diff --git a/packages.xml b/packages.xml index 26805ee..2fbcaa3 100644 --- a/packages.xml +++ b/packages.xml @@ -139,7 +139,6 @@ ByteArray.st FilePath.st File.st - ObjDumper.st SysDict.st ScaledDec.st FileSegment.st diff --git a/packages/object-dumper/Init.st b/packages/object-dumper/Init.st new file mode 100644 index 0000000..7dac59c --- /dev/null +++ b/packages/object-dumper/Init.st @@ -0,0 +1,9 @@ + +Eval [ + ObjectDumper + initialize; + registerProxyClass: PluggableProxy for: CompiledMethod; + registerProxyClass: PluggableProxy for: CompiledBlock; + registerProxyClass: SingletonProxy for: Processor class +] + diff --git a/packages/object-dumper/Makefile.frag b/packages/object-dumper/Makefile.frag new file mode 100644 index 0000000..ef289f7 --- /dev/null +++ b/packages/object-dumper/Makefile.frag @@ -0,0 +1,5 @@ +ObjectDumper_FILES = \ +packages/object-dumper/ObjDumper.st packages/object-dumper/Proxy.st packages/object-dumper/Init.st packages/object-dumper/ObjectDumperTest.st +$(ObjectDumper_FILES): +$(srcdir)/packages/object-dumper/stamp-classes: $(ObjectDumper_FILES) + touch $(srcdir)/packages/object-dumper/stamp-classes diff --git a/packages/object-dumper/ObjDumper.st b/packages/object-dumper/ObjDumper.st new file mode 100644 index 0000000..b83b1ad --- /dev/null +++ b/packages/object-dumper/ObjDumper.st @@ -0,0 +1,834 @@ +"====================================================================== +| +| ObjectDumper Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2003, 2006, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Stream subclass: ObjectDumper [ + | toObjects fromObjects stream | + + + + + SpecialCaseDump := nil. + SpecialCaseLoad := nil. + Proxies := nil. + + ObjectDumper class >> example [ + "This is a real torture test: it outputs recursive objects, + identical objects multiple times, classes, metaclasses, + integers, characters and proxies (which is also a test of more + complex objects)!" + + + | file test dumper method | + Transcript + nextPutAll: 'Must print true without errors.'; + nl. + file := FileStream open: 'dumptest' mode: FileStream write. + test := Array new: 1. + test at: 1 put: test. + method := thisContext method. + (ObjectDumper on: file) + dump: 'asdf'; + dump: #('asdf' 1 2 $a); + dump: Array; + dump: 'asdf'; + dump: Array class; + dump: test; + dump: Processor; + dump: Processor; + dump: method; + dump: method. "String" "Array" "Class" "String (must be identical to the first)" "Metaclass" "Circular reference" "SingletonProxy" "SingletonProxy" "PluggableProxy" "PluggableProxy" + file close. + file := FileStream open: 'dumptest' mode: FileStream read. + dumper := ObjectDumper on: file. + ((test := dumper load) = 'asdf') printNl. + (dumper load = #('asdf' 1 2 $a)) printNl. + (dumper load == Array) printNl. + (dumper load == test) printNl. + (dumper load == Array class) printNl. + test := dumper load. + (test == (test at: 1)) printNl. + (dumper load == Processor) printNl. + (dumper load == Processor) printNl. + (dumper load == method) printNl. + (dumper load == method) printNl. + file close + ] + + ObjectDumper class >> hasProxyFor: aClass [ + "Answer whether a proxy class has been registered for instances + of aClass." + + + Proxies keysDo: + [:any | + (aClass inheritsFrom: any) ifTrue: [^true]. + aClass == any ifTrue: [^true]]. + ^false + ] + + ObjectDumper class >> disableProxyFor: aClass [ + "Disable proxies for instances of aClass and its descendants" + + + self registerProxyClass: NullProxy for: aClass + ] + + ObjectDumper class >> registerProxyClass: aProxyClass for: aClass [ + "Register the proxy class aProxyClass - descendent of DumperProxy - + to be used for instances of aClass and its descendants" + + + (aProxyClass acceptUsageForClass: aClass) + ifFalse: [self error: 'registration request denied']. + Proxies at: aClass put: aProxyClass + ] + + ObjectDumper class >> proxyFor: anObject [ + "Answer a valid proxy for an object, or the object itself if none could + be found" + + + Proxies + keysAndValuesDo: [:key :value | (anObject isKindOf: key) ifTrue: [^value on: anObject]]. + ^anObject + ] + + ObjectDumper class >> proxyClassFor: anObject [ + "Answer the class of a valid proxy for an object, or nil if none could + be found" + + + Proxies + keysAndValuesDo: [:key :value | (anObject isKindOf: key) ifTrue: [^value]]. + ^nil + ] + + ObjectDumper class >> specialCaseIf: aBlock dump: dumpBlock load: loadBlock [ + "Private - This method establishes a condition on which a particular + method must be used to save an object. + An application should not use this method, since it might cause + failure to load file that set the special-case blocks differently; + instead, you should use ObjectDumper's higher level proxy feature, + i.e. its #registerProxyClass:for: method - which builds on the + low-level feature enabled by this method but without its inherent + problems." + + + SpecialCaseDump addLast: aBlock -> dumpBlock. + SpecialCaseLoad addLast: loadBlock + ] + + ObjectDumper class >> initialize [ + "Initialize the ObjectDumper class" + + + Proxies := IdentityDictionary new. + SpecialCaseDump := OrderedCollection new. + SpecialCaseLoad := OrderedCollection new. + + "We can only use #isNil, #==, #class here" + self + specialCaseIf: [:object | object == nil] + dump: [:client :object | ] + load: [:client | nil]; + specialCaseIf: [:object | object == true] + dump: [:client :object | ] + load: [:client | true]; + specialCaseIf: [:object | object == false] + dump: [:client :object | ] + load: [:client | false]; + specialCaseIf: [:object | object class == SmallInteger] + dump: [:client :object | client nextPutLong: object] + load: [:client | client nextLong]; + specialCaseIf: [:object | object class == Character] + dump: [:client :object | client stream nextPut: object] + load: [:client | client stream next]; + specialCaseIf: [:object | object class class == Metaclass] + dump: [:client :object | client storeGlobal: object] + load: [:client | client loadGlobal]; + specialCaseIf: [:object | object class == Metaclass] + dump: [:client :object | client storeGlobal: object asClass] + load: [:client | client loadGlobal class]; + specialCaseIf: [:object | object == Smalltalk] + dump: [:client :object | ] + load: [:client | Smalltalk]; + specialCaseIf: [:object | object class == Namespace] + dump: [:client :object | client storeGlobal: object] + load: [:client | client loadGlobal]; + specialCaseIf: [:object | object class == RootNamespace] + dump: [:client :object | client storeGlobal: object] + load: [:client | client loadGlobal]; + specialCaseIf: [:object | object class == Symbol] + dump: + [:client :object | + client stream nextPutAll: object. + client nextPutByte: 0] + load: [:client | client nextAsciiz asSymbol]; + specialCaseIf: [:object | self hasProxyFor: object class] + dump: + [:client :object | + | class | + (client lookup: object) + ifFalse: + [client storeGlobal: (class := self proxyClassFor: object). + (class on: object) dumpTo: client. + client register: object]] + load: + [:client | + "Special-case metaclasses and other objects" + + | index | + index := client nextLong. + index = 0 + ifTrue: [client register: (client loadGlobal loadFrom: client)] + ifFalse: [client lookupIndex: index]]; + specialCaseIf: [:object | object class == UnicodeCharacter] + dump: [:client :object | client nextPutLong: object codePoint] + load: [:client | client nextLong asCharacter] + ] + + ObjectDumper class >> on: aFileStream [ + "Answer an ObjectDumper working on aFileStream." + + + ^self basicNew initializeStream: aFileStream + ] + + ObjectDumper class >> new [ + + self shouldNotImplement + ] + + ObjectDumper class >> dump: anObject to: aFileStream [ + "Dump anObject to aFileStream. Answer anObject" + + + ^(self on: aFileStream) dump: anObject + ] + + ObjectDumper class >> loadFrom: aFileStream [ + "Load an object from aFileStream and answer it" + + + ^(self on: aFileStream) load + ] + + atEnd [ + "Answer whether the underlying stream is at EOF" + + + ^stream atEnd + ] + + next [ + "Load an object from the underlying stream" + + + ^self load + ] + + nextPut: anObject [ + "Store an object on the underlying stream" + + + self dump: anObject + ] + + dump: anObject [ + "Dump anObject on the stream associated with the receiver. Answer + anObject" + + + (self lookup: anObject) ifTrue: [^anObject]. + (self specialCaseDump: anObject) + ifFalse: + [anObject preStore. + [self primDump: anObject] ensure: [anObject postStore]] + ] + + load [ + "Load an object from the stream associated with the receiver and answer + it" + + + "Special-case metaclasses and other objects" + + | index | + stream atEnd ifTrue: [^self pastEnd]. + index := self nextLong. + ^index < 0 + ifTrue: [self specialCaseLoad: index] + ifFalse: [self primLoad: index] + ] + + flush [ + "`Forget' any information on previously stored objects." + + + toObjects := OrderedCollection new. + fromObjects := IdentityDictionary new + ] + + stream [ + "Answer the ByteStream to which the ObjectDumper will write + and from which it will read." + + + ^stream + ] + + stream: aByteStream [ + "Set the ByteStream to which the ObjectDumper will write + and from which it will read." + + + stream := aByteStream + ] + + lookup: anObject [ + + | index | + index := fromObjects at: anObject ifAbsent: [0]. + self nextPutLong: index. + ^index > 0 + ] + + lookupIndex: index [ + "Private - If index is a valid index into the toObjects map, evaluate + return the object associated to it. Else, fail." + + + ^toObjects at: index + ] + + register: anObject [ + "Private - Register the anObject in the fromObjects and toObjects maps. + Assumes that anObject is absent in these maps. Answer anObject" + + "(fromObject includesKey: anObject) ifTrue: [ + ^self error: 'Huh?!? Assertion failed' ]." + + + toObjects addLast: anObject. + fromObjects at: anObject put: toObjects size. + ^anObject + ] + + dumpContentsOf: anObject [ + "Dump anObject on the stream associated with the receiver. Answer + anObject" + + + | index | + (self lookup: anObject) ifTrue: [^anObject]. + anObject preStore. + [self primDump: anObject] ensure: [anObject postStore]. + ^self register: anObject + ] + + initializeStream: aStream [ + "Private - Initialize the receiver's instance variables" + + + stream := aStream. + self flush. + ^self + ] + + isClass: loadedClass [ + "Private - Answer whether loadedClass is really a class; only use + optimized selectors to avoid mess with objects that do not inherit + from Object." + + + ^loadedClass class class == Metaclass + ] + + loadClass [ + "Private - Load the next object's class from stream" + + + | isMeta loadedClass | + isMeta := self nextByte = 0. + loadedClass := self loadGlobal. + (self isClass: loadedClass) ifFalse: [^self error: 'Bad class']. + ^isMeta ifTrue: [loadedClass class] ifFalse: [loadedClass] + ] + + loadGlobal [ + "Private - Load a global object from the stream" + + + | object space index | + index := self nextLong. + index > 0 ifTrue: [^self lookupIndex: index]. + space := self load. + space isNil ifTrue: [space := Smalltalk]. + object := space at: self nextAsciiz asGlobalKey + ifAbsent: [^self error: 'Unknown global referenced']. + ^self register: object + ] + + load: anObject through: aBlock [ + "Private - Fill anObject's indexed instance variables from the stream. + To get a variable, evaluate aBlock. Answer anObject" + + + 1 to: anObject basicSize do: [:i | anObject basicAt: i put: aBlock value]. + ^anObject + postLoad; + yourself + ] + + loadFixedPart: class [ + "Private - Load the fixed instance variables of a new instance of class" + + + | object | + object := class isVariable + ifTrue: [class basicNew: self nextLong] + ifFalse: [class basicNew]. + self register: object. + 1 to: class instSize do: [:i | object instVarAt: i put: self load]. + ^object + ] + + nextAsciiz [ + "Private - Get a Null-terminated string from stream and answer it" + + + | ch answer | + answer := WriteStream on: (String new: 30). "Hopefully large enough" + + [ch := stream next. + ch asciiValue = 0] whileFalse: [answer nextPut: ch]. + ^answer contents + ] + + primDump: anObject [ + "Private - Basic code to dump anObject on the stream associated with the + receiver, without using proxies and the like." + + + | class shape | + self storeClass: (class := anObject class). + self register: anObject. + class isVariable ifTrue: [self nextPutLong: anObject basicSize]. + 1 to: class instSize do: [:i | self dump: (anObject instVarAt: i)]. + class isVariable ifFalse: [^self]. + class isPointers + ifTrue: [^self store: anObject through: [:obj | self dump: obj]]. + shape := class shape. + shape == #character + ifTrue: [^self store: anObject through: [:char | stream nextPut: char]]. + (shape == #byte or: [shape == #int8]) + ifTrue: [^self store: anObject through: [:byte | self nextPutByte: byte]]. + (shape == #short or: [shape == #ushort]) + ifTrue: [^self store: anObject through: [:short | self nextPutShort: short]]. + (shape == #int or: [shape == #int]) + ifTrue: [^self store: anObject through: [:int | self nextPutLong: int]]. + (shape == #int64 or: [shape == #uint64]) + ifTrue: [^self store: anObject through: [:int64 | self nextPutInt64: int64]]. + shape == #utf32 + ifTrue: + [^self store: anObject through: [:char | self nextPutLong: char codePoint]]. + shape == #float + ifTrue: [^self store: anObject through: [:float | self nextPutFloat: float]]. + shape == #double + ifTrue: + [^self store: anObject through: [:double | self nextPutFloat: double]]. + self notYetImplemented + ] + + loadFromVersion: version fixedSize: instSize [ + "Private - Basic code to load an object from a stream associated with + the receiver, calling the class' + #convertFromVersion:withFixedVariables:instanceVariables:for: method. + version will be the first parameter to that method, while instSize + will be the size of the second parameter. The object returned by + that method is registered and returned." + + + | object class realSize size fixed indexed placeholder index shape | + index := self nextLong. + index > 0 ifTrue: [^self lookupIndex: index]. + self register: (placeholder := Object new). + class := self loadClass. + version == class binaryRepresentationVersion ifTrue: [ ^ self primLoad: index class: class ]. + class isVariable ifTrue: [size := self nextUlong]. + realSize := instSize isNil + ifTrue: [class nonVersionedInstSize] + ifFalse: [instSize]. + fixed := (1 to: realSize) collect: [:i | self load]. + class isVariable + ifTrue: + [class isPointers + ifTrue: [indexed := (1 to: size) collect: [:i | self load]]. + shape := class shape. + shape == #character + ifTrue: [indexed := (1 to: size) collect: [:i | Character value: self nextByte]]. + (shape == #byte and: [indexed isNil]) + ifTrue: [indexed := (1 to: size) collect: [:i | self nextByte]]. + shape == #int8 + ifTrue: [indexed := (1 to: size) collect: [:i | self nextSignByte]]. + shape == #short + ifTrue: [indexed := (1 to: size) collect: [:i | self nextShort]]. + shape == #ushort + ifTrue: [indexed := (1 to: size) collect: [:i | self nextUshort]]. + shape == #int + ifTrue: [indexed := (1 to: size) collect: [:i | self nextLong]]. + shape == #uint + ifTrue: [indexed := (1 to: size) collect: [:i | self nextUlong]]. + shape == #int64 + ifTrue: [indexed := (1 to: size) collect: [:i | self nextInt64]]. + shape == #uint64 + ifTrue: [indexed := (1 to: size) collect: [:i | self nextUint64]]. + shape == #utf32 + ifTrue: [indexed := (1 to: size) collect: [:i | self nextLong asCharacter]]. + shape == #float + ifTrue: [indexed := (1 to: size) collect: [:i | self nextFloat]]. + shape == #double + ifTrue: [indexed := (1 to: size) collect: [:i | self nextDouble]]. + indexed isNil ifTrue: [self shouldNotImplement]]. + placeholder become: (class + convertFromVersion: version + withFixedVariables: fixed + indexedVariables: indexed + for: self). + ^ placeholder + ] + + primLoad: index [ + "Private - Basic code to load an object from the stream associated with the + receiver, assuming it doesn't use proxies and the like. The first four + bytes of the encoding are in index" + + + | object class shape | + index > 0 ifTrue: [^self lookupIndex: index]. + class := self loadClass. + class isMetaclass ifTrue: [^class instanceClass]. + ^ self primLoad: index class: class + ] + + primLoad: index class: aClass [ + "Private - Basic code to load an object from the stream associated with the + receiver, assuming it doesn't use proxies and the like. The first four + bytes of the encoding are in index" + + + | object shape | + object := self loadFixedPart: aClass. + aClass isVariable ifFalse: [^object postLoad; yourself]. + aClass isPointers ifTrue: [^self load: object through: [self load]]. + shape := aClass shape. + shape == #character ifTrue: [^self load: object through: [Character value: self nextByte]]. + shape == #byte ifTrue: [^self load: object through: [self nextByte]]. + shape == #int8 ifTrue: [^self load: object through: [self nextSignByte]]. + shape == #short ifTrue: [^self load: object through: [self nextShort]]. + shape == #ushort ifTrue: [^self load: object through: [self nextUshort]]. + shape == #int ifTrue: [^self load: object through: [self nextLong]]. + shape == #uint ifTrue: [^self load: object through: [self nextUlong]]. + shape == #int64 ifTrue: [^self load: object through: [self nextInt64]]. + shape == #uint64 ifTrue: [^self load: object through: [self nextUint64]]. + shape == #utf32 + ifTrue: [^self load: object through: [self nextLong asCharacter]]. + shape == #float ifTrue: [^self load: object through: [self nextFloat]]. + shape == #double ifTrue: [^self load: object through: [self nextDouble]]. + self shouldNotImplement + ] + + specialCaseDump: anObject [ + "Private - Store special-cased objects. These include booleans, integers, + nils, characters, classes and Processor. Answer true if object belongs + to one of these categories, else do nothing and answer false" + + + SpecialCaseDump keysAndValuesDo: + [:index :each | + (each key value: anObject) + ifTrue: + [stream skip: -4. + self nextPutLong: index negated. + each value value: self value: anObject. + self register: anObject. + ^true]]. + ^false + ] + + specialCaseLoad: index [ + "Private - The first 4 bytes in the file were less than 0. + Load the remaining info about the object and answer it." + + + | object | + index > SpecialCaseLoad size ifTrue: [^self error: 'error in file']. + object := (SpecialCaseLoad at: index negated) value: self. + ^self register: object + ] + + storeClass: aClass [ + "Private - Store the aClass class in stream. The format is: + - for a metaclass, a 0 followed by the asciiz name of its instance + - for a class, a 1 followed by its asciiz name" + + "We don't register metaclasses; instead we register their instance + (the class) and use a byte to distinguish between the two cases." + + + aClass isMetaclass + ifTrue: [self nextPutByte: 0] + ifFalse: [self nextPutByte: 1]. + self storeGlobal: aClass asClass + ] + + storeGlobal: anObject [ + + | namespace | + (self lookup: anObject) ifTrue: [^anObject]. + (anObject respondsTo: #environment) + ifTrue: [namespace := anObject environment] + ifFalse: + [(anObject respondsTo: #superspace) + ifTrue: [namespace := anObject superspace] + ifFalse: [namespace := nil "read as `Smalltalk' upon load."]]. + self + dump: namespace; + register: anObject. + stream nextPutAll: anObject name. + self nextPutByte: 0 + ] + + store: anObject through: aBlock [ + "Private - Store anObject's indexed instance variables into the stream. + To store a variable, pass its value to aBlock." + + + 1 to: anObject basicSize do: [:i | aBlock value: (anObject basicAt: i)]. + ^anObject + ] + + nextByte [ + "Return the next byte in the byte array" + + + ^stream next asInteger + ] + + nextByteArray: numBytes [ + "Return the next numBytes bytes in the byte array" + + + ^(stream next: numBytes) asByteArray + ] + + nextSignedByte [ + "Return the next byte in the byte array, interpreted as a 8 bit signed number" + + + ^self nextBytes: 1 signed: true + ] + + nextDouble [ + "Return the next 64-bit float in the byte array" + + + ^(FloatD new: 8) + at: 1 put: self nextByte; + at: 2 put: self nextByte; + at: 3 put: self nextByte; + at: 4 put: self nextByte; + at: 5 put: self nextByte; + at: 6 put: self nextByte; + at: 7 put: self nextByte; + at: 8 put: self nextByte + ] + + nextFloat [ + "Return the next 32-bit float in the byte array" + + + ^(FloatE new: 4) + at: 1 put: self nextByte; + at: 2 put: self nextByte; + at: 3 put: self nextByte; + at: 4 put: self nextByte + ] + + nextUint64 [ + "Return the next 8 bytes in the byte array, interpreted as a 64 bit unsigned int" + + + ^self nextBytes: 8 signed: false + ] + + nextLongLong [ + "Return the next 8 bytes in the byte array, interpreted as a 64 bit signed int" + + + ^self nextBytes: 8 signed: true + ] + + nextUlong [ + "Return the next 4 bytes in the byte array, interpreted as a 32 bit unsigned int" + + + ^self nextBytes: 4 signed: false + ] + + nextLong [ + "Return the next 4 bytes in the byte array, interpreted as a 32 bit signed int" + + + ^self nextBytes: 4 signed: true + ] + + nextUshort [ + "Return the next 2 bytes in the byte array, interpreted as a 16 bit unsigned int" + + + ^self nextBytes: 2 signed: false + ] + + nextShort [ + "Return the next 2 bytes in the byte array, interpreted as a 16 bit signed int" + + + ^self nextBytes: 2 signed: true + ] + + nextPutDouble: aDouble [ + "Store aDouble as a 64-bit float in the byte array" + + + | d | + d := aDouble asFloatD. + self nextPutByte: (d at: 1). + self nextPutByte: (d at: 2). + self nextPutByte: (d at: 3). + self nextPutByte: (d at: 4). + self nextPutByte: (d at: 5). + self nextPutByte: (d at: 6). + self nextPutByte: (d at: 7). + self nextPutByte: (d at: 8) + ] + + nextPutFloat: aFloat [ + "Return the next 32-bit float in the byte array" + + + | f | + f := aFloat asFloatE. + self nextPutByte: (f at: 1). + self nextPutByte: (f at: 2). + self nextPutByte: (f at: 3). + self nextPutByte: (f at: 4) + ] + + nextPutByte: anInteger [ + "Store anInteger (range: -128..255) on the byte array" + + + | int | + int := anInteger < 0 + ifTrue: [256 + anInteger] + ifFalse: [anInteger]. + ^stream nextPut: (Character value: int) + ] + + nextPutByteArray: aByteArray [ + "Store aByteArray on the byte array" + + + ^self nextPutAll: aByteArray + ] + + nextPutInt64: anInteger [ + "Store anInteger (range: -2^63..2^64-1) on the byte array as 4 bytes" + + + self nextPutBytes: 8 of: anInteger + ] + + nextPutLong: anInteger [ + "Store anInteger (range: -2^31..2^32-1) on the byte array as 4 bytes" + + + self nextPutBytes: 4 of: anInteger + ] + + nextPutShort: anInteger [ + "Store anInteger (range: -32768..65535) on the byte array as 2 bytes" + + + self nextPutBytes: 2 of: anInteger + ] + + nextBytes: n signed: signed [ + "Private - Get an integer out of the next anInteger bytes in the stream" + + + | int msb | + int := 0. + 0 to: n * 8 - 16 + by: 8 + do: [:i | int := int + (self nextByte bitShift: i)]. + msb := self nextByte. + (signed and: [msb > 127]) ifTrue: [msb := msb - 256]. + ^int + (msb bitShift: n * 8 - 8) + ] + + nextPutBytes: n of: anInteger [ + "Private - Store the n least significant bytes of int in little-endian format" + + + | int | + int := anInteger. + n timesRepeat: + [self nextPutByte: (int bitAnd: 255). + int := int bitShift: -8. + (int = 0 and: [anInteger < 0]) ifTrue: [int := 255]] + ] + +] + diff --git a/packages/object-dumper/ObjectDumperTest.st b/packages/object-dumper/ObjectDumperTest.st new file mode 100644 index 0000000..1afafde --- /dev/null +++ b/packages/object-dumper/ObjectDumperTest.st @@ -0,0 +1,83 @@ +"====================================================================== +| +| Test ObjectDumper operations +| +| + ======================================================================" + + +"====================================================================== +| +| Copyright (C) 2002, 2007, 2008, 2009 Free Software Foundation. +| Written by Paolo Bonzini and Markus Fritsche +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + +TestCase subclass: ObjectDumperTest [ + + + testDumpLoad [ + + + | stream method array secondArray x y | + stream := (String new: 1024) readWriteStream. + (ObjectDumper on: stream) dump: Array. + stream reset. + self assert: (ObjectDumper on: stream) load == Array. + + stream := (String new: 1024) readWriteStream. + (ObjectDumper on: stream) dump: #('asdf' 1 2 $a). + stream reset. + self assert: (ObjectDumper on: stream) load = #('asdf' 1 2 $a). + + stream := (String new: 1024) readWriteStream. + method := Object >> #yourself. + (ObjectDumper on: stream) dump: method. + stream reset. + self assert: (ObjectDumper on: stream) load == method. + + stream := (String new: 1024) readWriteStream. + array := Array new: 1. + array at: 1 put: array. + (ObjectDumper on: stream) dump: array. + stream reset. + secondArray := (ObjectDumper on: stream) load. + self assert: secondArray == (secondArray at: 1). + + stream := (String new: 1024) readWriteStream. + (ObjectDumper on: stream) dump: Processor. + stream reset. + self assert: (ObjectDumper on: stream) load == Processor. + + stream := (String new: 1024) readWriteStream. + (ObjectDumper on: stream) dump: 'asdf'. + stream reset. + self assert: (ObjectDumper on: stream) load = 'asdf'. + + stream := (String new: 1024) writeStream. + (ObjectDumper on: stream) dump: #('asdf' 1 2 $a). + self assert: (ObjectDumper on: stream readStream) load = #('asdf' 1 2 $a). + + stream := String new readStream. + y := [ (ObjectDumper on: stream) load ] + on: SystemExceptions.EndOfStream + do: [ :ex | x := true. ex resume: ex defaultAction ]. + self assert: y isNil. + self assert: x + ] +] diff --git a/packages/object-dumper/Proxy.st b/packages/object-dumper/Proxy.st new file mode 100644 index 0000000..904216a --- /dev/null +++ b/packages/object-dumper/Proxy.st @@ -0,0 +1,313 @@ +"====================================================================== +| +| ObjectDumper Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2003, 2006, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Object subclass: DumperProxy [ + + + + + DumperProxy class >> loadFrom: anObjectDumper [ + "Reload a proxy stored in anObjectDumper and reconstruct the object" + + + ^anObjectDumper load object + ] + + DumperProxy class >> acceptUsageForClass: aClass [ + "The receiver was asked to be used as a proxy for the class aClass. + Answer whether the registration is fine. By default, answer true" + + + ^true + ] + + DumperProxy class >> on: anObject [ + "Answer a proxy to be used to save anObject. This method + MUST be overridden and anObject must NOT be stored in the + object's instance variables unless you override #dumpTo:, + because that would result in an infinite loop!" + + + self subclassResponsibility + ] + + dumpTo: anObjectDumper [ + "Dump the proxy to anObjectDumper -- the #loadFrom: class method + will reconstruct the original object." + + + anObjectDumper dump: self + ] + + object [ + "Reconstruct the object stored in the proxy and answer it" + + + self subclassResponsibility + ] +] + + + +DumperProxy subclass: AlternativeObjectProxy [ + | object | + + + + + AlternativeObjectProxy class >> acceptUsageForClass: aClass [ + "The receiver was asked to be used as a proxy for the class aClass. + Answer whether the registration is fine. By default, answer true + except if AlternativeObjectProxy itself is being used." + + + ^self ~~ AlternativeObjectProxy + ] + + AlternativeObjectProxy class >> on: anObject [ + "Answer a proxy to be used to save anObject. IMPORTANT: this method + MUST be overridden so that the overridden version sends #on: to super + passing an object that is NOT the same as anObject (alternatively, + you can override #dumpTo:, which is what NullProxy does), because that + would result in an infinite loop! This also means that + AlternativeObjectProxy must never be used directly -- only as + a superclass." + + + ^self new object: anObject + ] + + object [ + "Reconstruct the object stored in the proxy and answer it. A + subclass will usually override this" + + + ^object + ] + + primObject [ + "Reconstruct the object stored in the proxy and answer it. This + method must not be overridden" + + + ^object + ] + + object: theObject [ + "Set the object to be dumped to theObject. This should not be + overridden." + + + object := theObject + ] +] + + + +AlternativeObjectProxy subclass: NullProxy [ + + + + + NullProxy class >> loadFrom: anObjectDumper [ + "Reload the object stored in anObjectDumper" + + + ^anObjectDumper load + ] + + dumpTo: anObjectDumper [ + "Dump the object stored in the proxy to anObjectDumper" + + + anObjectDumper dumpContentsOf: self object + ] +] + + + +AlternativeObjectProxy subclass: PluggableProxy [ + + + + + PluggableProxy class >> on: anObject [ + "Answer a proxy to be used to save anObject. The proxy + stores a different object obtained by sending to anObject + the #binaryRepresentationObject message (embedded + between #preStore and #postStore as usual)." + + + anObject preStore. + ^[super on: anObject binaryRepresentationObject] + ensure: [anObject postStore] + ] + + object [ + "Reconstruct the object stored in the proxy and answer it; + the binaryRepresentationObject is sent the + #reconstructOriginalObject message, and the resulting + object is sent the #postLoad message." + + + ^(super object reconstructOriginalObject) + postLoad; + yourself + ] +] + + + +NullProxy subclass: VersionableObjectProxy [ + + + + + VersionableObjectProxy class >> loadFrom: anObjectDumper [ + "Retrieve the object. If the version number doesn't match the + #binaryRepresentationVersion answered by the class, call the class' + #convertFromVersion:withFixedVariables:instanceVariables:for: method. + The stored version number will be the first parameter to that method + (or nil if the stored object did not employ a VersionableObjectProxy), + the remaining parameters will be respectively the fixed instance + variables, the indexed instance variables (or nil if the class is + fixed), and the ObjectDumper itself. + If no VersionableObjectProxy, the class is sent #nonVersionedInstSize + to retrieve the number of fixed instance variables stored for the + non-versioned object." + + + | version object instSize | + version := anObjectDumper nextLong. + version := version >= 0 + ifTrue: + ["The version was actually an object index -- move back in the stream." + + anObjectDumper stream skip: -4. + instSize := nil. + nil] + ifFalse: + [instSize := anObjectDumper nextUlong. + -1 - version]. + ^ anObjectDumper loadFromVersion: version fixedSize: instSize + ] + + dumpTo: anObjectDumper [ + "Save the object with extra versioning information." + + + anObjectDumper + nextPutLong: -1 - self object class binaryRepresentationVersion; + nextPutLong: self object class instSize. + super dumpTo: anObjectDumper + ] +] + + + +AlternativeObjectProxy subclass: SingletonProxy [ + + + + + SingletonProxy class [ + | singletons | + + ] + + SingletonProxy class >> singletons [ + + ^singletons isNil + ifTrue: [singletons := IdentityDictionary new] + ifFalse: [singletons] + ] + + SingletonProxy class >> acceptUsageForClass: aClass [ + "The receiver was asked to be used as a proxy for the class aClass. + The registration is fine if the class is actually a singleton." + + + | singleton | + singleton := aClass someInstance. + singleton nextInstance isNil ifFalse: [^false]. + self singletons at: aClass put: singleton. + ^true + ] + + SingletonProxy class >> on: anObject [ + "Answer a proxy to be used to save anObject. The proxy + stores the class and restores the object by looking into + a dictionary of class -> singleton objects." + + + (self singletons includesKey: anObject class) + ifTrue: [^super on: anObject class]. + self error: 'class not registered within SingletonProxy' + ] + + object [ + "Reconstruct the object stored in the proxy and answer it; + the binaryRepresentationObject is sent the + #reconstructOriginalObject message, and the resulting + object is sent the #postLoad message." + + + ^self class singletons at: super object + ifAbsent: [self error: 'class not registered within SingletonProxy'] + ] +] + diff --git a/packages/object-dumper/package.xml b/packages/object-dumper/package.xml new file mode 100644 index 0000000..00702d5 --- /dev/null +++ b/packages/object-dumper/package.xml @@ -0,0 +1,12 @@ + + ObjectDumper + + + ObjectDumperTest + ObjectDumperTest.st + + + ObjDumper.st + Proxy.st + Init.st + diff --git a/packages/object-dumper/stamp-classes b/packages/object-dumper/stamp-classes new file mode 100644 index 0000000..e69de29 diff --git a/packages/sandstonedb/Makefile.frag b/packages/sandstonedb/Makefile.frag index 70d945a..8142edc 100644 --- a/packages/sandstonedb/Makefile.frag +++ b/packages/sandstonedb/Makefile.frag @@ -1,5 +1,5 @@ SandstoneDb_FILES = \ -packages/sandstonedb/Core/Extensions.st packages/sandstonedb/Core/SDRecordMarker.st packages/sandstonedb/Core/SDAbstractStore.st packages/sandstonedb/Core/SDCachedStore.st packages/sandstonedb/Store/SDFileStore.st packages/sandstonedb/Store/SDMemoryStore.st packages/sandstonedb/Core/SDConcurrentDictionary.st packages/sandstonedb/Core/UUID.st packages/sandstonedb/Core/SDCheckPointer.st packages/sandstonedb/Core/SDActiveRecord.st packages/sandstonedb/Core/SDError.st packages/sandstonedb/Core/SDLoadError.st packages/sandstonedb/Core/SDCommitError.st packages/sandstonedb/Tests/SDGrandChildMock.st packages/sandstonedb/Tests/SDChildMock.st packages/sandstonedb/Tests/FooObject.st packages/sandstonedb/Tests/Extensions.st packages/sandstonedb/Tests/SDManMock.st packages/sandstonedb/Tests/SDWomanMock.st packages/sandstonedb/Tests/SDActiveRecordTest.st packages/sandstonedb/Tests/SDFileStoreTest.st packages/sandstonedb/Tests/SDPersonMock.st packages/sandstonedb/Tests/SDMemoryStoreTest.st +packages/sandstonedb/Core/Extensions.st packages/sandstonedb/Core/SDRecordMarker.st packages/sandstonedb/Core/SDAbstractStore.st packages/sandstonedb/Core/SDCachedStore.st packages/sandstonedb/Store/SDFileStore.st packages/sandstonedb/Store/SDMemoryStore.st packages/sandstonedb/Core/SDConcurrentDictionary.st packages/sandstonedb/Core/UUID.st packages/sandstonedb/Core/SDCheckPointer.st packages/sandstonedb/Core/SDActiveRecord.st packages/sandstonedb/Core/SDError.st packages/sandstonedb/Core/SDLoadError.st packages/sandstonedb/Core/SDCommitError.st packages/sandstonedb/Tests/Extensions.st packages/sandstonedb/Tests/SDPersonMock.st packages/sandstonedb/Tests/SDManMock.st packages/sandstonedb/Tests/SDWomanMock.st packages/sandstonedb/Tests/SDChildMock.st packages/sandstonedb/Tests/SDGrandChildMock.st packages/sandstonedb/Tests/FooObject.st packages/sandstonedb/Tests/SDActiveRecordTest.st packages/sandstonedb/Tests/SDMemoryStoreTest.st packages/sandstonedb/Tests/SDFileStoreTest.st $(SandstoneDb_FILES): $(srcdir)/packages/sandstonedb/stamp-classes: $(SandstoneDb_FILES) touch $(srcdir)/packages/sandstonedb/stamp-classes diff --git a/packages/sandstonedb/package.xml b/packages/sandstonedb/package.xml index abbd766..9f50429 100644 --- a/packages/sandstonedb/package.xml +++ b/packages/sandstonedb/package.xml @@ -1,6 +1,9 @@ SandstoneDb SandstoneDb + + ObjectDumper + Tests/Extensions.st Tests/SDPersonMock.st diff --git a/packages/sockets/package.xml b/packages/sockets/package.xml index fd9e7b5..439c754 100644 --- a/packages/sockets/package.xml +++ b/packages/sockets/package.xml @@ -2,6 +2,8 @@ Sockets Sockets + ObjectDumper + TCPaccept Buffers.st diff --git a/snprintfv/snprintfv/filament.h b/snprintfv/snprintfv/filament.h index 4a91eb6..8a7ce6c 100644 --- a/snprintfv/snprintfv/filament.h +++ b/snprintfv/snprintfv/filament.h @@ -1,4 +1,4 @@ -#line 1 "../../../snprintfv/snprintfv/filament.in" +#line 1 "./filament.in" /* -*- Mode: C -*- */ /* filament.h --- a bit like a string but different =)O| @@ -118,7 +118,7 @@ extern char * fildelete (Filament *fil); extern void _fil_extend (Filament *fil, size_t len, boolean copy); -#line 61 "../../../snprintfv/snprintfv/filament.in" +#line 61 "./filament.in" /* Save the overhead of a function call in the great majority of cases. */ #define fil_maybe_extend(fil, len, copy) \ diff --git a/snprintfv/snprintfv/printf.h b/snprintfv/snprintfv/printf.h index 49a2e9f..1437dd5 100644 --- a/snprintfv/snprintfv/printf.h +++ b/snprintfv/snprintfv/printf.h @@ -1,4 +1,4 @@ -#line 1 "../../../snprintfv/snprintfv/printf.in" +#line 1 "./printf.in" /* -*- Mode: C -*- */ /* printf.in --- printf clone for argv arrays @@ -266,7 +266,7 @@ enum } \ } SNV_STMT_END -#line 269 "../../../snprintfv/snprintfv/printf.in" +#line 269 "./printf.in" /** * printf_generic_info: * @pinfo: the current state information for the format @@ -302,7 +302,7 @@ extern int printf_generic_info (struct printf_info *const pinfo, size_t n, int * extern int printf_generic (STREAM *stream, struct printf_info *const pinfo, union printf_arg const *args); -#line 270 "../../../snprintfv/snprintfv/printf.in" +#line 270 "./printf.in" /** * register_printf_function: * @spec: the character which will trigger @func, cast to an unsigned int. @@ -789,7 +789,7 @@ extern int snv_vasprintf (char **result, const char *format, va_list ap); extern int snv_asprintfv (char **result, const char *format, snv_constpointer const args[]); -#line 271 "../../../snprintfv/snprintfv/printf.in" +#line 271 "./printf.in" /* If you don't want to use snprintfv functions for *all* of your string formatting API, then define COMPILING_SNPRINTFV_C and use the snv_ diff --git a/snprintfv/snprintfv/stream.h b/snprintfv/snprintfv/stream.h index 496bd33..0bebce1 100644 --- a/snprintfv/snprintfv/stream.h +++ b/snprintfv/snprintfv/stream.h @@ -1,4 +1,4 @@ -#line 1 "../../../snprintfv/snprintfv/stream.in" +#line 1 "./stream.in" /* -*- Mode: C -*- */ /* stream.h --- customizable stream routines @@ -180,7 +180,7 @@ extern int stream_puts (char *s, STREAM *stream); extern int stream_get (STREAM *stream); -#line 88 "../../../snprintfv/snprintfv/stream.in" +#line 88 "./stream.in" #ifdef __cplusplus #if 0 /* This brace is so that emacs can still indent properly: */ diff --git a/tests/Makefile.am b/tests/Makefile.am index 0b1764b..f227386 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -13,7 +13,7 @@ floatmath.ok floatmath.st getopt.ok getopt.st geometry.ok geometry.st hash.ok \ hash.st hash2.ok hash2.st heapsort.ok heapsort.st intmath.ok intmath.st \ lists.ok lists.st lists1.ok lists1.st lists2.ok lists2.st matrix.ok \ matrix.st methcall.ok methcall.st mutate.ok mutate.st nestedloop.ok \ -nestedloop.st objdump.ok objdump.st objects.ok objects.st objinst.ok \ +nestedloop.st objects.ok objects.st objinst.ok \ objinst.st processes.ok processes.st prodcons.ok prodcons.st quit.ok \ quit.st random-bench.ok random-bench.st untrusted.ok untrusted.st sets.ok \ sets.st sieve.ok sieve.st strcat.ok strcat.st strings.ok strings.st \ diff --git a/tests/objdump.ok b/tests/objdump.ok deleted file mode 100644 index 2882996..0000000 --- a/tests/objdump.ok +++ /dev/null @@ -1,25 +0,0 @@ - -Execution begins... -returned value is true - -Execution begins... -returned value is true - -Execution begins... -returned value is true - -Execution begins... -returned value is true - -Execution begins... -returned value is true - -Execution begins... -returned value is true - -Execution begins... -returned value is true - -Execution begins... -nil -returned value is true diff --git a/tests/objdump.st b/tests/objdump.st deleted file mode 100644 index c3e0bbc..0000000 --- a/tests/objdump.st +++ /dev/null @@ -1,91 +0,0 @@ -"====================================================================== -| -| Test ObjectDumper operations -| -| - ======================================================================" - - -"====================================================================== -| -| Copyright (C) 2002, 2007, 2008, 2009 Free Software Foundation. -| Written by Paolo Bonzini and Markus Fritsche -| -| This file is part of GNU Smalltalk. -| -| GNU Smalltalk is free software; you can redistribute it and/or modify it -| under the terms of the GNU General Public License as published by the Free -| Software Foundation; either version 2, or (at your option) any later version. -| -| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT -| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -| details. -| -| You should have received a copy of the GNU General Public License along with -| GNU Smalltalk; see the file COPYING. If not, write to the Free Software -| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. -| - ======================================================================" - -Eval [ - stream := (String new: 1024) readWriteStream. - (ObjectDumper on: stream) dump: Array. - stream reset. - ^(ObjectDumper on: stream) load == Array -] - -Eval [ - stream := (String new: 1024) readWriteStream. - (ObjectDumper on: stream) dump: #('asdf' 1 2 $a). - stream reset. - ^(ObjectDumper on: stream) load = #('asdf' 1 2 $a) -] - -Eval [ - stream := (String new: 1024) readWriteStream. - method := Object >> #yourself. - (ObjectDumper on: stream) dump: method. - stream reset. - ^(ObjectDumper on: stream) load == method -] - -Eval [ - stream := (String new: 1024) readWriteStream. - array := Array new: 1. - array at: 1 put: array. - (ObjectDumper on: stream) dump: array. - stream reset. - secondArray := (ObjectDumper on: stream) load. - ^secondArray == (secondArray at: 1) -] - -Eval [ - stream := (String new: 1024) readWriteStream. - (ObjectDumper on: stream) dump: Processor. - stream reset. - ^(ObjectDumper on: stream) load == Processor -] - -Eval [ - stream := (String new: 1024) readWriteStream. - (ObjectDumper on: stream) dump: 'asdf'. - stream reset. - ^(ObjectDumper on: stream) load = 'asdf' -] - -Eval [ - stream := (String new: 1024) writeStream. - (ObjectDumper on: stream) dump: #('asdf' 1 2 $a). - ^(ObjectDumper on: stream readStream) load = #('asdf' 1 2 $a) -] - -Eval [ - | x y | - stream := String new readStream. - y := [ (ObjectDumper on: stream) load ] - on: SystemExceptions.EndOfStream - do: [ :ex | x := true. ex resume: ex defaultAction ]. - y printNl. - ^x -] diff --git a/tests/testsuite.at b/tests/testsuite.at index ffa3919..4be63b6 100644 --- a/tests/testsuite.at +++ b/tests/testsuite.at @@ -40,7 +40,6 @@ AT_DIFF_TEST([dates.st]) AT_DIFF_TEST([objects.st]) AT_DIFF_TEST([strings.st]) AT_DIFF_TEST([chars.st]) -AT_DIFF_TEST([objdump.st]) AT_DIFF_TEST([delays.st]) AT_DIFF_TEST([geometry.st]) AT_DIFF_TEST([cobjects.st]) @@ -158,6 +157,7 @@ AT_OPTIONAL_PACKAGE_TEST([GDBM]) AT_OPTIONAL_PACKAGE_TEST([Iconv]) AT_PACKAGE_TEST([Magritte]) AT_OPTIONAL_PACKAGE_TEST([ROE]) +AT_PACKAGE_TEST([ObjectDumper]) AT_PACKAGE_TEST([SandstoneDb]) AT_OPTIONAL_PACKAGE_TEST([Seaside-Core]) AT_OPTIONAL_PACKAGE_TEST([Sockets], [AT_XFAIL_IF(:)]) -- 1.7.4.1