commit 232bb691c1095574b85b358c7f33a46d2ea79f29 (HEAD, refs/remotes/origin/master) Author: Eli Zaretskii Date: Sat May 23 11:19:54 2020 +0300 ; * etc/NEWS: Mention new customization options for package.el. diff --git a/etc/NEWS b/etc/NEWS index eb73bd64e0..32b59cb76f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -229,6 +229,12 @@ key binding / m package-menu-filter-marked / / package-menu-filter-clear +--- ++++ Column widths in 'list-packages' display can now be customized. +See the new user options 'package-name-column-width', +'package-version-column-width', 'package-status-column-width', and +'package-archive-column-width'. + ** gdb-mi +++ commit d7fc6bd17c2cdbd6a24b808223fa5bf9af9bb352 Author: Chris McMahan Date: Tue May 5 14:15:01 2020 -0400 Let user adjust the column widths of the package menu. * lisp/emacs-lisp/package.el (package-name-column-width) (package-version-column-width, package-status-column-width) (package-archive-column-width): New defcustoms. (package-menu-mode): Use the values of defcustoms instead of hardcoded values. (Bug#41086) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ecf833b547..9a6d1d7319 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -397,6 +397,26 @@ synchronously." :type 'boolean :version "25.1") +(defcustom package-name-column-width 30 + "Column width for the Package name in the package menu." + :type 'number + :version "28.1") + +(defcustom package-version-column-width 14 + "Column width for the Package version in the package menu." + :type 'number + :version "28.1") + +(defcustom package-status-column-width 12 + "Column width for the Package status in the package menu." + :type 'number + :version "28.1") + +(defcustom package-archive-column-width 8 + "Column width for the Package status in the package menu." + :type 'number + :version "28.1") + ;;; `package-desc' object definition ;; This is the struct used internally to represent packages. @@ -2750,11 +2770,11 @@ Letters do not insert themselves; instead, they are commands. (package-menu--transaction-status package-menu--transaction-status))) (setq tabulated-list-format - `[("Package" 18 package-menu--name-predicate) - ("Version" 13 package-menu--version-predicate) - ("Status" 10 package-menu--status-predicate) + `[("Package" ,package-name-column-width package-menu--name-predicate) + ("Version" ,package-version-column-width package-menu--version-predicate) + ("Status" ,package-status-column-width package-menu--status-predicate) ,@(if (cdr package-archives) - '(("Archive" 10 package-menu--archive-predicate))) + `(("Archive" ,package-archive-column-width package-menu--archive-predicate))) ("Description" 0 package-menu--description-predicate)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) commit b4a151918917de2be8b3958d5b59d16c8e3f457e Author: Stefan Kangas Date: Sat May 23 07:32:10 2020 +0200 Delete another library obsolete since 23.2 This was missed in a previous commit to remove obsolete libraries. Its deletion was already announced in NEWS. * lisp/obsolete/levents.el: Delete file. This library has been obsolete since 23.2. diff --git a/lisp/obsolete/levents.el b/lisp/obsolete/levents.el deleted file mode 100644 index 2ae1ca48d1..0000000000 --- a/lisp/obsolete/levents.el +++ /dev/null @@ -1,292 +0,0 @@ -;;; levents.el --- emulate the Lucid event data type and associated functions - -;; Copyright (C) 1993, 2001-2020 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: emulations -;; Obsolete-since: 23.2 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; Things we cannot emulate in Lisp: -;; It is not possible to emulate current-mouse-event as a variable, -;; though it is not hard to obtain the data from (this-command-keys). - -;; We do not have a variable unread-command-event; -;; instead, we have the more general unread-command-events. - -;; Our read-key-sequence and read-char are not precisely -;; compatible with those in Lucid Emacs, but they should work ok. - -;;; Code: - -(defun next-command-event (event) - (error "You must rewrite to use `read-command-event' instead of `next-command-event'")) - -(defun next-event (event) - (error "You must rewrite to use `read-event' instead of `next-event'")) - -(defun dispatch-event (event) - (error "`dispatch-event' not supported")) - -;; Make events of type eval, menu and timeout -;; execute properly. - -(define-key global-map [menu] 'execute-eval-event) -(define-key global-map [timeout] 'execute-eval-event) -(define-key global-map [eval] 'execute-eval-event) - -(defun execute-eval-event (event) - (interactive "e") - (funcall (nth 1 event) (nth 2 event))) - -(put 'eval 'event-symbol-elements '(eval)) -(put 'menu 'event-symbol-elements '(eval)) -(put 'timeout 'event-symbol-elements '(eval)) - -(defun allocate-event () - "Return an empty event structure. -In this emulation, it returns nil." - nil) - -(defun button-press-event-p (obj) - "True if the argument is a mouse-button-press event object." - (and (consp obj) (symbolp (car obj)) - (memq 'down (get (car obj) 'event-symbol-elements)))) - -(defun button-release-event-p (obj) - "True if the argument is a mouse-button-release event object." - (and (consp obj) (symbolp (car obj)) - (or (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun button-event-p (obj) - "True if the argument is a mouse-button press or release event object." - (and (consp obj) (symbolp (car obj)) - (or (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'down (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun mouse-event-p (obj) - "True if the argument is a mouse-button press or release event object." - (and (consp obj) (symbolp (car obj)) - (or (eq (car obj) 'mouse-movement) - (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'down (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun character-to-event (ch &optional event) - "Converts a numeric ASCII value to an event structure, replete with -bucky bits. The character is the first argument, and the event to fill -in is the second. This function contains knowledge about what the codes -mean -- for example, the number 9 is converted to the character Tab, -not the distinct character Control-I. - -Beware that character-to-event and event-to-character are not strictly -inverse functions, since events contain much more information than the -ASCII character set can encode." - ch) - -(defun copy-event (event1 &optional event2) - "Make a copy of the given event object. -In this emulation, `copy-event' just returns its argument." - event1) - -(defun deallocate-event (event) - "Allow the given event structure to be reused. -In actual Lucid Emacs, you MUST NOT use this event object after -calling this function with it. You will lose. It is not necessary to -call this function, as event objects are garbage- collected like all -other objects; however, it may be more efficient to explicitly -deallocate events when you are sure that this is safe. - -This emulation does not actually deallocate or reuse events -except via garbage collection and `cons'." - nil) - -(defun enqueue-eval-event: (function object) - "Add an eval event to the back of the queue. -It will be the next event read after all pending events." - (setq unread-command-events - (nconc unread-command-events - (list (list 'eval function object))))) - -(defun eval-event-p (obj) - "True if the argument is an eval or menu event object." - (eq (car-safe obj) 'eval)) - -(defun event-button (event) - "Return the button-number of the given mouse-button-press event." - (let ((sym (car (get (car event) 'event-symbol-elements)))) - (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3) - (mouse-4 . 4) (mouse-5 . 5)))))) - -(defun event-function (event) - "Return the callback function of the given timeout, menu, or eval event." - (nth 1 event)) - -(defun event-key (event) - "Return the KeySym of the given key-press event. -The value is an ASCII printing character (not upper case) or a symbol." - (if (symbolp event) - (car (get event 'event-symbol-elements)) - (let ((base (logand event (1- (ash 1 18))))) - (downcase (if (< base 32) (logior base 64) base))))) - -(defun event-object (event) - "Return the function argument of the given timeout, menu, or eval event." - (nth 2 event)) - -(defun event-point (event) - "Return the character position of the given mouse-related event. -If the event did not occur over a window, or did -not occur over text, then this returns nil. Otherwise, it returns an index -into the buffer visible in the event's window." - (posn-point (event-end event))) - -;; Return position of start of line LINE in WINDOW. -;; If LINE is nil, return the last position -;; visible in WINDOW. -(defun event-closest-point-1 (window &optional line) - (let* ((total (- (window-height window) - (if (window-minibuffer-p window) - 0 1))) - (distance (or line total))) - (save-excursion - (goto-char (window-start window)) - (if (= (vertical-motion distance) distance) - (if (not line) - (forward-char -1))) - (point)))) - -(defun event-closest-point (event &optional start-window) - "Return the nearest position to where EVENT ended its motion. -This is computed for the window where EVENT's motion started, -or for window WINDOW if that is specified." - (or start-window (setq start-window (posn-window (event-start event)))) - (if (eq start-window (posn-window (event-end event))) - (if (eq (event-point event) 'vertical-line) - (event-closest-point-1 start-window - (cdr (posn-col-row (event-end event)))) - (if (eq (event-point event) 'mode-line) - (event-closest-point-1 start-window) - (event-point event))) - ;; EVENT ended in some other window. - (let* ((end-w (posn-window (event-end event))) - (end-w-top) - (w-top (nth 1 (window-edges start-window)))) - (setq end-w-top - (if (windowp end-w) - (nth 1 (window-edges end-w)) - (/ (cdr (posn-x-y (event-end event))) - (frame-char-height end-w)))) - (if (>= end-w-top w-top) - (event-closest-point-1 start-window) - (window-start start-window))))) - -(defun event-process (event) - "Return the process of the given process-output event." - (nth 1 event)) - -(defun event-timestamp (event) - "Return the timestamp of the given event object. -In Lucid Emacs, this works for any kind of event. -In this emulation, it returns nil for non-mouse-related events." - (and (listp event) - (posn-timestamp (event-end event)))) - -(defun event-to-character (event &optional lenient) - "Return the closest ASCII approximation to the given event object. -If the event isn't a keypress, this returns nil. -If the second argument is non-nil, then this is lenient in its -translation; it will ignore modifier keys other than control and meta, -and will ignore the shift modifier on those characters which have no -shifted ASCII equivalent (Control-Shift-A for example, will be mapped to -the same ASCII code as Control-A.) If the second arg is nil, then nil -will be returned for events which have no direct ASCII equivalent." - (if (symbolp event) - (and lenient - (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9) - (return . 10) (enter . 10))))) - ;; Our interpretation is, ASCII means anything a number can represent. - (if (integerp event) - event nil))) - -(defun event-window (event) - "Return the window of the given mouse-related event object." - (posn-window (event-end event))) - -(defun event-x (event) - "Return the X position in characters of the given mouse-related event." - (/ (car (posn-col-row (event-end event))) - (frame-char-width (window-frame (event-window event))))) - -(defun event-x-pixel (event) - "Return the X position in pixels of the given mouse-related event." - (car (posn-col-row (event-end event)))) - -(defun event-y (event) - "Return the Y position in characters of the given mouse-related event." - (/ (cdr (posn-col-row (event-end event))) - (frame-char-height (window-frame (event-window event))))) - -(defun event-y-pixel (event) - "Return the Y position in pixels of the given mouse-related event." - (cdr (posn-col-row (event-end event)))) - -(defun key-press-event-p (obj) - "True if the argument is a keyboard event object." - (or (integerp obj) - (and (symbolp obj) - (get obj 'event-symbol-elements)))) - -(defun menu-event-p (obj) - "True if the argument is a menu event object." - (eq (car-safe obj) 'menu)) - -(defun motion-event-p (obj) - "True if the argument is a mouse-motion event object." - (eq (car-safe obj) 'mouse-movement)) - -(defun read-command-event () - "Return the next keyboard or mouse event; execute other events. -This is similar to the function `next-command-event' of Lucid Emacs, -but different in that it returns the event rather than filling in -an existing event object." - (let (event) - (while (progn - (setq event (read-event)) - (not (or (key-press-event-p event) - (button-press-event-p event) - (button-release-event-p event) - (menu-event-p event)))) - (let ((type (car-safe event))) - (cond ((eq type 'eval) - (funcall (nth 1 event) (nth 2 event))) - ((eq type 'switch-frame) - (select-frame (nth 1 event)))))) - event)) - -(defun process-event-p (obj) - "True if the argument is a process-output event object. -GNU Emacs 19 does not currently generate process-output events." - (eq (car-safe obj) 'process)) - -(provide 'levents) - -;;; levents.el ends here commit cde0589818ec1d8d663c707d1d8af19a9d8b0752 Author: Stefan Monnier Date: Fri May 22 23:36:57 2020 -0400 * lisp/doc-view.el (doc-view-presentation): Fix thinko diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 3cac2629a9..de342f1519 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -2050,8 +2050,8 @@ See the command `doc-view-mode' for more information on this mode." (when (memq (selected-frame) (alist-get 'frames attrs)) (let ((geom (alist-get 'geometry attrs))) (when geom - (setq monitor-top (nth 0 geom)) - (setq monitor-left (nth 1 geom)) + (setq monitor-left (nth 0 geom)) + (setq monitor-top (nth 1 geom)) (setq monitor-width (nth 2 geom)) (setq monitor-height (nth 3 geom)))))) (let ((frame (make-frame commit c67f8f298a21be61362d049cfff5273f7d010d75 Author: Dmitry Gutov Date: Sat May 23 05:08:06 2020 +0300 Implement 'mark-resolved' for the Git backend * lisp/vc/vc-git.el (vc-git-mark-resolved): New function. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2caa287bce..dcb5228265 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -72,6 +72,7 @@ ;; by git, so it's probably ;; not a good idea. ;; - merge-news (file) see `merge-file' +;; - mark-resolved (file) OK ;; - steal-lock (file &optional revision) NOT NEEDED ;; HISTORY FUNCTIONS ;; * print-log (files buffer &optional shortlog start-revision limit) OK @@ -1530,6 +1531,9 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (defun vc-git-rename-file (old new) (vc-git-command nil 0 (list old new) "mv" "-f" "--")) +(defun vc-git-mark-resolved (files) + (vc-git-command nil 0 files "add")) + (defvar vc-git-extra-menu-map (let ((map (make-sparse-keymap))) (define-key map [git-grep] commit 5044c19001fe608f2eac621add2e05cbca6c804b Author: Dmitry Gutov Date: Sat May 23 04:38:27 2020 +0300 project.el: A project has only one main root now Practice shows that the vast majority of projects only use one main root. The users of this API very often make this assumption as well. The rest of the "roots" should be possible to express through project-external-roots. * lisp/progmodes/project.el: Update the commentary. Only 4 non-obsolete generics now. (project-root): Replacement for `project-roots'. All callers updated. Implementations too. (project-roots): Declare obsolete. (project-external-roots): Simplify the docstring. (project-ignores): Update the docstring. (project-find-regexp): Omit the second arg to project-files. (project--dir-ignores): Simplify. (project-compile): Simplify, remove outdated comment. * lisp/cedet/ede.el: Add a FIXME. diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el index 8c336117c9..4125281573 100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el @@ -1515,8 +1515,11 @@ It does not apply the value to buffers." (when project-dir (ede-directory-get-open-project project-dir 'ROOT)))) -(cl-defmethod project-roots ((project ede-project)) - (list (ede-project-root-directory project))) +(cl-defmethod project-root ((project ede-project)) + (ede-project-root-directory project)) + +;;; FIXME: Could someone look into implementing `project-ignores' for +;;; EDE and/or a faster `project-files'? (add-hook 'project-find-functions #'project-try-ede) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 41e34a3750..c72e9d94b1 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -40,7 +40,7 @@ ;; Infrastructure: ;; ;; Function `project-current', to determine the current project -;; instance, and 5 (at the moment) generic functions that act on it. +;; instance, and 4 (at the moment) generic functions that act on it. ;; This list is to be extended in future versions. ;; ;; Utils: @@ -122,14 +122,25 @@ is not a part of a detectable project either, return a (defun project--find-in-directory (dir) (run-hook-with-args-until-success 'project-find-functions dir)) -(cl-defgeneric project-roots (project) - "Return the list of directory roots of the current project. +(cl-defgeneric project-root (project) + "Return root directory of the current project. + +It usually contains the main build file, dependencies +configuration file, etc. Though neither is mandatory. + +The directory name must be absolute." + (car (project-roots project))) -Most often it's just one directory which contains the project -build file and everything else in the project. But in more -advanced configurations, a project can span multiple directories. +(cl-defgeneric project-roots (project) + "Return the list containing the current project root. -The directory names should be absolute.") +The function is obsolete, all projects have one main root anyway, +and the rest should be possible to express through +`project-external-roots'." + ;; FIXME: Can we specify project's version here? + ;; FIXME: Could we make this affect cl-defmethod calls too? + (declare (obsolete project-root "0.3.0")) + (list (project-root project))) ;; FIXME: Add MODE argument, like in `ede-source-paths'? (cl-defgeneric project-external-roots (_project) @@ -138,18 +149,14 @@ The directory names should be absolute.") It's the list of directories outside of the project that are still related to it. If the project deals with source code then, depending on the languages used, this list should include the -headers search path, load path, class path, and so on. - -The rule of thumb for whether to include a directory here, and -not in `project-roots', is whether its contents are meant to be -edited together with the rest of the project." +headers search path, load path, class path, and so on." nil) (cl-defgeneric project-ignores (_project _dir) "Return the list of glob patterns to ignore inside DIR. Patterns can match both regular files and directories. To root an entry, start it with `./'. To match directories only, -end it with `/'. DIR must be one of `project-roots' or +end it with `/'. DIR must be either `project-root' or one of `project-external-roots'." ;; TODO: Document and support regexp ignores as used by Hg. ;; TODO: Support whitelist entries. @@ -170,13 +177,13 @@ end it with `/'. DIR must be one of `project-roots' or (t (complete-with-action action all-files string pred))))) -(cl-defmethod project-roots ((project (head transient))) - (list (cdr project))) +(cl-defmethod project-root ((project (head transient))) + (cdr project)) (cl-defgeneric project-files (project &optional dirs) "Return a list of files in directories DIRS in PROJECT. DIRS is a list of absolute directories; it should be some -subset of the project roots and external roots. +subset of the project root and external roots. The default implementation uses `find-program'. PROJECT is used to find the list of ignores for each directory." @@ -184,7 +191,8 @@ to find the list of ignores for each directory." (lambda (dir) (project--files-in-directory dir (project--dir-ignores project dir))) - (or dirs (project-roots project)))) + (or dirs + (list (project-root project))))) (defun project--files-in-directory (dir ignores &optional files) (require 'find-dired) @@ -322,8 +330,8 @@ backend implementation of `project-external-roots'.") t) (t nil)))) -(cl-defmethod project-roots ((project (head vc))) - (list (cdr project))) +(cl-defmethod project-root ((project (head vc))) + (cdr project)) (cl-defmethod project-external-roots ((project (head vc))) (project-subtract-directories @@ -331,7 +339,7 @@ backend implementation of `project-external-roots'.") (mapcar #'file-name-as-directory (funcall project-vc-external-roots-function))) - (project-roots project))) + (list (project-root project)))) (cl-defmethod project-files ((project (head vc)) &optional dirs) (cl-mapcan @@ -349,7 +357,8 @@ backend implementation of `project-external-roots'.") (project--files-in-directory dir (project--dir-ignores project dir))))) - (or dirs (project-roots project)))) + (or dirs + (list (project-root project))))) (declare-function vc-git--program-version "vc-git") (declare-function vc-git--run-command-string "vc-git") @@ -492,7 +501,7 @@ requires quoting, e.g. `\\[quoted-insert]'." (let* ((pr (project-current t)) (files (if (not current-prefix-arg) - (project-files pr (project-roots pr)) + (project-files pr) (let ((dir (read-directory-name "Base directory: " nil default-directory t))) (project--files-in-directory dir @@ -503,9 +512,8 @@ requires quoting, e.g. `\\[quoted-insert]'." nil))) (defun project--dir-ignores (project dir) - (let* ((roots (project-roots project)) - (root (cl-find dir roots :test #'file-in-directory-p))) - (if (not root) + (let ((root (project-root project))) + (if (not (file-in-directory-p dir root)) (project-ignores nil nil) ;The defaults. (let ((ignores (project-ignores project root))) (if (file-equal-p root dir) @@ -523,8 +531,8 @@ pattern to search for." (require 'xref) (let* ((pr (project-current t)) (files - (project-files pr (append - (project-roots pr) + (project-files pr (cons + (project-root pr) (project-external-roots pr))))) (xref--show-xrefs (apply-partially #'project--find-regexp-in-files regexp files) @@ -562,23 +570,23 @@ pattern to search for." ;;;###autoload (defun project-find-file () - "Visit a file (with completion) in the current project's roots. + "Visit a file (with completion) in the current project. The completion default is the filename at point, if one is recognized." (interactive) (let* ((pr (project-current t)) - (dirs (project-roots pr))) + (dirs (list (project-root pr)))) (project-find-file-in (thing-at-point 'filename) dirs pr))) ;;;###autoload (defun project-or-external-find-file () - "Visit a file (with completion) in the current project's roots or external roots. + "Visit a file (with completion) in the current project or external roots. The completion default is the filename at point, if one is recognized." (interactive) (let* ((pr (project-current t)) - (dirs (append - (project-roots pr) + (dirs (cons + (project-root pr) (project-external-roots pr)))) (project-find-file-in (thing-at-point 'filename) dirs pr))) @@ -686,11 +694,7 @@ loop using the command \\[fileloop-continue]." "Run `compile' in the project root." (interactive) (let* ((pr (project-current t)) - (roots (project-roots pr)) - ;; TODO: be more intelligent when choosing a directory. This - ;; currently isn't a priority, since no `project-roots' - ;; implementation returns more that one directory. - (default-directory (car roots))) + (default-directory (project-root pr))) (call-interactively 'compile))) (provide 'project) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 7d1ee705b8..2477884f1a 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -268,8 +268,8 @@ find a search tool; by default, this uses \"find | grep\" in the (lambda (dir) (xref-references-in-directory identifier dir)) (let ((pr (project-current t))) - (append - (project-roots pr) + (cons + (project-root pr) (project-external-roots pr))))) (cl-defgeneric xref-backend-apropos (backend pattern) commit 813e42c63bcd9f285daae6737c4ae7a9adae90d7 Author: Dmitry Gutov Date: Fri May 22 03:37:56 2020 +0300 Disable ido-everywhere when ido-mode is off * lisp/ido.el (ido-mode): Disable the effects of 'ido-everywhere' when ido-mode is turned off. diff --git a/lisp/ido.el b/lisp/ido.el index 5716c6ff44..ad71d468cb 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -1549,7 +1549,7 @@ This function also adds a hook to the minibuffer." ((> (prefix-numeric-value arg) 0) 'both) (t nil))) - (ido-everywhere (if ido-everywhere 1 -1)) + (ido-everywhere (if (and ido-mode ido-everywhere) 1 -1)) (when ido-mode (ido-common-initialization) commit 3a7894ecd11c66337e7aea8ade8f47673d290a24 Author: Basil L. Contovounesios Date: Wed May 6 18:02:32 2020 +0100 Improve shr/eww handling of mailto URLs * lisp/net/eww.el (eww): Use function-put in place of put, as recommended in "(elisp) Symbol Plists". (eww-follow-link): * lisp/net/shr.el (shr-browse-url): Rather than call browse-url-mail directly, call browse-url which respects the user options browse-url-handlers and browse-url-mailto-function. (Bug#41133) (shr--current-link-region): Return nil if there is no link at point. (shr--blink-link): Adapt accordingly. (shr-fill-line, shr-indent, shr-table-body): Refactor to avoid some unnecessary allocations. * etc/NEWS: Announce that eww-follow-link and shr-browse-url support custom URL handlers. diff --git a/etc/NEWS b/etc/NEWS index 4533dc46c5..eb73bd64e0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -356,6 +356,24 @@ symbol property to the browsing functions. With a new command 'browse-url-with-browser-kind', an URL can explicitly be browsed with either an internal or external browser. +** SHR + +--- +*** The command 'shr-browse-url' now supports custom mailto handlers. +Clicking on or otherwise following a 'mailto:' link in a HTML buffer +rendered by SHR previously invoked the command 'browse-url-mailto'. +This is still the case by default, but if you customize +'browse-url-mailto-function' or 'browse-url-handlers' to call some +other function, it will now be called instead of the default. + +** EWW + +--- +*** The command 'eww-follow-link' now supports custom mailto handlers. +The function that is invoked when clicking on or otherwise following a +'mailto:' link in an EWW buffer can now be customized. For more +information, see the related entry about 'shr-browse-url' above. + ** Project *** New user option 'project-vc-merge-submodules'. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index a6c1abdbb1..2a70560ca7 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -307,10 +307,10 @@ the default EWW buffer." (insert (format "Loading %s..." url)) (goto-char (point-min))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render + (url-retrieve url #'eww-render (list url nil (current-buffer))))) -(put 'eww 'browse-url-browser-kind 'internal) +(function-put 'eww 'browse-url-browser-kind 'internal) (defun eww--dwim-expand-url (url) (setq url (string-trim url)) @@ -375,8 +375,8 @@ engine used." (let ((region-string (buffer-substring (region-beginning) (region-end)))) (if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string)) (eww region-string) - (call-interactively 'eww))) - (call-interactively 'eww))) + (call-interactively #'eww))) + (call-interactively #'eww))) (defun eww-open-in-new-buffer () "Fetch link at point in a new EWW buffer." @@ -1013,7 +1013,7 @@ just re-display the HTML already fetched." (eww-display-html 'utf-8 url (plist-get eww-data :dom) (point) (current-buffer))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render + (url-retrieve url #'eww-render (list url (point) (current-buffer) encode)))))) ;; Form support. @@ -1576,8 +1576,10 @@ If EXTERNAL is double prefix, browse in new buffer." (cond ((not url) (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) + ((string-match-p "\\`mailto:" url) + ;; This respects the user options `browse-url-handlers' + ;; and `browse-url-mailto-function'. + (browse-url url)) ((and (consp external) (<= (car external) 4)) (funcall browse-url-secondary-browser-function url) (shr--blink-link)) @@ -1615,7 +1617,7 @@ Use link at point if there is one, else the current page's URL." (eww-current-url)))) (if (not url) (message "No URL under point") - (url-retrieve url 'eww-download-callback (list url))))) + (url-retrieve url #'eww-download-callback (list url))))) (defun eww-download-callback (status url) (unless (plist-get status :error) @@ -2128,12 +2130,12 @@ entries (if any) will be removed from the list. Only the properties listed in `eww-desktop-data-save' are included. Generally, the list should not include the (usually overly large) :dom, :source and :text properties." - (let ((history (mapcar 'eww-desktop-data-1 - (cons eww-data eww-history)))) - (list :history (if eww-desktop-remove-duplicates - (cl-remove-duplicates - history :test 'eww-desktop-history-duplicate) - history)))) + (let ((history (mapcar #'eww-desktop-data-1 + (cons eww-data eww-history)))) + (list :history (if eww-desktop-remove-duplicates + (cl-remove-duplicates + history :test #'eww-desktop-history-duplicate) + history)))) (defun eww-restore-desktop (file-name buffer-name misc-data) "Restore an eww buffer from its desktop file record. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 1f80ab74db..03260c9e70 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -135,7 +135,7 @@ same domain as the main data." This is used for cid: URLs, and the function is called with the cid: URL as the argument.") -(defvar shr-put-image-function 'shr-put-image +(defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") (defface shr-strike-through '((t :strike-through t)) @@ -365,25 +365,20 @@ If the URL is already at the front of the kill ring act like (shr-copy-url url))) (defun shr--current-link-region () - (let ((current (get-text-property (point) 'shr-url)) - start) - (save-excursion - ;; Go to the beginning. - (while (and (not (bobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char -1)) - (unless (equal (get-text-property (point) 'shr-url) current) - (forward-char 1)) - (setq start (point)) - ;; Go to the end. - (while (and (not (eobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char 1)) - (list start (point))))) + "Return the start and end positions of the URL at point, if any. +Value is a pair of positions (START . END) if there is a non-nil +`shr-url' text property at point; otherwise nil." + (when (get-text-property (point) 'shr-url) + (let* ((end (or (next-single-property-change (point) 'shr-url) + (point-max))) + (beg (or (previous-single-property-change end 'shr-url) + (point-min)))) + (cons beg end)))) (defun shr--blink-link () - (let* ((region (shr--current-link-region)) - (overlay (make-overlay (car region) (cadr region)))) + "Briefly fontify URL at point with the face `shr-selected-link'." + (when-let* ((region (shr--current-link-region)) + (overlay (make-overlay (car region) (cdr region)))) (overlay-put overlay 'face 'shr-selected-link) (run-at-time 1 nil (lambda () (delete-overlay overlay))))) @@ -437,7 +432,7 @@ the URL of the image to the kill buffer instead." (if (not url) (message "No image under point") (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker)) t)))) @@ -463,7 +458,7 @@ size, and full-buffer size." (when (> (- (point) start) 2) (delete-region start (1- (point))))) (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker) (list (cons 'size (cond ((or (eq size 'default) @@ -493,7 +488,7 @@ size, and full-buffer size." ((fboundp function) (apply function dom args)) (t - (apply 'shr-generic dom args))))) + (apply #'shr-generic dom args))))) (defun shr-descend (dom) (let ((function @@ -730,9 +725,10 @@ size, and full-buffer size." (let ((gap-start (point)) (face (get-text-property (point) 'face))) ;; Extend the background to the end of the line. - (if face - (insert (propertize "\n" 'face (shr-face-background face))) - (insert "\n")) + (insert ?\n) + (when face + (put-text-property (1- (point)) (point) + 'face (shr-face-background face))) (shr-indent) (when (and (> (1- gap-start) (point-min)) (get-text-property (point) 'shr-url) @@ -935,12 +931,11 @@ size, and full-buffer size." (defun shr-indent () (when (> shr-indentation 0) - (insert - (if (not shr-use-fonts) - (make-string shr-indentation ?\s) - (propertize " " - 'display - `(space :width (,shr-indentation))))))) + (if (not shr-use-fonts) + (insert-char ?\s shr-indentation) + (insert ?\s) + (put-text-property (1- (point)) (point) + 'display `(space :width (,shr-indentation)))))) (defun shr-fontize-dom (dom &rest types) (let ((start (point))) @@ -987,16 +982,11 @@ the mouse click event." (cond ((not url) (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) + (external + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) (t - (if external - (progn - (funcall browse-url-secondary-browser-function url) - (shr--blink-link)) - (browse-url url (if new-window - (not browse-url-new-window-flag) - browse-url-new-window-flag))))))) + (browse-url url (xor new-window browse-url-new-window-flag)))))) (defun shr-save-contents (directory) "Save the contents from URL in a file." @@ -1005,7 +995,7 @@ the mouse click event." (if (not url) (message "No link under point") (url-retrieve (shr-encode-url url) - 'shr-store-contents (list url directory))))) + #'shr-store-contents (list url directory))))) (defun shr-store-contents (status url directory) (unless (plist-get status :error) @@ -1156,7 +1146,6 @@ width/height instead." ;; url-cache-extract autoloads url-cache. (declare-function url-cache-create-filename "url-cache" (url)) -(autoload 'browse-url-mail "browse-url") (defun shr-get-image-data (url) "Get image data for URL. @@ -1230,7 +1219,7 @@ START, and END. Note that START and END should be markers." (funcall shr-put-image-function image (buffer-substring start end)) (delete-region (point) end)))) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) start end) t t))))) @@ -1679,7 +1668,7 @@ The preference is a float determined from `shr-prefer-media-type'." (or alt ""))) (insert " ") (url-queue-retrieve - (shr-encode-url url) 'shr-image-fetched + (shr-encode-url url) #'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (point)) (list :width width :height height)) t @@ -2006,12 +1995,11 @@ BASE is the URL of the HTML being rendered." (cond ((null tbodies) dom) - ((= (length tbodies) 1) + ((null (cdr tbodies)) (car tbodies)) (t ;; Table with multiple tbodies. Convert into a single tbody. - `(tbody nil ,@(cl-reduce 'append - (mapcar 'dom-non-text-children tbodies))))))) + `(tbody nil ,@(mapcan #'dom-non-text-children tbodies)))))) (defun shr--fix-tbody (tbody) (nconc (list 'tbody (dom-attributes tbody)) @@ -2311,8 +2299,8 @@ flags that control whether to collect or render objects." (dolist (column row) (aset natural-widths i (max (aref natural-widths i) column)) (setq i (1+ i))))) - (let ((extra (- (apply '+ (append suggested-widths nil)) - (apply '+ (append widths nil)) + (let ((extra (- (apply #'+ (append suggested-widths nil)) + (apply #'+ (append widths nil)) (* shr-table-separator-pixel-width (1+ (length widths))))) (expanded-columns 0)) ;; We have extra, unused space, so divide this space amongst the commit 3f082af536c33ba713561e7ad4b691aaad488701 Author: Basil L. Contovounesios Date: Sat May 16 13:23:48 2020 +0100 Various json.el improvements * etc/NEWS: Announce that json-read-number is now stricter. * json.el: Bump package version. (json-encoding-lisp-style-closings, json-pre-element-read-function) (json-post-element-read-function, json-advance, json-peek) (json--path): Clarify and improve style of doc strings. (json-join): Define as an obsolete alias of string-join. (json-alist-p, json-plist-p): Refactor for speed and declare as pure, side-effect-free, and error-free. (json--plist-reverse): Rename function... (json--plist-nreverse): ...to this, making it destructive for speed. All callers changed. (json--plist-to-alist): Remove, replacing single use with map-pairs. (json--with-indentation): Accept multiple forms as arguments, fix their indentation, and allow them to be instrumented for debugging. Add docstring. (json-pop, json-read-keyword, json-add-to-object) (json-encode-array): Simplify for speed. (json-skip-whitespace): Put newline before carriage return for likely frequency of occurrence, and so that the characters appear in increasing order. (json--check-position): Use 1+. (json-path-to-position): Open code apply-partially. (json-keywords): Turn into a defconst and mark as obsolete now that it is no longer used. (json--post-value, json--number, json--escape): New rx definitions. (json-encode-keyword): Declare as side-effect-free. (json-read-number): Reject leading zeros and plus signs, and make integer part mandatory in accordance with JSON standards and for consistency with native JSON parsing functions. Eagerly signal json-number-format when garbage follows a valid number, e.g., when reading "1.1.1", instead of leaving that up to the caller. Remove optional internal argument from advertised calling convention now that the function is no longer recursive. (json-encode-number): Define as an alias of number-to-string. (json-special-chars): Turn into a defconst. (json-read-escaped-char, json-new-object, json-read-file) (json-pretty-print): Simplify. (json-read-string): For consistency with other json.el error reporting, remove check for leading '"', and use the integer value rather than the printed representation of characters in error data. At EOB signal json-end-of-file instead of json-string-format. (json--long-string-threshold, json--string-buffer): New variables. (json-encode-string): Reimplement in terms of buffer manipulation for speed (bug#20154). (json-read-object): Escape ?\} properly. (json--encode-alist): New function extracted from json-encode-alist. (json-encode-hash-table, json-encode-alist, json-encode-plist): Use it to avoid destructively modifying the argument when json-encoding-object-sort-predicate is non-nil without incurring unnecessary copying (bug#40693). Encode empty object as "{}" even when pretty-printing. Simplify for speed. (json-read-array): Avoid recomputing list length on each iteration when json-pre-element-read-function is non-nil. Make first element of json-array-format error data a string for consistency with json-object-format and to make the displayed error message clearer. (json-readtable-dispatch): Accept any kind of argument, not just symbols. Generate the table in a simpler manner so the dispatch order is clearer. Remove dispatch on ?+ and ?. now that json-read-number is stricter and for consistency with native JSON parsing functions. Signal json-end-of-file if argument is nil. (json-read): Simplify accordingly. (json-encode): Avoid allocating a list on each invocation. * lisp/jsonrpc.el (jsonrpc--json-read, jsonrpc--json-encode): Check whether native JSON functions are fboundp only once, at load time. * lisp/progmodes/python.el (python--parse-json-array): New function. (python-shell-prompt-detect): Use it to parse JSON directly as a list rather than converting from a vector. * test/lisp/json-tests.el (json-tests--with-temp-buffer): Allow instrumenting for debugging. (test-json-join, test-json-plist-to-alist): Remove tests. (test-json-alist-p, test-json-plist-p, test-json-advance) (test-json-peek, test-json-pop, test-json-skip-whitespace) (test-json-read-keyword, test-json-encode-keyword) (test-json-encode-number, test-json-read-escaped-char) (test-json-read-string, test-json-encode-string) (test-json-encode-key, test-json-new-object) (test-json-encode-hash-table, test-json-encode-plist) (test-json-encode-list, test-json-read-array) (test-json-encode-array, test-json-read) (test-json-read-from-string, test-json-encode): Extend tests. (test-json-plist-reverse): Rename test... (test-json-plist-nreverse): ...to this and avoid modifying literal lists. (test-json-read-number): Rename test... (test-json-read-integer): ...to this, focusing on integers. (test-json-add-to-object): Rename test... (test-json-add-to-alist): ...to this, focusing on alists. (json-encode-simple-alist): Rename test... (test-json-encode-alist): ...to this, extending it. (test-json-encode-alist-with-sort-predicate): Rename test... (test-json-encode-alist-sort): ...to this, extending it. (test-json-encode-plist-with-sort-predicate): Rename test... (test-json-encode-plist-sort): ...to this, extending it. (test-json-read-keyword-invalid, test-json-read-fraction) (test-json-read-exponent, test-json-read-fraction-exponent) (test-json-read-number-invalid) (test-json-read-escaped-char-invalid, test-json-add-to-plist) (test-json-add-to-hash-table, test-json-read-object-empty) (test-json-read-object-invalid, test-json-read-object-function) (test-json-encode-hash-table-pretty) (test-json-encode-hash-table-lisp-style) (test-json-encode-hash-table-sort, test-json-encode-alist-pretty) (test-json-encode-alist-lisp-style, test-json-encode-plist-pretty) (test-json-encode-plist-lisp-style, test-json-read-array-function) (test-json-encode-array-pretty, test-json-encode-array-lisp-style) (test-json-read-invalid): New tests. (test-json-path-to-position-no-match): Use should-not. (test-json-read-object): Move error check to new test test-json-read-object-invalid. (test-json-pretty-print-object): Adapt test now that empty objects are pretty-printed as "{}". diff --git a/etc/NEWS b/etc/NEWS index 1bf1403cab..4533dc46c5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -360,6 +360,15 @@ either an internal or external browser. *** New user option 'project-vc-merge-submodules'. +** json.el + +--- +*** JSON number parsing is now stricter. +Numbers with a leading plus sign, leading zeros, or a missing integer +component are now rejected by 'json-read' and friends. This makes +them more compliant with the JSON specification and consistent with +the native JSON parsing functions. + * New Modes and Packages in Emacs 28.1 diff --git a/lisp/json.el b/lisp/json.el index 6f3b791ed1..9002e86853 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2006-2020 Free Software Foundation, Inc. ;; Author: Theresa O'Connor -;; Version: 1.4 +;; Version: 1.5 ;; Keywords: convenience ;; This file is part of GNU Emacs. @@ -29,11 +29,11 @@ ;; Learn all about JSON here: . ;; The user-serviceable entry points for the parser are the functions -;; `json-read' and `json-read-from-string'. The encoder has a single +;; `json-read' and `json-read-from-string'. The encoder has a single ;; entry point, `json-encode'. ;; Since there are several natural representations of key-value pair -;; mappings in elisp (alist, plist, hash-table), `json-read' allows you +;; mappings in Elisp (alist, plist, hash-table), `json-read' allows you ;; to specify which you'd prefer (see `json-object-type' and ;; `json-array-type'). @@ -55,6 +55,7 @@ ;;; Code: (require 'map) +(require 'seq) (require 'subr-x) ;; Parameters @@ -113,8 +114,10 @@ Used only when `json-encoding-pretty-print' is non-nil.") "If non-nil, then the output of `json-encode' will be pretty-printed.") (defvar json-encoding-lisp-style-closings nil - "If non-nil, ] and } closings will be formatted lisp-style, -without indentation.") + "If non-nil, delimiters ] and } will be formatted Lisp-style. +This means they will be placed on the same line as the last +element of the respective array or object, without indentation. +Used only when `json-encoding-pretty-print' is non-nil.") (defvar json-encoding-object-sort-predicate nil "Sorting predicate for JSON object keys during encoding. @@ -124,88 +127,81 @@ instance, setting this to `string<' will have JSON object keys ordered alphabetically.") (defvar json-pre-element-read-function nil - "Function called (if non-nil) by `json-read-array' and -`json-read-object' right before reading a JSON array or object, -respectively. The function is called with one argument, which is -the current JSON key.") + "If non-nil, a function to call before reading a JSON array or object. +It is called by `json-read-array' and `json-read-object', +respectively, with one argument, which is the current JSON key.") (defvar json-post-element-read-function nil - "Function called (if non-nil) by `json-read-array' and -`json-read-object' right after reading a JSON array or object, -respectively.") + "If non-nil, a function to call after reading a JSON array or object. +It is called by `json-read-array' and `json-read-object', +respectively, with no arguments.") ;;; Utilities -(defun json-join (strings separator) - "Join STRINGS with SEPARATOR." - (mapconcat 'identity strings separator)) +(define-obsolete-function-alias 'json-join #'string-join "28.1") (defun json-alist-p (list) - "Non-null if and only if LIST is an alist with simple keys." - (while (consp list) - (setq list (if (and (consp (car list)) - (atom (caar list))) - (cdr list) - 'not-alist))) + "Non-nil if and only if LIST is an alist with simple keys." + (declare (pure t) (side-effect-free error-free)) + (while (and (consp (car-safe list)) + (atom (caar list)) + (setq list (cdr list)))) (null list)) (defun json-plist-p (list) - "Non-null if and only if LIST is a plist with keyword keys." - (while (consp list) - (setq list (if (and (keywordp (car list)) - (consp (cdr list))) - (cddr list) - 'not-plist))) + "Non-nil if and only if LIST is a plist with keyword keys." + (declare (pure t) (side-effect-free error-free)) + (while (and (keywordp (car-safe list)) + (consp (cdr list)) + (setq list (cddr list)))) (null list)) -(defun json--plist-reverse (plist) - "Return a copy of PLIST in reverse order. -Unlike `reverse', this keeps the property-value pairs intact." - (let (res) - (while plist - (let ((prop (pop plist)) - (val (pop plist))) - (push val res) - (push prop res))) - res)) - -(defun json--plist-to-alist (plist) - "Return an alist of the property-value pairs in PLIST." - (let (res) - (while plist - (let ((prop (pop plist)) - (val (pop plist))) - (push (cons prop val) res))) - (nreverse res))) - -(defmacro json--with-indentation (body) +(defun json--plist-nreverse (plist) + "Return PLIST in reverse order. +Unlike `nreverse', this keeps the ordering of each property +relative to its value intact. Like `nreverse', this function may +destructively modify PLIST to produce the result." + (let (prev (next (cddr plist))) + (while next + (setcdr (cdr plist) prev) + (setq prev plist plist next next (cddr next)) + (setcdr (cdr plist) prev))) + plist) + +(defmacro json--with-indentation (&rest body) + "Evaluate BODY with the correct indentation for JSON encoding. +This macro binds `json--encoding-current-indentation' according +to `json-encoding-pretty-print' around BODY." + (declare (debug t) (indent 0)) `(let ((json--encoding-current-indentation (if json-encoding-pretty-print (concat json--encoding-current-indentation json-encoding-default-indentation) ""))) - ,body)) + ,@body)) ;; Reader utilities (define-inline json-advance (&optional n) - "Advance N characters forward." + "Advance N characters forward, or 1 character if N is nil. +On reaching the end of the accessible region of the buffer, stop +and signal an error." (inline-quote (forward-char ,n))) (define-inline json-peek () - "Return the character at point." + "Return the character at point. +At the end of the accessible region of the buffer, return 0." (inline-quote (following-char))) (define-inline json-pop () - "Advance past the character at point, returning it." + "Advance past the character at point, returning it. +Signal `json-end-of-file' if called at the end of the buffer." (inline-quote - (let ((char (json-peek))) - (if (zerop char) - (signal 'json-end-of-file nil) - (json-advance) - char)))) + (prog1 (or (char-after) + (signal 'json-end-of-file ())) + (json-advance)))) (define-inline json-skip-whitespace () "Skip past the whitespace at point." @@ -213,7 +209,7 @@ Unlike `reverse', this keeps the property-value pairs intact." ;; https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf ;; or https://tools.ietf.org/html/rfc7159#section-2 for the ;; definition of whitespace in JSON. - (inline-quote (skip-chars-forward "\t\r\n "))) + (inline-quote (skip-chars-forward "\t\n\r "))) @@ -236,8 +232,8 @@ Unlike `reverse', this keeps the property-value pairs intact." ;;; Paths (defvar json--path '() - "Used internally by `json-path-to-position' to keep track of -the path during recursive calls to `json-read'.") + "Keeps track of the path during recursive calls to `json-read'. +Used internally by `json-path-to-position'.") (defun json--record-path (key) "Record the KEY to the current JSON path. @@ -248,7 +244,7 @@ Used internally by `json-path-to-position'." "Check if the last parsed JSON structure passed POSITION. Used internally by `json-path-to-position'." (let ((start (caar json--path))) - (when (< start position (+ (point) 1)) + (when (< start position (1+ (point))) (throw :json-path (list :path (nreverse (mapcar #'cdr json--path)) :match-start start :match-end (point))))) @@ -266,13 +262,13 @@ properties: :path -- A list of strings and numbers forming the path to the JSON element at the given position. Strings denote object names, while numbers denote array - indexes. + indices. :match-start -- Position where the matched JSON element begins. :match-end -- Position where the matched JSON element ends. -This can for instance be useful to determine the path to a JSON +This can, for instance, be useful to determine the path to a JSON element in a deeply nested structure." (save-excursion (unless string @@ -280,7 +276,7 @@ element in a deeply nested structure." (let* ((json--path '()) (json-pre-element-read-function #'json--record-path) (json-post-element-read-function - (apply-partially #'json--check-position position)) + (lambda () (json--check-position position))) (path (catch :json-path (if string (json-read-from-string string) @@ -290,38 +286,33 @@ element in a deeply nested structure." ;;; Keywords -(defvar json-keywords '("true" "false" "null") +(defconst json-keywords '("true" "false" "null") "List of JSON keywords.") +(make-obsolete-variable 'json-keywords "it is no longer used." "28.1") ;; Keyword parsing +;; Characters that can follow a JSON value. +(rx-define json--post-value (| (in "\t\n\r ,]}") eos)) + (defun json-read-keyword (keyword) - "Read a JSON keyword at point. -KEYWORD is the keyword expected." - (unless (member keyword json-keywords) - (signal 'json-unknown-keyword (list keyword))) - (mapc (lambda (char) - (when (/= char (json-peek)) - (signal 'json-unknown-keyword - (list (save-excursion - (backward-word-strictly 1) - (thing-at-point 'word))))) - (json-advance)) - keyword) - (json-skip-whitespace) - (unless (looking-at "\\([],}]\\|$\\)") - (signal 'json-unknown-keyword - (list (save-excursion - (backward-word-strictly 1) - (thing-at-point 'word))))) - (cond ((string-equal keyword "true") t) - ((string-equal keyword "false") json-false) - ((string-equal keyword "null") json-null))) + "Read the expected JSON KEYWORD at point." + (prog1 (cond ((equal keyword "true") t) + ((equal keyword "false") json-false) + ((equal keyword "null") json-null) + (t (signal 'json-unknown-keyword (list keyword)))) + (or (looking-at-p keyword) + (signal 'json-unknown-keyword (list (thing-at-point 'word)))) + (json-advance (length keyword)) + (or (looking-at-p (rx json--post-value)) + (signal 'json-unknown-keyword (list (thing-at-point 'word)))) + (json-skip-whitespace))) ;; Keyword encoding (defun json-encode-keyword (keyword) "Encode KEYWORD as a JSON value." + (declare (side-effect-free t)) (cond ((eq keyword t) "true") ((eq keyword json-false) "false") ((eq keyword json-null) "null"))) @@ -330,37 +321,31 @@ KEYWORD is the keyword expected." ;; Number parsing -(defun json-read-number (&optional sign) - "Read the JSON number following point. -The optional SIGN argument is for internal use. - -N.B.: Only numbers which can fit in Emacs Lisp's native number -representation will be parsed correctly." - ;; If SIGN is non-nil, the number is explicitly signed. - (let ((number-regexp - "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?")) - (cond ((and (null sign) (= (json-peek) ?-)) - (json-advance) - (- (json-read-number t))) - ((and (null sign) (= (json-peek) ?+)) - (json-advance) - (json-read-number t)) - ((and (looking-at number-regexp) - (or (match-beginning 1) - (match-beginning 2))) - (goto-char (match-end 0)) - (string-to-number (match-string 0))) - (t (signal 'json-number-format (list (point))))))) +(rx-define json--number + (: (? ?-) ; Sign. + (| (: (in "1-9") (* digit)) ?0) ; Integer. + (? ?. (+ digit)) ; Fraction. + (? (in "Ee") (? (in ?+ ?-)) (+ digit)))) ; Exponent. + +(defun json-read-number (&optional _sign) + "Read the JSON number following point." + (declare (advertised-calling-convention () "28.1")) + (or (looking-at (rx json--number)) + (signal 'json-number-format (list (point)))) + (goto-char (match-end 0)) + (prog1 (string-to-number (match-string 0)) + (or (looking-at-p (rx json--post-value)) + (signal 'json-number-format (list (point)))) + (json-skip-whitespace))) ;; Number encoding -(defun json-encode-number (number) - "Return a JSON representation of NUMBER." - (format "%s" number)) +(defalias 'json-encode-number #'number-to-string + "Return a JSON representation of NUMBER.") ;;; Strings -(defvar json-special-chars +(defconst json-special-chars '((?\" . ?\") (?\\ . ?\\) (?b . ?\b) @@ -368,7 +353,7 @@ representation will be parsed correctly." (?n . ?\n) (?r . ?\r) (?t . ?\t)) - "Characters which are escaped in JSON, with their elisp counterparts.") + "Characters which are escaped in JSON, with their Elisp counterparts.") ;; String parsing @@ -378,48 +363,47 @@ representation will be parsed correctly." (defun json-read-escaped-char () "Read the JSON string escaped character at point." - ;; Skip over the '\' + ;; Skip over the '\'. (json-advance) - (let* ((char (json-pop)) - (special (assq char json-special-chars))) + (let ((char (json-pop))) (cond - (special (cdr special)) - ((not (eq char ?u)) char) + ((cdr (assq char json-special-chars))) + ((/= char ?u) char) ;; Special-case UTF-16 surrogate pairs, ;; cf. . Note that ;; this clause overlaps with the next one and therefore has to ;; come first. ((looking-at - (rx (group (any "Dd") (any "89ABab") (= 2 (any xdigit))) - "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any xdigit))))) + (rx (group (any "Dd") (any "89ABab") (= 2 xdigit)) + "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 xdigit)))) (json-advance 10) (json--decode-utf-16-surrogates (string-to-number (match-string 1) 16) (string-to-number (match-string 2) 16))) ((looking-at (rx (= 4 xdigit))) - (let ((hex (match-string 0))) - (json-advance 4) - (string-to-number hex 16))) + (json-advance 4) + (string-to-number (match-string 0) 16)) (t (signal 'json-string-escape (list (point))))))) (defun json-read-string () "Read the JSON string at point." - (unless (= (json-peek) ?\") - (signal 'json-string-format (list "doesn't start with `\"'!"))) - ;; Skip over the '"' + ;; Skip over the '"'. (json-advance) (let ((characters '()) (char (json-peek))) - (while (not (= char ?\")) + (while (/= char ?\") (when (< char 32) - (signal 'json-string-format (list (prin1-char char)))) + (if (zerop char) + (signal 'json-end-of-file ()) + (signal 'json-string-format (list char)))) (push (if (= char ?\\) (json-read-escaped-char) - (json-pop)) + (json-advance) + char) characters) (setq char (json-peek))) - ;; Skip over the '"' + ;; Skip over the '"'. (json-advance) (if characters (concat (nreverse characters)) @@ -427,29 +411,47 @@ representation will be parsed correctly." ;; String encoding +;; Escape only quotation mark, backslash, and the control +;; characters U+0000 to U+001F (RFC 4627, ECMA-404). +(rx-define json--escape (in ?\" ?\\ cntrl)) + +(defvar json--long-string-threshold 200 + "Length above which strings are considered long for JSON encoding. +It is generally faster to manipulate such strings in a buffer +rather than directly.") + +(defvar json--string-buffer nil + "Buffer used for encoding Lisp strings as JSON. +Initialized lazily by `json-encode-string'.") + (defun json-encode-string (string) "Return a JSON representation of STRING." - ;; Reimplement the meat of `replace-regexp-in-string', for - ;; performance (bug#20154). - (let ((l (length string)) - (start 0) - res mb) - ;; Only escape quotation mark, backslash and the control - ;; characters U+0000 to U+001F (RFC 4627, ECMA-404). - (while (setq mb (string-match "[\"\\[:cntrl:]]" string start)) - (let* ((c (aref string mb)) - (special (rassq c json-special-chars))) - (push (substring string start mb) res) - (push (if special - ;; Special JSON character (\n, \r, etc.). - (string ?\\ (car special)) - ;; Fallback: UCS code point in \uNNNN form. - (format "\\u%04x" c)) - res) - (setq start (1+ mb)))) - (push (substring string start l) res) - (push "\"" res) - (apply #'concat "\"" (nreverse res)))) + ;; Try to avoid buffer overhead in trivial cases, while also + ;; avoiding searching pathological strings for escape characters. + ;; Since `string-match-p' doesn't take a LIMIT argument, we use + ;; string length as our heuristic. See also bug#20154. + (if (and (< (length string) json--long-string-threshold) + (not (string-match-p (rx json--escape) string))) + (concat "\"" string "\"") + (with-current-buffer + (or json--string-buffer + (with-current-buffer (generate-new-buffer " *json-string*") + ;; This seems to afford decent performance gains. + (setq-local inhibit-modification-hooks t) + (setq json--string-buffer (current-buffer)))) + (insert ?\" string) + (goto-char (1+ (point-min))) + (while (re-search-forward (rx json--escape) nil 'move) + (let ((char (preceding-char))) + (delete-char -1) + (insert ?\\ (or + ;; Special JSON character (\n, \r, etc.). + (car (rassq char json-special-chars)) + ;; Fallback: UCS code point in \uNNNN form. + (format "u%04x" char))))) + (insert ?\") + ;; Empty buffer for next invocation. + (delete-and-extract-region (point-min) (point-max))))) (defun json-encode-key (object) "Return a JSON representation of OBJECT. @@ -460,15 +462,13 @@ this signals `json-key-format'." (signal 'json-key-format (list object))) encoded)) -;;; JSON Objects +;;; Objects (defun json-new-object () - "Create a new Elisp object corresponding to a JSON object. + "Create a new Elisp object corresponding to an empty JSON object. Please see the documentation of `json-object-type'." - (cond ((eq json-object-type 'hash-table) - (make-hash-table :test 'equal)) - (t - ()))) + (and (eq json-object-type 'hash-table) + (make-hash-table :test #'equal))) (defun json-add-to-object (object key value) "Add a new KEY -> VALUE association to OBJECT. @@ -476,10 +476,10 @@ Returns the updated object, which you should save, e.g.: (setq obj (json-add-to-object obj \"foo\" \"bar\")) Please see the documentation of `json-object-type' and `json-key-type'." (let ((json-key-type - (or json-key-type - (cdr (assq json-object-type '((hash-table . string) - (alist . symbol) - (plist . keyword))))))) + (cond (json-key-type) + ((eq json-object-type 'hash-table) 'string) + ((eq json-object-type 'alist) 'symbol) + ((eq json-object-type 'plist) 'keyword)))) (setq key (cond ((eq json-key-type 'string) key) @@ -499,13 +499,13 @@ Please see the documentation of `json-object-type' and `json-key-type'." (defun json-read-object () "Read the JSON object at point." - ;; Skip over the "{" + ;; Skip over the '{'. (json-advance) (json-skip-whitespace) - ;; read key/value pairs until "}" + ;; Read key/value pairs until '}'. (let ((elements (json-new-object)) key value) - (while (not (= (json-peek) ?})) + (while (/= (json-peek) ?\}) (json-skip-whitespace) (setq key (json-read-string)) (json-skip-whitespace) @@ -520,94 +520,94 @@ Please see the documentation of `json-object-type' and `json-key-type'." (funcall json-post-element-read-function)) (setq elements (json-add-to-object elements key value)) (json-skip-whitespace) - (when (/= (json-peek) ?}) + (when (/= (json-peek) ?\}) (if (= (json-peek) ?,) (json-advance) (signal 'json-object-format (list "," (json-peek)))))) - ;; Skip over the "}" + ;; Skip over the '}'. (json-advance) (pcase json-object-type ('alist (nreverse elements)) - ('plist (json--plist-reverse elements)) + ('plist (json--plist-nreverse elements)) (_ elements)))) ;; Hash table encoding (defun json-encode-hash-table (hash-table) "Return a JSON representation of HASH-TABLE." - (if json-encoding-object-sort-predicate - (json-encode-alist (map-into hash-table 'list)) - (format "{%s%s}" - (json-join - (let (r) - (json--with-indentation - (maphash - (lambda (k v) - (push (format - (if json-encoding-pretty-print - "%s%s: %s" - "%s%s:%s") - json--encoding-current-indentation - (json-encode-key k) - (json-encode v)) - r)) - hash-table)) - r) - json-encoding-separator) - (if (or (not json-encoding-pretty-print) - json-encoding-lisp-style-closings) - "" - json--encoding-current-indentation)))) + (cond ((hash-table-empty-p hash-table) "{}") + (json-encoding-object-sort-predicate + (json--encode-alist (map-pairs hash-table) t)) + (t + (let ((kv-sep (if json-encoding-pretty-print ": " ":")) + result) + (json--with-indentation + (maphash + (lambda (k v) + (push (concat json--encoding-current-indentation + (json-encode-key k) + kv-sep + (json-encode v)) + result)) + hash-table)) + (concat "{" + (string-join (nreverse result) json-encoding-separator) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}"))))) ;; List encoding (including alists and plists) -(defun json-encode-alist (alist) - "Return a JSON representation of ALIST." +(defun json--encode-alist (alist &optional destructive) + "Return a JSON representation of ALIST. +DESTRUCTIVE non-nil means it is safe to modify ALIST by +side-effects." (when json-encoding-object-sort-predicate - (setq alist - (sort alist (lambda (a b) + (setq alist (sort (if destructive alist (copy-sequence alist)) + (lambda (a b) (funcall json-encoding-object-sort-predicate (car a) (car b)))))) - (format "{%s%s}" - (json-join - (json--with-indentation - (mapcar (lambda (cons) - (format (if json-encoding-pretty-print - "%s%s: %s" - "%s%s:%s") - json--encoding-current-indentation - (json-encode-key (car cons)) - (json-encode (cdr cons)))) - alist)) - json-encoding-separator) - (if (or (not json-encoding-pretty-print) - json-encoding-lisp-style-closings) - "" - json--encoding-current-indentation))) + (concat "{" + (let ((kv-sep (if json-encoding-pretty-print ": " ":"))) + (json--with-indentation + (mapconcat (lambda (cons) + (concat json--encoding-current-indentation + (json-encode-key (car cons)) + kv-sep + (json-encode (cdr cons)))) + alist + json-encoding-separator))) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}")) + +(defun json-encode-alist (alist) + "Return a JSON representation of ALIST." + (if alist (json--encode-alist alist) "{}")) (defun json-encode-plist (plist) "Return a JSON representation of PLIST." - (if json-encoding-object-sort-predicate - (json-encode-alist (json--plist-to-alist plist)) - (let (result) - (json--with-indentation - (while plist - (push (concat - json--encoding-current-indentation - (json-encode-key (car plist)) - (if json-encoding-pretty-print - ": " - ":") - (json-encode (cadr plist))) + (cond ((null plist) "{}") + (json-encoding-object-sort-predicate + (json--encode-alist (map-pairs plist) t)) + (t + (let ((kv-sep (if json-encoding-pretty-print ": " ":")) result) - (setq plist (cddr plist)))) - (concat "{" - (json-join (nreverse result) json-encoding-separator) - (if (and json-encoding-pretty-print - (not json-encoding-lisp-style-closings)) - json--encoding-current-indentation - "") - "}")))) + (json--with-indentation + (while plist + (push (concat json--encoding-current-indentation + (json-encode-key (pop plist)) + kv-sep + (json-encode (pop plist))) + result))) + (concat "{" + (string-join (nreverse result) json-encoding-separator) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}"))))) (defun json-encode-list (list) "Return a JSON representation of LIST. @@ -625,15 +625,17 @@ become JSON objects." (defun json-read-array () "Read the JSON array at point." - ;; Skip over the "[" + ;; Skip over the '['. (json-advance) (json-skip-whitespace) - ;; read values until "]" - (let (elements) - (while (not (= (json-peek) ?\])) + ;; Read values until ']'. + (let (elements + (len 0)) + (while (/= (json-peek) ?\]) (json-skip-whitespace) (when json-pre-element-read-function - (funcall json-pre-element-read-function (length elements))) + (funcall json-pre-element-read-function len) + (setq len (1+ len))) (push (json-read) elements) (when json-post-element-read-function (funcall json-post-element-read-function)) @@ -641,8 +643,8 @@ become JSON objects." (when (/= (json-peek) ?\]) (if (= (json-peek) ?,) (json-advance) - (signal 'json-array-format (list ?, (json-peek)))))) - ;; Skip over the "]" + (signal 'json-array-format (list "," (json-peek)))))) + ;; Skip over the ']'. (json-advance) (pcase json-array-type ('vector (nreverse (vconcat elements))) @@ -653,42 +655,43 @@ become JSON objects." (defun json-encode-array (array) "Return a JSON representation of ARRAY." (if (and json-encoding-pretty-print - (> (length array) 0)) + (not (seq-empty-p array))) (concat + "[" (json--with-indentation - (concat (format "[%s" json--encoding-current-indentation) - (json-join (mapcar 'json-encode array) - (format "%s%s" - json-encoding-separator + (concat json--encoding-current-indentation + (mapconcat #'json-encode array + (concat json-encoding-separator json--encoding-current-indentation)))) - (format "%s]" - (if json-encoding-lisp-style-closings - "" - json--encoding-current-indentation))) + (unless json-encoding-lisp-style-closings + json--encoding-current-indentation) + "]") (concat "[" - (mapconcat 'json-encode array json-encoding-separator) + (mapconcat #'json-encode array json-encoding-separator) "]"))) -;;; JSON reader. +;;; Reader (defmacro json-readtable-dispatch (char) - "Dispatch reader function for CHAR." - (declare (debug (symbolp))) - (let ((table - '((?t json-read-keyword "true") - (?f json-read-keyword "false") - (?n json-read-keyword "null") - (?{ json-read-object) - (?\[ json-read-array) - (?\" json-read-string))) - res) - (dolist (c '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) - (push (list c 'json-read-number) table)) - (pcase-dolist (`(,c . ,rest) table) - (push `((eq ,char ,c) (,@rest)) res)) - `(cond ,@res (t (signal 'json-readtable-error (list ,char)))))) + "Dispatch reader function for CHAR at point. +If CHAR is nil, signal `json-end-of-file'." + (declare (debug t)) + (macroexp-let2 nil char char + `(cond ,@(map-apply + (lambda (key expr) + `((eq ,char ,key) ,expr)) + `((?\" ,#'json-read-string) + (?\[ ,#'json-read-array) + (?\{ ,#'json-read-object) + (?n ,#'json-read-keyword "null") + (?f ,#'json-read-keyword "false") + (?t ,#'json-read-keyword "true") + ,@(mapcar (lambda (c) (list c #'json-read-number)) + '(?- ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))) + (,char (signal 'json-readtable-error (list ,char))) + (t (signal 'json-end-of-file ()))))) (defun json-read () "Parse and return the JSON object following point. @@ -706,10 +709,7 @@ you will get the following structure returned: ((c . :json-false))]) (b . \"foo\"))" (json-skip-whitespace) - (let ((char (json-peek))) - (if (zerop char) - (signal 'json-end-of-file nil) - (json-readtable-dispatch char)))) + (json-readtable-dispatch (char-after))) ;; Syntactic sugar for the reader @@ -724,12 +724,11 @@ you will get the following structure returned: "Read the first JSON object contained in FILE and return it." (with-temp-buffer (insert-file-contents file) - (goto-char (point-min)) (json-read))) -;;; JSON encoder +;;; Encoder (defun json-encode (object) "Return a JSON representation of OBJECT as a string. @@ -737,20 +736,21 @@ you will get the following structure returned: OBJECT should have a structure like one returned by `json-read'. If an error is detected during encoding, an error based on `json-error' is signaled." - (cond ((memq object (list t json-null json-false)) - (json-encode-keyword object)) - ((stringp object) (json-encode-string object)) - ((keywordp object) (json-encode-string - (substring (symbol-name object) 1))) - ((listp object) (json-encode-list object)) - ((symbolp object) (json-encode-string - (symbol-name object))) - ((numberp object) (json-encode-number object)) - ((arrayp object) (json-encode-array object)) - ((hash-table-p object) (json-encode-hash-table object)) - (t (signal 'json-error (list object))))) - -;; Pretty printing & minimizing + (cond ((eq object t) (json-encode-keyword object)) + ((eq object json-null) (json-encode-keyword object)) + ((eq object json-false) (json-encode-keyword object)) + ((stringp object) (json-encode-string object)) + ((keywordp object) (json-encode-string + (substring (symbol-name object) 1))) + ((listp object) (json-encode-list object)) + ((symbolp object) (json-encode-string + (symbol-name object))) + ((numberp object) (json-encode-number object)) + ((arrayp object) (json-encode-array object)) + ((hash-table-p object) (json-encode-hash-table object)) + (t (signal 'json-error (list object))))) + +;;; Pretty printing & minimizing (defun json-pretty-print-buffer (&optional minimize) "Pretty-print current buffer. @@ -769,9 +769,9 @@ MAX-SECS.") With prefix argument MINIMIZE, minimize it instead." (interactive "r\nP") (let ((json-encoding-pretty-print (null minimize)) - ;; Distinguish an empty objects from 'null' + ;; Distinguish an empty object from 'null'. (json-null :json-null) - ;; Ensure that ordering is maintained + ;; Ensure that ordering is maintained. (json-object-type 'alist) (orig-buf (current-buffer)) error) @@ -800,9 +800,7 @@ With prefix argument MINIMIZE, minimize it instead." ;; them. (let ((space (buffer-substring (point) - (+ (point) - (skip-chars-forward - " \t\n" (point-max))))) + (+ (point) (skip-chars-forward " \t\n")))) (json (json-read))) (setq pos (point)) ; End of last good json-read. (set-buffer tmp-buf) @@ -832,14 +830,14 @@ With prefix argument MINIMIZE, minimize it instead." "Pretty-print current buffer with object keys ordered. With prefix argument MINIMIZE, minimize it instead." (interactive "P") - (let ((json-encoding-object-sort-predicate 'string<)) + (let ((json-encoding-object-sort-predicate #'string<)) (json-pretty-print-buffer minimize))) (defun json-pretty-print-ordered (begin end &optional minimize) "Pretty-print the region with object keys ordered. With prefix argument MINIMIZE, minimize it instead." (interactive "r\nP") - (let ((json-encoding-object-sort-predicate 'string<)) + (let ((json-encoding-object-sort-predicate #'string<)) (json-pretty-print begin end minimize))) (provide 'json) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 293dfaa748..42e7701af1 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -37,7 +37,6 @@ ;;; Code: (require 'cl-lib) -(require 'json) (require 'eieio) (eval-when-compile (require 'subr-x)) (require 'warnings) @@ -470,26 +469,35 @@ With optional CLEANUP, kill any associated buffers." ;;; (define-error 'jsonrpc-error "jsonrpc-error") -(defun jsonrpc--json-read () - "Read JSON object in buffer, move point to end of buffer." - ;; TODO: I guess we can make these macros if/when jsonrpc.el - ;; goes into Emacs core. - (cond ((fboundp 'json-parse-buffer) (json-parse-buffer - :object-type 'plist - :null-object nil - :false-object :json-false)) - (t (let ((json-object-type 'plist)) - (json-read))))) - -(defun jsonrpc--json-encode (object) - "Encode OBJECT into a JSON string." - (cond ((fboundp 'json-serialize) (json-serialize - object - :false-object :json-false - :null-object nil)) - (t (let ((json-false :json-false) - (json-null nil)) - (json-encode object))))) +(defalias 'jsonrpc--json-read + (if (fboundp 'json-parse-buffer) + (lambda () + (json-parse-buffer :object-type 'plist + :null-object nil + :false-object :json-false)) + (require 'json) + (defvar json-object-type) + (declare-function json-read "json" ()) + (lambda () + (let ((json-object-type 'plist)) + (json-read)))) + "Read JSON object in buffer, move point to end of buffer.") + +(defalias 'jsonrpc--json-encode + (if (fboundp 'json-serialize) + (lambda (object) + (json-serialize object + :false-object :json-false + :null-object nil)) + (require 'json) + (defvar json-false) + (defvar json-null) + (declare-function json-encode "json" (object)) + (lambda (object) + (let ((json-false :json-false) + (json-null nil)) + (json-encode object)))) + "Encode OBJECT into a JSON string.") (cl-defun jsonrpc--reply (connection id &key (result nil result-supplied-p) (error nil error-supplied-p)) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 67383b3415..1ca9f01963 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -261,7 +261,6 @@ (require 'ansi-color) (require 'cl-lib) (require 'comint) -(require 'json) (require 'tramp-sh) ;; Avoid compiler warnings @@ -2276,6 +2275,18 @@ Do not set this variable directly, instead use Do not set this variable directly, instead use `python-shell-prompt-set-calculated-regexps'.") +(defalias 'python--parse-json-array + (if (fboundp 'json-parse-string) + (lambda (string) + (json-parse-string string :array-type 'list)) + (require 'json) + (defvar json-array-type) + (declare-function json-read-from-string "json" (string)) + (lambda (string) + (let ((json-array-type 'list)) + (json-read-from-string string)))) + "Parse the JSON array in STRING into a Lisp list.") + (defun python-shell-prompt-detect () "Detect prompts for the current `python-shell-interpreter'. When prompts can be retrieved successfully from the @@ -2324,11 +2335,11 @@ detection and just returns nil." (catch 'prompts (dolist (line (split-string output "\n" t)) (let ((res - ;; Check if current line is a valid JSON array - (and (string= (substring line 0 2) "[\"") + ;; Check if current line is a valid JSON array. + (and (string-prefix-p "[\"" line) (ignore-errors - ;; Return prompts as a list, not vector - (append (json-read-from-string line) nil))))) + ;; Return prompts as a list. + (python--parse-json-array line))))) ;; The list must contain 3 strings, where the first ;; is the input prompt, the second is the block ;; prompt and the last one is the output prompt. The diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el index ac9706a8ae..a0e8c87c7b 100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@ -21,11 +21,16 @@ (require 'ert) (require 'json) +(require 'map) +(require 'seq) + +(eval-when-compile + (require 'cl-lib)) (defmacro json-tests--with-temp-buffer (content &rest body) "Create a temporary buffer with CONTENT and evaluate BODY there. Point is moved to beginning of the buffer." - (declare (indent 1)) + (declare (debug t) (indent 1)) `(with-temp-buffer (insert ,content) (goto-char (point-min)) @@ -33,66 +38,107 @@ Point is moved to beginning of the buffer." ;;; Utilities -(ert-deftest test-json-join () - (should (equal (json-join '() ", ") "")) - (should (equal (json-join '("a" "b" "c") ", ") "a, b, c"))) - (ert-deftest test-json-alist-p () (should (json-alist-p '())) - (should (json-alist-p '((a 1) (b 2) (c 3)))) - (should (json-alist-p '((:a 1) (:b 2) (:c 3)))) - (should (json-alist-p '(("a" 1) ("b" 2) ("c" 3)))) + (should (json-alist-p '((())))) + (should (json-alist-p '((a)))) + (should (json-alist-p '((a . 1)))) + (should (json-alist-p '((a . 1) (b 2) (c)))) + (should (json-alist-p '((:a) (:b 2) (:c . 3)))) + (should (json-alist-p '(("a" . 1) ("b" 2) ("c")))) + (should-not (json-alist-p '(()))) + (should-not (json-alist-p '(a))) + (should-not (json-alist-p '(a . 1))) + (should-not (json-alist-p '((a . 1) . []))) + (should-not (json-alist-p '((a . 1) []))) (should-not (json-alist-p '(:a :b :c))) (should-not (json-alist-p '(:a 1 :b 2 :c 3))) - (should-not (json-alist-p '((:a 1) (:b 2) 3)))) + (should-not (json-alist-p '((:a 1) (:b 2) 3))) + (should-not (json-alist-p '((:a 1) (:b 2) ()))) + (should-not (json-alist-p '(((a) 1) (b 2) (c 3)))) + (should-not (json-alist-p [])) + (should-not (json-alist-p [(a . 1)])) + (should-not (json-alist-p #s(hash-table)))) (ert-deftest test-json-plist-p () (should (json-plist-p '())) + (should (json-plist-p '(:a 1))) (should (json-plist-p '(:a 1 :b 2 :c 3))) + (should (json-plist-p '(:a :b))) + (should (json-plist-p '(:a :b :c :d))) + (should-not (json-plist-p '(a))) + (should-not (json-plist-p '(a 1))) (should-not (json-plist-p '(a 1 b 2 c 3))) (should-not (json-plist-p '("a" 1 "b" 2 "c" 3))) + (should-not (json-plist-p '(:a))) (should-not (json-plist-p '(:a :b :c))) - (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))) - -(ert-deftest test-json-plist-reverse () - (should (equal (json--plist-reverse '()) '())) - (should (equal (json--plist-reverse '(:a 1)) '(:a 1))) - (should (equal (json--plist-reverse '(:a 1 :b 2 :c 3)) + (should-not (json-plist-p '(:a 1 :b 2 :c))) + (should-not (json-plist-p '((:a 1)))) + (should-not (json-plist-p '((:a 1) (:b 2) (:c 3)))) + (should-not (json-plist-p [])) + (should-not (json-plist-p [:a 1])) + (should-not (json-plist-p #s(hash-table)))) + +(ert-deftest test-json-plist-nreverse () + (should (equal (json--plist-nreverse '()) '())) + (should (equal (json--plist-nreverse (list :a 1)) '(:a 1))) + (should (equal (json--plist-nreverse (list :a 1 :b 2)) '(:b 2 :a 1))) + (should (equal (json--plist-nreverse (list :a 1 :b 2 :c 3)) '(:c 3 :b 2 :a 1)))) -(ert-deftest test-json-plist-to-alist () - (should (equal (json--plist-to-alist '()) '())) - (should (equal (json--plist-to-alist '(:a 1)) '((:a . 1)))) - (should (equal (json--plist-to-alist '(:a 1 :b 2 :c 3)) - '((:a . 1) (:b . 2) (:c . 3))))) - (ert-deftest test-json-advance () (json-tests--with-temp-buffer "{ \"a\": 1 }" (json-advance 0) - (should (= (point) (point-min))) + (should (bobp)) + (json-advance) + (should (= (point) (1+ (point-min)))) + (json-advance 0) + (should (= (point) (1+ (point-min)))) + (json-advance 1) + (should (= (point) (+ (point-min) 2))) (json-advance 3) - (should (= (point) (+ (point-min) 3))))) + (should (= (point) (+ (point-min) 5))))) (ert-deftest test-json-peek () (json-tests--with-temp-buffer "" (should (zerop (json-peek)))) (json-tests--with-temp-buffer "{ \"a\": 1 }" - (should (equal (json-peek) ?{)))) + (should (= (json-peek) ?\{)) + (goto-char (1- (point-max))) + (should (= (json-peek) ?\})) + (json-advance) + (should (zerop (json-peek))))) (ert-deftest test-json-pop () (json-tests--with-temp-buffer "" (should-error (json-pop) :type 'json-end-of-file)) (json-tests--with-temp-buffer "{ \"a\": 1 }" - (should (equal (json-pop) ?{)) - (should (= (point) (+ (point-min) 1))))) + (should (= (json-pop) ?\{)) + (should (= (point) (1+ (point-min)))) + (goto-char (1- (point-max))) + (should (= (json-pop) ?\})) + (should-error (json-pop) :type 'json-end-of-file))) (ert-deftest test-json-skip-whitespace () + (json-tests--with-temp-buffer "" + (json-skip-whitespace) + (should (bobp)) + (should (eobp))) + (json-tests--with-temp-buffer "{}" + (json-skip-whitespace) + (should (bobp)) + (json-advance) + (json-skip-whitespace) + (should (= (point) (1+ (point-min)))) + (json-advance) + (json-skip-whitespace) + (should (eobp))) (json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }" (json-skip-whitespace) - (should (equal (char-after) ?\f))) + (should (= (json-peek) ?\f))) (json-tests--with-temp-buffer "\t\r\n\t { \"a\": 1 }" (json-skip-whitespace) - (should (equal (char-after) ?{)))) + (should (= (json-peek) ?\{)))) ;;; Paths @@ -113,59 +159,243 @@ Point is moved to beginning of the buffer." (ert-deftest test-json-path-to-position-no-match () (let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}") (matched-path (json-path-to-position 5 json-string))) - (should (null matched-path)))) + (should-not matched-path))) ;;; Keywords (ert-deftest test-json-read-keyword () (json-tests--with-temp-buffer "true" - (should (json-read-keyword "true"))) + (should (eq (json-read-keyword "true") t)) + (should (eobp))) + (json-tests--with-temp-buffer "true " + (should (eq (json-read-keyword "true") t)) + (should (eobp))) + (json-tests--with-temp-buffer "true}" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 4)))) + (json-tests--with-temp-buffer "true false" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "true }" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "true |" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "false" + (let ((json-false 'false)) + (should (eq (json-read-keyword "false") 'false))) + (should (eobp))) + (json-tests--with-temp-buffer "null" + (let ((json-null 'null)) + (should (eq (json-read-keyword "null") 'null))) + (should (eobp)))) + +(ert-deftest test-json-read-keyword-invalid () + (json-tests--with-temp-buffer "" + (should (equal (should-error (json-read-keyword "")) + '(json-unknown-keyword ""))) + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword ())))) (json-tests--with-temp-buffer "true" - (should-error - (json-read-keyword "false") :type 'json-unknown-keyword)) + (should (equal (should-error (json-read-keyword "false")) + '(json-unknown-keyword "true")))) (json-tests--with-temp-buffer "foo" - (should-error - (json-read-keyword "foo") :type 'json-unknown-keyword))) + (should (equal (should-error (json-read-keyword "foo")) + '(json-unknown-keyword "foo"))) + (should (equal (should-error (json-read-keyword "bar")) + '(json-unknown-keyword "bar")))) + (json-tests--with-temp-buffer " true" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword ())))) + (json-tests--with-temp-buffer "truefalse" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword "truefalse")))) + (json-tests--with-temp-buffer "true|" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword "true"))))) (ert-deftest test-json-encode-keyword () (should (equal (json-encode-keyword t) "true")) - (should (equal (json-encode-keyword json-false) "false")) - (should (equal (json-encode-keyword json-null) "null"))) + (let ((json-false 'false)) + (should (equal (json-encode-keyword 'false) "false")) + (should (equal (json-encode-keyword json-false) "false"))) + (let ((json-null 'null)) + (should (equal (json-encode-keyword 'null) "null")) + (should (equal (json-encode-keyword json-null) "null")))) ;;; Numbers -(ert-deftest test-json-read-number () - (json-tests--with-temp-buffer "3" - (should (= (json-read-number) 3))) - (json-tests--with-temp-buffer "-5" - (should (= (json-read-number) -5))) - (json-tests--with-temp-buffer "123.456" - (should (= (json-read-number) 123.456))) - (json-tests--with-temp-buffer "1e3" - (should (= (json-read-number) 1e3))) - (json-tests--with-temp-buffer "2e+3" - (should (= (json-read-number) 2e3))) - (json-tests--with-temp-buffer "3E3" - (should (= (json-read-number) 3e3))) - (json-tests--with-temp-buffer "1e-7" - (should (= (json-read-number) 1e-7))) - (json-tests--with-temp-buffer "abc" - (should-error (json-read-number) :type 'json-number-format))) +(ert-deftest test-json-read-integer () + (json-tests--with-temp-buffer "0 " + (should (= (json-read-number) 0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0 " + (should (= (json-read-number) 0)) + (should (eobp))) + (json-tests--with-temp-buffer "3 " + (should (= (json-read-number) 3)) + (should (eobp))) + (json-tests--with-temp-buffer "-10 " + (should (= (json-read-number) -10)) + (should (eobp))) + (json-tests--with-temp-buffer (format "%d " (1+ most-positive-fixnum)) + (should (= (json-read-number) (1+ most-positive-fixnum))) + (should (eobp))) + (json-tests--with-temp-buffer (format "%d " (1- most-negative-fixnum)) + (should (= (json-read-number) (1- most-negative-fixnum))) + (should (eobp)))) + +(ert-deftest test-json-read-fraction () + (json-tests--with-temp-buffer "0.0 " + (should (= (json-read-number) 0.0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.0 " + (should (= (json-read-number) 0.0)) + (should (eobp))) + (json-tests--with-temp-buffer "0.01 " + (should (= (json-read-number) 0.01)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.01 " + (should (= (json-read-number) -0.01)) + (should (eobp))) + (json-tests--with-temp-buffer "123.456 " + (should (= (json-read-number) 123.456)) + (should (eobp))) + (json-tests--with-temp-buffer "-123.456 " + (should (= (json-read-number) -123.456)) + (should (eobp)))) + +(ert-deftest test-json-read-exponent () + (json-tests--with-temp-buffer "0e0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0E0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0E+0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "0e-0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "12e34 " + (should (= (json-read-number) 12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "-12E34 " + (should (= (json-read-number) -12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "-12E+34 " + (should (= (json-read-number) -12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "12e-34 " + (should (= (json-read-number) 12e-34)) + (should (eobp)))) + +(ert-deftest test-json-read-fraction-exponent () + (json-tests--with-temp-buffer "0.0e0 " + (should (= (json-read-number) 0.0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.0E0 " + (should (= (json-read-number) 0.0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "0.12E-0 " + (should (= (json-read-number) 0.12e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-12.34e+56 " + (should (= (json-read-number) -12.34e+56)) + (should (eobp)))) + +(ert-deftest test-json-read-number-invalid () + (cl-flet ((read (str) + ;; Return error and point resulting from reading STR. + (json-tests--with-temp-buffer str + (cons (should-error (json-read-number)) (point))))) + ;; POS is where each of its STRINGS becomes invalid. + (pcase-dolist (`(,pos . ,strings) + '((1 "" "+" "-" "." "e" "e1" "abc" "++0" "++1" + "+0" "+0.0" "+12" "+12.34" "+12.34e56" + ".0" "+.0" "-.0" ".12" "+.12" "-.12" + ".e0" "+.e0" "-.e0" ".0e0" "+.0e0" "-.0e0") + (2 "01" "1ee1" "1e++1") + (3 "-01") + (4 "0.0.0" "1.1.1" "1e1e1") + (5 "-0.0.0" "-1.1.1"))) + ;; Expected error and point. + (let ((res `((json-number-format ,pos) . ,pos))) + (dolist (str strings) + (should (equal (read str) res))))))) (ert-deftest test-json-encode-number () + (should (equal (json-encode-number 0) "0")) + (should (equal (json-encode-number -0) "0")) (should (equal (json-encode-number 3) "3")) (should (equal (json-encode-number -5) "-5")) - (should (equal (json-encode-number 123.456) "123.456"))) + (should (equal (json-encode-number 123.456) "123.456")) + (let ((bignum (1+ most-positive-fixnum))) + (should (equal (json-encode-number bignum) + (number-to-string bignum))))) -;; Strings +;;; Strings (ert-deftest test-json-read-escaped-char () (json-tests--with-temp-buffer "\\\"" - (should (equal (json-read-escaped-char) ?\")))) + (should (= (json-read-escaped-char) ?\")) + (should (eobp))) + (json-tests--with-temp-buffer "\\\\ " + (should (= (json-read-escaped-char) ?\\)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\b " + (should (= (json-read-escaped-char) ?\b)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\f " + (should (= (json-read-escaped-char) ?\f)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\n " + (should (= (json-read-escaped-char) ?\n)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\r " + (should (= (json-read-escaped-char) ?\r)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\t " + (should (= (json-read-escaped-char) ?\t)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\x " + (should (= (json-read-escaped-char) ?x)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\ud800\\uDC00 " + (should (= (json-read-escaped-char) #x10000)) + (should (= (point) (+ (point-min) 12)))) + (json-tests--with-temp-buffer "\\ud7ff\\udc00 " + (should (= (json-read-escaped-char) #xd7ff)) + (should (= (point) (+ (point-min) 6)))) + (json-tests--with-temp-buffer "\\uffff " + (should (= (json-read-escaped-char) #xffff)) + (should (= (point) (+ (point-min) 6)))) + (json-tests--with-temp-buffer "\\ufffff " + (should (= (json-read-escaped-char) #xffff)) + (should (= (point) (+ (point-min) 6))))) + +(ert-deftest test-json-read-escaped-char-invalid () + (json-tests--with-temp-buffer "" + (should-error (json-read-escaped-char))) + (json-tests--with-temp-buffer "\\" + (should-error (json-read-escaped-char) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "\\ufff " + (should (equal (should-error (json-read-escaped-char)) + (list 'json-string-escape (+ (point-min) 2))))) + (json-tests--with-temp-buffer "\\ufffg " + (should (equal (should-error (json-read-escaped-char)) + (list 'json-string-escape (+ (point-min) 2)))))) (ert-deftest test-json-read-string () + (json-tests--with-temp-buffer "" + (should-error (json-read-string))) (json-tests--with-temp-buffer "\"formfeed\f\"" - (should-error (json-read-string) :type 'json-string-format)) + (should (equal (should-error (json-read-string)) + '(json-string-format ?\f)))) + (json-tests--with-temp-buffer "\"\"" + (should (equal (json-read-string) ""))) (json-tests--with-temp-buffer "\"foo \\\"bar\\\"\"" (should (equal (json-read-string) "foo \"bar\""))) (json-tests--with-temp-buffer "\"abcαβγ\"" @@ -175,57 +405,117 @@ Point is moved to beginning of the buffer." ;; Bug#24784 (json-tests--with-temp-buffer "\"\\uD834\\uDD1E\"" (should (equal (json-read-string) "\U0001D11E"))) + (json-tests--with-temp-buffer "f" + (should-error (json-read-string) :type 'json-end-of-file)) (json-tests--with-temp-buffer "foo" - (should-error (json-read-string) :type 'json-string-format))) + (should-error (json-read-string) :type 'json-end-of-file))) (ert-deftest test-json-encode-string () + (should (equal (json-encode-string "") "\"\"")) + (should (equal (json-encode-string "a") "\"a\"")) (should (equal (json-encode-string "foo") "\"foo\"")) (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\"")) (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t") "\"\\nasdфыв\\u001f\u007ffgh\\t\""))) (ert-deftest test-json-encode-key () + (should (equal (json-encode-key "") "\"\"")) + (should (equal (json-encode-key '##) "\"\"")) + (should (equal (json-encode-key :) "\"\"")) (should (equal (json-encode-key "foo") "\"foo\"")) (should (equal (json-encode-key 'foo) "\"foo\"")) (should (equal (json-encode-key :foo) "\"foo\"")) - (should-error (json-encode-key 5) :type 'json-key-format) - (should-error (json-encode-key ["foo"]) :type 'json-key-format) - (should-error (json-encode-key '("foo")) :type 'json-key-format)) + (should (equal (should-error (json-encode-key 5)) + '(json-key-format 5))) + (should (equal (should-error (json-encode-key ["foo"])) + '(json-key-format ["foo"]))) + (should (equal (should-error (json-encode-key '("foo"))) + '(json-key-format ("foo"))))) ;;; Objects (ert-deftest test-json-new-object () (let ((json-object-type 'alist)) - (should (equal (json-new-object) '()))) + (should-not (json-new-object))) (let ((json-object-type 'plist)) - (should (equal (json-new-object) '()))) + (should-not (json-new-object))) (let* ((json-object-type 'hash-table) (json-object (json-new-object))) (should (hash-table-p json-object)) - (should (= (hash-table-count json-object) 0)))) + (should (map-empty-p json-object)) + (should (eq (hash-table-test json-object) #'equal)))) -(ert-deftest test-json-add-to-object () +(ert-deftest test-json-add-to-alist () (let* ((json-object-type 'alist) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (equal (assq 'a obj) '(a . 1))) - (should (equal (assq 'b obj) '(b . 2)))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (equal (assq 'a obj) '(a . 1))) + (should (equal (assq 'b obj) '(b . 2)))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (equal (assq 'c obj) '(c . 3))) + (should (equal (assq 'd obj) '(d . 4)))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (equal (assq :e obj) '(:e . 5))) + (should (equal (assq :f obj) '(:f . 6)))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (equal (assoc "g" obj) '("g" . 7))) + (should (equal (assoc "h" obj) '("h" . 8)))))) + +(ert-deftest test-json-add-to-plist () (let* ((json-object-type 'plist) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (= (plist-get obj :a) 1)) - (should (= (plist-get obj :b) 2))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (plist-get obj :a) 1)) + (should (= (plist-get obj :b) 2))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (= (plist-get obj :c) 3)) + (should (= (plist-get obj :d) 4))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (= (plist-get obj 'e) 5)) + (should (= (plist-get obj 'f) 6))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (= (lax-plist-get obj "g") 7)) + (should (= (lax-plist-get obj "h") 8))))) + +(ert-deftest test-json-add-to-hash-table () (let* ((json-object-type 'hash-table) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (= (gethash "a" obj) 1)) - (should (= (gethash "b" obj) 2)))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (gethash "a" obj) 1)) + (should (= (gethash "b" obj) 2))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (= (gethash "c" obj) 3)) + (should (= (gethash "d" obj) 4))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (= (gethash 'e obj) 5)) + (should (= (gethash 'f obj) 6))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (= (gethash :g obj) 7)) + (should (= (gethash :h obj) 8))))) (ert-deftest test-json-read-object () (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" @@ -238,94 +528,384 @@ Point is moved to beginning of the buffer." (let* ((json-object-type 'hash-table) (hash-table (json-read-object))) (should (= (gethash "a" hash-table) 1)) - (should (= (gethash "b" hash-table) 2)))) + (should (= (gethash "b" hash-table) 2))))) + +(ert-deftest test-json-read-object-empty () + (json-tests--with-temp-buffer "{}" + (let ((json-object-type 'alist)) + (should-not (save-excursion (json-read-object)))) + (let ((json-object-type 'plist)) + (should-not (save-excursion (json-read-object)))) + (let* ((json-object-type 'hash-table) + (hash-table (json-read-object))) + (should (hash-table-p hash-table)) + (should (map-empty-p hash-table))))) + +(ert-deftest test-json-read-object-invalid () + (json-tests--with-temp-buffer "{ \"a\" 1, \"b\": 2 }" + (should (equal (should-error (json-read-object)) + '(json-object-format ":" ?1)))) (json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }" - (should-error (json-read-object) :type 'json-object-format))) + (should (equal (should-error (json-read-object)) + '(json-object-format "," ?\"))))) + +(ert-deftest test-json-read-object-function () + (let* ((pre nil) + (post nil) + (keys '("b" "a")) + (json-pre-element-read-function + (lambda (key) + (setq pre 'pre) + (should (equal key (pop keys))))) + (json-post-element-read-function + (lambda () (setq post 'post)))) + (json-tests--with-temp-buffer "{ \"b\": 2, \"a\": 1 }" + (json-read-object) + (should (eq pre 'pre)) + (should (eq post 'post))))) (ert-deftest test-json-encode-hash-table () - (let ((hash-table (make-hash-table)) - (json-encoding-object-sort-predicate 'string<) + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (puthash :a 1 hash-table) - (puthash :b 2 hash-table) - (puthash :c 3 hash-table) - (should (equal (json-encode hash-table) - "{\"a\":1,\"b\":2,\"c\":3}")))) - -(ert-deftest json-encode-simple-alist () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode '((a . 1) (b . 2))) - "{\"a\":1,\"b\":2}")))) - -(ert-deftest test-json-encode-plist () - (let ((plist '(:a 1 :b 2)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\"a\":1}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\"a\":1,\"b\":2}" "{\"b\":2,\"a\":1}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\"a\":1,\"b\":2,\"c\":3}" + "{\"a\":1,\"c\":3,\"b\":2}" + "{\"b\":2,\"a\":1,\"c\":3}" + "{\"b\":2,\"c\":3,\"a\":1}" + "{\"c\":3,\"a\":1,\"b\":2}" + "{\"c\":3,\"b\":2,\"a\":1}"))))) + +(ert-deftest test-json-encode-hash-table-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\n \"a\": 1\n}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2\n}" + "{\n \"b\": 2,\n \"a\": 1\n}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3\n}" + "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2\n}" + "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3\n}" + "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1\n}" + "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2\n}" + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}"))))) + +(ert-deftest test-json-encode-hash-table-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\n \"a\": 1}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2}" + "{\n \"b\": 2,\n \"a\": 1}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3}" + "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2}" + "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3}" + "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1}" + "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2}" + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}"))))) + +(ert-deftest test-json-encode-hash-table-sort () + (let ((json-encoding-object-sort-predicate #'string<) (json-encoding-pretty-print nil)) - (should (equal (json-encode plist) "{\"a\":1,\"b\":2}")))) - -(ert-deftest test-json-encode-plist-with-sort-predicate () - (let ((plist '(:c 3 :a 1 :b 2)) - (json-encoding-object-sort-predicate 'string<) + (pcase-dolist (`(,in . ,out) + '((#s(hash-table) . "{}") + (#s(hash-table data (a 1)) . "{\"a\":1}") + (#s(hash-table data (b 2 a 1)) . "{\"a\":1,\"b\":2}") + (#s(hash-table data (c 3 b 2 a 1)) + . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (map-pairs in))) + (should (equal (json-encode-hash-table in) out)) + ;; Ensure sorting isn't destructive. + (should (seq-set-equal-p (map-pairs in) copy)))))) + +(ert-deftest test-json-encode-alist () + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}")))) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\"a\":1}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\"c\":3,\"b\":2,\"a\":1}")))) + +(ert-deftest test-json-encode-alist-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1\n}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) + "{\n \"b\": 2,\n \"a\": 1\n}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}")))) + +(ert-deftest test-json-encode-alist-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) + "{\n \"b\": 2,\n \"a\": 1}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}")))) + +(ert-deftest test-json-encode-alist-sort () + (let ((json-encoding-object-sort-predicate #'string<) + (json-encoding-pretty-print nil)) + (pcase-dolist (`(,in . ,out) + '((() . "{}") + (((a . 1)) . "{\"a\":1}") + (((b . 2) (a . 1)) . "{\"a\":1,\"b\":2}") + (((c . 3) (b . 2) (a . 1)) + . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (copy-alist in))) + (should (equal (json-encode-alist in) out)) + ;; Ensure sorting isn't destructive (bug#40693). + (should (equal in copy)))))) -(ert-deftest test-json-encode-alist-with-sort-predicate () - (let ((alist '((:c . 3) (:a . 1) (:b . 2))) - (json-encoding-object-sort-predicate 'string<) +(ert-deftest test-json-encode-plist () + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}")))) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\"a\":1}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\"c\":3,\"b\":2,\"a\":1}")))) + +(ert-deftest test-json-encode-plist-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1\n}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) + "{\n \"b\": 2,\n \"a\": 1\n}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}")))) + +(ert-deftest test-json-encode-plist-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) + "{\n \"b\": 2,\n \"a\": 1}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}")))) + +(ert-deftest test-json-encode-plist-sort () + (let ((json-encoding-object-sort-predicate #'string<) + (json-encoding-pretty-print nil)) + (pcase-dolist (`(,in . ,out) + '((() . "{}") + ((:a 1) . "{\"a\":1}") + ((:b 2 :a 1) . "{\"a\":1,\"b\":2}") + ((:c 3 :b 2 :a 1) . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (copy-sequence in))) + (should (equal (json-encode-plist in) out)) + ;; Ensure sorting isn't destructive. + (should (equal in copy)))))) (ert-deftest test-json-encode-list () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode-list '(:a 1 :b 2)) - "{\"a\":1,\"b\":2}")) - (should (equal (json-encode-list '((:a . 1) (:b . 2))) - "{\"a\":1,\"b\":2}")) - (should (equal (json-encode-list '(1 2 3 4)) "[1,2,3,4]")))) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode-list ()) "{}")) + (should (equal (json-encode-list '(a)) "[\"a\"]")) + (should (equal (json-encode-list '(:a)) "[\"a\"]")) + (should (equal (json-encode-list '("a")) "[\"a\"]")) + (should (equal (json-encode-list '(a 1)) "[\"a\",1]")) + (should (equal (json-encode-list '("a" 1)) "[\"a\",1]")) + (should (equal (json-encode-list '(:a 1)) "{\"a\":1}")) + (should (equal (json-encode-list '((a . 1))) "{\"a\":1}")) + (should (equal (json-encode-list '((:a . 1))) "{\"a\":1}")) + (should (equal (json-encode-list '(:b 2 :a)) "[\"b\",2,\"a\"]")) + (should (equal (json-encode-list '(4 3 2 1)) "[4,3,2,1]")) + (should (equal (json-encode-list '(b 2 a 1)) "[\"b\",2,\"a\",1]")) + (should (equal (json-encode-list '(:b 2 :a 1)) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((:b . 2) (:a . 1))) + "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((a) 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '((:a) 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '(("a") 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '((a 1) 2)) "[[\"a\",1],2]")) + (should (equal (json-encode-list '((:a 1) 2)) "[{\"a\":1},2]")) + (should (equal (json-encode-list '(((a . 1)) 2)) "[{\"a\":1},2]")) + (should (equal (json-encode-list '(:a 1 :b (2))) "{\"a\":1,\"b\":[2]}")) + (should (equal (json-encode-list '((a . 1) (b 2))) "{\"a\":1,\"b\":[2]}")) + (should-error (json-encode-list '(a . 1)) :type 'wrong-type-argument) + (should-error (json-encode-list '((a . 1) 2)) :type 'wrong-type-argument) + (should (equal (should-error (json-encode-list [])) + '(json-error []))) + (should (equal (should-error (json-encode-list [a])) + '(json-error [a]))))) ;;; Arrays (ert-deftest test-json-read-array () (let ((json-array-type 'vector)) + (json-tests--with-temp-buffer "[]" + (should (equal (json-read-array) []))) + (json-tests--with-temp-buffer "[ ]" + (should (equal (json-read-array) []))) + (json-tests--with-temp-buffer "[1]" + (should (equal (json-read-array) [1]))) (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" (should (equal (json-read-array) [1 2 "a" "b"])))) (let ((json-array-type 'list)) + (json-tests--with-temp-buffer "[]" + (should-not (json-read-array))) + (json-tests--with-temp-buffer "[ ]" + (should-not (json-read-array))) + (json-tests--with-temp-buffer "[1]" + (should (equal (json-read-array) '(1)))) (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" (should (equal (json-read-array) '(1 2 "a" "b"))))) (json-tests--with-temp-buffer "[1 2]" - (should-error (json-read-array) :type 'json-error))) + (should (equal (should-error (json-read-array)) + '(json-array-format "," ?2))))) + +(ert-deftest test-json-read-array-function () + (let* ((pre nil) + (post nil) + (keys '(0 1)) + (json-pre-element-read-function + (lambda (key) + (setq pre 'pre) + (should (equal key (pop keys))))) + (json-post-element-read-function + (lambda () (setq post 'post)))) + (json-tests--with-temp-buffer "[1, 0]" + (json-read-array) + (should (eq pre 'pre)) + (should (eq post 'post))))) (ert-deftest test-json-encode-array () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode-array [1 2 "a" "b"]) - "[1,2,\"a\",\"b\"]")))) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[1]")) + (should (equal (json-encode-array '[1]) "[1]")) + (should (equal (json-encode-array '(2 1)) "[2,1]")) + (should (equal (json-encode-array '[2 1]) "[2,1]")) + (should (equal (json-encode-array '[:b a 2 1]) "[\"b\",\"a\",2,1]")))) + +(ert-deftest test-json-encode-array-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[\n 1\n]")) + (should (equal (json-encode-array '[1]) "[\n 1\n]")) + (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1\n]")) + (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1\n]")) + (should (equal (json-encode-array '[:b a 2 1]) + "[\n \"b\",\n \"a\",\n 2,\n 1\n]")))) + +(ert-deftest test-json-encode-array-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[\n 1]")) + (should (equal (json-encode-array '[1]) "[\n 1]")) + (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1]")) + (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1]")) + (should (equal (json-encode-array '[:b a 2 1]) + "[\n \"b\",\n \"a\",\n 2,\n 1]")))) ;;; Reader (ert-deftest test-json-read () - (json-tests--with-temp-buffer "{ \"a\": 1 }" - ;; We don't care exactly what the return value is (that is tested - ;; in `test-json-read-object'), but it should parse without error. - (should (json-read))) + (pcase-dolist (`(,fn . ,contents) + '((json-read-string "\"\"" "\"a\"") + (json-read-array "[]" "[1]") + (json-read-object "{}" "{\"a\":1}") + (json-read-keyword "null" "false" "true") + (json-read-number + "-0" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))) + (dolist (content contents) + ;; Check that leading whitespace is skipped. + (dolist (str (list content (concat " " content))) + (cl-letf* ((called nil) + ((symbol-function fn) + (lambda (&rest _) (setq called t)))) + (json-tests--with-temp-buffer str + ;; We don't care exactly what the return value is (that is + ;; tested elsewhere), but it should parse without error. + (should (json-read)) + (should called))))))) + +(ert-deftest test-json-read-invalid () (json-tests--with-temp-buffer "" (should-error (json-read) :type 'json-end-of-file)) - (json-tests--with-temp-buffer "xxx" - (let ((err (should-error (json-read) :type 'json-readtable-error))) - (should (equal (cdr err) '(?x)))))) + (json-tests--with-temp-buffer " " + (should-error (json-read) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "x" + (should (equal (should-error (json-read)) + '(json-readtable-error ?x)))) + (json-tests--with-temp-buffer " x" + (should (equal (should-error (json-read)) + '(json-readtable-error ?x))))) (ert-deftest test-json-read-from-string () - (let ((json-string "{ \"a\": 1 }")) - (json-tests--with-temp-buffer json-string - (should (equal (json-read-from-string json-string) + (dolist (str '("\"\"" "\"a\"" "[]" "[1]" "{}" "{\"a\":1}" + "null" "false" "true" "0" "123")) + (json-tests--with-temp-buffer str + (should (equal (json-read-from-string str) (json-read)))))) -;;; JSON encoder +;;; Encoder (ert-deftest test-json-encode () + (should (equal (json-encode t) "true")) + (let ((json-null 'null)) + (should (equal (json-encode json-null) "null"))) + (let ((json-false 'false)) + (should (equal (json-encode json-false) "false"))) + (should (equal (json-encode "") "\"\"")) (should (equal (json-encode "foo") "\"foo\"")) + (should (equal (json-encode :) "\"\"")) + (should (equal (json-encode :foo) "\"foo\"")) + (should (equal (json-encode '(1)) "[1]")) + (should (equal (json-encode 'foo) "\"foo\"")) + (should (equal (json-encode 0) "0")) + (should (equal (json-encode 123) "123")) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode []) "[]")) + (should (equal (json-encode [1]) "[1]")) + (should (equal (json-encode #s(hash-table)) "{}")) + (should (equal (json-encode #s(hash-table data (a 1))) "{\"a\":1}"))) (with-temp-buffer - (should-error (json-encode (current-buffer)) :type 'json-error))) + (should (equal (should-error (json-encode (current-buffer))) + (list 'json-error (current-buffer)))))) -;;; Pretty-print +;;; Pretty printing & minimizing (defun json-tests-equal-pretty-print (original &optional expected) "Abort current test if pretty-printing ORIGINAL does not yield EXPECTED. @@ -351,46 +931,45 @@ nil, ORIGINAL should stay unchanged by pretty-printing." (json-tests-equal-pretty-print "0.123")) (ert-deftest test-json-pretty-print-object () - ;; empty (regression test for bug#24252) - (json-tests-equal-pretty-print - "{}" - "{\n}") - ;; one pair + ;; Empty (regression test for bug#24252). + (json-tests-equal-pretty-print "{}") + ;; One pair. (json-tests-equal-pretty-print "{\"key\":1}" "{\n \"key\": 1\n}") - ;; two pairs + ;; Two pairs. (json-tests-equal-pretty-print "{\"key1\":1,\"key2\":2}" "{\n \"key1\": 1,\n \"key2\": 2\n}") - ;; embedded object + ;; Nested object. (json-tests-equal-pretty-print "{\"foo\":{\"key\":1}}" "{\n \"foo\": {\n \"key\": 1\n }\n}") - ;; embedded array + ;; Nested array. (json-tests-equal-pretty-print "{\"key\":[1,2]}" "{\n \"key\": [\n 1,\n 2\n ]\n}")) (ert-deftest test-json-pretty-print-array () - ;; empty + ;; Empty. (json-tests-equal-pretty-print "[]") - ;; one item + ;; One item. (json-tests-equal-pretty-print "[1]" "[\n 1\n]") - ;; two items + ;; Two items. (json-tests-equal-pretty-print "[1,2]" "[\n 1,\n 2\n]") - ;; embedded object + ;; Nested object. (json-tests-equal-pretty-print "[{\"key\":1}]" "[\n {\n \"key\": 1\n }\n]") - ;; embedded array + ;; Nested array. (json-tests-equal-pretty-print "[[1,2]]" "[\n [\n 1,\n 2\n ]\n]")) (provide 'json-tests) + ;;; json-tests.el ends here