Initial port from Pharo
Based on 305ae856d4b551 from https://github.com/svenvc/ston.git
"{ Package: 'stx:goodies/ston' }"
"{ NameSpace: Smalltalk }"
Object subclass:#STONWriter
instanceVariableNames:'writeStream prettyPrint stonCharacters newLine asciiOnly jsonMode
keepNewLines referencePolicy level objects'
classVariableNames:'STONCharacters STONSimpleSymbolCharacters'
poolDictionaries:''
category:'STON-Core-Writer'
!
!STONWriter class methodsFor:'instance creation'!
new
"return an initialized instance"
^ self basicNew initialize.
!
on: writeStream
^ self new
on: writeStream;
yourself
! !
!STONWriter class methodsFor:'class initialization'!
initialize
"Modification timestamp 20170131"
self initializeSTONCharacters.
self initializeSTONSimpleSymbolCharacters
!
initializeSTONCharacters
| escapes |
STONCharacters := Array new: 127.
32 to: 126 do: [ :each |
STONCharacters at: each + 1 put: #pass ].
"This is the minimal STON set of named escapes"
escapes := #( 8 '\b' 9 '\t' 10 '\n' 12 '\f' 13 '\r' 39 '\''' 92 '\\' ).
escapes pairWiseDo: [ :code :escape |
STONCharacters at: code + 1 put: escape ]
"Modified: / 04-06-2019 / 10:59:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
initializeSTONSimpleSymbolCharacters
"STONSimpleSymbolCharacters asArray collectWithIndex: [ :each :index |
each isZero ifTrue: [ (index - 1) asCharacter ] ]."
STONSimpleSymbolCharacters := ByteArray new: 256 withAll: 1.
1 to: 256 do: [ :each | | char |
char := (each - 1) asCharacter.
(self isSimpleSymbolChar: char)
ifTrue: [
STONSimpleSymbolCharacters at: each put: 0 ] ]
! !
!STONWriter class methodsFor:'private'!
isSimpleSymbolChar: char
^ 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_./' includes: char
! !
!STONWriter methodsFor:'accessing'!
jsonMode
^ jsonMode
! !
!STONWriter methodsFor:'error handling'!
error: aString
^ STONWriterError signal: aString
! !
!STONWriter methodsFor:'initialize-release'!
asciiOnly: boolean
asciiOnly := boolean
!
close
writeStream ifNotNil: [
writeStream close.
writeStream := nil ]
!
escape: char with: anObject
"Instruct me to escape char with object, either a replacement string or #pass"
"self escape: $/ with: '\/'."
self assert: (anObject isString | (anObject == #pass)).
self assert: char codePoint < 256.
self writeableStonCharacters at: char codePoint + 1 put: anObject
"Modified: / 04-06-2019 / 11:12:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
initialize
super initialize.
stonCharacters := STONCharacters.
prettyPrint := false.
newLine := Character cr asString.
level := 0.
referencePolicy := #normal.
jsonMode := keepNewLines := asciiOnly := false.
objects := IdentityDictionary new
"Modified: / 04-06-2019 / 10:58:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
jsonMode: boolean
(jsonMode := boolean)
ifTrue: [
self
escape: $' with: #pass;
escape: $" with: '\"' ]
ifFalse: [
self
escape: $" with: #pass;
escape: $' with: '\''' ]
!
keepNewLines: boolean
"If true, any newline CR, LF or CRLF inside strings or symbols will not be escaped
but will instead be converted to the newline convention chosen, see #newLine:
The default is false, where CR, LF or CRLF will be enscaped unchanged."
keepNewLines := boolean
!
newLine: string
"The sequence to use when ending a line, either CR, LF or CRLF"
newLine := string
!
on: aWriteStream
writeStream := aWriteStream
!
optimizeForLargeStructures
self class environment
at: #FLLargeIdentityDictionary
ifPresent: [ :identityDictionaryClass | objects := identityDictionaryClass new ].
!
prettyPrint: boolean
prettyPrint := boolean
!
referencePolicy: policy
self assert: ( #(#normal #ignore #error) includes: policy ).
referencePolicy := policy
!
reset
objects removeAll
! !
!STONWriter methodsFor:'private'!
encodeCharacter: char
| code encoding |
"STONCharacters contains for the lower 127 characters (codes 0 to 126) either nil (unknown),
#pass (output as is, clean ASCII characters) or a full escape string"
((code := char codePoint) < 127 and: [ (encoding := self stonCharacters at: code + 1) notNil ])
ifTrue: [
(encoding = #pass or: [ jsonMode and: [ char = $' ] ])
ifTrue: [ writeStream nextPut: char ]
ifFalse: [ writeStream nextPutAll: encoding ] ]
ifFalse: [
"always escape Latin1 C1 controls, or when asciiOnly is true"
(code > 16r9F and: [ asciiOnly not ])
ifTrue: [ writeStream nextPut: char ]
ifFalse: [ self escapeUnicode: code ] ]
!
encodeKey: key value: value
(jsonMode and: [ key isString not ])
ifTrue: [ self error: 'JSON key names in objects must be strings' ].
self nextPut: key.
self prettyPrintSpace.
writeStream nextPut: $:.
self prettyPrintSpace.
self nextPut: value
!
encodeString: string
writeStream nextPut: (jsonMode ifTrue: [ $" ] ifFalse: [ $' ]).
keepNewLines
ifTrue: [
self encodeStringKeepingNewLines: string ]
ifFalse: [
string do: [ :each | self encodeCharacter: each ] ].
writeStream nextPut: (jsonMode ifTrue: [ $" ] ifFalse: [ $' ])
!
encodeStringKeepingNewLines: string
| input char |
input := string readStream.
[ input atEnd ]
whileFalse: [
char := input next.
char = Character lf
ifTrue: [ writeStream nextPutAll: newLine ]
ifFalse: [
char = Character cr
ifTrue: [
input peekFor: Character lf.
writeStream nextPutAll: newLine ]
ifFalse: [ self encodeCharacter: char ] ] ]
!
escapeUnicode4: codePoint
writeStream nextPutAll: '\u'.
codePoint printOn: writeStream base: 16 nDigits: 4
!
escapeUnicode: codePoint
codePoint <= 16rFFFF
ifTrue: [ self escapeUnicode4: codePoint ]
ifFalse: [
codePoint <= 16r10FFFF
ifTrue: [ | leadSurrogate trailSurrogate shifted |
"Characters not in the Basic Multilingual Plane are encoded as a UTF-16 surrogate pair"
"See https://tools.ietf.org/html/rfc7159#section-7"
shifted := codePoint - 16r10000.
leadSurrogate := 16rD800 + (shifted // 16r400).
trailSurrogate := 16rDC00 + (shifted \\ 16r400).
self escapeUnicode4: leadSurrogate.
self escapeUnicode4: trailSurrogate ]
ifFalse: [ self error: 'Character Unicode code point outside encoder range' ] ]
!
indentedDo: block
level := level + 1.
block value.
level := level - 1
!
isSimpleSymbol: symbol
symbol isEmpty ifTrue: [ ^ false ].
^ (symbol class
findFirstInString: symbol
inSet: STONSimpleSymbolCharacters
startingAt: 1) = 0
!
listElementSeparator
writeStream nextPut: $,.
self newlineIndent
!
mapElementSeparator
writeStream nextPut: $,.
self newlineIndent
!
newlineIndent
prettyPrint ifTrue: [
writeStream nextPutAll: newLine.
level timesRepeat: [ writeStream tab ] ]
!
prettyPrintSpace
prettyPrint ifTrue: [ writeStream space ]
!
shortListElementSeparator
writeStream nextPut: $,.
self prettyPrintSpace
!
stonCharacters
^ stonCharacters ifNil: [ stonCharacters := STONCharacters ]
!
with: object do: block
| index |
referencePolicy = #ignore
ifTrue: [ ^ block value ].
(index := objects at: object ifAbsent: [ nil ]) notNil
ifTrue: [
referencePolicy = #error
ifTrue: [ ^ self error: 'shared reference detected' ].
self writeReference: index ]
ifFalse: [
index := objects size + 1.
objects at: object put: index.
block value ]
!
writeableStonCharacters
^ self stonCharacters == STONCharacters
ifTrue: [ stonCharacters := stonCharacters copy ]
ifFalse: [ stonCharacters ]
! !
!STONWriter methodsFor:'public'!
nextPut: anObject
anObject stonOn: self
! !
!STONWriter methodsFor:'writing'!
encodeList: elements
writeStream nextPut: $[.
elements isEmpty
ifTrue: [
self prettyPrintSpace ]
ifFalse: [
self indentedDo: [
self newlineIndent.
elements
do: [ :each | self nextPut: each ]
separatedBy: [ self listElementSeparator ] ].
self newlineIndent ].
writeStream nextPut: $]
!
encodeMap: pairs
| first |
first := true.
writeStream nextPut: ${.
pairs isEmpty
ifTrue: [
self prettyPrintSpace ]
ifFalse: [
self indentedDo: [
self newlineIndent.
pairs keysAndValuesDo: [ :key :value |
first
ifTrue: [ first := false ]
ifFalse: [ self mapElementSeparator ].
self encodeKey: key value: value ] ].
self newlineIndent ].
writeStream nextPut: $}
!
writeAssociation: association
jsonMode
ifTrue: [ self error: 'wrong object class for JSON mode' ].
self
encodeKey: association key
value: association value
!
writeBoolean: boolean
writeStream print: boolean
!
writeFloat: float
writeStream print: float
!
writeFraction: fraction
jsonMode
ifTrue: [ self writeFloat: fraction asFloat ]
ifFalse: [ writeStream
print: fraction numerator;
nextPut: $/;
print: fraction denominator ]
!
writeInteger: integer
writeStream print: integer
!
writeList: collection
self with: collection do: [
self encodeList: collection ]
!
writeMap: hashedCollection
self with: hashedCollection do: [
self encodeMap: hashedCollection ]
!
writeNull
jsonMode
ifTrue: [ writeStream nextPutAll: 'null' ]
ifFalse: [ writeStream print: nil ]
!
writeObject: anObject
| instanceVariableNames |
(instanceVariableNames := anObject class stonAllInstVarNames) isEmpty
ifTrue: [
self writeObject: anObject do: [ self encodeMap: #() ] ]
ifFalse: [
self writeObject: anObject streamMap: [ :dictionary |
instanceVariableNames do: [ :each |
| value |
(value := anObject instVarNamed: each) notNil
ifTrue: [
dictionary at: each asSymbol put: value ]
ifFalse: [
anObject stonShouldWriteNilInstVars
ifTrue: [ dictionary at: each asSymbol put: nil ] ] ] ] ]
!
writeObject: anObject do: block
(jsonMode and: [ anObject class ~= STON listClass and: [ anObject class ~= STON mapClass and: [anObject class ~= ImmutableArray ] ] ])
ifTrue: [ self error: 'wrong object class for JSON mode' ].
self with: anObject do: [
writeStream nextPutAll: anObject class stonName.
self prettyPrintSpace.
block value ]
"Modified: / 20-05-2020 / 11:07:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
writeObject: object listSingleton: element
self writeObject: object do: [
writeStream nextPut: $[.
self
prettyPrintSpace;
nextPut: element;
prettyPrintSpace.
writeStream nextPut: $] ]
!
writeObject: anObject named: stonName do: block
(jsonMode and: [ anObject class ~= STON listClass and: [ anObject class ~= STON mapClass ] ])
ifTrue: [ self error: 'wrong object class for JSON mode' ].
self with: anObject do: [
writeStream nextPutAll: stonName.
self prettyPrintSpace.
block value ]
!
writeObject: object named: stonName listSingleton: element
self writeObject: object named: stonName do: [
writeStream nextPut: $[.
self
prettyPrintSpace;
nextPut: element;
prettyPrintSpace.
writeStream nextPut: $] ]
!
writeObject: object streamList: block
self writeObject: object do: [ | listWriter |
listWriter := STONListWriter on: self.
writeStream nextPut: $[.
self indentedDo: [
self newlineIndent.
block value: listWriter ].
self newlineIndent.
writeStream nextPut: $] ]
!
writeObject: object streamMap: block
self writeObject: object do: [ | mapWriter |
mapWriter := STONMapWriter on: self.
writeStream nextPut: ${.
self indentedDo: [
self newlineIndent.
block value: mapWriter ].
self newlineIndent.
writeStream nextPut: $} ]
!
writeObject: object streamShortList: block
self writeObject: object do: [ | listWriter |
listWriter := STONShortListWriter on: self.
writeStream nextPut: $[.
self indentedDo: [
self prettyPrintSpace.
block value: listWriter ].
self prettyPrintSpace.
writeStream nextPut: $] ]
!
writeReference: index
writeStream
nextPut: $@;
print: index
!
writeScaledDecimal: scaledDecimal
jsonMode
ifTrue: [ self writeFloat: scaledDecimal asFloat ]
ifFalse: [ writeStream
print: scaledDecimal numerator;
nextPut: $/;
print: scaledDecimal denominator;
nextPut: $s;
print: scaledDecimal scale ]
!
writeString: string
self encodeString: string
!
writeSymbol: symbol
jsonMode
ifTrue: [
self writeString: symbol ]
ifFalse: [
writeStream nextPut: $#.
(self isSimpleSymbol: symbol)
ifTrue: [
writeStream nextPutAll: symbol ]
ifFalse: [
self encodeString: symbol ] ]
! !
!STONWriter class methodsFor:'documentation'!
version_HG
^ '$Changeset: <not expanded> $'
! !
STONWriter initialize!