lisp/json.el

   1 ;;; json.el --- JavaScript Object Notation parser / generator
   2
   3 ;; Copyright (C) 2006-2012 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-key-format 'error-message "Bad JSON object key")
 178 (put 'json-key-format 'error-conditions
 179      '(json-key-format json-error error))
 180
 181 (put 'json-object-format 'error-message "Bad JSON object")
 182 (put 'json-object-format 'error-conditions
 183      '(json-object-format json-error error))
 184
 185 \f
 186
 187 ;;; Keywords
 188
 189 (defvar json-keywords '("true" "false" "null")
 190   "List of JSON keywords.")
 191
 192 ;; Keyword parsing
 193
 194 (defun json-read-keyword (keyword)
 195   "Read a JSON keyword at point.
 196 KEYWORD is the keyword expected."
 197   (unless (member keyword json-keywords)
 198     (signal 'json-unknown-keyword (list keyword)))
 199   (mapc (lambda (char)
 200           (unless (char-equal char (json-peek))
 201             (signal 'json-unknown-keyword
 202                     (list (save-excursion
 203                             (backward-word 1)
 204                             (thing-at-point 'word)))))
 205           (json-advance))
 206         keyword)
 207   (unless (looking-at "\\(\\s-\\|[],}]\\|$\\)")
 208     (signal 'json-unknown-keyword
 209             (list (save-excursion
 210                     (backward-word 1)
 211                     (thing-at-point 'word)))))
 212   (cond ((string-equal keyword "true") t)
 213         ((string-equal keyword "false") json-false)
 214         ((string-equal keyword "null") json-null)))
 215
 216 ;; Keyword encoding
 217
 218 (defun json-encode-keyword (keyword)
 219   "Encode KEYWORD as a JSON value."
 220   (cond ((eq keyword t)          "true")
 221         ((eq keyword json-false) "false")
 222         ((eq keyword json-null)  "null")))
 223
 224 ;;; Numbers
 225
 226 ;; Number parsing
 227
 228 (defun json-read-number (&optional sign)
 229  "Read the JSON number following point.
 230 The optional SIGN argument is for internal use.
 231
 232 N.B.: Only numbers which can fit in Emacs Lisp's native number
 233 representation will be parsed correctly."
 234  ;; If SIGN is non-nil, the number is explicitly signed.
 235  (let ((number-regexp
 236         "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?"))
 237    (cond ((and (null sign) (char-equal (json-peek) ?-))
 238           (json-advance)
 239           (- (json-read-number t)))
 240          ((and (null sign) (char-equal (json-peek) ?+))
 241           (json-advance)
 242           (json-read-number t))
 243          ((and (looking-at number-regexp)
 244                (or (match-beginning 1)
 245                    (match-beginning 2)))
 246           (goto-char (match-end 0))
 247           (string-to-number (match-string 0)))
 248          (t (signal 'json-number-format (list (point)))))))
 249
 250 ;; Number encoding
 251
 252 (defun json-encode-number (number)
 253   "Return a JSON representation of NUMBER."
 254   (format "%s" number))
 255
 256 ;;; Strings
 257
 258 (defvar json-special-chars
 259   '((?\" . ?\")
 260     (?\\ . ?\\)
 261     (?/ . ?/)
 262     (?b . ?\b)
 263     (?f . ?\f)
 264     (?n . ?\n)
 265     (?r . ?\r)
 266     (?t . ?\t))
 267   "Characters which are escaped in JSON, with their elisp counterparts.")
 268
 269 ;; String parsing
 270
 271 (defun json-read-escaped-char ()
 272   "Read the JSON string escaped character at point."
 273   ;; Skip over the '\'
 274   (json-advance)
 275   (let* ((char (json-pop))
 276          (special (assq char json-special-chars)))
 277     (cond
 278      (special (cdr special))
 279      ((not (eq char ?u)) char)
 280      ((looking-at "[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]")
 281       (let ((hex (match-string 0)))
 282         (json-advance 4)
 283         (json-decode-char0 'ucs (string-to-number hex 16))))
 284      (t
 285       (signal 'json-string-escape (list (point)))))))
 286
 287 (defun json-read-string ()
 288   "Read the JSON string at point."
 289   (unless (char-equal (json-peek) ?\")
 290     (signal 'json-string-format (list "doesn't start with '\"'!")))
 291   ;; Skip over the '"'
 292   (json-advance)
 293   (let ((characters '())
 294         (char (json-peek)))
 295     (while (not (char-equal char ?\"))
 296       (push (if (char-equal char ?\\)
 297                 (json-read-escaped-char)
 298               (json-pop))
 299             characters)
 300       (setq char (json-peek)))
 301     ;; Skip over the '"'
 302     (json-advance)
 303     (if characters
 304         (apply 'string (nreverse characters))
 305       "")))
 306
 307 ;; String encoding
 308
 309 (defun json-encode-char (char)
 310   "Encode CHAR as a JSON string."
 311   (setq char (json-encode-char0 char 'ucs))
 312   (let ((control-char (car (rassoc char json-special-chars))))
 313     (cond
 314      ;; Special JSON character (\n, \r, etc.).
 315      (control-char
 316       (format "\\%c" control-char))
 317      ;; ASCIIish printable character.
 318      ((and (> char 31) (< char 127))
 319       (format "%c" char))
 320      ;; Fallback: UCS code point in \uNNNN form.
 321      (t
 322       (format "\\u%04x" char)))))
 323
 324 (defun json-encode-string (string)
 325   "Return a JSON representation of STRING."
 326   (format "\"%s\"" (mapconcat 'json-encode-char string "")))
 327
 328 (defun json-encode-key (object)
 329   "Return a JSON representation of OBJECT.
 330 If the resulting JSON object isn't a valid JSON object key,
 331 this signals `json-key-format'."
 332   (let ((encoded (json-encode object)))
 333     (unless (stringp (json-read-from-string encoded))
 334       (signal 'json-key-format (list object)))
 335     encoded))
 336
 337 ;;; JSON Objects
 338
 339 (defun json-new-object ()
 340   "Create a new Elisp object corresponding to a JSON object.
 341 Please see the documentation of `json-object-type'."
 342   (cond ((eq json-object-type 'hash-table)
 343          (make-hash-table :test 'equal))
 344         (t
 345          (list))))
 346
 347 (defun json-add-to-object (object key value)
 348   "Add a new KEY -> VALUE association to OBJECT.
 349 Returns the updated object, which you should save, e.g.:
 350     (setq obj (json-add-to-object obj \"foo\" \"bar\"))
 351 Please see the documentation of `json-object-type' and `json-key-type'."
 352   (let ((json-key-type
 353          (if (eq json-key-type nil)
 354              (cdr (assq json-object-type '((hash-table . string)
 355                                            (alist . symbol)
 356                                            (plist . keyword))))
 357            json-key-type)))
 358     (setq key
 359           (cond ((eq json-key-type 'string)
 360                  key)
 361                 ((eq json-key-type 'symbol)
 362                  (intern key))
 363                 ((eq json-key-type 'keyword)
 364                  (intern (concat ":" key)))))
 365     (cond ((eq json-object-type 'hash-table)
 366            (puthash key value object)
 367            object)
 368           ((eq json-object-type 'alist)
 369            (cons (cons key value) object))
 370           ((eq json-object-type 'plist)
 371            (cons key (cons value object))))))
 372
 373 ;; JSON object parsing
 374
 375 (defun json-read-object ()
 376   "Read the JSON object at point."
 377   ;; Skip over the "{"
 378   (json-advance)
 379   (json-skip-whitespace)
 380   ;; read key/value pairs until "}"
 381   (let ((elements (json-new-object))
 382         key value)
 383     (while (not (char-equal (json-peek) ?}))
 384       (json-skip-whitespace)
 385       (setq key (json-read-string))
 386       (json-skip-whitespace)
 387       (if (char-equal (json-peek) ?:)
 388           (json-advance)
 389         (signal 'json-object-format (list ":" (json-peek))))
 390       (setq value (json-read))
 391       (setq elements (json-add-to-object elements key value))
 392       (json-skip-whitespace)
 393       (unless (char-equal (json-peek) ?})
 394         (if (char-equal (json-peek) ?,)
 395             (json-advance)
 396           (signal 'json-object-format (list "," (json-peek))))))
 397     ;; Skip over the "}"
 398     (json-advance)
 399     elements))
 400
 401 ;; Hash table encoding
 402
 403 (defun json-encode-hash-table (hash-table)
 404   "Return a JSON representation of HASH-TABLE."
 405   (format "{%s}"
 406           (json-join
 407            (let (r)
 408              (maphash
 409               (lambda (k v)
 410                 (push (format "%s:%s"
 411                               (json-encode-key k)
 412                               (json-encode v))
 413                       r))
 414               hash-table)
 415              r)
 416            ", ")))
 417
 418 ;; List encoding (including alists and plists)
 419
 420 (defun json-encode-alist (alist)
 421   "Return a JSON representation of ALIST."
 422   (format "{%s}"
 423           (json-join (mapcar (lambda (cons)
 424                                (format "%s:%s"
 425                                        (json-encode-key (car cons))
 426                                        (json-encode (cdr cons))))
 427                              alist)
 428                      ", ")))
 429
 430 (defun json-encode-plist (plist)
 431   "Return a JSON representation of PLIST."
 432   (let (result)
 433     (while plist
 434       (push (concat (json-encode-key (car plist))
 435                     ":"
 436                     (json-encode (cadr plist)))
 437             result)
 438       (setq plist (cddr plist)))
 439     (concat "{" (json-join (nreverse result) ", ") "}")))
 440
 441 (defun json-encode-list (list)
 442   "Return a JSON representation of LIST.
 443 Tries to DWIM: simple lists become JSON arrays, while alists and plists
 444 become JSON objects."
 445   (cond ((null list)         "null")
 446         ((json-alist-p list) (json-encode-alist list))
 447         ((json-plist-p list) (json-encode-plist list))
 448         ((listp list)        (json-encode-array list))
 449         (t
 450          (signal 'json-error (list list)))))
 451
 452 ;;; Arrays
 453
 454 ;; Array parsing
 455
 456 (defun json-read-array ()
 457   "Read the JSON array at point."
 458   ;; Skip over the "["
 459   (json-advance)
 460   (json-skip-whitespace)
 461   ;; read values until "]"
 462   (let (elements)
 463     (while (not (char-equal (json-peek) ?\]))
 464       (push (json-read) elements)
 465       (json-skip-whitespace)
 466       (unless (char-equal (json-peek) ?\])
 467         (if (char-equal (json-peek) ?,)
 468             (json-advance)
 469           (signal 'json-error (list 'bleah)))))
 470     ;; Skip over the "]"
 471     (json-advance)
 472     (apply json-array-type (nreverse elements))))
 473
 474 ;; Array encoding
 475
 476 (defun json-encode-array (array)
 477   "Return a JSON representation of ARRAY."
 478   (concat "[" (mapconcat 'json-encode array ", ") "]"))
 479
 480 \f
 481
 482 ;;; JSON reader.
 483
 484 (defvar json-readtable
 485   (let ((table
 486          '((?t json-read-keyword "true")
 487            (?f json-read-keyword "false")
 488            (?n json-read-keyword "null")
 489            (?{ json-read-object)
 490            (?\[ json-read-array)
 491            (?\" json-read-string))))
 492     (mapc (lambda (char)
 493             (push (list char 'json-read-number) table))
 494           '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
 495     table)
 496   "Readtable for JSON reader.")
 497
 498 (defun json-read ()
 499   "Parse and return the JSON object following point.
 500 Advances point just past JSON object."
 501   (json-skip-whitespace)
 502   (let ((char (json-peek)))
 503     (if (not (eq char :json-eof))
 504         (let ((record (cdr (assq char json-readtable))))
 505           (if (functionp (car record))
 506               (apply (car record) (cdr record))
 507             (signal 'json-readtable-error record)))
 508       (signal 'end-of-file nil))))
 509
 510 ;; Syntactic sugar for the reader
 511
 512 (defun json-read-from-string (string)
 513   "Read the JSON object contained in STRING and return it."
 514   (with-temp-buffer
 515     (insert string)
 516     (goto-char (point-min))
 517     (json-read)))
 518
 519 (defun json-read-file (file)
 520   "Read the first JSON object contained in FILE and return it."
 521   (with-temp-buffer
 522     (insert-file-contents file)
 523     (goto-char (point-min))
 524     (json-read)))
 525
 526 \f
 527
 528 ;;; JSON encoder
 529
 530 (defun json-encode (object)
 531   "Return a JSON representation of OBJECT as a string."
 532   (cond ((memq object (list t json-null json-false))
 533          (json-encode-keyword object))
 534         ((stringp object)      (json-encode-string object))
 535         ((keywordp object)     (json-encode-string
 536                                 (substring (symbol-name object) 1)))
 537         ((symbolp object)      (json-encode-string
 538                                 (symbol-name object)))
 539         ((numberp object)      (json-encode-number object))
 540         ((arrayp object)       (json-encode-array object))
 541         ((hash-table-p object) (json-encode-hash-table object))
 542         ((listp object)        (json-encode-list object))
 543         (t                     (signal 'json-error (list object)))))
 544
 545 (provide 'json)
 546
 547 ;;; json.el ends here