lisp/json.el

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