Update copyright year to 2016
[gnus] / lisp / gnus-fallback-lib / json.el
1 ;;; json.el --- JavaScript Object Notation parser / generator
2
3 ;; Copyright (C) 2006-2016 Free Software Foundation, Inc.
4
5 ;; Author: Edward O'Connor <ted@oconnor.cx>
6 ;; Version: 1.3
7 ;; Keywords: convenience
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;;; Commentary:
25
26 ;; This is a library for parsing and generating JSON (JavaScript Object
27 ;; Notation).
28
29 ;; Learn all about JSON here: <URL:http://json.org/>.
30
31 ;; The user-serviceable entry points for the parser are the functions
32 ;; `json-read' and `json-read-from-string'. The encoder has a single
33 ;; entry point, `json-encode'.
34
35 ;; Since there are several natural representations of key-value pair
36 ;; mappings in elisp (alist, plist, hash-table), `json-read' allows you
37 ;; to specify which you'd prefer (see `json-object-type' and
38 ;; `json-array-type').
39
40 ;; Similarly, since `false' and `null' are distinct in JSON, you can
41 ;; distinguish them by binding `json-false' and `json-null' as desired.
42
43 ;;; History:
44
45 ;; 2006-03-11 - Initial version.
46 ;; 2006-03-13 - Added JSON generation in addition to parsing. Various
47 ;;              other cleanups, bugfixes, and improvements.
48 ;; 2006-12-29 - XEmacs support, from Aidan Kehoe <kehoea@parhasard.net>.
49 ;; 2008-02-21 - Installed in GNU Emacs.
50 ;; 2011-10-17 - Patch `json-alist-p' and `json-plist-p' to avoid recursion -tzz
51
52 ;;; Code:
53
54 (eval-when-compile (require 'cl))
55
56 ;; Compatibility code
57
58 (defalias 'json-encode-char0 'encode-char)
59 (defalias 'json-decode-char0 'decode-char)
60
61
62 ;; Parameters
63
64 (defvar json-object-type 'alist
65   "Type to convert JSON objects to.
66 Must be one of `alist', `plist', or `hash-table'.  Consider let-binding
67 this around your call to `json-read' instead of `setq'ing it.")
68
69 (defvar json-array-type 'vector
70   "Type to convert JSON arrays to.
71 Must be one of `vector' or `list'.  Consider let-binding this around
72 your call to `json-read' instead of `setq'ing it.")
73
74 (defvar json-key-type nil
75   "Type to convert JSON keys to.
76 Must be one of `string', `symbol', `keyword', or nil.
77
78 If nil, `json-read' will guess the type based on the value of
79 `json-object-type':
80
81     If `json-object-type' is:   nil will be interpreted as:
82       `hash-table'                `string'
83       `alist'                     `symbol'
84       `plist'                     `keyword'
85
86 Note that values other than `string' might behave strangely for
87 Sufficiently Weird keys.  Consider let-binding this around your call to
88 `json-read' instead of `setq'ing it.")
89
90 (defvar json-false :json-false
91   "Value to use when reading JSON `false'.
92 If this has the same value as `json-null', you might not be able to tell
93 the difference between `false' and `null'.  Consider let-binding this
94 around your call to `json-read' instead of `setq'ing it.")
95
96 (defvar json-null nil
97   "Value to use when reading JSON `null'.
98 If this has the same value as `json-false', you might not be able to
99 tell the difference between `false' and `null'.  Consider let-binding
100 this around your call to `json-read' instead of `setq'ing it.")
101
102 \f
103
104 ;;; Utilities
105
106 (defun json-join (strings separator)
107   "Join STRINGS with SEPARATOR."
108   (mapconcat 'identity strings separator))
109
110 (defun json-alist-p (list)
111   "Non-null if and only if LIST is an alist."
112   (while (consp list)
113     (setq list (if (consp (car list))
114                    (cdr list)
115                  'not-alist)))
116   (null list))
117
118 (defun json-plist-p (list)
119   "Non-null if and only if LIST is a plist."
120   (while (consp list)
121     (setq list (if (and (keywordp (car list))
122                         (consp (cdr list)))
123                    (cddr list)
124                  'not-plist)))
125   (null list))
126
127 ;; Reader utilities
128
129 (defsubst json-advance (&optional n)
130   "Skip past the following N characters."
131   (forward-char n))
132
133 (defsubst json-peek ()
134   "Return the character at point."
135   (let ((char (char-after (point))))
136     (or char :json-eof)))
137
138 (defsubst json-pop ()
139   "Advance past the character at point, returning it."
140   (let ((char (json-peek)))
141     (if (eq char :json-eof)
142         (signal 'end-of-file nil)
143       (json-advance)
144       char)))
145
146 (defun json-skip-whitespace ()
147   "Skip past the whitespace at point."
148   (skip-chars-forward "\t\r\n\f\b "))
149
150 \f
151
152 ;; Error conditions
153
154 (put 'json-error 'error-message "Unknown JSON error")
155 (put 'json-error 'error-conditions '(json-error error))
156
157 (put 'json-readtable-error 'error-message "JSON readtable error")
158 (put 'json-readtable-error 'error-conditions
159      '(json-readtable-error json-error error))
160
161 (put 'json-unknown-keyword 'error-message "Unrecognized keyword")
162 (put 'json-unknown-keyword 'error-conditions
163      '(json-unknown-keyword json-error error))
164
165 (put 'json-number-format 'error-message "Invalid number format")
166 (put 'json-number-format 'error-conditions
167      '(json-number-format json-error error))
168
169 (put 'json-string-escape 'error-message "Bad unicode escape")
170 (put 'json-string-escape 'error-conditions
171      '(json-string-escape json-error error))
172
173 (put 'json-string-format 'error-message "Bad string format")
174 (put 'json-string-format 'error-conditions
175      '(json-string-format json-error error))
176
177 (put 'json-object-format 'error-message "Bad JSON object")
178 (put 'json-object-format 'error-conditions
179      '(json-object-format json-error error))
180
181 \f
182
183 ;;; Keywords
184
185 (defvar json-keywords '("true" "false" "null")
186   "List of JSON keywords.")
187
188 ;; Keyword parsing
189
190 (defun json-read-keyword (keyword)
191   "Read a JSON keyword at point.
192 KEYWORD is the keyword expected."
193   (unless (member keyword json-keywords)
194     (signal 'json-unknown-keyword (list keyword)))
195   (mapc (lambda (char)
196           (unless (char-equal char (json-peek))
197             (signal 'json-unknown-keyword
198                     (list (save-excursion
199                             (backward-word 1)
200                             (thing-at-point 'word)))))
201           (json-advance))
202         keyword)
203   (unless (looking-at "\\(\\s-\\|[],}]\\|$\\)")
204     (signal 'json-unknown-keyword
205             (list (save-excursion
206                     (backward-word 1)
207                     (thing-at-point 'word)))))
208   (cond ((string-equal keyword "true") t)
209         ((string-equal keyword "false") json-false)
210         ((string-equal keyword "null") json-null)))
211
212 ;; Keyword encoding
213
214 (defun json-encode-keyword (keyword)
215   "Encode KEYWORD as a JSON value."
216   (cond ((eq keyword t)          "true")
217         ((eq keyword json-false) "false")
218         ((eq keyword json-null)  "null")))
219
220 ;;; Numbers
221
222 ;; Number parsing
223
224 (defun json-read-number (&optional sign)
225  "Read the JSON number following point.
226 The optional SIGN argument is for internal use.
227
228 N.B.: Only numbers which can fit in Emacs Lisp's native number
229 representation will be parsed correctly."
230  ;; If SIGN is non-nil, the number is explicitly signed.
231  (let ((number-regexp
232         "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?"))
233    (cond ((and (null sign) (char-equal (json-peek) ?-))
234           (json-advance)
235           (- (json-read-number t)))
236          ((and (null sign) (char-equal (json-peek) ?+))
237           (json-advance)
238           (json-read-number t))
239          ((and (looking-at number-regexp)
240                (or (match-beginning 1)
241                    (match-beginning 2)))
242           (goto-char (match-end 0))
243           (string-to-number (match-string 0)))
244          (t (signal 'json-number-format (list (point)))))))
245
246 ;; Number encoding
247
248 (defun json-encode-number (number)
249   "Return a JSON representation of NUMBER."
250   (format "%s" number))
251
252 ;;; Strings
253
254 (defvar json-special-chars
255   '((?\" . ?\")
256     (?\\ . ?\\)
257     (?/ . ?/)
258     (?b . ?\b)
259     (?f . ?\f)
260     (?n . ?\n)
261     (?r . ?\r)
262     (?t . ?\t))
263   "Characters which are escaped in JSON, with their elisp counterparts.")
264
265 ;; String parsing
266
267 (defun json-read-escaped-char ()
268   "Read the JSON string escaped character at point."
269   ;; Skip over the '\'
270   (json-advance)
271   (let* ((char (json-pop))
272          (special (assq char json-special-chars)))
273     (cond
274      (special (cdr special))
275      ((not (eq char ?u)) char)
276      ((looking-at "[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]")
277       (let ((hex (match-string 0)))
278         (json-advance 4)
279         (json-decode-char0 'ucs (string-to-number hex 16))))
280      (t
281       (signal 'json-string-escape (list (point)))))))
282
283 (defun json-read-string ()
284   "Read the JSON string at point."
285   (unless (char-equal (json-peek) ?\")
286     (signal 'json-string-format (list "doesn't start with '\"'!")))
287   ;; Skip over the '"'
288   (json-advance)
289   (let ((characters '())
290         (char (json-peek)))
291     (while (not (char-equal char ?\"))
292       (push (if (char-equal char ?\\)
293                 (json-read-escaped-char)
294               (json-pop))
295             characters)
296       (setq char (json-peek)))
297     ;; Skip over the '"'
298     (json-advance)
299     (if characters
300         (apply 'string (nreverse characters))
301       "")))
302
303 ;; String encoding
304
305 (defun json-encode-char (char)
306   "Encode CHAR as a JSON string."
307   (setq char (json-encode-char0 char 'ucs))
308   (let ((control-char (car (rassoc char json-special-chars))))
309     (cond
310      ;; Special JSON character (\n, \r, etc.)
311      (control-char
312       (format "\\%c" control-char))
313      ;; ASCIIish printable character
314      ((and (> char 31) (< char 161))
315       (format "%c" char))
316      ;; Fallback: UCS code point in \uNNNN form
317      (t
318       (format "\\u%04x" char)))))
319
320 (defun json-encode-string (string)
321   "Return a JSON representation of STRING."
322   (format "\"%s\"" (mapconcat 'json-encode-char string "")))
323
324 ;;; JSON Objects
325
326 (defun json-new-object ()
327   "Create a new Elisp object corresponding to a JSON object.
328 Please see the documentation of `json-object-type'."
329   (cond ((eq json-object-type 'hash-table)
330          (make-hash-table :test 'equal))
331         (t
332          (list))))
333
334 (defun json-add-to-object (object key value)
335   "Add a new KEY -> VALUE association to OBJECT.
336 Returns the updated object, which you should save, e.g.:
337     (setq obj (json-add-to-object obj \"foo\" \"bar\"))
338 Please see the documentation of `json-object-type' and `json-key-type'."
339   (let ((json-key-type
340          (if (eq json-key-type nil)
341              (cdr (assq json-object-type '((hash-table . string)
342                                            (alist . symbol)
343                                            (plist . keyword))))
344            json-key-type)))
345     (setq key
346           (cond ((eq json-key-type 'string)
347                  key)
348                 ((eq json-key-type 'symbol)
349                  (intern key))
350                 ((eq json-key-type 'keyword)
351                  (intern (concat ":" key)))))
352     (cond ((eq json-object-type 'hash-table)
353            (puthash key value object)
354            object)
355           ((eq json-object-type 'alist)
356            (cons (cons key value) object))
357           ((eq json-object-type 'plist)
358            (cons key (cons value object))))))
359
360 ;; JSON object parsing
361
362 (defun json-read-object ()
363   "Read the JSON object at point."
364   ;; Skip over the "{"
365   (json-advance)
366   (json-skip-whitespace)
367   ;; read key/value pairs until "}"
368   (let ((elements (json-new-object))
369         key value)
370     (while (not (char-equal (json-peek) ?}))
371       (json-skip-whitespace)
372       (setq key (json-read-string))
373       (json-skip-whitespace)
374       (if (char-equal (json-peek) ?:)
375           (json-advance)
376         (signal 'json-object-format (list ":" (json-peek))))
377       (setq value (json-read))
378       (setq elements (json-add-to-object elements key value))
379       (json-skip-whitespace)
380       (unless (char-equal (json-peek) ?})
381         (if (char-equal (json-peek) ?,)
382             (json-advance)
383           (signal 'json-object-format (list "," (json-peek))))))
384     ;; Skip over the "}"
385     (json-advance)
386     elements))
387
388 ;; Hash table encoding
389
390 (defun json-encode-hash-table (hash-table)
391   "Return a JSON representation of HASH-TABLE."
392   (format "{%s}"
393           (json-join
394            (let (r)
395              (maphash
396               (lambda (k v)
397                 (push (format "%s:%s"
398                               (json-encode k)
399                               (json-encode v))
400                       r))
401               hash-table)
402              r)
403            ", ")))
404
405 ;; List encoding (including alists and plists)
406
407 (defun json-encode-alist (alist)
408   "Return a JSON representation of ALIST."
409   (format "{%s}"
410           (json-join (mapcar (lambda (cons)
411                                (format "%s:%s"
412                                        (json-encode (car cons))
413                                        (json-encode (cdr cons))))
414                              alist)
415                      ", ")))
416
417 (defun json-encode-plist (plist)
418   "Return a JSON representation of PLIST."
419   (let (result)
420     (while plist
421       (push (concat (json-encode (car plist))
422                     ":"
423                     (json-encode (cadr plist)))
424             result)
425       (setq plist (cddr plist)))
426     (concat "{" (json-join (nreverse result) ", ") "}")))
427
428 (defun json-encode-list (list)
429   "Return a JSON representation of LIST.
430 Tries to DWIM: simple lists become JSON arrays, while alists and plists
431 become JSON objects."
432   (cond ((null list)         "null")
433         ((json-alist-p list) (json-encode-alist list))
434         ((json-plist-p list) (json-encode-plist list))
435         ((listp list)        (json-encode-array list))
436         (t
437          (signal 'json-error (list list)))))
438
439 ;;; Arrays
440
441 ;; Array parsing
442
443 (defun json-read-array ()
444   "Read the JSON array at point."
445   ;; Skip over the "["
446   (json-advance)
447   (json-skip-whitespace)
448   ;; read values until "]"
449   (let (elements)
450     (while (not (char-equal (json-peek) ?\]))
451       (push (json-read) elements)
452       (json-skip-whitespace)
453       (unless (char-equal (json-peek) ?\])
454         (if (char-equal (json-peek) ?,)
455             (json-advance)
456           (signal 'json-error (list 'bleah)))))
457     ;; Skip over the "]"
458     (json-advance)
459     (apply json-array-type (nreverse elements))))
460
461 ;; Array encoding
462
463 (defun json-encode-array (array)
464   "Return a JSON representation of ARRAY."
465   (concat "[" (mapconcat 'json-encode array ", ") "]"))
466
467 \f
468
469 ;;; JSON reader.
470
471 (defvar json-readtable
472   (let ((table
473          '((?t json-read-keyword "true")
474            (?f json-read-keyword "false")
475            (?n json-read-keyword "null")
476            (?{ json-read-object)
477            (?\[ json-read-array)
478            (?\" json-read-string))))
479     (mapc (lambda (char)
480             (push (list char 'json-read-number) table))
481           '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
482     table)
483   "Readtable for JSON reader.")
484
485 (defun json-read ()
486   "Parse and return the JSON object following point.
487 Advances point just past JSON object."
488   (json-skip-whitespace)
489   (let ((char (json-peek)))
490     (if (not (eq char :json-eof))
491         (let ((record (cdr (assq char json-readtable))))
492           (if (functionp (car record))
493               (apply (car record) (cdr record))
494             (signal 'json-readtable-error record)))
495       (signal 'end-of-file nil))))
496
497 ;; Syntactic sugar for the reader
498
499 (defun json-read-from-string (string)
500   "Read the JSON object contained in STRING and return it."
501   (with-temp-buffer
502     (insert string)
503     (goto-char (point-min))
504     (json-read)))
505
506 (defun json-read-file (file)
507   "Read the first JSON object contained in FILE and return it."
508   (with-temp-buffer
509     (insert-file-contents file)
510     (goto-char (point-min))
511     (json-read)))
512
513 \f
514
515 ;;; JSON encoder
516
517 (defun json-encode (object)
518   "Return a JSON representation of OBJECT as a string."
519   (cond ((memq object (list t json-null json-false))
520          (json-encode-keyword object))
521         ((stringp object)      (json-encode-string object))
522         ((keywordp object)     (json-encode-string
523                                 (substring (symbol-name object) 1)))
524         ((symbolp object)      (json-encode-string
525                                 (symbol-name object)))
526         ((numberp object)      (json-encode-number object))
527         ((arrayp object)       (json-encode-array object))
528         ((hash-table-p object) (json-encode-hash-table object))
529         ((listp object)        (json-encode-list object))
530         (t                     (signal 'json-error (list object)))))
531
532 (provide 'json)
533
534 ;;; json.el ends here