code.delx.au - gnu-emacs/blob - lisp/json.el

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