(ns ^{:author "Stuart Sierra"

:doc "JavaScript Object Notation (JSON) parser/generator.

See http://www.json.org/"}

clojure.data.json

(:refer-clojure :exclude (read))

(:require [clojure.pprint :as pprint])

(:import (java.io PrintWriter PushbackReader StringWriter

Writer StringReader EOFException)))

(set! *warn-on-reflection* true)

(definterface InternalPBR

(^int readChar [])

(^long readChars [^chars buffer ^long start ^long bufflen])

(^void unreadChar [^int c])

(^void unreadChars [^chars buffer ^int off ^int bufflen])

(^java.io.Reader toReader []))

(deftype ReaderPBR [^PushbackReader rdr]

InternalPBR

(readChar [_]

(.read rdr))

(readChars [_ buffer start bufflen]

(.read rdr ^chars buffer start bufflen))

(unreadChar [_ c]

(.unread rdr c))

(unreadChars [_ buffer start bufflen]

(.unread rdr buffer start bufflen))

(toReader [_]

rdr))

(comment

(compile 'clojure.data.json)

)

(deftype StringPBR [^String s ^:unsynchronized-mutable ^long pos ^long len]

InternalPBR

(readChar [_]

(if (< pos len)

(let [p pos]

(set! pos (unchecked-inc pos))

(let [c (int (.charAt s p))]

c))

(let [i (int -1)]

i)))

(readChars [_ buffer start bufflen]

(let [remaining (- len pos)

n (Math/min remaining bufflen)]

(when (pos? n)

(let [p pos

end (+ p n)]

(set! pos end)

(.getChars ^String s p end ^chars buffer start)))

(if (pos? n) n -1)))

(unreadChar [_ _c]

(set! pos (unchecked-dec pos))

nil)

(unreadChars [_ _buffer _start bufflen]

(set! pos (unchecked-subtract pos bufflen))

nil)

(toReader [_]

(StringReader. (.subSequence s pos len))))

(defn- pushback-pbr

[^PushbackReader r]

(->ReaderPBR r))

(defn- string-pbr

[^String s]

(->StringPBR s 0 (.length s)))

(set! *warn-on-reflection* true)

(defn- default-write-key-fn

[x]

(cond (instance? clojure.lang.Named x)

(name x)

(nil? x)

(throw (Exception. "JSON object properties may not be nil"))

:else (str x)))

(defn- default-value-fn [k v] v)

(declare -read)

(defmacro ^:private codepoint [c]

(int c))

(defn- codepoint-clause [[test result]]

(cond (list? test)

[(map int test) result]

(= test :whitespace)

['(9 10 13 32) result]

(= test :js-separators)

['(16r2028 16r2029) result]

:else

[(int test) result]))

(defmacro ^:private codepoint-case [e & clauses]

`(case ~e

~@(mapcat codepoint-clause (partition 2 clauses))

~@(when (odd? (count clauses))

[(last clauses)])))

(defn- read-hex-char [^InternalPBR stream]

;; Expects to be called with the head of the stream AFTER the

;; initial "\u". Reads the next four characters from the stream.

(let [a (.readChar stream)

b (.readChar stream)

c (.readChar stream)

d (.readChar stream)]

(when (or (neg? a) (neg? b) (neg? c) (neg? d))

(throw (EOFException.

"JSON error (end-of-file inside Unicode character escape)")))

(let [s (str (char a) (char b) (char c) (char d))]

(char (Integer/parseInt s 16)))))

(defn- read-escaped-char [^InternalPBR stream]

;; Expects to be called with the head of the stream AFTER the

;; initial backslash.

(let [c (.readChar stream)]

(when (neg? c)

(throw (EOFException. "JSON error (end-of-file inside escaped char)")))

(codepoint-case c

(\" \\ \/) (char c)

\b \backspace

\f \formfeed

\n \newline

\r \return

\t \tab

\u (read-hex-char stream))))

(defn- slow-read-string [^InternalPBR stream ^String already-read]

(let [buffer (StringBuilder. already-read)]

(loop []

(let [c (.readChar stream)]

(when (neg? c)

(throw (EOFException. "JSON error (end-of-file inside string)")))

(codepoint-case c

\" (str buffer)

\\ (do (.append buffer (read-escaped-char stream))

(recur))

(do (.append buffer (char c))

(recur)))))))

(defn- read-quoted-string [^InternalPBR stream]

;; Expects to be called with the head of the stream AFTER the

;; opening quotation mark.

(let [buffer ^chars (char-array 64)

read (.readChars stream buffer 0 64)

end-index (unchecked-dec-int read)]

(when (neg? read)

(throw (EOFException. "JSON error (end-of-file inside string)")))

(loop [i (int 0)]

(let [c (int (aget buffer i))]

(codepoint-case c

\" (let [off (unchecked-inc-int i)

len (unchecked-subtract-int read off)]

(.unreadChars stream buffer off len)

(String. buffer 0 i))

\\ (let [off i

len (unchecked-subtract-int read off)]

(.unreadChars stream buffer off len)

(slow-read-string stream (String. buffer 0 i)))

(if (= i end-index)

(do (.unreadChar stream c)

(slow-read-string stream (String. buffer 0 i)))

(recur (unchecked-inc-int i))))))))

(defn- read-integer [^String string]

(if (< (count string) 18) ; definitely fits in a Long

(Long/valueOf string)

(or (try (Long/valueOf string)

(catch NumberFormatException e nil))

(bigint string))))

(defn- read-decimal [^String string bigdec?]

(if bigdec?

(bigdec string)

(Double/valueOf string)))

(defn- read-number [^InternalPBR stream bigdec?]

(let [buffer (StringBuilder.)

decimal? (loop [stage :minus]

(let [c (.readChar stream)]

(case stage

:minus

(codepoint-case c

\-

(do (.append buffer (char c))

(recur :int-zero))

\0

(do (.append buffer (char c))

(recur :frac-point))

(\1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.append buffer (char c))

(recur :int-digit))

(throw (Exception. "JSON error (invalid number literal)")))

;; Number must either be a single 0 or 1-9 followed by 0-9

:int-zero

(codepoint-case c

\0

(do (.append buffer (char c))

(recur :frac-point))

(\1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.append buffer (char c))

(recur :int-digit))

(throw (Exception. "JSON error (invalid number literal)")))

;; at this point, there is at least one digit

:int-digit

(codepoint-case c

(\0 \1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.append buffer (char c))

(recur :int-digit))

\.

(do (.append buffer (char c))

(recur :frac-first))

(\e \E)

(do (.append buffer (char c))

(recur :exp-symbol))

;; early exit

:whitespace

(do (.unreadChar stream c)

false)

(\, \] \} -1)

(do (.unreadChar stream c)

false)

(throw (Exception. "JSON error (invalid number literal)")))

;; previous character is a "0"

:frac-point

(codepoint-case c

\.

(do (.append buffer (char c))

(recur :frac-first))

(\e \E)

(do (.append buffer (char c))

(recur :exp-symbol))

;; early exit

:whitespace

(do (.unreadChar stream c)

false)

(\, \] \} -1)

(do (.unreadChar stream c)

false)

;; Disallow zero-padded numbers or invalid characters

(throw (Exception. "JSON error (invalid number literal)")))

;; previous character is a "."

:frac-first

(codepoint-case c

(\0 \1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.append buffer (char c))

(recur :frac-digit))

(throw (Exception. "JSON error (invalid number literal)")))

;; any number of following digits

:frac-digit

(codepoint-case c

(\0 \1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.append buffer (char c))

(recur :frac-digit))

(\e \E)

(do (.append buffer (char c))

(recur :exp-symbol))

;; early exit

:whitespace

(do (.unreadChar stream c)

true)

(\, \] \} -1)

(do (.unreadChar stream c)

true)

(throw (Exception. "JSON error (invalid number literal)")))

;; previous character is a "e" or "E"

:exp-symbol

(codepoint-case c

(\- \+)

(do (.append buffer (char c))

(recur :exp-first))

(\0 \1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.append buffer (char c))

(recur :exp-digit)))

;; previous character is a "-" or "+"

;; must have at least one digit

:exp-first

(codepoint-case c

(\0 \1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.append buffer (char c))

(recur :exp-digit))

(throw (Exception. "JSON error (invalid number literal)")))

;; any number of following digits

:exp-digit

(codepoint-case c

(\0 \1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.append buffer (char c))

(recur :exp-digit))

:whitespace

(do (.unreadChar stream c)

true)

(\, \] \} -1)

(do (.unreadChar stream c)

true)

(throw (Exception. "JSON error (invalid number literal)"))))))]

(if decimal?

(read-decimal (str buffer) bigdec?)

(read-integer (str buffer)))))

(defn- next-token [^InternalPBR stream]

(loop [c (.readChar stream)]

(if (< 32 c)

(int c)

(codepoint-case (int c)

:whitespace (recur (.readChar stream))

-1 -1))))

(defn invalid-array-exception []

(Exception. "JSON error (invalid array)"))

(defn- read-array* [^InternalPBR stream options]

;; Handles all array values after the first.

(loop [result (transient [])]

(let [r (conj! result (-read stream true nil options))]

(codepoint-case (int (next-token stream))

\] (persistent! r)

\, (recur r)

(throw (invalid-array-exception))))))

(defn- read-array [^InternalPBR stream options]

;; Expects to be called with the head of the stream AFTER the

;; opening bracket.

;; Only handles array value.

(let [c (int (next-token stream))]

(codepoint-case c

\] []

\, (throw (invalid-array-exception))

(do (.unreadChar stream c)

(read-array* stream options)))))

(defn- read-key [^InternalPBR stream]

(let [c (int (next-token stream))]

(if (= c (codepoint \"))

(let [key (read-quoted-string stream)]

(if (= (codepoint \:) (int (next-token stream)))

key

(throw (Exception. "JSON error (missing `:` in object)"))))

(if (= c (codepoint \}))

nil

(throw (Exception. (str "JSON error (non-string key in object), found `" (char c) "`, expected `\"`")))))))

