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