lisp/json.el

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