(defn- read-object [^InternalPBR stream options]

;; Expects to be called with the head of the stream AFTER the

;; opening bracket.

(let [key-fn (get options :key-fn)

value-fn (get options :value-fn)]

(loop [result (transient {})]

(if-let [key (read-key stream)]

(let [key (cond-> key key-fn key-fn)

value (-read stream true nil options)

r (if value-fn

(let [out-value (value-fn key value)]

(if-not (= value-fn out-value)

(assoc! result key out-value)

result))

(assoc! result key value))]

(codepoint-case (int (next-token stream))

\, (recur r)

\} (persistent! r)

(throw (Exception. "JSON error (missing entry in object)"))))

(let [r (persistent! result)]

(if (empty? r)

r

(throw (Exception. "JSON error empty entry in object is not allowed"))))))))

(defn- -read

[^InternalPBR stream eof-error? eof-value options]

(let [c (int (next-token stream))]

(codepoint-case c

;; Read numbers

(\- \0 \1 \2 \3 \4 \5 \6 \7 \8 \9)

(do (.unreadChar stream c)

(read-number stream (:bigdec options)))

;; Read strings

\" (read-quoted-string stream)

;; Read null as nil

\n (if (and (= (codepoint \u) (.readChar stream))

(= (codepoint \l) (.readChar stream))

(= (codepoint \l) (.readChar stream)))

nil

(throw (Exception. "JSON error (expected null)")))

;; Read true

\t (if (and (= (codepoint \r) (.readChar stream))

(= (codepoint \u) (.readChar stream))

(= (codepoint \e) (.readChar stream)))

true

(throw (Exception. "JSON error (expected true)")))

;; Read false

\f (if (and (= (codepoint \a) (.readChar stream))

(= (codepoint \l) (.readChar stream))

(= (codepoint \s) (.readChar stream))

(= (codepoint \e) (.readChar stream)))

false

(throw (Exception. "JSON error (expected false)")))

;; Read JSON objects

\{ (read-object stream options)

;; Read JSON arrays

\[ (read-array stream options)

(if (neg? c) ;; Handle end-of-stream

(if eof-error?

(throw (EOFException. "JSON error (end-of-file)"))

eof-value)

(throw (Exception.

(str "JSON error (unexpected character): " (char c))))))))

(defn- -read1

[^InternalPBR stream eof-error? eof-value options]

(let [val (-read stream eof-error? eof-value options)]

(if-let [extra-data-fn (:extra-data-fn options)]

(if (or eof-error? (not (identical? eof-value val)))

(let [c (.readChar stream)]

(if (neg? c)

val

(do

(.unreadChar stream c)

(extra-data-fn val (.toReader stream)))))

val)

val)))

(defn on-extra-throw

"Pass as :extra-data-fn to `read` or `read-str` to throw if data is found

[val rdr]

(throw (ex-info "Found extra data after json object" {:val val})))

(defn on-extra-throw-remaining

"Pass as :extra-data-fn to `read` or `read-str` to throw if data is found

[val rdr]

(let [remaining (slurp rdr)]

(throw (ex-info (str "Found extra data after json object: " remaining)

{:val val, :remaining remaining}))))

(def default-read-options {:bigdec false

:key-fn nil

:value-fn nil})

(defn read

"Reads a single item of JSON data from a java.io.Reader.

[reader & {:as options}]

(let [{:keys [eof-error? eof-value]

:or {eof-error? true}} options

pbr (pushback-pbr

(if (instance? PushbackReader reader)

reader

(PushbackReader. reader 64)))]

(->> options

(merge default-read-options)

(-read1 pbr eof-error? eof-value))))

(defn read-str

"Reads one JSON value from input String. Options are the same as for

[string & {:as options}]

(let [{:keys [eof-error? eof-value]

:or {eof-error? true}} options]

(->> options

(merge default-read-options)

(-read1 (string-pbr string) eof-error? eof-value))))

(defprotocol JSONWriter

(-write [object out options]

"Print object to Appendable out as JSON"))

(defn- ->hex-string [^Appendable out cp]

(let [cpl (long cp)]

(.append out "\\u")

(cond

(< cpl 16)

(.append out "000")

(< cpl 256)

(.append out "00")

(< cpl 4096)

(.append out "0"))

(.append out (Integer/toHexString cp))))

(def ^{:tag "[S"} codepoint-decoder

(let [shorts (short-array 128)]

(dotimes [i 128]

(codepoint-case i

\" (aset shorts i (short 1))

\\ (aset shorts i (short 1))

\/ (aset shorts i (short 2))

\backspace (aset shorts i (short 3))

\formfeed (aset shorts i (short 4))

\newline (aset shorts i (short 5))

\return (aset shorts i (short 6))

\tab (aset shorts i (short 7))

(if (< i 32)

(aset shorts i (short 8))

(aset shorts i (short 0)))))

shorts))

(defn- slow-write-string [^CharSequence s ^Appendable out options]

(let [decoder codepoint-decoder]

(dotimes [i (.length s)]

(let [cp (int (.charAt s i))]

(if (< cp 128)

(case (aget decoder cp)

0 (.append out (char cp))

1 (do (.append out (char (codepoint \\))) (.append out (char cp)))

2 (.append out (if (get options :escape-slash) "\\/" "/"))

3 (.append out "\\b")

4 (.append out "\\f")

5 (.append out "\\n")

6 (.append out "\\r")

7 (.append out "\\t")

8 (->hex-string out cp))

(codepoint-case cp

:js-separators (if (get options :escape-js-separators)

(->hex-string out cp)

(.append out (char cp)))

(if (get options :escape-unicode)

(->hex-string out cp) ; Hexadecimal-escaped

(.append out (char cp)))))))))

(defn- write-string [^CharSequence s ^Appendable out options]

(let [decoder codepoint-decoder

l (.length s)]

(.append out \")

(loop [i 0]

(if (= i l)

(.append out s)

(let [cp (int (.charAt s i))]

(if (and (< cp 128)

(zero? (aget decoder cp)))

(recur (unchecked-inc i))

(do

(.append out s 0 i)

(slow-write-string (.subSequence s i l) out options))))))

(.append out \")))

(defn- write-indent [^Appendable out options]

(let [indent-depth (:indent-depth options)]

(.append out \newline)

(loop [i indent-depth]

(when (pos? i)

(.append out " ")

(recur (dec i))))))

(defn- write-object [m ^Appendable out options]

(let [key-fn (get options :key-fn)

value-fn (get options :value-fn)

indent (get options :indent)

opts (cond-> options

indent (update :indent-depth inc))]

(.append out \{)

(when (and indent (seq m))

(write-indent out opts))

(loop [x m, have-printed-kv false]

(when (seq x)

(let [[k v] (first x)

out-key (key-fn k)

out-value (value-fn k v)

nxt (next x)]

(when-not (string? out-key)

(throw (Exception. "JSON object keys must be strings")))

(if-not (= value-fn out-value)

(do

(when have-printed-kv

(.append out \,)

(when indent

(write-indent out opts)))

(write-string out-key out opts)

(.append out \:)

(when indent

(.append out \space))

(-write out-value out opts)

(when (seq nxt)

(recur nxt true)))

(when (seq nxt)

(recur nxt have-printed-kv))))))

(when (and indent (seq m))

(write-indent out options)))

(.append out \}))

(defn- write-array [s ^Appendable out options]

(let [indent (get options :indent)

opts (cond-> options

indent (update :indent-depth inc))]

(.append out \[)

(when (and indent (seq s))

(write-indent out opts))

(loop [x s]

(when (seq x)

(let [fst (first x)

nxt (next x)]

(-write fst out opts)

(when (seq nxt)

(.append out \,)

(when indent

(write-indent out opts))

(recur nxt)))))

(when (and indent (seq s))

(write-indent out options)))

(.append out \]))

(defn- write-bignum [x ^Appendable out options]

(.append out (str x)))

(defn- write-float [^Float x ^Appendable out options]

(cond (.isInfinite x)

(throw (Exception. "JSON error: cannot write infinite Float"))

(.isNaN x)

(throw (Exception. "JSON error: cannot write Float NaN"))

:else

(.append out (str x))))

(defn- write-double [^Double x ^Appendable out options]

(cond (.isInfinite x)

(throw (Exception. "JSON error: cannot write infinite Double"))

(.isNaN x)

(throw (Exception. "JSON error: cannot write Double NaN"))

:else

(.append out (str x))))

(defn- write-plain [x ^Appendable out options]

(.append out (str x)))

(defn- write-uuid [^java.util.UUID x ^Appendable out options]

(.append out \")

(.append out (.toString x))

(.append out \"))

(defn- write-instant [^java.time.Instant x ^Appendable out options]

(let [formatter ^java.time.format.DateTimeFormatter (:date-formatter options)]

(.append out \")

(.append out (.format formatter x))

(.append out \")))

(defn- write-date [^java.util.Date x ^Appendable out options]

(write-instant (.toInstant x) out options))

(defn- default-sql-date->instant-fn [^java.sql.Date d]

(.toInstant (.atStartOfDay (.toLocalDate d) (java.time.ZoneId/systemDefault))))

(defn- write-sql-date [^java.sql.Date x ^Appendable out options]

(let [->instant (:sql-date-converter options)]

(write-instant (->instant x) out options)))

(defn- write-null [x ^Appendable out options]

(.append out "null"))

(defn- write-named [x out options]

(write-string (name x) out options))

(defn- write-generic [x out options]

(if (.isArray (class x))

(-write (seq x) out options)

((:default-write-fn options) x out options)))

(defn- write-ratio [x out options]

(-write (double x) out options))

(extend nil JSONWriter {:-write write-null})

(extend java.lang.Boolean JSONWriter {:-write write-plain})

(extend java.lang.Byte JSONWriter {:-write write-plain})

(extend java.lang.Short JSONWriter {:-write write-plain})

(extend java.lang.Integer JSONWriter {:-write write-plain})

(extend java.lang.Long JSONWriter {:-write write-plain})

(extend java.lang.Float JSONWriter {:-write write-float})

(extend java.lang.Double JSONWriter {:-write write-double})

(extend clojure.lang.Ratio JSONWriter {:-write write-ratio})

(extend java.math.BigInteger JSONWriter {:-write write-bignum})

(extend java.math.BigDecimal JSONWriter {:-write write-bignum})

(extend java.util.concurrent.atomic.AtomicInteger JSONWriter {:-write write-plain})

(extend java.util.concurrent.atomic.AtomicLong JSONWriter {:-write write-plain})

(extend java.util.UUID JSONWriter {:-write write-uuid})

(extend java.time.Instant JSONWriter {:-write write-instant})

(extend java.util.Date JSONWriter {:-write write-date})

(extend java.sql.Date JSONWriter {:-write write-sql-date})

(extend clojure.lang.BigInt JSONWriter {:-write write-bignum})

(extend clojure.lang.Named JSONWriter {:-write write-named})

(extend java.lang.CharSequence JSONWriter {:-write write-string})

(extend java.util.Map JSONWriter {:-write write-object})

(extend java.util.Collection JSONWriter {:-write write-array})

(extend java.lang.Object JSONWriter {:-write write-generic})

(defn- default-write-fn [x out options]

(throw (Exception. (str "Don't know how to write JSON of " (class x)))))

(def default-write-options {:escape-unicode true

:escape-js-separators true

:escape-slash true

:sql-date-converter default-sql-date->instant-fn

:date-formatter java.time.format.DateTimeFormatter/ISO_INSTANT

:key-fn default-write-key-fn

:value-fn default-value-fn

:default-write-fn default-write-fn

:indent false

:indent-depth 0 ;; internal, to track nesting depth

})

(defn write

"Write JSON-formatted output to a java.io.Writer. Options are

[x ^Writer writer & {:as options}]

(-write x writer (merge default-write-options options)))

(defn write-str

"Converts x to a JSON-formatted string. Options are the same as

^String [x & {:as options}]

(let [sw (StringWriter.)]

(-write x sw (merge default-write-options options))

(.toString sw)))

(defn- pprint-array [s]

((pprint/formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>") s))

(defn- pprint-object [m options]

(let [key-fn (:key-fn options)]

((pprint/formatter-out "~<{~;~@{~<~w:~_~w~:>~^, ~_~}~;}~:>")

(for [[k v] m] [(key-fn k) v]))))

(defn- pprint-generic [x options]

(if (.isArray (class x))

(pprint-array (seq x))

;; pprint proxies Writer, so we can't just wrap it

(print (with-out-str (-write x (PrintWriter. *out*) options)))))

(defn- pprint-dispatch [x options]

(cond (nil? x) (print "null")

(instance? java.util.Map x) (pprint-object x options)

(instance? java.util.Collection x) (pprint-array x)

(instance? clojure.lang.ISeq x) (pprint-array x)

:else (pprint-generic x options)))

(defn pprint

"Pretty-prints JSON representation of x to *out*. Options are the same

[x & {:as options}]

(let [opts (merge default-write-options options)]

(pprint/with-pprint-dispatch #(pprint-dispatch % opts)

(pprint/pprint x))))

(defn read-json

"DEPRECATED; replaced by read-str.

([input]

(read-json input true true nil))

([input keywordize?]

(read-json input keywordize? true nil))

([input keywordize? eof-error? eof-value]

(let [key-fn (if keywordize? keyword identity)]

(condp instance? input

String

(read-str input

:key-fn key-fn

:eof-error? eof-error?

:eof-value eof-value)

java.io.Reader

(read input

:key-fn key-fn

:eof-error? eof-error?

:eof-value eof-value)))))

(defn write-json

"DEPRECATED; replaced by 'write'.

[x out escape-unicode?]

(write x out :escape-unicode escape-unicode?))

(defn json-str

"DEPRECATED; replaced by 'write-str'.

[x & options]

(apply write-str x options))

(defn print-json

"DEPRECATED; replaced by 'write' to *out*.

[x & options]

(apply write x *out* options))

(defn pprint-json

"DEPRECATED; replaced by 'pprint'.

[x & options]

(apply pprint x options))