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.4
   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 ;; 2012-10-25 - Added pretty-printed reformatting -Ryan Crum (ryan@ryancrum.org)
  52
  53 ;;; Code:
  54
  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 (defvar json-encoding-separator ","
 103   "Value to use as an element separator when encoding.")
 104
 105 (defvar json-encoding-default-indentation "  "
 106   "The default indentation level for encoding.
 107 Used only when `json-encoding-pretty-print' is non-nil.")
 108
 109 (defvar json--encoding-current-indentation "\n"
 110   "Internally used to keep track of the current indentation level of encoding.
 111 Used only when `json-encoding-pretty-print' is non-nil.")
 112
 113 (defvar json-encoding-pretty-print nil
 114   "If non-nil, then the output of `json-encode' will be pretty-printed.")
 115
 116 (defvar json-encoding-lisp-style-closings nil
 117   "If non-nil, ] and } closings will be formatted lisp-style,
 118 without indentation.")
 119
 120 \f
 121
 122 ;;; Utilities
 123
 124 (defun json-join (strings separator)
 125   "Join STRINGS with SEPARATOR."
 126   (mapconcat 'identity strings separator))
 127
 128 (defun json-alist-p (list)
 129   "Non-null if and only if LIST is an alist."
 130   (while (consp list)
 131     (setq list (if (consp (car list))
 132                    (cdr list)
 133                  'not-alist)))
 134   (null list))
 135
 136 (defun json-plist-p (list)
 137   "Non-null if and only if LIST is a plist."
 138   (while (consp list)
 139     (setq list (if (and (keywordp (car list))
 140                         (consp (cdr list)))
 141                    (cddr list)
 142                  'not-plist)))
 143   (null list))
 144
 145 (defmacro json--with-indentation (body)
 146   `(let ((json--encoding-current-indentation
 147           (if json-encoding-pretty-print
 148               (concat json--encoding-current-indentation
 149                       json-encoding-default-indentation)
 150             "")))
 151      ,body))
 152
 153 ;; Reader utilities
 154
 155 (defsubst json-advance (&optional n)
 156   "Skip past the following N characters."
 157   (forward-char n))
 158
 159 (defsubst json-peek ()
 160   "Return the character at point."
 161   (let ((char (char-after (point))))
 162     (or char :json-eof)))
 163
 164 (defsubst json-pop ()
 165   "Advance past the character at point, returning it."
 166   (let ((char (json-peek)))
 167     (if (eq char :json-eof)
 168         (signal 'end-of-file nil)
 169       (json-advance)
 170       char)))
 171
 172 (defun json-skip-whitespace ()
 173   "Skip past the whitespace at point."
 174   (skip-chars-forward "\t\r\n\f\b "))
 175
 176 \f
 177
 178 ;; Error conditions
 179
 180 (put 'json-error 'error-message "Unknown JSON error")
 181 (put 'json-error 'error-conditions '(json-error error))
 182
 183 (put 'json-readtable-error 'error-message "JSON readtable error")
 184 (put 'json-readtable-error 'error-conditions
 185      '(json-readtable-error json-error error))
 186
 187 (put 'json-unknown-keyword 'error-message "Unrecognized keyword")
 188 (put 'json-unknown-keyword 'error-conditions
 189      '(json-unknown-keyword json-error error))
 190
 191 (put 'json-number-format 'error-message "Invalid number format")
 192 (put 'json-number-format 'error-conditions
 193      '(json-number-format json-error error))
 194
 195 (put 'json-string-escape 'error-message "Bad Unicode escape")
 196 (put 'json-string-escape 'error-conditions
 197      '(json-string-escape json-error error))
 198
 199 (put 'json-string-format 'error-message "Bad string format")
 200 (put 'json-string-format 'error-conditions
 201      '(json-string-format json-error error))
 202
 203 (put 'json-key-format 'error-message "Bad JSON object key")
 204 (put 'json-key-format 'error-conditions
 205      '(json-key-format json-error error))
 206
 207 (put 'json-object-format 'error-message "Bad JSON object")
 208 (put 'json-object-format 'error-conditions
 209      '(json-object-format json-error error))
 210
 211 \f
 212
 213 ;;; Keywords
 214
 215 (defvar json-keywords '("true" "false" "null")
 216   "List of JSON keywords.")
 217
 218 ;; Keyword parsing
 219
 220 (defun json-read-keyword (keyword)
 221   "Read a JSON keyword at point.
 222 KEYWORD is the keyword expected."
 223   (unless (member keyword json-keywords)
 224     (signal 'json-unknown-keyword (list keyword)))
 225   (mapc (lambda (char)
 226           (unless (char-equal char (json-peek))
 227             (signal 'json-unknown-keyword
 228                     (list (save-excursion
 229                             (backward-word 1)
 230                             (thing-at-point 'word)))))
 231           (json-advance))
 232         keyword)
 233   (unless (looking-at "\\(\\s-\\|[],}]\\|$\\)")
 234     (signal 'json-unknown-keyword
 235             (list (save-excursion
 236                     (backward-word 1)
 237                     (thing-at-point 'word)))))
 238   (cond ((string-equal keyword "true") t)
 239         ((string-equal keyword "false") json-false)
 240         ((string-equal keyword "null") json-null)))
 241
 242 ;; Keyword encoding
 243
 244 (defun json-encode-keyword (keyword)
 245   "Encode KEYWORD as a JSON value."
 246   (cond ((eq keyword t)          "true")
 247         ((eq keyword json-false) "false")
 248         ((eq keyword json-null)  "null")))
 249
 250 ;;; Numbers
 251
 252 ;; Number parsing
 253
 254 (defun json-read-number (&optional sign)
 255  "Read the JSON number following point.
 256 The optional SIGN argument is for internal use.
 257
 258 N.B.: Only numbers which can fit in Emacs Lisp's native number
 259 representation will be parsed correctly."
 260  ;; If SIGN is non-nil, the number is explicitly signed.
 261  (let ((number-regexp
 262         "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?"))
 263    (cond ((and (null sign) (char-equal (json-peek) ?-))
 264           (json-advance)
 265           (- (json-read-number t)))
 266          ((and (null sign) (char-equal (json-peek) ?+))
 267           (json-advance)
 268           (json-read-number t))
 269          ((and (looking-at number-regexp)
 270                (or (match-beginning 1)
 271                    (match-beginning 2)))
 272           (goto-char (match-end 0))
 273           (string-to-number (match-string 0)))
 274          (t (signal 'json-number-format (list (point)))))))
 275
 276 ;; Number encoding
 277
 278 (defun json-encode-number (number)
 279   "Return a JSON representation of NUMBER."
 280   (format "%s" number))
 281
 282 ;;; Strings
 283
 284 (defvar json-special-chars
 285   '((?\" . ?\")
 286     (?\\ . ?\\)
 287     (?/ . ?/)
 288     (?b . ?\b)
 289     (?f . ?\f)
 290     (?n . ?\n)
 291     (?r . ?\r)
 292     (?t . ?\t))
 293   "Characters which are escaped in JSON, with their elisp counterparts.")
 294
 295 ;; String parsing
 296
 297 (defun json-read-escaped-char ()
 298   "Read the JSON string escaped character at point."
 299   ;; Skip over the '\'
 300   (json-advance)
 301   (let* ((char (json-pop))
 302          (special (assq char json-special-chars)))
 303     (cond
 304      (special (cdr special))
 305      ((not (eq char ?u)) char)
 306      ((looking-at "[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]")
 307       (let ((hex (match-string 0)))
 308         (json-advance 4)
 309         (json-decode-char0 'ucs (string-to-number hex 16))))
 310      (t
 311       (signal 'json-string-escape (list (point)))))))
 312
 313 (defun json-read-string ()
 314   "Read the JSON string at point."
 315   (unless (char-equal (json-peek) ?\")
 316     (signal 'json-string-format (list "doesn't start with '\"'!")))
 317   ;; Skip over the '"'
 318   (json-advance)
 319   (let ((characters '())
 320         (char (json-peek)))
 321     (while (not (char-equal char ?\"))
 322       (push (if (char-equal char ?\\)
 323                 (json-read-escaped-char)
 324               (json-pop))
 325             characters)
 326       (setq char (json-peek)))
 327     ;; Skip over the '"'
 328     (json-advance)
 329     (if characters
 330         (apply 'string (nreverse characters))
 331       "")))
 332
 333 ;; String encoding
 334
 335 (defun json-encode-char (char)
 336   "Encode CHAR as a JSON string."
 337   (setq char (json-encode-char0 char 'ucs))
 338   (let ((control-char (car (rassoc char json-special-chars))))
 339     (cond
 340      ;; Special JSON character (\n, \r, etc.).
 341      (control-char
 342       (format "\\%c" control-char))
 343      ;; ASCIIish printable character.
 344      ((and (> char 31) (< char 127))
 345       (format "%c" char))
 346      ;; Fallback: UCS code point in \uNNNN form.
 347      (t
 348       (format "\\u%04x" char)))))
 349
 350 (defun json-encode-string (string)
 351   "Return a JSON representation of STRING."
 352   (format "\"%s\"" (mapconcat 'json-encode-char string "")))
 353
 354 (defun json-encode-key (object)
 355   "Return a JSON representation of OBJECT.
 356 If the resulting JSON object isn't a valid JSON object key,
 357 this signals `json-key-format'."
 358   (let ((encoded (json-encode object)))
 359     (unless (stringp (json-read-from-string encoded))
 360       (signal 'json-key-format (list object)))
 361     encoded))
 362
 363 ;;; JSON Objects
 364
 365 (defun json-new-object ()
 366   "Create a new Elisp object corresponding to a JSON object.
 367 Please see the documentation of `json-object-type'."
 368   (cond ((eq json-object-type 'hash-table)
 369          (make-hash-table :test 'equal))
 370         (t
 371          (list))))
 372
 373 (defun json-add-to-object (object key value)
 374   "Add a new KEY -> VALUE association to OBJECT.
 375 Returns the updated object, which you should save, e.g.:
 376     (setq obj (json-add-to-object obj \"foo\" \"bar\"))
 377 Please see the documentation of `json-object-type' and `json-key-type'."
 378   (let ((json-key-type
 379          (if (eq json-key-type nil)
 380              (cdr (assq json-object-type '((hash-table . string)
 381                                            (alist . symbol)
 382                                            (plist . keyword))))
 383            json-key-type)))
 384     (setq key
 385           (cond ((eq json-key-type 'string)
 386                  key)
 387                 ((eq json-key-type 'symbol)
 388                  (intern key))
 389                 ((eq json-key-type 'keyword)
 390                  (intern (concat ":" key)))))
 391     (cond ((eq json-object-type 'hash-table)
 392            (puthash key value object)
 393            object)
 394           ((eq json-object-type 'alist)
 395            (cons (cons key value) object))
 396           ((eq json-object-type 'plist)
 397            (cons key (cons value object))))))
 398
 399 ;; JSON object parsing
 400
 401 (defun json-read-object ()
 402   "Read the JSON object at point."
 403   ;; Skip over the "{"
 404   (json-advance)
 405   (json-skip-whitespace)
 406   ;; read key/value pairs until "}"
 407   (let ((elements (json-new-object))
 408         key value)
 409     (while (not (char-equal (json-peek) ?}))
 410       (json-skip-whitespace)
 411       (setq key (json-read-string))
 412       (json-skip-whitespace)
 413       (if (char-equal (json-peek) ?:)
 414           (json-advance)
 415         (signal 'json-object-format (list ":" (json-peek))))
 416       (setq value (json-read))
 417       (setq elements (json-add-to-object elements key value))
 418       (json-skip-whitespace)
 419       (unless (char-equal (json-peek) ?})
 420         (if (char-equal (json-peek) ?,)
 421             (json-advance)
 422           (signal 'json-object-format (list "," (json-peek))))))
 423     ;; Skip over the "}"
 424     (json-advance)
 425     elements))
 426
 427 ;; Hash table encoding
 428
 429 (defun json-encode-hash-table (hash-table)
 430   "Return a JSON representation of HASH-TABLE."
 431   (format "{%s%s}"
 432           (json-join
 433            (let (r)
 434              (json--with-indentation
 435               (maphash
 436                (lambda (k v)
 437                  (push (format
 438                         (if json-encoding-pretty-print
 439                             "%s%s: %s"
 440                           "%s%s:%s")
 441                         json--encoding-current-indentation
 442                         (json-encode-key k)
 443                         (json-encode v))
 444                        r))
 445                hash-table))
 446              r)
 447            json-encoding-separator)
 448           (if (or (not json-encoding-pretty-print)
 449                   json-encoding-lisp-style-closings)
 450               ""
 451             json--encoding-current-indentation)))
 452
 453 ;; List encoding (including alists and plists)
 454
 455 (defun json-encode-alist (alist)
 456   "Return a JSON representation of ALIST."
 457   (format "{%s%s}"
 458           (json-join
 459            (json--with-indentation
 460             (mapcar (lambda (cons)
 461                       (format (if json-encoding-pretty-print
 462                                   "%s%s: %s"
 463                                 "%s%s:%s")
 464                               json--encoding-current-indentation
 465                               (json-encode-key (car cons))
 466                               (json-encode (cdr cons))))
 467                     alist))
 468            json-encoding-separator)
 469           (if (or (not json-encoding-pretty-print)
 470                   json-encoding-lisp-style-closings)
 471               ""
 472             json--encoding-current-indentation)))
 473
 474 (defun json-encode-plist (plist)
 475   "Return a JSON representation of PLIST."
 476   (let (result)
 477     (json--with-indentation
 478       (while plist
 479         (push (concat
 480                json--encoding-current-indentation
 481                (json-encode-key (car plist))
 482                (if json-encoding-pretty-print
 483                    ": "
 484                  ":")
 485                (json-encode (cadr plist)))
 486               result)
 487         (setq plist (cddr plist))))
 488     (concat "{"
 489             (json-join (nreverse result) json-encoding-separator)
 490             (if (and json-encoding-pretty-print
 491                      (not json-encoding-lisp-style-closings))
 492                 json--encoding-current-indentation
 493               "")
 494             "}")))
 495
 496 (defun json-encode-list (list)
 497   "Return a JSON representation of LIST.
 498 Tries to DWIM: simple lists become JSON arrays, while alists and plists
 499 become JSON objects."
 500   (cond ((null list)         "null")
 501         ((json-alist-p list) (json-encode-alist list))
 502         ((json-plist-p list) (json-encode-plist list))
 503         ((listp list)        (json-encode-array list))
 504         (t
 505          (signal 'json-error (list list)))))
 506
 507 ;;; Arrays
 508
 509 ;; Array parsing
 510
 511 (defun json-read-array ()
 512   "Read the JSON array at point."
 513   ;; Skip over the "["
 514   (json-advance)
 515   (json-skip-whitespace)
 516   ;; read values until "]"
 517   (let (elements)
 518     (while (not (char-equal (json-peek) ?\]))
 519       (push (json-read) elements)
 520       (json-skip-whitespace)
 521       (unless (char-equal (json-peek) ?\])
 522         (if (char-equal (json-peek) ?,)
 523             (json-advance)
 524           (signal 'json-error (list 'bleah)))))
 525     ;; Skip over the "]"
 526     (json-advance)
 527     (apply json-array-type (nreverse elements))))
 528
 529 ;; Array encoding
 530
 531 (defun json-encode-array (array)
 532   "Return a JSON representation of ARRAY."
 533   (if (and json-encoding-pretty-print
 534            (> (length array) 0))
 535       (concat
 536        (json--with-indentation
 537          (concat (format "[%s" json--encoding-current-indentation)
 538                  (json-join (mapcar 'json-encode array)
 539                             (format "%s%s"
 540                                     json-encoding-separator
 541                                     json--encoding-current-indentation))))
 542        (format "%s]"
 543                (if json-encoding-lisp-style-closings
 544                    ""
 545                  json--encoding-current-indentation)))
 546     (concat "["
 547             (mapconcat 'json-encode array json-encoding-separator)
 548             "]")))
 549
 550 \f
 551
 552 ;;; JSON reader.
 553
 554 (defvar json-readtable
 555   (let ((table
 556          '((?t json-read-keyword "true")
 557            (?f json-read-keyword "false")
 558            (?n json-read-keyword "null")
 559            (?{ json-read-object)
 560            (?\[ json-read-array)
 561            (?\" json-read-string))))
 562     (mapc (lambda (char)
 563             (push (list char 'json-read-number) table))
 564           '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
 565     table)
 566   "Readtable for JSON reader.")
 567
 568 (defun json-read ()
 569   "Parse and return the JSON object following point.
 570 Advances point just past JSON object."
 571   (json-skip-whitespace)
 572   (let ((char (json-peek)))
 573     (if (not (eq char :json-eof))
 574         (let ((record (cdr (assq char json-readtable))))
 575           (if (functionp (car record))
 576               (apply (car record) (cdr record))
 577             (signal 'json-readtable-error record)))
 578       (signal 'end-of-file nil))))
 579
 580 ;; Syntactic sugar for the reader
 581
 582 (defun json-read-from-string (string)
 583   "Read the JSON object contained in STRING and return it."
 584   (with-temp-buffer
 585     (insert string)
 586     (goto-char (point-min))
 587     (json-read)))
 588
 589 (defun json-read-file (file)
 590   "Read the first JSON object contained in FILE and return it."
 591   (with-temp-buffer
 592     (insert-file-contents file)
 593     (goto-char (point-min))
 594     (json-read)))
 595
 596 \f
 597
 598 ;;; JSON encoder
 599
 600 (defun json-encode (object)
 601   "Return a JSON representation of OBJECT as a string."
 602   (cond ((memq object (list t json-null json-false))
 603          (json-encode-keyword object))
 604         ((stringp object)      (json-encode-string object))
 605         ((keywordp object)     (json-encode-string
 606                                 (substring (symbol-name object) 1)))
 607         ((symbolp object)      (json-encode-string
 608                                 (symbol-name object)))
 609         ((numberp object)      (json-encode-number object))
 610         ((arrayp object)       (json-encode-array object))
 611         ((hash-table-p object) (json-encode-hash-table object))
 612         ((listp object)        (json-encode-list object))
 613         (t                     (signal 'json-error (list object)))))
 614
 615 ;; Pretty printing
 616
 617 (defun json-pretty-print-buffer ()
 618   "Pretty-print current buffer."
 619   (interactive)
 620   (json-pretty-print (point-min) (point-max)))
 621
 622 (defun json-pretty-print (begin end)
 623   "Pretty-print selected region."
 624   (interactive "r")
 625   (atomic-change-group
 626     (let ((json-encoding-pretty-print t)
 627           (txt (delete-and-extract-region begin end)))
 628       (insert (json-encode (json-read-from-string txt))))))
 629
 630 (provide 'json)
 631
 632 ;;; json.el ends here