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