lisp/json.el

   1 ;;; json.el --- JavaScript Object Notation parser / generator -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2006-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Theresa 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 <https://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 (require 'map)
  56
  57 ;; Parameters
  58
  59 (defvar json-object-type 'alist
  60   "Type to convert JSON objects to.
  61 Must be one of `alist', `plist', or `hash-table'.  Consider let-binding
  62 this around your call to `json-read' instead of `setq'ing it.  Ordering
  63 is maintained for `alist' and `plist', but not for `hash-table'.")
  64
  65 (defvar json-array-type 'vector
  66   "Type to convert JSON arrays to.
  67 Must be one of `vector' or `list'.  Consider let-binding this around
  68 your call to `json-read' instead of `setq'ing it.")
  69
  70 (defvar json-key-type nil
  71   "Type to convert JSON keys to.
  72 Must be one of `string', `symbol', `keyword', or nil.
  73
  74 If nil, `json-read' will guess the type based on the value of
  75 `json-object-type':
  76
  77     If `json-object-type' is:   nil will be interpreted as:
  78       `hash-table'                `string'
  79       `alist'                     `symbol'
  80       `plist'                     `keyword'
  81
  82 Note that values other than `string' might behave strangely for
  83 Sufficiently Weird keys.  Consider let-binding this around your call to
  84 `json-read' instead of `setq'ing it.")
  85
  86 (defvar json-false :json-false
  87   "Value to use when reading JSON `false'.
  88 If this has the same value as `json-null', you might not be able to tell
  89 the difference between `false' and `null'.  Consider let-binding this
  90 around your call to `json-read' instead of `setq'ing it.")
  91
  92 (defvar json-null nil
  93   "Value to use when reading JSON `null'.
  94 If this has the same value as `json-false', you might not be able to
  95 tell the difference between `false' and `null'.  Consider let-binding
  96 this around your call to `json-read' instead of `setq'ing it.")
  97
  98 (defvar json-encoding-separator ","
  99   "Value to use as an element separator when encoding.")
 100
 101 (defvar json-encoding-default-indentation "  "
 102   "The default indentation level for encoding.
 103 Used only when `json-encoding-pretty-print' is non-nil.")
 104
 105 (defvar json--encoding-current-indentation "\n"
 106   "Internally used to keep track of the current indentation level of encoding.
 107 Used only when `json-encoding-pretty-print' is non-nil.")
 108
 109 (defvar json-encoding-pretty-print nil
 110   "If non-nil, then the output of `json-encode' will be pretty-printed.")
 111
 112 (defvar json-encoding-lisp-style-closings nil
 113   "If non-nil, ] and } closings will be formatted lisp-style,
 114 without indentation.")
 115
 116 (defvar json-encoding-object-sort-predicate nil
 117   "Sorting predicate for JSON object keys during encoding.
 118 If nil, no sorting is performed.  Else, JSON object keys are
 119 ordered by the specified sort predicate during encoding.  For
 120 instance, setting this to `string<' will have JSON object keys
 121 ordered alphabetically.")
 122
 123 (defvar json-pre-element-read-function nil
 124   "Function called (if non-nil) by `json-read-array' and
 125 `json-read-object' right before reading a JSON array or object,
 126 respectively.  The function is called with one argument, which is
 127 the current JSON key.")
 128
 129 (defvar json-post-element-read-function nil
 130   "Function called (if non-nil) by `json-read-array' and
 131 `json-read-object' right after reading a JSON array or object,
 132 respectively.")
 133
 134 \f
 135
 136 ;;; Utilities
 137
 138 (defun json-join (strings separator)
 139   "Join STRINGS with SEPARATOR."
 140   (mapconcat 'identity strings separator))
 141
 142 (defun json-alist-p (list)
 143   "Non-null if and only if LIST is an alist with simple keys."
 144   (while (consp list)
 145     (setq list (if (and (consp (car list))
 146                         (atom (caar list)))
 147                    (cdr list)
 148                  'not-alist)))
 149   (null list))
 150
 151 (defun json-plist-p (list)
 152   "Non-null if and only if LIST is a plist with keyword keys."
 153   (while (consp list)
 154     (setq list (if (and (keywordp (car list))
 155                         (consp (cdr list)))
 156                    (cddr list)
 157                  'not-plist)))
 158   (null list))
 159
 160 (defun json--plist-reverse (plist)
 161   "Return a copy of PLIST in reverse order.
 162 Unlike `reverse', this keeps the property-value pairs intact."
 163   (let (res)
 164     (while plist
 165       (let ((prop (pop plist))
 166             (val (pop plist)))
 167         (push val res)
 168         (push prop res)))
 169     res))
 170
 171 (defun json--plist-to-alist (plist)
 172   "Return an alist of the property-value pairs in PLIST."
 173   (let (res)
 174     (while plist
 175       (let ((prop (pop plist))
 176             (val (pop plist)))
 177         (push (cons prop val) res)))
 178     (nreverse res)))
 179
 180 (defmacro json--with-indentation (body)
 181   `(let ((json--encoding-current-indentation
 182           (if json-encoding-pretty-print
 183               (concat json--encoding-current-indentation
 184                       json-encoding-default-indentation)
 185             "")))
 186      ,body))
 187
 188 ;; Reader utilities
 189
 190 (defsubst json-advance (&optional n)
 191   "Advance N characters forward."
 192   (forward-char n))
 193
 194 (defsubst json-peek ()
 195   "Return the character at point."
 196   (following-char))
 197
 198 (defsubst json-pop ()
 199   "Advance past the character at point, returning it."
 200   (let ((char (json-peek)))
 201     (if (zerop char)
 202         (signal 'json-end-of-file nil)
 203       (json-advance)
 204       char)))
 205
 206 (defun json-skip-whitespace ()
 207   "Skip past the whitespace at point."
 208   ;; See
 209   ;; https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf
 210   ;; or https://tools.ietf.org/html/rfc7159#section-2 for the
 211   ;; definition of whitespace in JSON.
 212   (skip-chars-forward "\t\r\n "))
 213
 214 \f
 215
 216 ;; Error conditions
 217
 218 (define-error 'json-error "Unknown JSON error")
 219 (define-error 'json-readtable-error "JSON readtable error" 'json-error)
 220 (define-error 'json-unknown-keyword "Unrecognized keyword" 'json-error)
 221 (define-error 'json-number-format "Invalid number format" 'json-error)
 222 (define-error 'json-string-escape "Bad Unicode escape" 'json-error)
 223 (define-error 'json-string-format "Bad string format" 'json-error)
 224 (define-error 'json-key-format "Bad JSON object key" 'json-error)
 225 (define-error 'json-object-format "Bad JSON object" 'json-error)
 226 (define-error 'json-end-of-file "End of file while parsing JSON"
 227   '(end-of-file json-error))
 228
 229 \f
 230
 231 ;;; Paths
 232
 233 (defvar json--path '()
 234   "Used internally by `json-path-to-position' to keep track of
 235 the path during recursive calls to `json-read'.")
 236
 237 (defun json--record-path (key)
 238   "Record the KEY to the current JSON path.
 239 Used internally by `json-path-to-position'."
 240   (push (cons (point) key) json--path))
 241
 242 (defun json--check-position (position)
 243   "Check if the last parsed JSON structure passed POSITION.
 244 Used internally by `json-path-to-position'."
 245   (let ((start (caar json--path)))
 246     (when (< start position (+ (point) 1))
 247       (throw :json-path (list :path (nreverse (mapcar #'cdr json--path))
 248                               :match-start start
 249                               :match-end (point)))))
 250   (pop json--path))
 251
 252 (defun json-path-to-position (position &optional string)
 253   "Return the path to the JSON element at POSITION.
 254
 255 When STRING is provided, return the path to the position in the
 256 string, else to the position in the current buffer.
 257
 258 The return value is a property list with the following
 259 properties:
 260
 261 :path        -- A list of strings and numbers forming the path to
 262                 the JSON element at the given position.  Strings
 263                 denote object names, while numbers denote array
 264                 indexes.
 265
 266 :match-start -- Position where the matched JSON element begins.
 267
 268 :match-end   -- Position where the matched JSON element ends.
 269
 270 This can for instance be useful to determine the path to a JSON
 271 element in a deeply nested structure."
 272   (save-excursion
 273     (unless string
 274       (goto-char (point-min)))
 275     (let* ((json--path '())
 276            (json-pre-element-read-function #'json--record-path)
 277            (json-post-element-read-function
 278             (apply-partially #'json--check-position position))
 279            (path (catch :json-path
 280                    (if string
 281                        (json-read-from-string string)
 282                      (json-read)))))
 283       (when (plist-get path :path)
 284         path))))
 285
 286 ;;; Keywords
 287
 288 (defvar json-keywords '("true" "false" "null")
 289   "List of JSON keywords.")
 290
 291 ;; Keyword parsing
 292
 293 (defun json-read-keyword (keyword)
 294   "Read a JSON keyword at point.
 295 KEYWORD is the keyword expected."
 296   (unless (member keyword json-keywords)
 297     (signal 'json-unknown-keyword (list keyword)))
 298   (mapc (lambda (char)
 299           (when (/= char (json-peek))
 300             (signal 'json-unknown-keyword
 301                     (list (save-excursion
 302                             (backward-word-strictly 1)
 303                             (thing-at-point 'word)))))
 304           (json-advance))
 305         keyword)
 306   (unless (looking-at "\\(\\s-\\|[],}]\\|$\\)")
 307     (signal 'json-unknown-keyword
 308             (list (save-excursion
 309                     (backward-word-strictly 1)
 310                     (thing-at-point 'word)))))
 311   (cond ((string-equal keyword "true") t)
 312         ((string-equal keyword "false") json-false)
 313         ((string-equal keyword "null") json-null)))
 314
 315 ;; Keyword encoding
 316
 317 (defun json-encode-keyword (keyword)
 318   "Encode KEYWORD as a JSON value."
 319   (cond ((eq keyword t)          "true")
 320         ((eq keyword json-false) "false")
 321         ((eq keyword json-null)  "null")))
 322
 323 ;;; Numbers
 324
 325 ;; Number parsing
 326
 327 (defun json-read-number (&optional sign)
 328  "Read the JSON number following point.
 329 The optional SIGN argument is for internal use.
 330
 331 N.B.: Only numbers which can fit in Emacs Lisp's native number
 332 representation will be parsed correctly."
 333  ;; If SIGN is non-nil, the number is explicitly signed.
 334  (let ((number-regexp
 335         "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?"))
 336    (cond ((and (null sign) (= (json-peek) ?-))
 337           (json-advance)
 338           (- (json-read-number t)))
 339          ((and (null sign) (= (json-peek) ?+))
 340           (json-advance)
 341           (json-read-number t))
 342          ((and (looking-at number-regexp)
 343                (or (match-beginning 1)
 344                    (match-beginning 2)))
 345           (goto-char (match-end 0))
 346           (string-to-number (match-string 0)))
 347          (t (signal 'json-number-format (list (point)))))))
 348
 349 ;; Number encoding
 350
 351 (defun json-encode-number (number)
 352   "Return a JSON representation of NUMBER."
 353   (format "%s" number))
 354
 355 ;;; Strings
 356
 357 (defvar json-special-chars
 358   '((?\" . ?\")
 359     (?\\ . ?\\)
 360     (?b . ?\b)
 361     (?f . ?\f)
 362     (?n . ?\n)
 363     (?r . ?\r)
 364     (?t . ?\t))
 365   "Characters which are escaped in JSON, with their elisp counterparts.")
 366
 367 ;; String parsing
 368
 369 (defun json--decode-utf-16-surrogates (high low)
 370   "Return the code point represented by the UTF-16 surrogates HIGH and LOW."
 371   (+ (lsh (- high #xD800) 10) (- low #xDC00) #x10000))
 372
 373 (defun json-read-escaped-char ()
 374   "Read the JSON string escaped character at point."
 375   ;; Skip over the '\'
 376   (json-advance)
 377   (let* ((char (json-pop))
 378          (special (assq char json-special-chars)))
 379     (cond
 380      (special (cdr special))
 381      ((not (eq char ?u)) char)
 382      ;; Special-case UTF-16 surrogate pairs,
 383      ;; cf. <https://tools.ietf.org/html/rfc7159#section-7>.  Note that
 384      ;; this clause overlaps with the next one and therefore has to
 385      ;; come first.
 386      ((looking-at
 387        (rx (group (any "Dd") (any "89ABab") (= 2 (any xdigit)))
 388            "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any xdigit)))))
 389       (json-advance 10)
 390       (json--decode-utf-16-surrogates
 391        (string-to-number (match-string 1) 16)
 392        (string-to-number (match-string 2) 16)))
 393      ((looking-at (rx (= 4 xdigit)))
 394       (let ((hex (match-string 0)))
 395         (json-advance 4)
 396         (string-to-number hex 16)))
 397      (t
 398       (signal 'json-string-escape (list (point)))))))
 399
 400 (defun json-read-string ()
 401   "Read the JSON string at point."
 402   (unless (= (json-peek) ?\")
 403     (signal 'json-string-format (list "doesn't start with `\"'!")))
 404   ;; Skip over the '"'
 405   (json-advance)
 406   (let ((characters '())
 407         (char (json-peek)))
 408     (while (not (= char ?\"))
 409       (when (< char 32)
 410         (signal 'json-string-format (list (prin1-char char))))
 411       (push (if (= char ?\\)
 412                 (json-read-escaped-char)
 413               (json-pop))
 414             characters)
 415       (setq char (json-peek)))
 416     ;; Skip over the '"'
 417     (json-advance)
 418     (if characters
 419         (concat (nreverse characters))
 420       "")))
 421
 422 ;; String encoding
 423
 424 (defun json-encode-string (string)
 425   "Return a JSON representation of STRING."
 426   ;; Reimplement the meat of `replace-regexp-in-string', for
 427   ;; performance (bug#20154).
 428   (let ((l (length string))
 429         (start 0)
 430         res mb)
 431     ;; Only escape quotation mark, backslash and the control
 432     ;; characters U+0000 to U+001F (RFC 4627, ECMA-404).
 433     (while (setq mb (string-match "[\"\\[:cntrl:]]" string start))
 434       (let* ((c (aref string mb))
 435              (special (rassq c json-special-chars)))
 436         (push (substring string start mb) res)
 437         (push (if special
 438                   ;; Special JSON character (\n, \r, etc.).
 439                   (string ?\\ (car special))
 440                 ;; Fallback: UCS code point in \uNNNN form.
 441                 (format "\\u%04x" c))
 442               res)
 443         (setq start (1+ mb))))
 444     (push (substring string start l) res)
 445     (push "\"" res)
 446     (apply #'concat "\"" (nreverse res))))
 447
 448 (defun json-encode-key (object)
 449   "Return a JSON representation of OBJECT.
 450 If the resulting JSON object isn't a valid JSON object key,
 451 this signals `json-key-format'."
 452   (let ((encoded (json-encode object)))
 453     (unless (stringp (json-read-from-string encoded))
 454       (signal 'json-key-format (list object)))
 455     encoded))
 456
 457 ;;; JSON Objects
 458
 459 (defun json-new-object ()
 460   "Create a new Elisp object corresponding to a JSON object.
 461 Please see the documentation of `json-object-type'."
 462   (cond ((eq json-object-type 'hash-table)
 463          (make-hash-table :test 'equal))
 464         (t
 465          ())))
 466
 467 (defun json-add-to-object (object key value)
 468   "Add a new KEY -> VALUE association to OBJECT.
 469 Returns the updated object, which you should save, e.g.:
 470     (setq obj (json-add-to-object obj \"foo\" \"bar\"))
 471 Please see the documentation of `json-object-type' and `json-key-type'."
 472   (let ((json-key-type
 473          (if (eq json-key-type nil)
 474              (cdr (assq json-object-type '((hash-table . string)
 475                                            (alist . symbol)
 476                                            (plist . keyword))))
 477            json-key-type)))
 478     (setq key
 479           (cond ((eq json-key-type 'string)
 480                  key)
 481                 ((eq json-key-type 'symbol)
 482                  (intern key))
 483                 ((eq json-key-type 'keyword)
 484                  (intern (concat ":" key)))))
 485     (cond ((eq json-object-type 'hash-table)
 486            (puthash key value object)
 487            object)
 488           ((eq json-object-type 'alist)
 489            (cons (cons key value) object))
 490           ((eq json-object-type 'plist)
 491            (cons key (cons value object))))))
 492
 493 ;; JSON object parsing
 494
 495 (defun json-read-object ()
 496   "Read the JSON object at point."
 497   ;; Skip over the "{"
 498   (json-advance)
 499   (json-skip-whitespace)
 500   ;; read key/value pairs until "}"
 501   (let ((elements (json-new-object))
 502         key value)
 503     (while (not (= (json-peek) ?}))
 504       (json-skip-whitespace)
 505       (setq key (json-read-string))
 506       (json-skip-whitespace)
 507       (if (= (json-peek) ?:)
 508           (json-advance)
 509         (signal 'json-object-format (list ":" (json-peek))))
 510       (json-skip-whitespace)
 511       (when json-pre-element-read-function
 512         (funcall json-pre-element-read-function key))
 513       (setq value (json-read))
 514       (when json-post-element-read-function
 515         (funcall json-post-element-read-function))
 516       (setq elements (json-add-to-object elements key value))
 517       (json-skip-whitespace)
 518       (when (/= (json-peek) ?})
 519         (if (= (json-peek) ?,)
 520             (json-advance)
 521           (signal 'json-object-format (list "," (json-peek))))))
 522     ;; Skip over the "}"
 523     (json-advance)
 524     (pcase json-object-type
 525       (`alist (nreverse elements))
 526       (`plist (json--plist-reverse elements))
 527       (_ elements))))
 528
 529 ;; Hash table encoding
 530
 531 (defun json-encode-hash-table (hash-table)
 532   "Return a JSON representation of HASH-TABLE."
 533   (if json-encoding-object-sort-predicate
 534       (json-encode-alist (map-into hash-table 'list))
 535     (format "{%s%s}"
 536             (json-join
 537              (let (r)
 538                (json--with-indentation
 539                 (maphash
 540                  (lambda (k v)
 541                    (push (format
 542                           (if json-encoding-pretty-print
 543                               "%s%s: %s"
 544                             "%s%s:%s")
 545                           json--encoding-current-indentation
 546                           (json-encode-key k)
 547                           (json-encode v))
 548                          r))
 549                  hash-table))
 550                r)
 551              json-encoding-separator)
 552             (if (or (not json-encoding-pretty-print)
 553                     json-encoding-lisp-style-closings)
 554                 ""
 555               json--encoding-current-indentation))))
 556
 557 ;; List encoding (including alists and plists)
 558
 559 (defun json-encode-alist (alist)
 560   "Return a JSON representation of ALIST."
 561   (when json-encoding-object-sort-predicate
 562     (setq alist
 563           (sort alist (lambda (a b)
 564                         (funcall json-encoding-object-sort-predicate
 565                                  (car a) (car b))))))
 566   (format "{%s%s}"
 567           (json-join
 568            (json--with-indentation
 569             (mapcar (lambda (cons)
 570                       (format (if json-encoding-pretty-print
 571                                   "%s%s: %s"
 572                                 "%s%s:%s")
 573                               json--encoding-current-indentation
 574                               (json-encode-key (car cons))
 575                               (json-encode (cdr cons))))
 576                     alist))
 577            json-encoding-separator)
 578           (if (or (not json-encoding-pretty-print)
 579                   json-encoding-lisp-style-closings)
 580               ""
 581             json--encoding-current-indentation)))
 582
 583 (defun json-encode-plist (plist)
 584   "Return a JSON representation of PLIST."
 585   (if json-encoding-object-sort-predicate
 586       (json-encode-alist (json--plist-to-alist plist))
 587     (let (result)
 588       (json--with-indentation
 589        (while plist
 590          (push (concat
 591                 json--encoding-current-indentation
 592                 (json-encode-key (car plist))
 593                 (if json-encoding-pretty-print
 594                     ": "
 595                   ":")
 596                 (json-encode (cadr plist)))
 597                result)
 598          (setq plist (cddr plist))))
 599       (concat "{"
 600               (json-join (nreverse result) json-encoding-separator)
 601               (if (and json-encoding-pretty-print
 602                        (not json-encoding-lisp-style-closings))
 603                   json--encoding-current-indentation
 604                 "")
 605               "}"))))
 606
 607 (defun json-encode-list (list)
 608   "Return a JSON representation of LIST.
 609 Tries to DWIM: simple lists become JSON arrays, while alists and plists
 610 become JSON objects."
 611   (cond ((null list)         "null")
 612         ((json-alist-p list) (json-encode-alist list))
 613         ((json-plist-p list) (json-encode-plist list))
 614         ((listp list)        (json-encode-array list))
 615         (t
 616          (signal 'json-error (list list)))))
 617
 618 ;;; Arrays
 619
 620 ;; Array parsing
 621
 622 (defun json-read-array ()
 623   "Read the JSON array at point."
 624   ;; Skip over the "["
 625   (json-advance)
 626   (json-skip-whitespace)
 627   ;; read values until "]"
 628   (let (elements)
 629     (while (not (= (json-peek) ?\]))
 630       (json-skip-whitespace)
 631       (when json-pre-element-read-function
 632         (funcall json-pre-element-read-function (length elements)))
 633       (push (json-read) elements)
 634       (when json-post-element-read-function
 635         (funcall json-post-element-read-function))
 636       (json-skip-whitespace)
 637       (when (/= (json-peek) ?\])
 638         (if (= (json-peek) ?,)
 639             (json-advance)
 640           (signal 'json-error (list 'bleah)))))
 641     ;; Skip over the "]"
 642     (json-advance)
 643     (pcase json-array-type
 644       (`vector (nreverse (vconcat elements)))
 645       (`list (nreverse elements)))))
 646
 647 ;; Array encoding
 648
 649 (defun json-encode-array (array)
 650   "Return a JSON representation of ARRAY."
 651   (if (and json-encoding-pretty-print
 652            (> (length array) 0))
 653       (concat
 654        (json--with-indentation
 655          (concat (format "[%s" json--encoding-current-indentation)
 656                  (json-join (mapcar 'json-encode array)
 657                             (format "%s%s"
 658                                     json-encoding-separator
 659                                     json--encoding-current-indentation))))
 660        (format "%s]"
 661                (if json-encoding-lisp-style-closings
 662                    ""
 663                  json--encoding-current-indentation)))
 664     (concat "["
 665             (mapconcat 'json-encode array json-encoding-separator)
 666             "]")))
 667
 668 \f
 669
 670 ;;; JSON reader.
 671
 672 (defmacro json-readtable-dispatch (char)
 673   "Dispatch reader function for CHAR."
 674   (declare (debug (symbolp)))
 675   (let ((table
 676          '((?t json-read-keyword "true")
 677            (?f json-read-keyword "false")
 678            (?n json-read-keyword "null")
 679            (?{ json-read-object)
 680            (?\[ json-read-array)
 681            (?\" json-read-string)))
 682         res)
 683     (dolist (c '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
 684       (push (list c 'json-read-number) table))
 685     (pcase-dolist (`(,c . ,rest) table)
 686       (push `((eq ,char ,c) (,@rest)) res))
 687     `(cond ,@res (t (signal 'json-readtable-error ,char)))))
 688
 689 (defun json-read ()
 690   "Parse and return the JSON object following point.
 691 Advances point just past JSON object."
 692   (json-skip-whitespace)
 693   (let ((char (json-peek)))
 694     (if (zerop char)
 695         (signal 'json-end-of-file nil)
 696       (json-readtable-dispatch char))))
 697
 698 ;; Syntactic sugar for the reader
 699
 700 (defun json-read-from-string (string)
 701   "Read the JSON object contained in STRING and return it."
 702   (with-temp-buffer
 703     (insert string)
 704     (goto-char (point-min))
 705     (json-read)))
 706
 707 (defun json-read-file (file)
 708   "Read the first JSON object contained in FILE and return it."
 709   (with-temp-buffer
 710     (insert-file-contents file)
 711     (goto-char (point-min))
 712     (json-read)))
 713
 714 \f
 715
 716 ;;; JSON encoder
 717
 718 (defun json-encode (object)
 719   "Return a JSON representation of OBJECT as a string."
 720   (cond ((memq object (list t json-null json-false))
 721          (json-encode-keyword object))
 722         ((stringp object)      (json-encode-string object))
 723         ((keywordp object)     (json-encode-string
 724                                 (substring (symbol-name object) 1)))
 725         ((symbolp object)      (json-encode-string
 726                                 (symbol-name object)))
 727         ((numberp object)      (json-encode-number object))
 728         ((arrayp object)       (json-encode-array object))
 729         ((hash-table-p object) (json-encode-hash-table object))
 730         ((listp object)        (json-encode-list object))
 731         (t                     (signal 'json-error (list object)))))
 732
 733 ;; Pretty printing
 734
 735 (defun json-pretty-print-buffer ()
 736   "Pretty-print current buffer."
 737   (interactive)
 738   (json-pretty-print (point-min) (point-max)))
 739
 740 (defun json-pretty-print (begin end)
 741   "Pretty-print selected region."
 742   (interactive "r")
 743   (atomic-change-group
 744     (let ((json-encoding-pretty-print t)
 745           ;; Ensure that ordering is maintained
 746           (json-object-type 'alist)
 747           (txt (delete-and-extract-region begin end)))
 748       (insert (json-encode (json-read-from-string txt))))))
 749
 750 (defun json-pretty-print-buffer-ordered ()
 751   "Pretty-print current buffer with object keys ordered."
 752   (interactive)
 753   (let ((json-encoding-object-sort-predicate 'string<))
 754     (json-pretty-print-buffer)))
 755
 756 (defun json-pretty-print-ordered (begin end)
 757   "Pretty-print the region with object keys ordered."
 758   (interactive "r")
 759   (let ((json-encoding-object-sort-predicate 'string<))
 760     (json-pretty-print begin end)))
 761
 762 (provide 'json)
 763
 764 ;;; json.el ends here