[squeak-dev] The Trunk: JSON-tonyg.25.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Sep 8 14:57:25 UTC 2022
Christoph Thiede uploaded a new version of JSON to project The Trunk:
http://source.squeak.org/trunk/JSON-tonyg.25.mcz
==================== Summary ====================
Name: JSON-tonyg.25
Author: tonyg
Time: 21 August 2009, 11:00:03 pm
UUID: 45705127-0bf3-4f62-8652-83d3ef15bf33
Ancestors: JSON-avi.24, JSON-ul.15
Merge avi.24 with ul.15, fix the tests, rudimentary (and possibly incorrect?) support for non-ASCII characters in strings, Improvements to JsonObject to get it past the tests,
==================== Snapshot ====================
SystemOrganization addCategory: #JSON!
----- Method: ArrayedCollection>>jsonWriteOn: (in category '*JSON-writing') -----
jsonWriteOn: aStream
aStream nextPut: $[.
self size > 0 ifTrue: [
(self at: 1) jsonWriteOn: aStream.
2 to: self size do: [ :index |
aStream nextPut: $,.
(self at: index) jsonWriteOn: aStream ] ].
aStream nextPut: $]!
Object subclass: #Json
instanceVariableNames: 'stream ctorMap'
classVariableNames: ''
poolDictionaries: ''
category: 'JSON'!
Json class
instanceVariableNames: 'escapeArray'!
!Json commentStamp: '<historical>' prior: 0!
This class reads and writes JSON format data - strings, numbers, boolean, nil, arrays and dictionaries. See http://www.crockford.com/JSON/index.html. It has been extended with syntax for invoking a prearranged list of constructors on read objects.!
Json class
instanceVariableNames: 'escapeArray'!
----- Method: Json class>>escapeForCharacter: (in category 'as yet unclassified') -----
escapeForCharacter: c
| index |
^ (index := c asciiValue + 1) <= escapeArray size
ifTrue: [ ^ escapeArray at: index ]
ifFalse: [ ^ '\u', ((c asciiValue bitAnd: 16rFFFF) printStringBase: 16) ]!
----- Method: Json class>>initialize (in category 'as yet unclassified') -----
initialize
"Json initialize."
escapeArray := Array new: 128.
(0 to: 31), #(127) do: [ :each |
escapeArray at: each + 1 put: '\u', (each printStringHex padded: #left to: 4 with: $0) ].
{
$" -> '\"'.
$\ -> '\\'.
Character backspace -> '\b'.
Character lf -> '\n'.
Character newPage -> '\f'.
Character cr -> '\r'.
Character tab -> '\t'.
} do: [ :each |
escapeArray at: each key asciiValue + 1 put: each value ].
!
----- Method: Json class>>mimeType (in category 'as yet unclassified') -----
mimeType
^ 'application/x-json'!
----- Method: Json class>>newWithConstructors: (in category 'as yet unclassified') -----
newWithConstructors: aCollection
| m |
m _ Dictionary new.
aCollection do: [:each |
(each isKindOf: Association)
ifTrue: [m add: each]
ifFalse: [m at: each name asString put: each]].
^ self new ctorMap: m; yourself.!
----- Method: Json class>>numbersMayContain: (in category 'as yet unclassified') -----
numbersMayContain: aChar
^ aChar isDigit or: [#($- $+ $. $e $E) includes: aChar]!
----- Method: Json class>>readFrom: (in category 'as yet unclassified') -----
readFrom: aStream
^ self new readFrom: aStream.!
----- Method: Json class>>render: (in category 'as yet unclassified') -----
render: anObject
| s |
s := WriteStream on: String new.
anObject jsonWriteOn: s.
^ s contents.!
----- Method: Json class>>render:withConstructor:on: (in category 'as yet unclassified') -----
render: anObject withConstructor: aConstructorName on: aStream
aStream nextPutAll: '@', aConstructorName.
anObject jsonWriteOn: aStream.
!
----- Method: Json class>>renderInstanceVariables:of:on: (in category 'as yet unclassified') -----
renderInstanceVariables: aCollection of: anObject on: aStream
| map |
map _ Dictionary new.
aCollection do: [:ivarName | map at: ivarName put: (anObject instVarNamed: ivarName)].
self render: map withConstructor: anObject class name asString on: aStream!
----- Method: Json>>consume:returning: (in category 'private') -----
consume: aString returning: anObject
aString do: [:c | self next == c ifFalse: [JsonSyntaxError signal: 'Expected ''', aString, ''''] ].
^ anObject!
----- Method: Json>>ctorMap (in category 'accessing') -----
ctorMap
^ ctorMap!
----- Method: Json>>ctorMap: (in category 'accessing') -----
ctorMap: m
ctorMap _ m!
----- Method: Json>>interpretStringEscape (in category 'private') -----
interpretStringEscape
| c |
c := self next.
c == $b ifTrue: [^ Character backspace].
c == $n ifTrue: [^ Character lf].
c == $f ifTrue: [^ Character newPage].
c == $r ifTrue: [^ Character cr].
c == $t ifTrue: [^ Character tab].
c == $u ifTrue: [^ self unescapeUnicode].
^ c.!
----- Method: Json>>next (in category 'private') -----
next
^ self stream next!
----- Method: Json>>peek (in category 'private') -----
peek
^ self stream peek!
----- Method: Json>>readAny (in category 'parsing') -----
readAny
"This is the main entry point for the JSON parser. See also readFrom: on the class side."
| c |
self skipWhitespace.
c := self peek asLowercase.
c == ${ ifTrue: [self next. ^ self readDictionary].
c == $[ ifTrue: [self next. ^ self readArray].
c == $" ifTrue: [self next. ^ self readString].
c == $t ifTrue: [^ self consume: 'true' returning: true].
c == $f ifTrue: [^ self consume: 'false' returning: false].
c == $n ifTrue: [^ self consume: 'null' returning: nil].
c == $@ ifTrue: [self next. ^ self readConstructor].
(Json numbersMayContain: c) ifTrue: [^ self readNumber].
JsonSyntaxError signal: 'Unknown Json input'!
----- Method: Json>>readArray (in category 'private') -----
readArray
| a needComma |
a := OrderedCollection new.
needComma _ false.
[
self skipWhitespace.
self peek == $] ifTrue: [self next. ^ a asArray].
needComma
ifTrue: [self peek == $, ifFalse: [JsonSyntaxError signal: 'Missing comma'].
self next.]
ifFalse: [needComma _ true].
a add: self readAny.
] repeat.
!
----- Method: Json>>readConstructor (in category 'private') -----
readConstructor
| s c v ctor |
s := WriteStream on: ''.
[
c := self peek.
c ifNil: [JsonSyntaxError signal: 'Premature EOF reading constructor name'].
((c == $.) or: [c isLetter])
ifTrue: [s nextPut: c. self next]
ifFalse: [
v := self readAny.
s := s contents.
ctor _ ctorMap ifNotNil: [ctor _ ctorMap at: s ifAbsent: [nil]].
ctor ifNil: [JsonSyntaxError signal: 'Unknown ctor ', s].
^ ctor constructFromJson: v]
] repeat.
!
----- Method: Json>>readDictionary (in category 'private') -----
readDictionary
| m k v needComma |
m := JsonObject new.
needComma _ false.
[
self skipWhitespace.
self peek == $} ifTrue: [self next. ^ m].
needComma
ifTrue: [self peek == $, ifFalse: [JsonSyntaxError signal: 'Missing comma'].
self next. self skipWhitespace]
ifFalse: [needComma _ true.].
self next == $" ifFalse: [JsonSyntaxError signal: 'Key in dictionary must be string'].
k := self readString.
self skipWhitespace.
self peek == $: ifFalse: [JsonSyntaxError signal: 'Missing colon'].
self next.
v := self readAny.
m at: k put: v.
] repeat.
!
----- Method: Json>>readFrom: (in category 'parsing') -----
readFrom: aStream
self stream: aStream.
^ self readAny!
----- Method: Json>>readNumber (in category 'private') -----
readNumber
| acc c |
acc := WriteStream on: ''.
[
c := self peek.
(c isNil not and: [Json numbersMayContain: c]) ifFalse: [
[^ acc contents asNumber] on: Error do: [JsonSyntaxError signal: 'Invalid number']].
acc nextPut: c.
self next.
] repeat.!
----- Method: Json>>readString (in category 'private') -----
readString
| s c |
s := WriteStream on: ''.
[
c := self next.
c == $\
ifTrue: [s nextPut: self interpretStringEscape.]
ifFalse: [c == $" ifTrue: [^ s contents.].
s nextPut: c]
] repeat.!
----- Method: Json>>skipComment (in category 'private') -----
skipComment
self peek == $/ ifTrue: [
self next.
self peek == $/
ifTrue: [self skipToEndOfLine]
ifFalse: [self peek == $*
ifTrue: [self next. self skipCommentBody]
ifFalse: [JsonSyntaxError signal: 'Invalid comment syntax']]]
!
----- Method: Json>>skipCommentBody (in category 'private') -----
skipCommentBody
[
[self next == $*] whileFalse.
self peek == $/
] whileFalse.
self next. "skip that last slash"
self skipWhitespace.!
----- Method: Json>>skipToEndOfLine (in category 'private') -----
skipToEndOfLine
[self peek == Character cr or: [self peek == Character lf]] whileFalse: [self next].
self skipWhitespace!
----- Method: Json>>skipWhitespace (in category 'private') -----
skipWhitespace
[self peek isSeparator] whileTrue: [self next].
self skipComment.!
----- Method: Json>>stream (in category 'accessing') -----
stream
"Answer the value of stream"
^ stream!
----- Method: Json>>stream: (in category 'accessing') -----
stream: anObject
"Set the value of stream"
stream := anObject.
(stream respondsTo: #reset) ifTrue: [
stream reset.
].
!
----- Method: Json>>unescapeUnicode (in category 'private') -----
unescapeUnicode
|string|
string := (String with: self next with: self next with: self next with: self next) asUppercase.
^ Unicode value: (Number readFrom: '16r', string)!
Object subclass: #JsonDummyTestObject
instanceVariableNames: 'a b c'
classVariableNames: ''
poolDictionaries: ''
category: 'JSON'!
----- Method: JsonDummyTestObject class>>constructFromJson: (in category 'as yet unclassified') -----
constructFromJson: j
^ self new a: (j at: 'a'); b: (j at: 'b'); c: (j at: 'c'); yourself!
----- Method: JsonDummyTestObject>>= (in category 'as yet unclassified') -----
= other
^ other class == self class and: [
a = other a and: [
b = other b and: [
c = other c]]]!
----- Method: JsonDummyTestObject>>a (in category 'accessing') -----
a
"Answer the value of a"
^ a!
----- Method: JsonDummyTestObject>>a: (in category 'accessing') -----
a: anObject
"Set the value of a"
a _ anObject!
----- Method: JsonDummyTestObject>>b (in category 'accessing') -----
b
"Answer the value of b"
^ b!
----- Method: JsonDummyTestObject>>b: (in category 'accessing') -----
b: anObject
"Set the value of b"
b _ anObject!
----- Method: JsonDummyTestObject>>c (in category 'accessing') -----
c
"Answer the value of c"
^ c!
----- Method: JsonDummyTestObject>>c: (in category 'accessing') -----
c: anObject
"Set the value of c"
c _ anObject!
----- Method: JsonDummyTestObject>>jsonWriteOn: (in category 'as yet unclassified') -----
jsonWriteOn: s
Json renderInstanceVariables: {#a. #b. #c} of: self on: s
!
Object subclass: #JsonObject
instanceVariableNames: 'properties'
classVariableNames: ''
poolDictionaries: ''
category: 'JSON'!
----- Method: JsonObject class>>newFrom: (in category 'as yet unclassified') -----
newFrom: aDict
| result p |
result := self new.
p := result properties.
aDict associationsDo: [:a | p add: a].
^ result!
----- Method: JsonObject>>= (in category 'as yet unclassified') -----
= anObject
(anObject isKindOf: JsonObject)
ifTrue: [^ properties = anObject properties]
ifFalse: [^ properties = anObject]!
----- Method: JsonObject>>associationsDo: (in category 'as yet unclassified') -----
associationsDo: aBlock
^ properties associationsDo: aBlock!
----- Method: JsonObject>>at: (in category 'as yet unclassified') -----
at: key
^ self at: key ifAbsent: [self error: 'key not found']
!
----- Method: JsonObject>>at:ifAbsent: (in category 'as yet unclassified') -----
at: key ifAbsent: aBlock
^ (properties detect: [:ea | ea key = key] ifNone: [^ aBlock value]) value!
----- Method: JsonObject>>at:put: (in category 'as yet unclassified') -----
at: key put: value
properties associationsDo: [:a | a key = key ifTrue: [a value: value. ^ value]].
properties add: key -> value!
----- Method: JsonObject>>doesNotUnderstand: (in category 'as yet unclassified') -----
doesNotUnderstand: aMessage
| key |
key := aMessage selector.
key isUnary ifTrue: [^ self at: key ifAbsent: [super doesNotUnderstand: aMessage]].
^ (key isKeyword and: [(key occurrencesOf: $:) = 1])
ifTrue: [key := key allButLast asSymbol.
self at: key put: aMessage arguments first]
ifFalse: [super doesNotUnderstand: aMessage]
!
----- Method: JsonObject>>initialize (in category 'as yet unclassified') -----
initialize
properties := OrderedCollection new!
----- Method: JsonObject>>jsonWriteOn: (in category 'as yet unclassified') -----
jsonWriteOn: aStream
aStream nextPut: ${.
properties
do:
[:ea |
ea key asString jsonWriteOn: aStream.
aStream nextPut: $:.
ea value jsonWriteOn: aStream]
separatedBy: [aStream nextPut: $,].
aStream nextPut: $}.!
----- Method: JsonObject>>properties (in category 'as yet unclassified') -----
properties
^ properties!
----- Method: True>>jsonWriteOn: (in category '*JSON-writing') -----
jsonWriteOn: aStream
aStream nextPutAll: 'true'!
----- Method: Number>>jsonWriteOn: (in category '*JSON-writing') -----
jsonWriteOn: aWriteStream
self printOn: aWriteStream base: 10!
----- Method: Dictionary>>jsonWriteOn: (in category '*JSON-writing') -----
jsonWriteOn: aStream
| needComma |
needComma := false.
aStream nextPut: ${.
self associationsDo: [ :assoc |
needComma
ifTrue: [ aStream nextPut: $, ]
ifFalse: [ needComma := true ].
assoc key asString jsonWriteOn: aStream.
aStream nextPut: $:.
assoc value jsonWriteOn: aStream ].
aStream nextPut: $}.!
----- Method: WriteStream>>jsonPrint: (in category '*json-printing') -----
jsonPrint: anObject
anObject jsonWriteOn: self!
----- Method: Text>>jsonWriteOn: (in category '*json-printing') -----
jsonWriteOn: aStream
self string jsonWriteOn: aStream!
----- Method: String>>jsonWriteOn: (in category '*JSON-writing') -----
jsonWriteOn: aStream
| replacement |
aStream nextPut: $".
self do: [ :ch |
(replacement := Json escapeForCharacter: ch)
ifNil: [ aStream nextPut: ch ]
ifNotNil: [ aStream nextPutAll: replacement ] ].
aStream nextPut: $".
!
----- Method: Integer>>jsonWriteOn: (in category '*JSON-writing') -----
jsonWriteOn: aWriteStream
aWriteStream nextPutAll: (self printStringBase: 10)!
----- Method: UndefinedObject>>jsonWriteOn: (in category '*JSON-writing') -----
jsonWriteOn: aWriteStream
aWriteStream nextPutAll: 'null'!
----- Method: Collection>>jsonWriteOn: (in category '*json') -----
jsonWriteOn: aStream
| needComma |
needComma := false.
aStream nextPut: $[.
self do: [:v |
needComma
ifTrue: [ aStream nextPut: $, ]
ifFalse: [ needComma := true ].
v jsonWriteOn: aStream.
].
aStream nextPut: $].!
Error subclass: #JsonSyntaxError
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'JSON'!
!JsonSyntaxError commentStamp: '<historical>' prior: 0!
Class Json signals instances of me when an input stream contains invalid JSON input.!
TestCase subclass: #JsonTests
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'JSON'!
!JsonTests commentStamp: '<historical>' prior: 0!
I provide a number of test cases for class Json.!
----- Method: JsonTests>>json:equals: (in category 'as yet unclassified') -----
json: aString equals: aValue
| readValue |
readValue := self readFrom: aString.
self assert: readValue = aValue.!
----- Method: JsonTests>>readFrom: (in category 'as yet unclassified') -----
readFrom: aString
^ (Json newWithConstructors: {JsonDummyTestObject.}) readFrom: aString readStream
!
----- Method: JsonTests>>render:equals: (in category 'as yet unclassified') -----
render: anObject equals: aString
self assert: (Json render: anObject) = aString!
----- Method: JsonTests>>simpleDummyObject (in category 'as yet unclassified') -----
simpleDummyObject
^ JsonDummyTestObject new a: 1; b: 2; c: 3; yourself!
----- Method: JsonTests>>testArray (in category 'as yet unclassified') -----
testArray
self json: '[]' equals: #().
self json: '[[]]' equals: #(#()).
self json: '[[], []]' equals: #(#() #()).
self json: '["hi", "there"]' equals: #('hi' 'there').
self json: '[["a", "b", null]]' equals: #(('a' 'b' nil)).!
----- Method: JsonTests>>testAtomFalse (in category 'as yet unclassified') -----
testAtomFalse
self json: 'false' equals: false.
self json: ' false' equals: false.
self json: 'false ' equals: false.
self json: ' false ' equals: false.
!
----- Method: JsonTests>>testAtomNull (in category 'as yet unclassified') -----
testAtomNull
self json: 'null' equals: nil.
self json: ' null' equals: nil.
self json: 'null ' equals: nil.
self json: ' null ' equals: nil.
!
----- Method: JsonTests>>testAtomNumber (in category 'as yet unclassified') -----
testAtomNumber
self json: '1' equals: 1.
self json: '0123' equals: 123.
self json: '1.23e2' equals: 123.
self json: '-1' equals: -1.
self json: '-0' equals: 0.
self json: '[-1.2]' equals: #(-1.2).!
----- Method: JsonTests>>testAtomString (in category 'as yet unclassified') -----
testAtomString
self json: '"hi"' equals: 'hi'.
self json: '"\""' equals: '"'.
self json: '"\\"' equals: '\'.
self json: '""' equals: ''.
self json: '"a\u0004b"' equals: ({$a. Character value: 4. $b} as: String).
self json: '"a\nb"' equals: ({$a. Character lf. $b} as: String).!
----- Method: JsonTests>>testAtomTrue (in category 'as yet unclassified') -----
testAtomTrue
self json: 'true' equals: true.
self json: ' true' equals: true.
self json: 'true ' equals: true.
self json: ' true ' equals: true.
!
----- Method: JsonTests>>testCtor (in category 'as yet unclassified') -----
testCtor
self json: '@JsonDummyTestObject {"a": 1, "b": 2, "c": 3}' equals: self simpleDummyObject.
self json: (Json render: self simpleDummyObject) equals: self simpleDummyObject.!
----- Method: JsonTests>>testDictionary (in category 'as yet unclassified') -----
testDictionary
self json: '{}' equals: (JsonObject new).
self json: '{"a": "a"}' equals: (JsonObject new at: 'a' put: 'a'; yourself).
self json: '{"a": [[]]}' equals: (JsonObject new at: 'a' put: #(#()); yourself).
self json: '{"a":"b", "b":"a"}' equals: ({'a'->'b'. 'b'->'a'} as: JsonObject).!
----- Method: JsonTests>>testMissingCtor (in category 'as yet unclassified') -----
testMissingCtor
self
should: [self readFrom: '@Missing[]']
raise: JsonSyntaxError
!
----- Method: JsonTests>>testMissingCtorNoMap (in category 'as yet unclassified') -----
testMissingCtorNoMap
self
should: [Json new readFrom: '@Missing[]' readStream]
raise: JsonSyntaxError!
----- Method: JsonTests>>testStringWithUnicode (in category 'as yet unclassified') -----
testStringWithUnicode
self json: '"\u263A"' equals: (Unicode value: 16r263A) asString.
self render: (Unicode value: 16r263A) asString equals: '"\u263A"'.!
----- Method: JsonTests>>testWriteString (in category 'as yet unclassified') -----
testWriteString
self render: '"' equals: '"\""'.
self render: '\' equals: '"\\"'.
self render: 'hi' equals: '"hi"'.
self render: ({$a. Character lf. $b} as: String) equals: '"a\nb"'.
self render: ({$a. Character value: 4. $b} as: String) equals: '"a\u0004b"'.!
----- Method: False>>jsonWriteOn: (in category '*JSON-writing') -----
jsonWriteOn: aStream
aStream nextPutAll: 'false'!
More information about the Squeak-dev
mailing list
|