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