lisp/json.el

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