Merge pull request #14 from OpenSmock/toplo

Toplo ready

src/Bloc-Serialization-STON/BlDirectEventDispatcher.extension.st

@@ -1,14 +1,5 @@
 Extension { #name : #BlDirectEventDispatcher }
 
-{ #category : #'*Bloc-Serialization-STON' }
-BlDirectEventDispatcher >> fromSton: stonReader [
-
-	stonReader parseMapDo: [ :key :value | 
-		key = #handlers ifTrue: [ value do: [ :each | self addEventHandler: each ] ].
-		key = #owner ifTrue: [ self owner: value ] 
-	]
-]
-
 { #category : #'*Bloc-Serialization-STON' }
 BlDirectEventDispatcher class >> fromSton: stonReader [
 
@@ -19,30 +10,3 @@ BlDirectEventDispatcher class >> fromSton: stonReader [
 		  fromSton: stonReader;
 		  yourself
 ]
-
-{ #category : #'*Bloc-Serialization-STON' }
-BlDirectEventDispatcher >> stonOn: stonWriter [
-
-	stonWriter writeObject: self streamMap: [ :map | 
-		map
-			at: #owner put: self owner;
-			at: #handlers put: self handlers 
-	]
-]
-
-{ #category : #'*Bloc-Serialization-STON' }
-BlDirectEventDispatcher >> stonProcessSubObjects: block [
-
-	"Custom to ignore cycling in BlElement ownership"
-	1 to: self class instSize do: [ :each | 
-		((self instVarAt: each) isKindOf: BlElement) ifFalse: [ 
-			self instVarAt: each put: (block value: (self instVarAt: each)) 
-		]. 
-	].
-
-	(self class isVariable and: [ self class isBytes not ]) ifTrue: [ 
-		1 to: self basicSize do: [ :each | 
-			self basicAt: each put: (block value: (self basicAt: each)) 
-		]. 
-	].
-]

src/Bloc-Serialization-STON/BlElement.extension.st

@@ -11,33 +11,99 @@ BlElement >> stonOn: stonWriter [
 
 	| previousData copyData |
 	previousData := self userData.
-	copyData := previousData copy.
-
-	copyData removeKey: #blocProperties ifAbsent: [nil].
-	copyData removeKey: #blocStates ifAbsent: [nil].
-	copyData removeKey: #blocPreviousMeasurementSpec ifAbsent: [nil].
-	copyData removeKey: #blocStyles ifAbsent: [nil].
+	copyData := IdentityDictionary new.
+	self stonUserDataOn: copyData.
 
 	userData := copyData.
-	stonWriter writeObject: self.
-	userData := previousData.
+	self shouldSerializedChildren
+		ifFalse: [ self stonOnWithoutChildren: stonWriter ]
+		ifTrue: [ self stonOnWithChildren: stonWriter ].
+	userData := previousData
+]
+
+{ #category : #'*Bloc-Serialization-STON' }
+BlElement >> stonOn: stonWriter withInstanceVariables: instanceVariableNames [
+
+	instanceVariableNames  isEmpty
+		ifTrue: [
+		stonWriter writeObject: self do: [ stonWriter encodeMap: #(  ) ] ]
+		ifFalse: [
+			stonWriter writeObject: self streamMap: [ :dictionary |
+				(instanceVariableNames ) do: [
+					:each |
+					(self instVarNamed: each)
+						ifNotNil: [ :value | dictionary at: each asSymbol put: value ]
+						ifNil: [
+							self stonShouldWriteNilInstVars ifTrue: [
+								dictionary at: each asSymbol put: nil ] ] ] ] ]
+]
+
+{ #category : #'*Bloc-Serialization-STON' }
+BlElement >> stonOnWithChildren: stonWriter [
+
+	self stonOn: stonWriter withInstanceVariables: (self class stonAllInstVarNames)
+]
+
+{ #category : #'*Bloc-Serialization-STON' }
+BlElement >> stonOnWithoutChildren: stonWriter [
+
+
+	self
+		stonOn: stonWriter
+		withInstanceVariables: (self class stonAllInstVarNames reject: [ :each | each = #children ])
+
 ]
 
 { #category : #'*Bloc-Serialization-STON' }
 BlElement >> stonPostReferenceResolution [
 
-	self childrenDo: [ :child | child parent: self ]
+	self childrenDo: [ :child | child parent: self ].
+
+	self flag: #danger.
+	"For Toplo / should work even if Toplo is not loaded."
+	self userData at: #toTheme ifPresent: [ :aTheme |
+		self userData removeKey: #toTheme.
+		self perform: #toTheme: with: aTheme ].
+	self userData at: #stamps ifPresent: [ :aCollection | aCollection do: [ :assoc | self perform: #addStamp:withValue: with: assoc key with: assoc value ] ].
+	self userData at: #tokens ifPresent: [ :aCollection | aCollection do: [ :assoc | self perform: #addTokenNamed:withValue: with: assoc key with: assoc value ] ]
 ]
 
 { #category : #'*Bloc-Serialization-STON' }
 BlElement >> stonProcessSubObjects: block [
-
 	"Custom to ignore cycling in BlElement ownership"
 
-	1 to: self class instSize do: [ :each | 
-		((self instVarAt: each) isKindOf: BlElement) ifFalse: [ 
-			self instVarAt: each put: (block value: (self instVarAt: each)) ] ].
-	(self class isVariable and: [ self class isBytes not ]) ifTrue: [ 
-		1 to: self basicSize do: [ :each | 
-		self basicAt: each put: (block value: (self basicAt: each)) ] ]
+	| instanceVariables instanceToRemove |
+	instanceVariables := self class stonAllInstVarNames.
+	instanceToRemove := OrderedCollection new.
+	self shouldSerializedChildren ifFalse: [
+		instanceToRemove add: #children ].
+	visuals = BlDefaultVisuals uniqueInstance ifTrue: [ instanceToRemove add: #visuals ].
+	instanceVariables := instanceVariables reject: [ :each | instanceToRemove includes: each ]. 
+	instanceVariables do: [ :each |
+		self
+			instVarNamed: each
+			put: (block value: (self instVarNamed: each)) ]
+]
+
+{ #category : #'*Bloc-Serialization-STON' }
+BlElement >> stonUserDataOn: aIdentityDictionary [
+
+	self userData
+		at: #elementId
+		ifPresent: [ :id | aIdentityDictionary at: #elementId put: id ].
+
+	self flag: #danger.
+	"For Toplo / should work even if Toplo is not loaded."
+	self userData
+		at: #toTheme
+		ifPresent: [ :aTheme | aIdentityDictionary at: #toTheme put: aTheme ].
+	self userData at: #toStyleStore ifPresent: [ :aToStyleStore |
+		aIdentityDictionary
+			at: #stamps
+			put:
+			((aToStyleStore perform: #rawStampIndex) perform: #allProperties).
+		aIdentityDictionary
+			at: #tokens
+			put: ((aToStyleStore perform: #rawTokenPropertyIndex) perform:
+					 #allProperties) ]
 ]

src/Bloc-Serialization-Tests/BlElementSerializationTests.class.st

@@ -21,3 +21,11 @@ BlElementSerializationTests >> testSerializeThenMaterialize [
 
 	self assert: element class equals: newElement class.
 ]
+
+{ #category : #tests }
+BlElementSerializationTests >> testShouldSerializedChildren [
+
+	| element |
+	element := BlElement new.
+	self assert: element shouldSerializedChildren.
+]

src/Bloc-Serialization-Tests/BlTestShouldNotSerializedChildrenElement.class.st

@@ -0,0 +1,14 @@
+"
+This BlELement is a used for testing the no serialization of children.
+"
+Class {
+	#name : #BlTestShouldNotSerializedChildrenElement,
+	#superclass : #BlElement,
+	#category : #'Bloc-Serialization-Tests-Core'
+}
+
+{ #category : #asserting }
+BlTestShouldNotSerializedChildrenElement >> shouldSerializedChildren [
+
+	^ false
+]

src/Bloc-Serialization-Tests/BlocSerializationChildrenTests.class.st

@@ -200,3 +200,40 @@ BlocSerializationChildrenTests >> testNoChildren [
 		on: [ :element | self assert: element children size equals: 0.
 			self assert: element parent equals: nil ]
 ]
+
+{ #category : #tests }
+BlocSerializationChildrenTests >> testShouldNotSerializedChildrenBasic1 [
+
+	| origin e1 e2 e3 element |
+	origin := BlTestShouldNotSerializedChildrenElement new.
+	e1 := BlElement new.
+	e2 := BlElement new.
+	e3 := BlElement new.
+
+	origin addChildren: { 
+			e1.
+			e2.
+			e3 }.
+
+	element := origin serializeThenMaterialize. 
+	self assert: element parent equals: nil.
+	self assert: element children size equals: 0.
+]
+
+{ #category : #tests }
+BlocSerializationChildrenTests >> testShouldNotSerializedChildrenBasic2 [
+
+	| origin e1 e2 e3 element |
+	origin := BlTestShouldNotSerializedChildrenElement new.
+	e1 := BlElement new.
+	e2 := BlElement new.
+	e3 := BlElement new.
+
+	origin addChild: e1.
+	e1 addChild: e2.
+	e2 addChild: e3.
+
+	element := origin serializeThenMaterialize. 
+	self assert: element parent equals: nil.
+	self assert: element children size equals: 0.
+]

src/Bloc-Serialization/BlElement.extension.st

@@ -11,3 +11,9 @@ BlElement >> serializeThenMaterialize [
 
 	^ BlSerializer materialize: (BlSerializer serialize: self)
 ]
+
+{ #category : #'*Bloc-Serialization' }
+BlElement >> shouldSerializedChildren [
+
+	^ true
+]