From 6ac2326e5bc4796087910eb429e0cb4384e0e0cf Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 16 May 2020 17:17:00 -0700 Subject: [PATCH 01/55] =?UTF-8?q?Don=E2=80=99t=20use=20=E2=80=9Cconstant?= =?UTF-8?q?=E2=80=9D=20for=20values=20you=20shouldn=E2=80=99t=20change?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Inspired by patch proposed by Dmitry Gutov (Bug#40671#393) and by further comments by him and by Michael Heerdegen in the same bug report. * doc/lispintro/emacs-lisp-intro.texi (setcar): Don’t push mutability here. * doc/lispref/eval.texi (Self-Evaluating Forms, Quoting) (Backquote): * doc/lispref/lists.texi (Modifying Lists): * doc/lispref/objects.texi (Lisp Data Types, Mutability): * doc/lispref/sequences.texi (Array Functions, Vectors): * doc/lispref/strings.texi (String Basics, Modifying Strings): Don’t use the word “constant” to describe all values that a program should not change. * doc/lispref/objects.texi (Mutability): Rename from “Constants and Mutability”. All uses changed. In a footnote, contrast the Emacs behavior with that of Common Lisp, Python, etc. for clarity, and say the goal is to be nicer. --- doc/lispintro/emacs-lisp-intro.texi | 5 +- doc/lispref/elisp.texi | 2 +- doc/lispref/eval.texi | 21 +++---- doc/lispref/lists.texi | 16 +++--- doc/lispref/objects.texi | 88 +++++++++++++++-------------- doc/lispref/sequences.texi | 25 ++++---- doc/lispref/strings.texi | 11 ++-- 7 files changed, 82 insertions(+), 86 deletions(-) diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index ea16d9ef155..46462162ca0 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -7317,8 +7317,6 @@ which leave the original list as it was. One way to find out how this works is to experiment. We will start with the @code{setcar} function. @need 1200 -@cindex constant lists -@cindex mutable lists First, we can make a list and then set the value of a variable to the list, using the @code{setq} special form. Because we intend to use @code{setcar} to change the list, this @code{setq} should not use the @@ -7327,8 +7325,7 @@ a list that is part of the program and bad things could happen if we tried to change part of the program while running it. Generally speaking an Emacs Lisp program's components should be constant (or unchanged) while the program is running. So we instead construct an -animal list that is @dfn{mutable} (or changeable) by using the -@code{list} function, as follows: +animal list by using the @code{list} function, as follows: @smallexample (setq animals (list 'antelope 'giraffe 'lion 'tiger)) diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index bba1b63115f..9a6796790c4 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -297,7 +297,7 @@ Lisp Data Types * Circular Objects:: Read syntax for circular structure. * Type Predicates:: Tests related to types. * Equality Predicates:: Tests of equality between any two objects. -* Constants and Mutability:: Whether an object's value can change. +* Mutability:: Some objects should not be modified. Programming Types diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi index baddce4d9c9..39f342a798b 100644 --- a/doc/lispref/eval.texi +++ b/doc/lispref/eval.texi @@ -158,11 +158,11 @@ contents unchanged. @end group @end example - A self-evaluating form yields constant conses, vectors and strings, and you -should not attempt to modify their contents via @code{setcar}, @code{aset} or + A self-evaluating form yields a value that becomes part of the program, +and you should not try to modify it via @code{setcar}, @code{aset} or similar operations. The Lisp interpreter might unify the constants yielded by your program's self-evaluating forms, so that these -constants might share structure. @xref{Constants and Mutability}. +constants might share structure. @xref{Mutability}. It is common to write numbers, characters, strings, and even vectors in Lisp code, taking advantage of the fact that they self-evaluate. @@ -564,8 +564,8 @@ and vectors.) @defspec quote object This special form returns @var{object}, without evaluating it. -The returned value is a constant, and should not be modified. -@xref{Constants and Mutability}. +The returned value might be shared and should not be modified. +@xref{Self-Evaluating Forms}. @end defspec @cindex @samp{'} for quoting @@ -608,9 +608,9 @@ Here are some examples of expressions that use @code{quote}: Although the expressions @code{(list '+ 1 2)} and @code{'(+ 1 2)} both yield lists equal to @code{(+ 1 2)}, the former yields a -freshly-minted mutable list whereas the latter yields a constant list -built from conses that may be shared with other constants. -@xref{Constants and Mutability}. +freshly-minted mutable list whereas the latter yields a list +built from conses that might be shared and should not be modified. +@xref{Self-Evaluating Forms}. Other quoting constructs include @code{function} (@pxref{Anonymous Functions}), which causes an anonymous lambda expression written in Lisp @@ -710,8 +710,9 @@ Here are some examples: @end example If a subexpression of a backquote construct has no substitutions or -splices, it acts like @code{quote} in that it yields constant conses, -vectors and strings that should not be modified. +splices, it acts like @code{quote} in that it yields conses, +vectors and strings that might be shared and should not be modified. +@xref{Self-Evaluating Forms}. @node Eval @section Eval diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index fcaf4386b15..ae793d5e15e 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -873,8 +873,8 @@ primitives @code{setcar} and @code{setcdr}. These are destructive operations because they change existing list structure. Destructive operations should be applied only to mutable lists, that is, lists constructed via @code{cons}, @code{list} or similar -operations. Lists created by quoting are constants and should not be -changed by destructive operations. @xref{Constants and Mutability}. +operations. Lists created by quoting are part of the program and +should not be changed by destructive operations. @xref{Mutability}. @cindex CL note---@code{rplaca} vs @code{setcar} @quotation @@ -911,7 +911,7 @@ value @var{object}. For example: @example @group -(setq x (list 1 2)) ; @r{Create a mutable list.} +(setq x (list 1 2)) @result{} (1 2) @end group @group @@ -931,7 +931,7 @@ these lists. Here is an example: @example @group -;; @r{Create two mutable lists that are partly shared.} +;; @r{Create two lists that are partly shared.} (setq x1 (list 'a 'b 'c)) @result{} (a b c) (setq x2 (cons 'z (cdr x1))) @@ -1022,11 +1022,11 @@ reached via the @sc{cdr}. @example @group -(setq x (list 1 2 3)) ; @r{Create a mutable list.} +(setq x (list 1 2 3)) @result{} (1 2 3) @end group @group -(setcdr x '(4)) ; @r{Modify the list's tail to be a constant list.} +(setcdr x '(4)) @result{} (4) @end group @group @@ -1135,11 +1135,11 @@ Unlike @code{append} (@pxref{Building Lists}), the @var{lists} are @example @group -(setq x (list 1 2 3)) ; @r{Create a mutable list.} +(setq x (list 1 2 3)) @result{} (1 2 3) @end group @group -(nconc x '(4 5)) ; @r{Modify the list's tail to be a constant list.} +(nconc x '(4 5)) @result{} (1 2 3 4 5) @end group @group diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 1d5b2c690fe..136213ad661 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -46,10 +46,6 @@ you store in it, type and all. (Actually, a small number of Emacs Lisp variables can only take on values of a certain type. @xref{Variables with Restricted Values}.) - Some Lisp objects are @dfn{constant}: their values should never change. -Others are @dfn{mutable}: their values can be changed via destructive -operations that involve side effects. - This chapter describes the purpose, printed representation, and read syntax of each of the standard types in GNU Emacs Lisp. Details on how to use these types can be found in later chapters. @@ -63,7 +59,7 @@ to use these types can be found in later chapters. * Circular Objects:: Read syntax for circular structure. * Type Predicates:: Tests related to types. * Equality Predicates:: Tests of equality between any two objects. -* Constants and Mutability:: Whether an object's value can change. +* Mutability:: Some objects should not be modified. @end menu @node Printed Representation @@ -2379,51 +2375,59 @@ that for two strings to be equal, they have the same text properties. @end example @end defun -@node Constants and Mutability -@section Constants and Mutability -@cindex constants +@node Mutability +@section Mutability @cindex mutable objects - Some Lisp objects are constant: their values should never change -during a single execution of Emacs running well-behaved Lisp code. -For example, you can create a new integer by calculating one, but you -cannot modify the value of an existing integer. + Some Lisp objects should never change. For example, the Lisp +expression @code{"aaa"} yields a string, but you should not change +its contents. Indeed, some objects cannot be changed; for example, +although you can create a new number by calculating one, Lisp provides +no operation to change the value of an existing number. - Other Lisp objects are mutable: it is safe to change their values -via destructive operations involving side effects. For example, an -existing marker can be changed by moving the marker to point to -somewhere else. + Other Lisp objects are @dfn{mutable}: it is safe to change their +values via destructive operations involving side effects. For +example, an existing marker can be changed by moving the marker to +point to somewhere else. - Although all numbers are constants and all markers are -mutable, some types contain both constant and mutable members. These -types include conses, vectors, strings, and symbols. For example, the string -literal @code{"aaa"} yields a constant string, whereas the function -call @code{(make-string 3 ?a)} yields a mutable string that can be -changed via later calls to @code{aset}. + Although numbers never change and all markers are mutable, +some types have members some of which are mutable and others not. These +types include conses, vectors, and strings. For example, +although @code{"aaa"} yields a string that should not be changed, +@code{(make-string 3 ?a)} yields a mutable string that can be +changed via later calls to @code{aset}. Another example: +@code{(symbol-name 'cons)} yields a string @code{"cons"} that should +not be changed. - A mutable object can become constant if it is part of an expression -that is evaluated. The reverse does not occur: constant objects -should stay constant. + A mutable object stops being mutable if it is part of an expression +that is evaluated. For example: - Trying to modify a constant variable signals an error -(@pxref{Constant Variables}). -A program should not attempt to modify other types of constants because the -resulting behavior is undefined: the Lisp interpreter might or might -not detect the error, and if it does not detect the error the -interpreter can behave unpredictably thereafter. Another way to put -this is that although mutable objects are safe to change and constant -variables reliably prevent attempts to change them, other constants -are not safely mutable: if a misbehaving program tries to change such a -constant then the constant's value might actually change, or the -program might crash or worse. This problem occurs -with types that have both constant and mutable members, and that have -mutators like @code{setcar} and @code{aset} that are valid on mutable -objects but hazardous on constants. +@example +(let* ((x (list 0.5)) + (y (eval (list 'quote x)))) + (setcar x 1.5) ;; The program should not do this. + y) +@end example - When the same constant occurs multiple times in a program, the Lisp +@noindent +Although the list @code{(0.5)} was mutable when it was created, it should not +have been changed via @code{setcar} because it given to @code{eval}. The +reverse does not occur: an object that should not be changed never +becomes mutable afterwards. + + If a program attempts to change objects that should not be +changed, the resulting behavior is undefined: the Lisp interpreter +might signal an error, or it might crash or behave unpredictably in +other ways.@footnote{This is the behavior specified for languages like +Common Lisp and C, and it differs from the behavior of languages like +JavaScript and Python where an interpreter is required to signal an +error if a program attempts to change a constant. Ideally the Emacs +Lisp interpreter will evolve in latter direction.} + + When similar constants occur as parts of a program, the Lisp interpreter might save time or space by reusing existing constants or -constant components. For example, @code{(eq "abc" "abc")} returns +their components. For example, @code{(eq "abc" "abc")} returns @code{t} if the interpreter creates only one instance of the string -constant @code{"abc"}, and returns @code{nil} if it creates two +literal @code{"abc"}, and returns @code{nil} if it creates two instances. Lisp programs should be written so that they work regardless of whether this optimization is in use. diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index 1cb0d05cc7b..91c3049f875 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -183,11 +183,11 @@ for other ways to copy sequences. @example @group -(setq bar (list 1 2)) ; @r{Create a mutable list.} +(setq bar (list 1 2)) @result{} (1 2) @end group @group -(setq x (vector 'foo bar)) ; @r{Create a mutable vector.} +(setq x (vector 'foo bar)) @result{} [foo (1 2)] @end group @group @@ -278,7 +278,7 @@ Unlike @code{reverse} the original @var{sequence} may be modified. @example @group -(setq x (list 'a 'b 'c)) ; @r{Create a mutable list.} +(setq x (list 'a 'b 'c)) @result{} (a b c) @end group @group @@ -320,7 +320,7 @@ presented graphically: For the vector, it is even simpler because you don't need setq: @example -(setq x (copy-sequence [1 2 3 4])) ; @r{Create a mutable vector.} +(setq x (copy-sequence [1 2 3 4])) @result{} [1 2 3 4] (nreverse x) @result{} [4 3 2 1] @@ -331,6 +331,7 @@ x Note that unlike @code{reverse}, this function doesn't work with strings. Although you can alter string data by using @code{aset}, it is strongly encouraged to treat strings as immutable even when they are mutable. +@xref{Mutability}. @end defun @@ -374,7 +375,7 @@ appears in a different position in the list due to the change of @example @group -(setq nums (list 1 3 2 6 5 4 0)) ; @r{Create a mutable list.} +(setq nums (list 1 3 2 6 5 4 0)) @result{} (1 3 2 6 5 4 0) @end group @group @@ -1228,7 +1229,7 @@ This function sets the @var{index}th element of @var{array} to be @example @group -(setq w (vector 'foo 'bar 'baz)) ; @r{Create a mutable vector.} +(setq w (vector 'foo 'bar 'baz)) @result{} [foo bar baz] (aset w 0 'fu) @result{} fu @@ -1237,7 +1238,7 @@ w @end group @group -;; @r{@code{copy-sequence} creates a mutable string.} +;; @r{@code{copy-sequence} copies the string to be modified later.} (setq x (copy-sequence "asdfasfd")) @result{} "asdfasfd" (aset x 3 ?Z) @@ -1247,9 +1248,7 @@ x @end group @end example -The @var{array} should be mutable; that is, it should not be a constant, -such as the constants created via quoting or via self-evaluating forms. -@xref{Constants and Mutability}. +The @var{array} should be mutable. @xref{Mutability}. If @var{array} is a string and @var{object} is not a character, a @code{wrong-type-argument} error results. The function converts a @@ -1262,7 +1261,6 @@ each element of @var{array} is @var{object}. It returns @var{array}. @example @group -;; @r{Create a mutable vector and then fill it with zeros.} (setq a (copy-sequence [a b c d e f g])) @result{} [a b c d e f g] (fillarray a 0) @@ -1271,7 +1269,6 @@ a @result{} [0 0 0 0 0 0 0] @end group @group -;; @r{Create a mutable string and then fill it with "-".} (setq s (copy-sequence "When in the course")) @result{} "When in the course" (fillarray s ?-) @@ -1310,8 +1307,8 @@ same way in Lisp input. evaluation: the result of evaluating it is the same vector. This does not evaluate or even examine the elements of the vector. @xref{Self-Evaluating Forms}. Vectors written with square brackets -are constants and should not be modified via @code{aset} or other -destructive operations. @xref{Constants and Mutability}. +should not be modified via @code{aset} or other destructive +operations. @xref{Mutability}. Here are examples illustrating these principles: diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index a4c9c2549c5..70c3b3cf4be 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -49,10 +49,9 @@ by a distinguished character code. Since strings are arrays, and therefore sequences as well, you can operate on them with the general array and sequence functions documented -in @ref{Sequences Arrays Vectors}. For example, you can access or -change individual characters in a string using the functions @code{aref} -and @code{aset} (@pxref{Array Functions}). However, you should not -try to change the contents of constant strings (@pxref{Modifying Strings}). +in @ref{Sequences Arrays Vectors}. For example, you can access +individual characters in a string using the function @code{aref} +(@pxref{Array Functions}). There are two text representations for non-@acronym{ASCII} characters in Emacs strings (and in buffers): unibyte and multibyte. @@ -382,9 +381,7 @@ usual value is @w{@code{"[ \f\t\n\r\v]+"}}. @cindex string modification You can alter the contents of a mutable string via operations -described in this section. However, you should not try to use these -operations to alter the contents of a constant string. -@xref{Constants and Mutability}. +described in this section. @xref{Mutability}. The most basic way to alter the contents of an existing string is with @code{aset} (@pxref{Array Functions}). @code{(aset @var{string} From b48ab743a861b8041518ce7459bde51c3dd02ee0 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 16 May 2020 18:16:23 -0700 Subject: [PATCH 02/55] Minor fixups for mutability doc * doc/lispref/objects.texi (Mutability): Minor fixups in response to a comment by Dmitry Gutov (Bug#40671#477). --- doc/lispref/objects.texi | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 136213ad661..5c5f89eb433 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -2381,7 +2381,7 @@ that for two strings to be equal, they have the same text properties. Some Lisp objects should never change. For example, the Lisp expression @code{"aaa"} yields a string, but you should not change -its contents. Indeed, some objects cannot be changed; for example, +its contents. And some objects cannot be changed; for example, although you can create a new number by calculating one, Lisp provides no operation to change the value of an existing number. @@ -2393,11 +2393,10 @@ point to somewhere else. Although numbers never change and all markers are mutable, some types have members some of which are mutable and others not. These types include conses, vectors, and strings. For example, -although @code{"aaa"} yields a string that should not be changed, -@code{(make-string 3 ?a)} yields a mutable string that can be -changed via later calls to @code{aset}. Another example: -@code{(symbol-name 'cons)} yields a string @code{"cons"} that should -not be changed. +although @code{"cons"} and @code{(symbol-name 'cons)} both yield +strings that should not be changed, @code{(copy-sequence "cons")} and +@code{(make-string 3 ?a)} both yield mutable strings that can be +changed via later calls to @code{aset}. A mutable object stops being mutable if it is part of an expression that is evaluated. For example: @@ -2419,9 +2418,9 @@ becomes mutable afterwards. changed, the resulting behavior is undefined: the Lisp interpreter might signal an error, or it might crash or behave unpredictably in other ways.@footnote{This is the behavior specified for languages like -Common Lisp and C, and it differs from the behavior of languages like +Common Lisp and C for constants, and this differs from languages like JavaScript and Python where an interpreter is required to signal an -error if a program attempts to change a constant. Ideally the Emacs +error if a program attempts to change an immutable object. Ideally the Emacs Lisp interpreter will evolve in latter direction.} When similar constants occur as parts of a program, the Lisp From 00be23c2af4aa1bb09afc6404c5ef68997dc18f5 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sun, 17 May 2020 16:50:49 -0700 Subject: [PATCH 03/55] =?UTF-8?q?Don=E2=80=99t=20attempt=20to=20modify=20c?= =?UTF-8?q?onstant=20strings?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit These attempts were found by ‘make compile-always’. * lisp/language/tibet-util.el (tibetan-obsolete-glyphs): * lisp/org/org-agenda.el (org-agenda-get-restriction-and-command): Don’t try to modify string constants. --- lisp/language/tibet-util.el | 14 +++++++++----- lisp/org/org-agenda.el | 5 +++-- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/lisp/language/tibet-util.el b/lisp/language/tibet-util.el index 29fff9175b7..8684cdb1338 100644 --- a/lisp/language/tibet-util.el +++ b/lisp/language/tibet-util.el @@ -43,13 +43,17 @@ ("་" . "་") ("༔" . "༔") ;; Yes these are dirty. But ... - ("༎ ༎" . ,(compose-string "༎ ༎" 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎])) + ("༎ ༎" . ,(compose-string (copy-sequence "༎ ༎") + 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎])) ("༄༅༅" . ,(compose-string - "࿁࿂࿂࿂" 0 4 + (copy-sequence "࿁࿂࿂࿂") 0 4 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂ (Br . Bl) ?࿂])) - ("༄༅" . ,(compose-string "࿁࿂࿂" 0 3 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂])) - ("༆" . ,(compose-string "࿁࿂༙" 0 3 [?࿁ (Br . Bl) ?࿂ (br . tr) ?༙])) - ("༄" . ,(compose-string "࿁࿂" 0 2 [?࿁ (Br . Bl) ?࿂])))) + ("༄༅" . ,(compose-string (copy-sequence "࿁࿂࿂") + 0 3 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂])) + ("༆" . ,(compose-string (copy-sequence "࿁࿂༙") + 0 3 [?࿁ (Br . Bl) ?࿂ (br . tr) ?༙])) + ("༄" . ,(compose-string (copy-sequence "࿁࿂") + 0 2 [?࿁ (Br . Bl) ?࿂])))) ;;;###autoload (defun tibetan-char-p (ch) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 5fe140d00ef..689d134627e 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -2995,7 +2995,8 @@ Agenda views are separated by `org-agenda-block-separator'." (erase-buffer) (insert (eval-when-compile (let ((header - "Press key for an agenda command: + (copy-sequence + "Press key for an agenda command: -------------------------------- < Buffer, subtree/region restriction a Agenda for current week or day > Remove restriction t List of all TODO entries e Export agenda views @@ -3004,7 +3005,7 @@ s Search for keywords M Like m, but only TODO entries / Multi-occur S Like s, but only TODO entries ? Find :FLAGGED: entries C Configure custom agenda commands * Toggle sticky agenda views # List stuck projects (!=configure) -") +")) (start 0)) (while (string-match "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)" From 94f01fe206b554df94f7860892088cd22ed191dd Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Mon, 18 May 2020 02:46:06 +0300 Subject: [PATCH 04/55] vc-working-revision: Bind default-directory * lisp/vc/vc-hooks.el (vc-working-revision): Bind default-directory to be on the safe side. Suggested by Ilya Ostapyshyn (https://lists.gnu.org/archive/html/emacs-devel/2020-05/msg02301.html). --- lisp/vc/vc-hooks.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 2ca9d3e620c..ce72a49b955 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -498,7 +498,7 @@ status of this file. Otherwise, the value returned is one of: "Return the repository version from which FILE was checked out. If FILE is not registered, this function always returns nil." (or (vc-file-getprop file 'vc-working-revision) - (progn + (let ((default-directory (file-name-directory file))) (setq backend (or backend (vc-backend file))) (when backend (vc-file-setprop file 'vc-working-revision From 30e8d560aac0442cfcbd6c88f616227a5e67743c Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Mon, 18 May 2020 03:36:43 +0300 Subject: [PATCH 05/55] Add user option project-vc-merge-submodules * lisp/progmodes/project.el (project-vc): Update the docstring. (project-vc-merge-submodules): New user option. (project-try-vc): Use it. (project--submodule-p): Extract from project-try-vc. --- lisp/progmodes/project.el | 63 ++++++++++++++++++++++++--------------- 1 file changed, 39 insertions(+), 24 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 198f040fb29..0b2761c2a5e 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -223,7 +223,7 @@ to find the list of ignores for each directory." local-files)))) (defgroup project-vc nil - "Project implementation using the VC package." + "Project implementation based on the VC package." :version "25.1" :group 'tools) @@ -232,6 +232,12 @@ to find the list of ignores for each directory." :type '(repeat string) :safe 'listp) +(defcustom project-vc-merge-submodules t + "Non-nil to consider submodules part of the parent project." + :type 'boolean + :package-version '(project . "0.2.0") + :safe 'booleanp) + ;; FIXME: Using the current approach, major modes are supposed to set ;; this variable to a buffer-local value. So we don't have access to ;; the "external roots" of language A from buffers of language B, which @@ -273,36 +279,45 @@ backend implementation of `project-external-roots'.") (pcase backend ('Git ;; Don't stop at submodule boundary. - ;; Note: It's not necessarily clear-cut what should be - ;; considered a "submodule" in the sense that some users - ;; may setup things equivalent to "git-submodule"s using - ;; "git worktree" instead (for example). - ;; FIXME: Also it may be the case that some users would consider - ;; a submodule as its own project. So there's a good chance - ;; we will need to let the user tell us what is their intention. (or (vc-file-getprop dir 'project-git-root) - (let* ((root (vc-call-backend backend 'root dir)) - (gitfile (expand-file-name ".git" root))) + (let ((root (vc-call-backend backend 'root dir))) (vc-file-setprop dir 'project-git-root - (cond - ((file-directory-p gitfile) - root) - ((with-temp-buffer - (insert-file-contents gitfile) - (goto-char (point-min)) - ;; Kind of a hack to distinguish a submodule from - ;; other cases of .git files pointing elsewhere. - (looking-at "gitdir: [./]+/\\.git/modules/")) - (let* ((parent (file-name-directory - (directory-file-name root)))) - (vc-call-backend backend 'root parent))) - (t root))) - ))) + (if (and + project-vc-merge-submodules + (project--submodule-p root)) + (let* ((parent (file-name-directory + (directory-file-name root)))) + (vc-call-backend backend 'root parent)) + root))))) ('nil nil) (_ (ignore-errors (vc-call-backend backend 'root dir)))))) (and root (cons 'vc root)))) +(defun project--submodule-p (root) + ;; XXX: We only support Git submodules for now. + ;; + ;; For submodules, at least, we expect the users to prefer them to + ;; be considered part of the parent project. For those who don't, + ;; there is the custom var now. + ;; + ;; Some users may also set up things equivalent to Git submodules + ;; using "git worktree" instead (for example). However, we expect + ;; that most of them would prefer to treat those as separate + ;; projects anyway. + (let* ((gitfile (expand-file-name ".git" root))) + (cond + ((file-directory-p gitfile) + nil) + ((with-temp-buffer + (insert-file-contents gitfile) + (goto-char (point-min)) + ;; Kind of a hack to distinguish a submodule from + ;; other cases of .git files pointing elsewhere. + (looking-at "gitdir: [./]+/\\.git/modules/")) + t) + (t nil)))) + (cl-defmethod project-roots ((project (head vc))) (list (cdr project))) From 2216468786f64cfa403dface1dab1cd20b84d5aa Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Mon, 18 May 2020 03:44:26 +0300 Subject: [PATCH 06/55] Update the package version * lisp/progmodes/project.el: Update the package version. (project-vc-merge-submodules): Update the docstring. (project-try-vc): Add a FIXME. --- lisp/progmodes/project.el | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 0b2761c2a5e..44259990bbf 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1,7 +1,7 @@ ;;; project.el --- Operations on the current project -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. -;; Version: 0.1.3 +;; Version: 0.2.0 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid using functionality that @@ -233,7 +233,10 @@ to find the list of ignores for each directory." :safe 'listp) (defcustom project-vc-merge-submodules t - "Non-nil to consider submodules part of the parent project." + "Non-nil to consider submodules part of the parent project. + +After changing this variable (using Customize or .dir-locals.el) +you might have to restart Emacs to see the effect." :type 'boolean :package-version '(project . "0.2.0") :safe 'booleanp) @@ -284,6 +287,8 @@ backend implementation of `project-external-roots'.") (vc-file-setprop dir 'project-git-root (if (and + ;; FIXME: Invalidate the cache when the value + ;; of this variable changes. project-vc-merge-submodules (project--submodule-p root)) (let* ((parent (file-name-directory @@ -302,9 +307,8 @@ backend implementation of `project-external-roots'.") ;; there is the custom var now. ;; ;; Some users may also set up things equivalent to Git submodules - ;; using "git worktree" instead (for example). However, we expect - ;; that most of them would prefer to treat those as separate - ;; projects anyway. + ;; using "git worktree" (for example). However, we expect that most + ;; of them would prefer to treat those as separate projects anyway. (let* ((gitfile (expand-file-name ".git" root))) (cond ((file-directory-p gitfile) From b1fe27d77db8f819641231ca46725f3eed0b4d9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sun, 17 May 2020 18:11:27 +0200 Subject: [PATCH 07/55] Fix calculator entry of numbers with negative exponents (bug#41347) * lisp/calculator.el (calculator-string-to-number): Remove obsolete string transformations preventing entry of 1e-3 etc. Keep one transformation to allow entry of "1.e3". Reported by Chris Zheng. --- lisp/calculator.el | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/lisp/calculator.el b/lisp/calculator.el index 7e0b2fcc6a3..cd92f992689 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -858,12 +858,10 @@ The result should not exceed the screen width." "Convert the given STR to a number, according to the value of `calculator-input-radix'." (if calculator-input-radix - (string-to-number str (cadr (assq calculator-input-radix - '((bin 2) (oct 8) (hex 16))))) - (let* ((str (replace-regexp-in-string - "\\.\\([^0-9].*\\)?$" ".0\\1" str)) - (str (replace-regexp-in-string - "[eE][+-]?\\([^0-9].*\\)?$" "e0\\1" str))) + (string-to-number str (cadr (assq calculator-input-radix + '((bin 2) (oct 8) (hex 16))))) + ;; Allow entry of "1.e3". + (let ((str (replace-regexp-in-string (rx "." (any "eE")) "e" str))) (float (string-to-number str))))) (defun calculator-push-curnum () From b2e2128745a00e06cb714bb3f47829f036a9caf9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simen=20Heggest=C3=B8yl?= Date: Mon, 18 May 2020 17:54:05 +0200 Subject: [PATCH 08/55] Use lexical-binding in webjump.el and add tests * lisp/net/webjump.el: Use lexical-binding. (webjump-read-url-choice): Remove redundant 'function' around lambda. * test/lisp/net/webjump-tests.el: New file with tests for webjump.el. --- lisp/net/webjump.el | 5 +-- test/lisp/net/webjump-tests.el | 73 ++++++++++++++++++++++++++++++++++ 2 files changed, 75 insertions(+), 3 deletions(-) create mode 100644 test/lisp/net/webjump-tests.el diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 6edd03c39cc..8bb156199c5 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -1,4 +1,4 @@ -;;; webjump.el --- programmable Web hotlist +;;; webjump.el --- programmable Web hotlist -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1997, 2001-2020 Free Software Foundation, Inc. @@ -323,8 +323,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (defun webjump-read-url-choice (what urls &optional default) ;; Note: Convert this to use `webjump-read-choice' someday. - (let* ((completions (mapcar (function (lambda (n) (cons n n))) - urls)) + (let* ((completions (mapcar (lambda (n) (cons n n)) urls)) (input (completing-read (concat what ;;(if default " (RET for default)" "") ": ") diff --git a/test/lisp/net/webjump-tests.el b/test/lisp/net/webjump-tests.el new file mode 100644 index 00000000000..47569c948f5 --- /dev/null +++ b/test/lisp/net/webjump-tests.el @@ -0,0 +1,73 @@ +;;; webjump-tests.el --- Tests for webjump.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl +;; Keywords: + +;; 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: + +;; + +;;; Code: + +(require 'ert) +(require 'webjump) + +(ert-deftest webjump-tests-builtin () + (should (equal (webjump-builtin '[name] "gnu.org") "gnu.org"))) + +(ert-deftest webjump-tests-builtin-check-args () + (should (webjump-builtin-check-args [1 2 3] "Foo" 2)) + (should-error (webjump-builtin-check-args [1 2 3] "Foo" 3))) + +(ert-deftest webjump-tests-mirror-default () + (should (equal (webjump-mirror-default + '("https://ftp.gnu.org/pub/gnu/" + "https://ftpmirror.gnu.org")) + "https://ftp.gnu.org/pub/gnu/"))) + +(ert-deftest webjump-tests-null-or-blank-string-p () + (should (webjump-null-or-blank-string-p nil)) + (should (webjump-null-or-blank-string-p "")) + (should (webjump-null-or-blank-string-p " ")) + (should-not (webjump-null-or-blank-string-p " . "))) + +(ert-deftest webjump-tests-url-encode () + (should (equal (webjump-url-encode "") "")) + (should (equal (webjump-url-encode "a b c") "a+b+c")) + (should (equal (webjump-url-encode "foo?") "foo%3F")) + (should (equal (webjump-url-encode "/foo\\") "/foo%5C")) + (should (equal (webjump-url-encode "f&o") "f%26o"))) + +(ert-deftest webjump-tests-url-fix () + (should (equal (webjump-url-fix nil) "")) + (should (equal (webjump-url-fix "/tmp/") "file:///tmp/")) + (should (equal (webjump-url-fix "gnu.org") "http://gnu.org/")) + (should (equal (webjump-url-fix "ftp.x.org") "ftp://ftp.x.org/")) + (should (equal (webjump-url-fix "https://gnu.org") + "https://gnu.org/"))) + +(ert-deftest webjump-tests-url-fix-trailing-slash () + (should (equal (webjump-url-fix-trailing-slash "https://gnu.org") + "https://gnu.org/")) + (should (equal (webjump-url-fix-trailing-slash "https://gnu.org/") + "https://gnu.org/"))) + +(provide 'webjump-tests) +;;; webjump-tests.el ends here From 86594a3ddb04c7b086f1d6796d5102da73020ac7 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Mon, 18 May 2020 10:54:14 -0700 Subject: [PATCH 09/55] Restore buffer-undo-list to buffer-local-variables It has been missing since 2012-07-03 (Emacs 24.3) "Cleanup basic buffer management", when undo_list was moved to the end of struct buffer. (Bug#33492) * src/buffer.c (buffer_local_variables_1): New function. (Fbuffer_local_variables): Explicitly add buffer-undo-list. --- src/buffer.c | 40 ++++++++++++++++++++++++++++++---------- 1 file changed, 30 insertions(+), 10 deletions(-) diff --git a/src/buffer.c b/src/buffer.c index 53b3bd960c4..f1cb4d50414 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -119,6 +119,7 @@ static void free_buffer_text (struct buffer *b); static struct Lisp_Overlay * copy_overlays (struct buffer *, struct Lisp_Overlay *); static void modify_overlay (struct buffer *, ptrdiff_t, ptrdiff_t); static Lisp_Object buffer_lisp_local_variables (struct buffer *, bool); +static Lisp_Object buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym); static void CHECK_OVERLAY (Lisp_Object x) @@ -1300,6 +1301,25 @@ buffer_lisp_local_variables (struct buffer *buf, bool clone) return result; } + +/* If the variable at position index OFFSET in buffer BUF has a + buffer-local value, return (name . value). If SYM is non-nil, + it replaces name. */ + +static Lisp_Object +buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym) +{ + int idx = PER_BUFFER_IDX (offset); + if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) + && SYMBOLP (PER_BUFFER_SYMBOL (offset))) + { + sym = NILP (sym) ? PER_BUFFER_SYMBOL (offset) : sym; + Lisp_Object val = per_buffer_value (buf, offset); + return EQ (val, Qunbound) ? sym : Fcons (sym, val); + } + return Qnil; +} + DEFUN ("buffer-local-variables", Fbuffer_local_variables, Sbuffer_local_variables, 0, 1, 0, doc: /* Return an alist of variables that are buffer-local in BUFFER. @@ -1311,25 +1331,25 @@ No argument or nil as argument means use current buffer as BUFFER. */) { struct buffer *buf = decode_buffer (buffer); Lisp_Object result = buffer_lisp_local_variables (buf, 0); + Lisp_Object tem; /* Add on all the variables stored in special slots. */ { - int offset, idx; + int offset; FOR_EACH_PER_BUFFER_OBJECT_AT (offset) { - idx = PER_BUFFER_IDX (offset); - if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) - && SYMBOLP (PER_BUFFER_SYMBOL (offset))) - { - Lisp_Object sym = PER_BUFFER_SYMBOL (offset); - Lisp_Object val = per_buffer_value (buf, offset); - result = Fcons (EQ (val, Qunbound) ? sym : Fcons (sym, val), - result); - } + tem = buffer_local_variables_1 (buf, offset, Qnil); + if (!NILP (tem)) + result = Fcons (tem, result); } } + tem = buffer_local_variables_1 (buf, PER_BUFFER_VAR_OFFSET (undo_list), + intern ("buffer-undo-list")); + if (!NILP (tem)) + result = Fcons (tem, result); + return result; } From ceee275431c7eb07b50cd1ecf7b22d2c0b6ed5f7 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Mon, 18 May 2020 18:20:05 +0000 Subject: [PATCH 10/55] CC Mode: Allow "static" etc. to be placed after a declaration's type name Fixes bug #41284. * lisp/progmodes/cc-langs.el (c-type-decl-prefix-key): include additionally c-modifier-kwds in the set of keywords at the base of this lang-const. --- lisp/progmodes/cc-langs.el | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index 1e72352f719..17ffea59ff0 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -3412,8 +3412,14 @@ regexp should match \"(\" if parentheses are valid in declarators. The end of the first submatch is taken as the end of the operator. Identifier syntax is in effect when this is matched (see `c-identifier-syntax-table')." - t (if (c-lang-const c-type-modifier-kwds) - (concat (regexp-opt (c-lang-const c-type-modifier-kwds) t) "\\>") + t (if (or (c-lang-const c-type-modifier-kwds) (c-lang-const c-modifier-kwds)) + (concat + (regexp-opt (c--delete-duplicates + (append (c-lang-const c-type-modifier-kwds) + (c-lang-const c-modifier-kwds)) + :test 'string-equal) + t) + "\\>") ;; Default to a regexp that never matches. regexp-unmatchable) ;; Check that there's no "=" afterwards to avoid matching tokens From ca7224d5dbfd6f07d537f6159aae8df667a65497 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Mon, 18 May 2020 13:08:27 -0700 Subject: [PATCH 11/55] Add test for recent buffer-local-variables change * test/src/buffer-tests.el (buffer-tests-buffer-local-variables-undo): New. --- test/src/buffer-tests.el | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 6e87cb94897..6e9764625a9 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -1327,4 +1327,10 @@ with parameters from the *Messages* buffer modification." (set-buffer-multibyte t) (buffer-string))))))) +;; https://debbugs.gnu.org/33492 +(ert-deftest buffer-tests-buffer-local-variables-undo () + "Test that `buffer-undo-list' appears in `buffer-local-variables'." + (with-temp-buffer + (should (assq 'buffer-undo-list (buffer-local-variables))))) + ;;; buffer-tests.el ends here From 018eb31fc0a8e558975be3835b9596408bfc3a0c Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Tue, 19 May 2020 00:55:27 +0300 Subject: [PATCH 12/55] ; Update NEWS --- etc/NEWS | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 303036ece34..2cbb7adb0b2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -353,6 +353,10 @@ 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. +** Project + +*** New user option 'project-vc-merge-submodules'. + * New Modes and Packages in Emacs 28.1 From 3d1bcfba5e21b29be8669aa2a8f27b344c9e02fd Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 18 May 2020 15:19:49 -0700 Subject: [PATCH 13/55] Redo RCS Id for pdumper MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/version.el: Don’t put an RCS Id style string into the executable via purecopy, as this does not work with the pdumper. * src/emacs.c (RCS_Id): New constant, for 'ident'. --- lisp/version.el | 4 ---- src/emacs.c | 5 +++++ 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/version.el b/lisp/version.el index 24da21c731c..b247232dcfd 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -163,8 +163,4 @@ correspond to the running Emacs. Optional argument DIR is a directory to use instead of `source-directory'." (emacs-repository-branch-git (or dir source-directory))) -;; We put version info into the executable in the form that `ident' uses. -(purecopy (concat "\n$Id: " (subst-char-in-string ?\n ?\s (emacs-version)) - " $\n")) - ;;; version.el ends here diff --git a/src/emacs.c b/src/emacs.c index ea9c4cd79dc..49793fd1e86 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -124,6 +124,11 @@ static const char emacs_version[] = PACKAGE_VERSION; static const char emacs_copyright[] = COPYRIGHT; static const char emacs_bugreport[] = PACKAGE_BUGREPORT; +/* Put version info into the executable in the form that 'ident' uses. */ +char const EXTERNALLY_VISIBLE RCS_Id[] + = "$Id" ": GNU Emacs " PACKAGE_VERSION + " (" EMACS_CONFIGURATION " " EMACS_CONFIG_FEATURES ") $"; + /* Empty lisp strings. To avoid having to build any others. */ Lisp_Object empty_unibyte_string, empty_multibyte_string; From b1cd1f0b5aaf8030a7a4c6111cc8b18645f294e2 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 18 May 2020 15:42:18 -0700 Subject: [PATCH 14/55] Improve password-cache-add example in comment * lisp/password-cache.el: Improve comment. See Andreas Schwab in: https://lists.gnu.org/r/emacs-devel/2020-05/msg02422.html --- lisp/password-cache.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/password-cache.el b/lisp/password-cache.el index 86d802f283c..f5007579a8a 100644 --- a/lisp/password-cache.el +++ b/lisp/password-cache.el @@ -31,7 +31,8 @@ ;; ;; Minibuffer prompt for password. ;; => "foo" ;; -;; (password-cache-add "test" (copy-sequence "foo")) +;; (password-cache-add "test" (read-passwd "Password? ")) +;; ;; Minibuffer prompt from read-passwd, which returns "foo". ;; => nil ;; (password-read "Password? " "test") From 06fe322c8d7123edea0759a7aa12051f4e676376 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Tue, 19 May 2020 02:22:02 +0200 Subject: [PATCH 15/55] Clarify wording in my last commit * lisp/mouse.el (mouse-drag-and-drop-region-show-tooltip): Clarify wording of integer option. Suggested by Eli Zaretskii. --- lisp/mouse.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/mouse.el b/lisp/mouse.el index f045e5bdce2..640f10af4e1 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -2580,7 +2580,7 @@ in a tooltip." :type '(choice (const :tag "Do not show tooltips" nil) (const :tag "Show all text" t) - (integer :tag "Show characters (max)" 256)) + (integer :tag "Max number of characters to show" 256)) :version "26.1") (defcustom mouse-drag-and-drop-region-show-cursor t From c5eafccc9d2a32ef422060e50533b36292bdcc01 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 18 May 2020 17:17:46 -0700 Subject: [PATCH 16/55] Reject attempts to clear pure strings * src/fns.c (Ffillarray, Fclear_string): Add CHECK_IMPURE here, to be consistent with Faset etc. (Ffillarray): Prefer memset when the fill is a single byte. --- src/fns.c | 51 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/src/fns.c b/src/fns.c index 301bd59ab90..b2f84b202de 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2508,26 +2508,36 @@ ARRAY is a vector, string, char-table, or bool-vector. */) } else if (STRINGP (array)) { - register unsigned char *p = SDATA (array); - int charval; + unsigned char *p = SDATA (array); CHECK_CHARACTER (item); - charval = XFIXNAT (item); + int charval = XFIXNAT (item); size = SCHARS (array); - if (STRING_MULTIBYTE (array)) + if (size != 0) { + CHECK_IMPURE (array, XSTRING (array)); unsigned char str[MAX_MULTIBYTE_LENGTH]; - int len = CHAR_STRING (charval, str); - ptrdiff_t size_byte = SBYTES (array); - ptrdiff_t product; + int len; + if (STRING_MULTIBYTE (array)) + len = CHAR_STRING (charval, str); + else + { + str[0] = charval; + len = 1; + } - if (INT_MULTIPLY_WRAPV (size, len, &product) || product != size_byte) - error ("Attempt to change byte length of a string"); - for (idx = 0; idx < size_byte; idx++) - *p++ = str[idx % len]; + ptrdiff_t size_byte = SBYTES (array); + if (len == 1 && size == size_byte) + memset (p, str[0], size); + else + { + ptrdiff_t product; + if (INT_MULTIPLY_WRAPV (size, len, &product) + || product != size_byte) + error ("Attempt to change byte length of a string"); + for (idx = 0; idx < size_byte; idx++) + *p++ = str[idx % len]; + } } - else - for (idx = 0; idx < size; idx++) - p[idx] = charval; } else if (BOOL_VECTOR_P (array)) return bool_vector_fill (array, item); @@ -2542,12 +2552,15 @@ DEFUN ("clear-string", Fclear_string, Sclear_string, This makes STRING unibyte and may change its length. */) (Lisp_Object string) { - ptrdiff_t len; CHECK_STRING (string); - len = SBYTES (string); - memset (SDATA (string), 0, len); - STRING_SET_CHARS (string, len); - STRING_SET_UNIBYTE (string); + ptrdiff_t len = SBYTES (string); + if (len != 0 || STRING_MULTIBYTE (string)) + { + CHECK_IMPURE (string, XSTRING (string)); + memset (SDATA (string), 0, len); + STRING_SET_CHARS (string, len); + STRING_SET_UNIBYTE (string); + } return Qnil; } From 03d44acfdda30cf355736de7442cdf2f1a1ba97e Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Tue, 19 May 2020 02:33:57 +0200 Subject: [PATCH 17/55] * doc/lispref/control.texi (Processing of Errors): Improve indexing. --- doc/lispref/control.texi | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index c601e3af9bc..7755cbb5f25 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -1867,6 +1867,7 @@ concept of continuable errors. @node Processing of Errors @subsubsection How Emacs Processes Errors @cindex processing of errors +@cindex handle errors When an error is signaled, @code{signal} searches for an active @dfn{handler} for the error. A handler is a sequence of Lisp From 659ed857c04936140fea847795f8b85c5dcc3920 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Tue, 19 May 2020 15:17:57 +0200 Subject: [PATCH 18/55] Indicate not downloaded parts in MIME buttons. Via nnimap-fetch-partial-articles one can tell Gnus to omit fetching certain parts by default. Now the MIME buttons in the article buffer indicate how to fetch the complete message in order to act on those missing parts. * lisp/gnus/gnus-art.el (gnus-insert-mime-button): Indicate not downloaded parts in MIME buttons. --- lisp/gnus/gnus-art.el | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 6b9610d3121..614651afff9 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5833,6 +5833,7 @@ all parts." "" "...")) (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) (buffer-size))) + (help-echo "mouse-2: toggle the MIME part; down-mouse-3: more options") gnus-tmp-type-long b e) (when (string-match ".*/" gnus-tmp-name) (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) @@ -5841,6 +5842,16 @@ all parts." (concat "; " gnus-tmp-name)))) (unless (equal gnus-tmp-description "") (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) + (when (zerop gnus-tmp-length) + (setq gnus-tmp-type-long + (concat + gnus-tmp-type-long + (substitute-command-keys + (concat "\\ (not downloaded, " + "\\[gnus-summary-show-complete-article] to fetch.)")))) + (setq help-echo + (concat "Type \\[gnus-summary-show-complete-article] " + "to download complete article. " help-echo))) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist @@ -5859,8 +5870,7 @@ all parts." 'keymap gnus-mime-button-map 'face gnus-article-button-face 'follow-link t - 'help-echo - "mouse-2: toggle the MIME part; down-mouse-3: more options"))) + 'help-echo help-echo))) (defvar gnus-displaying-mime nil) From 4b9fbdb5a713745dfdb13042e33ba2345e6860e1 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Tue, 19 May 2020 18:46:27 +0300 Subject: [PATCH 19/55] ; Update TODO item about ligature support * etc/TODO: Add the todo item for moving cursor "inside" a ligature. --- etc/TODO | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/etc/TODO b/etc/TODO index 20262a77e97..f983fa27d33 100644 --- a/etc/TODO +++ b/etc/TODO @@ -264,6 +264,37 @@ of the mode line. The prettify-symbols-mode should be deprecated once ligature support is in place. +A related, but somewhat independent, feature is being able to move the +cursor "into a ligature", whereby cursor motion commands shows some +pseudo-cursor on some part of a ligature. For example, if "ffi" is +displayed as a ligature, then moving by one buffer position should +show the middle part of the ligature's glyph similar to the cursor +display: some special background and perhaps also a special +foreground. There are two possible ways of figuring out the offset at +which to display the pseudo-cursor: + + . Arbitrarily divide the ligature's glyph width W into N parts, + where N is the number of codepoints composed into the ligature, then + move that pseudo-cursor by W/N pixels each time a cursor-motion + command is invoked; + . Use the font information. For example, HarfBuzz has the + hb_ot_layout_get_ligature_carets API for that purpose. However, + it could be that few fonts actually have that information recorded + in them, in which case the previous heuristics will be needed as + fallback. + +One subtle issue needs to be resolved to have this feature of +"sub-glyph" cursor movement inside composed characters. The way Emacs +currently displays the default block cursor is by simply redrawing the +glyph at point in reverse video. So Emacs currently doesn't have a +way of displaying a cursor that "covers" only part of a glyph. To +make this happen, the display code will probably need to be changed to +draw the cursor as part of drawing the foreground and/or background of +the corresponding glyph, which is against the current flow of the +display code: it generally first completely draws the background and +foreground of the entire text that needs to be redrawn, and only then +draws the cursor where it should be placed. + ** Support for Stylistic Sets This will allow using "alternate glyphs" supported by modern fonts. For an overview of this feature, see From 5af991872d5024b69272588772961bafef5a35bb Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Sat, 16 May 2020 10:05:12 +0200 Subject: [PATCH 20/55] Allow back-references in syntax-propertize-rules. * lisp/emacs-lisp/syntax.el (syntax-propertize--shift-groups-and-backrefs): Renamed from syntax-propertize--shift-groups, and also shift back-references. (syntax-propertize-rules): Adapt docstring and use renamed function. * test/lisp/emacs-lisp/syntax-tests.el: New test. (syntax-propertize--shift-groups-and-backrefs): New ERT test. --- lisp/emacs-lisp/syntax.el | 35 ++++++++++----- test/lisp/emacs-lisp/syntax-tests.el | 67 ++++++++++++++++++++++++++++ 2 files changed, 92 insertions(+), 10 deletions(-) create mode 100644 test/lisp/emacs-lisp/syntax-tests.el diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 46dc8d9ade8..ce495af95bc 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -139,14 +139,28 @@ delimiter or an Escaped or Char-quoted character.")) (point-max)))) (cons beg end)) -(defun syntax-propertize--shift-groups (re n) - (replace-regexp-in-string - "\\\\(\\?\\([0-9]+\\):" - (lambda (s) - (replace-match - (number-to-string (+ n (string-to-number (match-string 1 s)))) - t t s 1)) - re t t)) +(defun syntax-propertize--shift-groups-and-backrefs (re n) + (let ((new-re (replace-regexp-in-string + "\\\\(\\?\\([0-9]+\\):" + (lambda (s) + (replace-match + (number-to-string + (+ n (string-to-number (match-string 1 s)))) + t t s 1)) + re t t)) + (pos 0)) + (while (string-match "\\\\\\([0-9]+\\)" new-re pos) + (setq pos (+ 1 (match-beginning 1))) + (when (save-match-data + ;; With \N, the \ must be in a subregexp context, i.e., + ;; not in a character class or in a \{\} repetition. + (subregexp-context-p new-re (match-beginning 0))) + (let ((shifted (+ n (string-to-number (match-string 1 new-re))))) + (when (> shifted 9) + (error "There may be at most nine back-references")) + (setq new-re (replace-match (number-to-string shifted) + t t new-re 1))))) + new-re)) (defmacro syntax-propertize-precompile-rules (&rest rules) "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. @@ -190,7 +204,8 @@ for subsequent HIGHLIGHTs. Also SYNTAX is free to move point, in which case RULES may not be applied to some parts of the text or may be applied several times to other parts. -Note: back-references in REGEXPs do not work." +Note: There may be at most nine back-references in the REGEXPs of +all RULES in total." (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. (form &rest (numberp @@ -219,7 +234,7 @@ Note: back-references in REGEXPs do not work." ;; tell when *this* match 0 has succeeded. (cl-incf offset) (setq re (concat "\\(" re "\\)"))) - (setq re (syntax-propertize--shift-groups re offset)) + (setq re (syntax-propertize--shift-groups-and-backrefs re offset)) (let ((code '()) (condition (cond diff --git a/test/lisp/emacs-lisp/syntax-tests.el b/test/lisp/emacs-lisp/syntax-tests.el new file mode 100644 index 00000000000..9d4c4113fdd --- /dev/null +++ b/test/lisp/emacs-lisp/syntax-tests.el @@ -0,0 +1,67 @@ +;;; syntax-tests.el --- tests for syntax.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'syntax) + +(ert-deftest syntax-propertize--shift-groups-and-backrefs () + "Test shifting of numbered groups and back-references in regexps." + ;; A numbered group must be shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foobar" 2) + "\\(?4:[abc]+\\)foobar")) + ;; A back-reference \1 on a normal sub-regexp context must be + ;; shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\1" 2) + "\\(a\\)\\3")) + ;; Shifting must not happen if the \1 appears in a character class, + ;; or in a \{\} repetition construct (although \1 isn't valid there + ;; anyway). + (let ((rx-with-class "\\(a\\)[\\1-2]") + (rx-with-rep "\\(a\\)\\{1,\\1\\}")) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-class 2) + rx-with-class)) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-rep 2) + rx-with-rep))) + ;; Now numbered groups and back-references in combination. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foo\\(\\2\\)" 2) + "\\(?4:[abc]+\\)foo\\(\\4\\)")) + ;; Emacs supports only the back-references \1,...,\9, so when a + ;; shift would result in \10 or more, an error must be signalled. + (should-error + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\3" 7))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; syntax-tests.el ends here. From 3c2624e18826d9466eff13524b43903b781ada91 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Wed, 20 May 2020 01:54:33 +0300 Subject: [PATCH 21/55] project--vc-list-files: Don't list conflicted files thrice * lisp/progmodes/project.el (project--vc-list-files): Use delete-consecutive-dups. --- lisp/progmodes/project.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 44259990bbf..06e882b9f06 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -391,7 +391,9 @@ backend implementation of `project-external-roots'.") submodules))) (setq files (apply #'nconc files sub-files))) - files)) + ;; 'git ls-files' returns duplicate entries for merge conflicts. + ;; XXX: Better solutions welcome, but this seems cheap enough. + (delete-consecutive-dups files))) (`Hg (let ((default-directory (expand-file-name (file-name-as-directory dir))) args) From babdd2e90e170bd99b7d3e3331fec14d31771a5a Mon Sep 17 00:00:00 2001 From: Philip K Date: Tue, 19 May 2020 19:30:14 +0200 Subject: [PATCH 22/55] Add project-compile command * lisp/progmodes/project.el (project-compile): New function. --- lisp/progmodes/project.el | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 06e882b9f06..41e34a37507 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -681,5 +681,17 @@ loop using the command \\[fileloop-continue]." from to (project-files (project-current t)) 'default) (fileloop-continue)) +;;;###autoload +(defun project-compile () + "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))) + (call-interactively 'compile))) + (provide 'project) ;;; project.el ends here From 5352bda4eeb7415ad2bda5d74e007b4f36021e68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Tue, 19 May 2020 23:17:04 +0200 Subject: [PATCH 23/55] Add test for bug#39680 * test/lisp/electric-tests.el (electric-pair-undo-unrelated-state): New test. --- test/lisp/electric-tests.el | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 56d1bdb110e..67f474cbd52 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -546,6 +546,24 @@ baz\"\"" (electric-pair-delete-pair 1) (should (equal "" (buffer-string)))))) + +;;; Undoing +(ert-deftest electric-pair-undo-unrelated-state () + "Make sure `electric-pair-mode' does not confuse `undo' (bug#39680)." + (with-temp-buffer + (buffer-enable-undo) + (electric-pair-local-mode) + (let ((last-command-event ?\()) + (ert-simulate-command '(self-insert-command 1))) + (undo-boundary) + (let ((last-command-event ?a)) + (ert-simulate-command '(self-insert-command 1))) + (undo-boundary) + (ert-simulate-command '(undo)) + (let ((last-command-event ?\()) + (ert-simulate-command '(self-insert-command 1))) + (should (string= (buffer-string) "(())")))) + ;;; Electric newlines between pairs ;;; TODO: better tests From f0b0105d913a94c66f230874c9269b19dbbc83bd Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Tue, 19 May 2020 23:22:40 -0700 Subject: [PATCH 24/55] Hoist some byte-code checking out of eval MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Check Lisp_Compiled objects better as they’re created, so that the byte-code interpreter needn’t do the checks each time it executes them. This improved performance of ‘make compile-always’ by 1.5% on my platform. Also, improve the quality of the (still-incomplete) checks, as this is more practical now that they’re done less often. * src/alloc.c (make_byte_code): Remove. All uses removed. (Fmake_byte_code): Put a better (though still incomplete) check here instead. Simplify by using Fvector instead of make_uninit_vector followed by memcpy, and by using XSETPVECTYPE instead of make_byte_code followed by XSETCOMPILED. * src/bytecode.c (Fbyte_code): Do sanity check and conditional translation to unibyte here instead of each time the function is executed. (exec_byte_code): Omit no-longer-necessary sanity and unibyte checking. Use SCHARS instead of SBYTES where either will do, as SCHARS is faster. * src/eval.c (fetch_and_exec_byte_code): New function. (funcall_lambda): Use it. (funcall_lambda, lambda_arity, Ffetch_bytecode): Omit no-longer-necessary sanity checks. (Ffetch_bytecode): Add sanity check if actually fetching. * src/lisp.h (XSETCOMPILED): Remove. All uses removed. * src/lread.c (read1): Check byte-code objects more thoroughly, albeit still incompletely, and do translation to unibyte here instead of each time the function is executed. (read1): Use XSETPVECYPE instead of make_byte_code. (read_vector): Omit no-longer-necessary sanity check. --- src/alloc.c | 33 ++++++++++----------------------- src/bytecode.c | 28 +++++++++++++++------------- src/eval.c | 48 +++++++++++++++++++----------------------------- src/lisp.h | 2 -- src/lread.c | 26 +++++++++++++++++++++----- 5 files changed, 65 insertions(+), 72 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index ebc55857ea0..b7ebaa63a5b 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3421,23 +3421,6 @@ usage: (vector &rest OBJECTS) */) return val; } -void -make_byte_code (struct Lisp_Vector *v) -{ - /* Don't allow the global zero_vector to become a byte code object. */ - eassert (0 < v->header.size); - - if (v->header.size > 1 && STRINGP (v->contents[1]) - && STRING_MULTIBYTE (v->contents[1])) - /* BYTECODE-STRING must have been produced by Emacs 20.2 or the - earlier because they produced a raw 8-bit string for byte-code - and now such a byte-code string is loaded as multibyte while - raw 8-bit characters converted to multibyte form. Thus, now we - must convert them back to the original unibyte form. */ - v->contents[1] = Fstring_as_unibyte (v->contents[1]); - XSETPVECTYPE (v, PVEC_COMPILED); -} - DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant @@ -3456,8 +3439,14 @@ stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object val = make_uninit_vector (nargs); - struct Lisp_Vector *p = XVECTOR (val); + if (! ((FIXNUMP (args[COMPILED_ARGLIST]) + || CONSP (args[COMPILED_ARGLIST]) + || NILP (args[COMPILED_ARGLIST])) + && STRINGP (args[COMPILED_BYTECODE]) + && !STRING_MULTIBYTE (args[COMPILED_BYTECODE]) + && VECTORP (args[COMPILED_CONSTANTS]) + && FIXNATP (args[COMPILED_STACK_DEPTH]))) + error ("Invalid byte-code object"); /* We used to purecopy everything here, if purify-flag was set. This worked OK for Emacs-23, but with Emacs-24's lexical binding code, it can be @@ -3466,10 +3455,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT copied into pure space, including its free variables, which is sometimes just wasteful and other times plainly wrong (e.g. those free vars may want to be setcar'd). */ - - memcpy (p->contents, args, nargs * sizeof *args); - make_byte_code (p); - XSETCOMPILED (val, p); + Lisp_Object val = Fvector (nargs, args); + XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED); return val; } diff --git a/src/bytecode.c b/src/bytecode.c index 3c90544f3f2..5ac30aa1010 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -319,6 +319,19 @@ the third, MAXDEPTH, the maximum stack depth used in this function. If the third argument is incorrect, Emacs may crash. */) (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) { + if (! (STRINGP (bytestr) && VECTORP (vector) && FIXNATP (maxdepth))) + error ("Invalid byte-code"); + + if (STRING_MULTIBYTE (bytestr)) + { + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and now + such a byte-code string is loaded as multibyte with raw 8-bit + characters converted to multibyte form. Convert them back to + the original unibyte form. */ + bytestr = Fstring_as_unibyte (bytestr); + } + return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); } @@ -344,21 +357,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, int volatile this_op = 0; #endif - CHECK_STRING (bytestr); - CHECK_VECTOR (vector); - CHECK_FIXNAT (maxdepth); + eassert (!STRING_MULTIBYTE (bytestr)); ptrdiff_t const_length = ASIZE (vector); - - if (STRING_MULTIBYTE (bytestr)) - /* BYTESTR must have been produced by Emacs 20.2 or the earlier - because they produced a raw 8-bit string for byte-code and now - such a byte-code string is loaded as multibyte while raw 8-bit - characters converted to multibyte form. Thus, now we must - convert them back to the originally intended unibyte form. */ - bytestr = Fstring_as_unibyte (bytestr); - - ptrdiff_t bytestr_length = SBYTES (bytestr); + ptrdiff_t bytestr_length = SCHARS (bytestr); Lisp_Object *vectorp = XVECTOR (vector)->contents; unsigned char quitcounter = 1; diff --git a/src/eval.c b/src/eval.c index 014905ce6df..be2af2d041b 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2904,6 +2904,21 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) } } +/* Call the compiled Lisp function FUN. If we have not yet read FUN's + bytecode string and constants vector, fetch them from the file first. */ + +static Lisp_Object +fetch_and_exec_byte_code (Lisp_Object fun, Lisp_Object syms_left, + ptrdiff_t nargs, Lisp_Object *args) +{ + if (CONSP (AREF (fun, COMPILED_BYTECODE))) + Ffetch_bytecode (fun); + return exec_byte_code (AREF (fun, COMPILED_BYTECODE), + AREF (fun, COMPILED_CONSTANTS), + AREF (fun, COMPILED_STACK_DEPTH), + syms_left, nargs, args); +} + static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) { @@ -2968,9 +2983,6 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, } else if (COMPILEDP (fun)) { - ptrdiff_t size = PVSIZE (fun); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); if (FIXNUMP (syms_left)) /* A byte-code object with an integer args template means we @@ -2982,15 +2994,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, argument-binding code below instead (as do all interpreted functions, even lexically bound ones). */ { - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (AREF (fun, COMPILED_BYTECODE))) - Ffetch_bytecode (fun); - return exec_byte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - syms_left, - nargs, arg_vector); + return fetch_and_exec_byte_code (fun, syms_left, nargs, arg_vector); } lexenv = Qnil; } @@ -3059,16 +3063,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); else - { - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (AREF (fun, COMPILED_BYTECODE))) - Ffetch_bytecode (fun); - val = exec_byte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - Qnil, 0, 0); - } + val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL); return unbind_to (count, val); } @@ -3153,9 +3148,6 @@ lambda_arity (Lisp_Object fun) } else if (COMPILEDP (fun)) { - ptrdiff_t size = PVSIZE (fun); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); if (FIXNUMP (syms_left)) return get_byte_code_arity (syms_left); @@ -3198,13 +3190,11 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, if (COMPILEDP (object)) { - ptrdiff_t size = PVSIZE (object); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, object); if (CONSP (AREF (object, COMPILED_BYTECODE))) { tem = read_doc_string (AREF (object, COMPILED_BYTECODE)); - if (!CONSP (tem)) + if (! (CONSP (tem) && STRINGP (XCAR (tem)) + && VECTORP (XCDR (tem)))) { tem = AREF (object, COMPILED_BYTECODE); if (CONSP (tem) && STRINGP (XCAR (tem))) diff --git a/src/lisp.h b/src/lisp.h index ad7d67ae695..85bdc172b20 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1341,7 +1341,6 @@ dead_object (void) #define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) #define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) #define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) -#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) #define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) @@ -3934,7 +3933,6 @@ build_string (const char *str) extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object); -extern void make_byte_code (struct Lisp_Vector *); extern struct Lisp_Vector *allocate_vector (ptrdiff_t); extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t); diff --git a/src/lread.c b/src/lread.c index 59bf529f45c..53b4e1be2df 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2966,8 +2966,26 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) struct Lisp_Vector *vec; tmp = read_vector (readcharfun, 1); vec = XVECTOR (tmp); - if (vec->header.size == 0) - invalid_syntax ("Empty byte-code object"); + if (! (COMPILED_STACK_DEPTH < vec->header.size + && (FIXNUMP (vec->contents[COMPILED_ARGLIST]) + || CONSP (vec->contents[COMPILED_ARGLIST]) + || NILP (vec->contents[COMPILED_ARGLIST])) + && ((STRINGP (vec->contents[COMPILED_BYTECODE]) + && VECTORP (vec->contents[COMPILED_CONSTANTS])) + || CONSP (vec->contents[COMPILED_BYTECODE])) + && FIXNATP (vec->contents[COMPILED_STACK_DEPTH]))) + invalid_syntax ("Invalid byte-code object"); + + if (STRING_MULTIBYTE (AREF (tmp, COMPILED_BYTECODE))) + { + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and + now such a byte-code string is loaded as multibyte with + raw 8-bit characters converted to multibyte form. + Convert them back to the original unibyte form. */ + ASET (tmp, COMPILED_BYTECODE, + Fstring_as_unibyte (AREF (tmp, COMPILED_BYTECODE))); + } if (COMPILED_DOC_STRING < vec->header.size && EQ (AREF (tmp, COMPILED_DOC_STRING), make_fixnum (0))) @@ -2986,7 +3004,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) ASET (tmp, COMPILED_DOC_STRING, make_ufixnum (hash)); } - make_byte_code (vec); + XSETPVECTYPE (vec, PVEC_COMPILED); return tmp; } if (c == '(') @@ -3824,8 +3842,6 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) { Lisp_Object tem = read_list (1, readcharfun); ptrdiff_t size = list_length (tem); - if (bytecodeflag && size <= COMPILED_STACK_DEPTH) - error ("Invalid byte code"); Lisp_Object vector = make_nil_vector (size); Lisp_Object *ptr = XVECTOR (vector)->contents; From 453ffe5d535438fba3d189cf26c47f25491d15fb Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 20 May 2020 11:09:44 +0200 Subject: [PATCH 25/55] Fix minor Tramp oddities * lisp/net/tramp-archive.el (tramp-archive-file-name-handler): Increase `max-specpdl-size' temporarily. * lisp/net/tramp-rclone.el (tramp-rclone-flush-directory-cache): Fix a problem with older Emacsen. --- lisp/net/tramp-archive.el | 5 ++++- lisp/net/tramp-rclone.el | 13 ++++++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 95cbfb8c22a..63c0769e309 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -318,7 +318,10 @@ arguments to pass to the OPERATION." (let* ((filename (apply #'tramp-archive-file-name-for-operation operation args)) - (archive (tramp-archive-file-name-archive filename))) + (archive (tramp-archive-file-name-archive filename)) + ;; Sometimes, it fails with "Variable binding depth exceeds + ;; max-specpdl-size". + (max-specpdl-size (* 2 max-specpdl-size))) ;; `filename' could be a quoted file name. Or the file ;; archive could be a directory, see Bug#30293. diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 445098a5bca..08bba33afed 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -477,7 +477,18 @@ file names." (with-tramp-connection-property (tramp-get-connection-process vec) "rclone-pid" (catch 'pid - (dolist (pid (list-system-processes)) ;; "pidof rclone" ? + (dolist + (pid + ;; Until Emacs 25, `process-attributes' could + ;; crash Emacs for some processes. So we use + ;; "pidof", which might not work everywhere. + (if (<= emacs-major-version 25) + (let ((default-directory temporary-file-directory)) + (mapcar + #'string-to-number + (split-string + (shell-command-to-string "pidof rclone")))) + (list-system-processes))) (and (string-match-p (regexp-quote (format "rclone mount %s:" (tramp-file-name-host vec))) From 6b3fb29ede140c79a4146fb2056306632e3bd511 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 May 2020 22:33:38 +0100 Subject: [PATCH 26/55] ; src/alloc.c: Add a GC reg spill mechanism and Bug#41357 related commentary. --- src/alloc.c | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index b7ebaa63a5b..d5a6d9167ea 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4998,8 +4998,9 @@ mark_stack (char const *bottom, char const *end) #endif } -/* This is a trampoline function that flushes registers to the stack, - and then calls FUNC. ARG is passed through to FUNC verbatim. +/* flush_stack_call_func is the trampoline function that flushes + registers to the stack, and then calls FUNC. ARG is passed through + to FUNC verbatim. This function must be called whenever Emacs is about to release the global interpreter lock. This lets the garbage collector easily @@ -5007,7 +5008,20 @@ mark_stack (char const *bottom, char const *end) Lisp. It is invalid to run any Lisp code or to allocate any GC memory - from FUNC. */ + from FUNC. + + Note: all register spilling is done in flush_stack_call_func before + flush_stack_call_func1 is activated. + + flush_stack_call_func1 is responsible for identifying the stack + address range to be scanned. It *must* be carefully kept as + noinline to make sure that registers has been spilled before it is + called, otherwise given __builtin_frame_address (0) typically + returns the frame pointer (base pointer) and not the stack pointer + [1] GC will miss to scan callee-saved registers content + (Bug#41357). + + [1] . */ NO_INLINE void flush_stack_call_func1 (void (*func) (void *arg), void *arg) From 525df72753acdd0221771a2a298842868f49f4b4 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 20 May 2020 18:01:06 +0200 Subject: [PATCH 27/55] ; Fix comment in tramp-archive.el --- lisp/net/tramp-archive.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 63c0769e309..24ee6fa51f3 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -109,7 +109,7 @@ (eval-when-compile (require 'cl-lib)) ;; Sometimes, compilation fails with "Variable binding depth exceeds -;; max-specpdl-size". +;; max-specpdl-size". Shall be fixed in Emacs 27. (eval-and-compile (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs))) @@ -320,7 +320,7 @@ arguments to pass to the OPERATION." operation args)) (archive (tramp-archive-file-name-archive filename)) ;; Sometimes, it fails with "Variable binding depth exceeds - ;; max-specpdl-size". + ;; max-specpdl-size". Shall be fixed in Emacs 27. (max-specpdl-size (* 2 max-specpdl-size))) ;; `filename' could be a quoted file name. Or the file From bd64571ef213a4279f897b7446e97ccd76fe4516 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Wed, 20 May 2020 18:02:13 +0000 Subject: [PATCH 28/55] which-function-mode: put hook function on after-change-major-mode-hook , rather than find-file-hook. This keeps which-function-mode active should the major mode be reinitialized. Also accept a null result from add-log-current-defun as definitive, should that function have run. This fixes bug #40714. * lisp/progmodes/which-func.el (which-func-ff-hook): Put on after-change-major-mode-hook. (which-function): Enhance the logic to accept a null result from add-log-current-defun. --- lisp/progmodes/which-func.el | 89 +++++++++++++++++++----------------- 1 file changed, 46 insertions(+), 43 deletions(-) diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el index 1cee552b0c0..266f40abbae 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -186,7 +186,7 @@ and you want to simplify them for the mode line "Non-nil means display current function name in mode line. This makes a difference only if `which-function-mode' is non-nil.") -(add-hook 'find-file-hook 'which-func-ff-hook t) +(add-hook 'after-change-major-mode-hook 'which-func-ff-hook t) (defun which-func-try-to-enable () (unless (or (not which-function-mode) @@ -195,7 +195,7 @@ This makes a difference only if `which-function-mode' is non-nil.") (member major-mode which-func-modes))))) (defun which-func-ff-hook () - "File find hook for Which Function mode. + "`after-change-major-mode-hook' for Which Function mode. It creates the Imenu index for the buffer, if necessary." (which-func-try-to-enable) @@ -282,52 +282,55 @@ If no function name is found, return nil." (when (null name) (setq name (add-log-current-defun))) ;; If Imenu is loaded, try to make an index alist with it. + ;; If `add-log-current-defun' ran and gave nil, accept that. (when (and (null name) - (boundp 'imenu--index-alist) - (or (null imenu--index-alist) - ;; Update if outdated - (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick)) - (null which-function-imenu-failed)) - (ignore-errors (imenu--make-index-alist t)) - (unless imenu--index-alist - (set (make-local-variable 'which-function-imenu-failed) t))) - ;; If we have an index alist, use it. - (when (and (null name) - (boundp 'imenu--index-alist) imenu--index-alist) - (let ((alist imenu--index-alist) - (minoffset (point-max)) - offset pair mark imstack namestack) - ;; Elements of alist are either ("name" . marker), or - ;; ("submenu" ("name" . marker) ... ). The list can be - ;; arbitrarily nested. - (while (or alist imstack) - (if (null alist) - (setq alist (car imstack) - namestack (cdr namestack) - imstack (cdr imstack)) + (null add-log-current-defun-function)) + (when (and (null name) + (boundp 'imenu--index-alist) + (or (null imenu--index-alist) + ;; Update if outdated + (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick)) + (null which-function-imenu-failed)) + (ignore-errors (imenu--make-index-alist t)) + (unless imenu--index-alist + (set (make-local-variable 'which-function-imenu-failed) t))) + ;; If we have an index alist, use it. + (when (and (null name) + (boundp 'imenu--index-alist) imenu--index-alist) + (let ((alist imenu--index-alist) + (minoffset (point-max)) + offset pair mark imstack namestack) + ;; Elements of alist are either ("name" . marker), or + ;; ("submenu" ("name" . marker) ... ). The list can be + ;; arbitrarily nested. + (while (or alist imstack) + (if (null alist) + (setq alist (car imstack) + namestack (cdr namestack) + imstack (cdr imstack)) - (setq pair (car-safe alist) - alist (cdr-safe alist)) + (setq pair (car-safe alist) + alist (cdr-safe alist)) - (cond - ((atom pair)) ; Skip anything not a cons. + (cond + ((atom pair)) ; Skip anything not a cons. - ((imenu--subalist-p pair) - (setq imstack (cons alist imstack) - namestack (cons (car pair) namestack) - alist (cdr pair))) + ((imenu--subalist-p pair) + (setq imstack (cons alist imstack) + namestack (cons (car pair) namestack) + alist (cdr pair))) - ((or (number-or-marker-p (setq mark (cdr pair))) - (and (overlayp mark) - (setq mark (overlay-start mark)))) - (when (and (>= (setq offset (- (point) mark)) 0) - (< offset minoffset)) ; Find the closest item. - (setq minoffset offset - name (if (null which-func-imenu-joiner-function) - (car pair) - (funcall - which-func-imenu-joiner-function - (reverse (cons (car pair) namestack)))))))))))) + ((or (number-or-marker-p (setq mark (cdr pair))) + (and (overlayp mark) + (setq mark (overlay-start mark)))) + (when (and (>= (setq offset (- (point) mark)) 0) + (< offset minoffset)) ; Find the closest item. + (setq minoffset offset + name (if (null which-func-imenu-joiner-function) + (car pair) + (funcall + which-func-imenu-joiner-function + (reverse (cons (car pair) namestack))))))))))))) ;; Filter the name if requested. (when name (if which-func-cleanup-function From 5b66483eadebbd3b1c37a46d2d987637b2872a8e Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Wed, 29 Apr 2020 18:10:35 -0700 Subject: [PATCH 29/55] Prevent gnus-registry-handle-action from creating spurious entries Thanks to Bob Newell for finding this. * lisp/gnus/gnus-registry.el (gnus-registry-handle-action): If a message entry ends up with no groups in its 'group key, that means the entry should be deleted. --- lisp/gnus/gnus-registry.el | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 480ed80ef81..f306889a7fc 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -485,23 +485,25 @@ This is not required after changing `gnus-registry-cache-file'." (when from (setq entry (cons (delete from (assoc 'group entry)) (assq-delete-all 'group entry)))) - - (dolist (kv `((group ,to) - (sender ,sender) - (recipient ,@recipients) - (subject ,subject))) - (when (cadr kv) - (let ((new (or (assq (car kv) entry) - (list (car kv))))) - (dolist (toadd (cdr kv)) - (unless (member toadd new) - (setq new (append new (list toadd))))) - (setq entry (cons new - (assq-delete-all (car kv) entry)))))) - (gnus-message 10 "Gnus registry: new entry for %s is %S" - id - entry) - (gnus-registry-insert db id entry))) + ;; Only keep the entry if the message is going to a new group, or + ;; it's still in some previous group. + (when (or to (alist-get 'group entry)) + (dolist (kv `((group ,to) + (sender ,sender) + (recipient ,@recipients) + (subject ,subject))) + (when (cadr kv) + (let ((new (or (assq (car kv) entry) + (list (car kv))))) + (dolist (toadd (cdr kv)) + (unless (member toadd new) + (setq new (append new (list toadd))))) + (setq entry (cons new + (assq-delete-all (car kv) entry)))))) + (gnus-message 10 "Gnus registry: new entry for %s is %S" + id + entry) + (gnus-registry-insert db id entry)))) ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. From 5989432d15feb4439e759d2c0e28233ca22a7604 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Wed, 20 May 2020 19:02:26 +0000 Subject: [PATCH 30/55] CC Mode: Fix bug #39972, by fixing c-display-defun-name for nested defuns * lisp/progmodes/cc-mode.el (c-common-init): Build add-log-current-defun-function out of c-defun-name-and-limits instead of the former c-defun-name. --- lisp/progmodes/cc-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index d822788bee2..b3b2374805d 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -795,7 +795,7 @@ compatible with old code; callers should always specify it." (set (make-local-variable 'outline-level) 'c-outline-level) (set (make-local-variable 'add-log-current-defun-function) (lambda () - (or (c-cpp-define-name) (c-defun-name)))) + (or (c-cpp-define-name) (car (c-defun-name-and-limits nil))))) (let ((rfn (assq mode c-require-final-newline))) (when rfn (if (boundp 'mode-require-final-newline) From 0eeeedf19574d4370b3bf9e1f751a14e8911f300 Mon Sep 17 00:00:00 2001 From: Alan Third Date: Wed, 20 May 2020 21:23:01 +0100 Subject: [PATCH 31/55] ; * etc/PROBLEMS: Add note about color list issues on macOS. ; Do not merge to master. --- etc/PROBLEMS | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 9e4a631c729..12cfbd0de2f 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -2647,6 +2647,15 @@ If you do, please send it to bug-gnu-emacs@gnu.org so we can list it here. Libxpm is available for macOS as part of the XQuartz project. +** The color list can become corrupt. + +This can be seen when Emacs is run from the command line and produces +output containing the text: + + non-keyed archive cannot be decoded by NSKeyedUnarchiver + +The solution is to delete '$HOME/Library/Colors/Emacs.clr'. + * Build-time problems From 0bfee4b18be9455e33899178fe4ccf2743ea179b Mon Sep 17 00:00:00 2001 From: Matthias Meulien Date: Thu, 21 May 2020 01:37:30 +0300 Subject: [PATCH 32/55] Bookmark locations can refer to VC directory buffers (bug#39722) * etc/NEWS: Document feature. * lisp/vc/vc-dir.el (vc-dir-mode): Set local bookmark-make-record-function. (bookmark-make-record-default, bookmark-prop-get, bookmark-default-handler) (bookmark-get-bookmark-record): Declarations. (vc-dir-bookmark-make-record): Make record used to bookmark a `vc-dir' buffer. (vc-dir-bookmark-jump): Provides bookmark-jump behavior for a `vc-dir' buffer. --- etc/NEWS | 3 +++ lisp/vc/vc-dir.el | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 2cbb7adb0b2..1bf1403cabf 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -139,6 +139,9 @@ directories with the help of new command 'dired-vc-next-action'. *** New commands 'vc-dir-mark-registered-files' (bound to '* r') and 'vc-dir-mark-unregistered-files'. +*** Support for bookmark.el. +Bookmark locations can refer to VC directory buffers. + ** Gnus --- diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 0c9e656add4..a86c37c24ae 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1106,6 +1106,7 @@ the *vc-dir* buffer. (set (make-local-variable 'vc-dir-backend) use-vc-backend) (set (make-local-variable 'desktop-save-buffer) 'vc-dir-desktop-buffer-misc-data) + (setq-local bookmark-make-record-function #'vc-dir-bookmark-make-record) (setq buffer-read-only t) (when (boundp 'tool-bar-map) (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map)) @@ -1465,6 +1466,41 @@ These are the commands available for use in the file status buffer: (add-to-list 'desktop-buffer-mode-handlers '(vc-dir-mode . vc-dir-restore-desktop-buffer)) + +;;; Support for bookmark.el (adapted from what info.el does). + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) +(declare-function bookmark-default-handler "bookmark" (bmk)) +(declare-function bookmark-get-bookmark-record "bookmark" (bmk)) + +(defun vc-dir-bookmark-make-record () + "Make record used to bookmark a `vc-dir' buffer. +This implements the `bookmark-make-record-function' type for +`vc-dir' buffers." + (let* ((bookmark-name + (concat "(" (symbol-name vc-dir-backend) ") " + (file-name-nondirectory + (directory-file-name default-directory)))) + (defaults (list bookmark-name default-directory))) + `(,bookmark-name + ,@(bookmark-make-record-default 'no-file) + (filename . ,default-directory) + (handler . vc-dir-bookmark-jump) + (defaults . ,defaults)))) + +;;;###autoload +(defun vc-dir-bookmark-jump (bmk) + "Provides the bookmark-jump behavior for a `vc-dir' buffer. +This implements the `handler' function interface for the record +type returned by `vc-dir-bookmark-make-record'." + (let* ((file (bookmark-prop-get bmk 'filename)) + (buf (save-window-excursion + (vc-dir file) (current-buffer)))) + (bookmark-default-handler + `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk))))) + (provide 'vc-dir) From cdec3139b9125d2360223fcd1fb0fe1a52595cb7 Mon Sep 17 00:00:00 2001 From: "Ryan C. Thompson" Date: Thu, 21 May 2020 02:21:12 +0300 Subject: [PATCH 33/55] lisp/ido.el: Respect completion-auto-help setting This commit makes ido completion respect the user's setting for `completion-auto-help' by default. It does this by defining a wrapper function `ido-completion-auto-help', which calls `ido-completion-help' only when `completion-auto-help' is non-nil. * lisp/ido.el (ido-completion-auto-help): New function. (ido-cannot-complete-command): Use it as the new default (bug#41340). --- lisp/ido.el | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/lisp/ido.el b/lisp/ido.el index 81883402add..15144f131ba 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -499,11 +499,13 @@ This means that \\[ido-complete] must always be followed by \\[ido-exit-minibuff even when there is only one unique completion." :type 'boolean) -(defcustom ido-cannot-complete-command 'ido-completion-help +(defcustom ido-cannot-complete-command 'ido-completion-auto-help "Command run when `ido-complete' can't complete any more. The most useful values are `ido-completion-help', which pops up a -window with completion alternatives, or `ido-next-match' or -`ido-prev-match', which cycle the buffer list." +window with completion alternatives; `ido-completion-auto-help', +which does the same but respects the value of +`completion-auto-help'; or `ido-next-match' or `ido-prev-match', +which cycle the buffer list." :type 'function) @@ -3926,6 +3928,14 @@ If `ido-change-word-sub' cannot be found in WORD, return nil." (when (bobp) (next-completion 1))))) +(defun ido-completion-auto-help () + "Call `ido-completion-help' if `completion-auto-help' is non-nil." + (interactive) + ;; Note: `completion-auto-help' could also be `lazy', but this value + ;; is irrelevant to ido, which is fundamentally eager, so it is + ;; treated the same as t. + (when completion-auto-help + (ido-completion-help))) (defun ido-completion-help () "Show possible completions in the `ido-completion-buffer'." From 8cc453d788883bccc2d86d5bc89e644ecd48eb9a Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Wed, 20 May 2020 00:43:40 +0200 Subject: [PATCH 34/55] Second attempt at improving indexing in control.texi * doc/lispref/control.texi (Processing of Errors): Improve indexing by adding the word form "handle" in addition to "handling". With thanks to Eli Zaretskii. --- doc/lispref/control.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 7755cbb5f25..58f93366fe9 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -1867,7 +1867,6 @@ concept of continuable errors. @node Processing of Errors @subsubsection How Emacs Processes Errors @cindex processing of errors -@cindex handle errors When an error is signaled, @code{signal} searches for an active @dfn{handler} for the error. A handler is a sequence of Lisp @@ -1906,6 +1905,7 @@ variables precisely as they were at the time of the error. @subsubsection Writing Code to Handle Errors @cindex error handler @cindex handling errors +@cindex handle Lisp errors @cindex forms for handling errors The usual effect of signaling an error is to terminate the command From d714aa753b744c903d149a1f6c69262d958c313e Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Thu, 21 May 2020 12:23:19 +0100 Subject: [PATCH 35/55] ; Bump defcustom :version in last change * lisp/ido.el (ido-cannot-complete-command): Bump defcustom :version after default value was changed. --- lisp/ido.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/ido.el b/lisp/ido.el index 15144f131ba..5716c6ff442 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -499,13 +499,14 @@ This means that \\[ido-complete] must always be followed by \\[ido-exit-minibuff even when there is only one unique completion." :type 'boolean) -(defcustom ido-cannot-complete-command 'ido-completion-auto-help +(defcustom ido-cannot-complete-command #'ido-completion-auto-help "Command run when `ido-complete' can't complete any more. The most useful values are `ido-completion-help', which pops up a window with completion alternatives; `ido-completion-auto-help', which does the same but respects the value of -`completion-auto-help'; or `ido-next-match' or `ido-prev-match', +`completion-auto-help'; and `ido-next-match' or `ido-prev-match', which cycle the buffer list." + :version "28.1" :type 'function) From 62a5e890d72de11263996b25c1a7256423d22a7b Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 18 May 2020 15:19:49 -0700 Subject: [PATCH 36/55] Redo RCS Id for pdumper MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/version.el: Don’t put an RCS Id style string into the executable via purecopy, as this does not work with the pdumper. * src/emacs.c (RCS_Id): New constant, for 'ident'. (cherry picked from commit 3d1bcfba5e21b29be8669aa2a8f27b344c9e02fd) --- lisp/version.el | 4 ---- src/emacs.c | 5 +++++ 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/lisp/version.el b/lisp/version.el index 012cb2175ee..bf666cbff99 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -163,8 +163,4 @@ correspond to the running Emacs. Optional argument DIR is a directory to use instead of `source-directory'." (emacs-repository-branch-git (or dir source-directory))) -;; We put version info into the executable in the form that `ident' uses. -(purecopy (concat "\n$Id: " (subst-char-in-string ?\n ?\s (emacs-version)) - " $\n")) - ;;; version.el ends here diff --git a/src/emacs.c b/src/emacs.c index c5a760d29f6..db3e92a4773 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -124,6 +124,11 @@ static const char emacs_version[] = PACKAGE_VERSION; static const char emacs_copyright[] = COPYRIGHT; static const char emacs_bugreport[] = PACKAGE_BUGREPORT; +/* Put version info into the executable in the form that 'ident' uses. */ +char const EXTERNALLY_VISIBLE RCS_Id[] + = "$Id" ": GNU Emacs " PACKAGE_VERSION + " (" EMACS_CONFIGURATION " " EMACS_CONFIG_FEATURES ") $"; + /* Empty lisp strings. To avoid having to build any others. */ Lisp_Object empty_unibyte_string, empty_multibyte_string; From c0aa2f2abf732ddb9d1f393c5989b14e047d63d7 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Wed, 20 May 2020 19:02:26 +0000 Subject: [PATCH 37/55] CC Mode: Fix bug #39972, by fixing c-display-defun-name for nested defuns * lisp/progmodes/cc-mode.el (c-common-init): Build add-log-current-defun-function out of c-defun-name-and-limits instead of the former c-defun-name. --- lisp/progmodes/cc-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index fd7750b0d82..066bec60091 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -770,7 +770,7 @@ compatible with old code; callers should always specify it." (set (make-local-variable 'outline-level) 'c-outline-level) (set (make-local-variable 'add-log-current-defun-function) (lambda () - (or (c-cpp-define-name) (c-defun-name)))) + (or (c-cpp-define-name) (car (c-defun-name-and-limits nil))))) (let ((rfn (assq mode c-require-final-newline))) (when rfn (if (boundp 'mode-require-final-newline) From 3f082af536c33ba713561e7ad4b691aaad488701 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 16 May 2020 13:23:48 +0100 Subject: [PATCH 38/55] 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 "{}". --- etc/NEWS | 9 + lisp/json.el | 570 +++++++++++++------------- lisp/jsonrpc.el | 48 ++- lisp/progmodes/python.el | 21 +- test/lisp/json-tests.el | 857 ++++++++++++++++++++++++++++++++------- 5 files changed, 1055 insertions(+), 450 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 1bf1403cabf..4533dc46c56 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 6f3b791ed17..9002e868537 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-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) -(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) +(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. +(rx-define json--number + (: (? ?-) ; Sign. + (| (: (in "1-9") (* digit)) ?0) ; Integer. + (? ?. (+ digit)) ; Fraction. + (? (in "Ee") (? (in ?+ ?-)) (+ digit)))) ; Exponent. -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))))))) +(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))))) + (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 +;;; 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 293dfaa7483..42e7701af18 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))))) +(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.") -(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-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 67383b34154..1ca9f019638 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 ac9706a8ae7..a0e8c87c7b3 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))))) + (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-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)) +(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}")))) + (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 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-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)) + (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-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-plist () - (let ((plist '(:a 1 :b 2)) + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode plist) "{\"a\":1,\"b\":2}")))) + (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-with-sort-predicate () - (let ((plist '(:c 3 :a 1 :b 2)) - (json-encoding-object-sort-predicate 'string<) - (json-encoding-pretty-print nil)) - (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}")))) +(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-alist-with-sort-predicate () - (let ((alist '((:c . 3) (:a . 1) (:b . 2))) - (json-encoding-object-sort-predicate 'string<) +(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)) - (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}")))) + (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 From 3a7894ecd11c66337e7aea8ade8f47673d290a24 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Wed, 6 May 2020 18:02:32 +0100 Subject: [PATCH 39/55] 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. --- etc/NEWS | 18 +++++++++++ lisp/net/eww.el | 30 +++++++++--------- lisp/net/shr.el | 84 +++++++++++++++++++++---------------------------- 3 files changed, 70 insertions(+), 62 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 4533dc46c56..eb73bd64e05 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 a6c1abdbb19..2a70560ca7b 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 1f80ab74db5..03260c9e70a 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 From 813e42c63bcd9f285daae6737c4ae7a9adae90d7 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Fri, 22 May 2020 03:37:56 +0300 Subject: [PATCH 40/55] 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. --- lisp/ido.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/ido.el b/lisp/ido.el index 5716c6ff442..ad71d468cb4 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) From 5044c19001fe608f2eac621add2e05cbca6c804b Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 23 May 2020 04:38:27 +0300 Subject: [PATCH 41/55] 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. --- lisp/cedet/ede.el | 7 +++- lisp/progmodes/project.el | 78 ++++++++++++++++++++------------------- lisp/progmodes/xref.el | 4 +- 3 files changed, 48 insertions(+), 41 deletions(-) diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el index 8c336117c92..41252815734 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 41e34a37507..c72e9d94b1c 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-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))) + (cl-defgeneric project-roots (project) - "Return the list of directory roots of the current project. + "Return the list containing the current project root. -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. - -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 7d1ee705b80..2477884f1ab 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) From c67f8f298a21be61362d049cfff5273f7d010d75 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 23 May 2020 05:08:06 +0300 Subject: [PATCH 42/55] Implement 'mark-resolved' for the Git backend * lisp/vc/vc-git.el (vc-git-mark-resolved): New function. --- lisp/vc/vc-git.el | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2caa287bce2..dcb52282656 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] From cde0589818ec1d8d663c707d1d8af19a9d8b0752 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 22 May 2020 23:36:57 -0400 Subject: [PATCH 43/55] * lisp/doc-view.el (doc-view-presentation): Fix thinko --- lisp/doc-view.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 3cac2629a9c..de342f1519e 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 From b4a151918917de2be8b3958d5b59d16c8e3f457e Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sat, 23 May 2020 07:32:10 +0200 Subject: [PATCH 44/55] 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. --- lisp/obsolete/levents.el | 292 --------------------------------------- 1 file changed, 292 deletions(-) delete mode 100644 lisp/obsolete/levents.el diff --git a/lisp/obsolete/levents.el b/lisp/obsolete/levents.el deleted file mode 100644 index 2ae1ca48d16..00000000000 --- 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 From a10254dd46da920d14dd990714d0f21fd508d07d Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 May 2020 08:50:22 +0300 Subject: [PATCH 45/55] Fix accessing files on networked drives on MS-Windows * src/w32.c (acl_get_file): Set errno to ENOTSUP if get_file_security returns ERROR_NOT_SUPPORTED. (Bug#41463) --- src/w32.c | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/w32.c b/src/w32.c index 62c53fd7711..78e75f0937e 100644 --- a/src/w32.c +++ b/src/w32.c @@ -6398,7 +6398,15 @@ acl_get_file (const char *fname, acl_type_t type) if (!get_file_security (fname, si, psd, sd_len, &sd_len)) { xfree (psd); - errno = EIO; + err = GetLastError (); + if (err == ERROR_NOT_SUPPORTED) + errno = ENOTSUP; + else if (err == ERROR_FILE_NOT_FOUND + || err == ERROR_PATH_NOT_FOUND + || err == ERROR_INVALID_NAME) + errno = ENOENT; + else + errno = EIO; psd = NULL; } } @@ -6409,6 +6417,8 @@ acl_get_file (const char *fname, acl_type_t type) be encoded in the current ANSI codepage. */ || err == ERROR_INVALID_NAME) errno = ENOENT; + else if (err == ERROR_NOT_SUPPORTED) + errno = ENOTSUP; else errno = EIO; } From 13b6dfd4f767a6ce2b01a519fe412dbf80f4921e Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 May 2020 10:33:35 +0300 Subject: [PATCH 46/55] * doc/emacs/killing.texi (Rectangles): Improve indexing. --- doc/emacs/killing.texi | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi index 834a5c6159d..6b1f35e6158 100644 --- a/doc/emacs/killing.texi +++ b/doc/emacs/killing.texi @@ -727,6 +727,8 @@ them. Rectangle commands are useful with text in multicolumn formats, and for changing text into or out of such formats. @cindex mark rectangle +@cindex region-rectangle +@cindex rectangular region To specify a rectangle for a command to work on, set the mark at one corner and point at the opposite corner. The rectangle thus specified is called the @dfn{region-rectangle}. If point and the mark are in From fb2e34cd2155cbaaf945d8cd167b600b55b9edff Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 May 2020 10:59:39 +0300 Subject: [PATCH 47/55] ; * etc/TODO (Ligatures): Update the entry based on recent discussions. --- etc/TODO | 33 +++++++++++++++++++++++++-------- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/etc/TODO b/etc/TODO index f983fa27d33..c11848e0c5d 100644 --- a/etc/TODO +++ b/etc/TODO @@ -220,10 +220,23 @@ https://lists.gnu.org/r/emacs-devel/2013-11/msg00515.html width fonts. However, more features are still needed to achieve this. ** Support ligatures out of the box -For the list of typographical ligatures, see +For the list of frequently-used typographical ligatures, see https://en.wikipedia.org/wiki/Orthographic_ligature#Ligatures_in_Unicode_(Latin_alphabets) +(Note that in general, the number of possible ligatures can be much +larger, and there's no way, in principle, to specify the superset of +all the ligatures that could exist. Each font can support different +ligatures. The reliable way of supporting any and all ligatures is to +hand all text to be displayed to the shaping engine and get back the +font glyphs to display that text. However, doing this is impossible +with the current design of the Emacs display engine, since it examines +buffer text one character at a time, and implements character +composition by calls to Lisp, which makes doing this for every +character impractically slow. therefore, the rest of this item +describes a limited form of ligature support which is compatible with +the current display engine design and uses automatic compositions.) + For Text and derived modes, the job is to figure out which ligatures we want to support, how to let the user customize that, and probably define a minor mode for automatic ligation (as some contexts might not @@ -237,12 +250,12 @@ prettify-symbols-mode. We need to figure out which ligatures are needed for each programming language, and provide user options to turn this on and off. -The implementation should use the infrastructure for character -compositions, i.e., we should define appropriate regexp-based rules -for character sequences that need to be composed into ligatures, and -populate composition-function-table with those rules. See -composite.el for examples of this, and also grep lisp/language/*.el -for references to composition-function-table. +The implementation should use the infrastructure for automatic +character compositions, i.e., we should define appropriate +regexp-based rules for character sequences that need to be composed +into ligatures, and populate composition-function-table with those +rules. See composite.el for examples of this, and also grep +lisp/language/*.el for references to composition-function-table. One problem with character compositions that will need to be solved is that composition-function-table, the char-table which holds the @@ -259,7 +272,11 @@ way of preventing the ligation from happening. One possibility is to have a ZWNJ character separate these ASCII characters; another possibility is to introduce a special text property that prevents character composition, and place that property on the relevant parts -of the mode line. +of the mode line. Yet another possibility would be to write a +specialized composition function, which would detect that it is called +on mode-line strings, and return nil to signal that composition is not +possible in this case; then use that function in the rules for +ligatures stored in composition-function-table. The prettify-symbols-mode should be deprecated once ligature support is in place. From c7737d40f2ae9f8459508e9d07cd7aa5f1ea78b6 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 May 2020 11:01:09 +0300 Subject: [PATCH 48/55] ; * etc/TODO (Ligatures): Update the entry based on recent discussions. --- etc/TODO | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/etc/TODO b/etc/TODO index c11848e0c5d..0f908def768 100644 --- a/etc/TODO +++ b/etc/TODO @@ -233,7 +233,7 @@ font glyphs to display that text. However, doing this is impossible with the current design of the Emacs display engine, since it examines buffer text one character at a time, and implements character composition by calls to Lisp, which makes doing this for every -character impractically slow. therefore, the rest of this item +character impractically slow. Therefore, the rest of this item describes a limited form of ligature support which is compatible with the current display engine design and uses automatic compositions.) From d7fc6bd17c2cdbd6a24b808223fa5bf9af9bb352 Mon Sep 17 00:00:00 2001 From: Chris McMahan Date: Tue, 5 May 2020 14:15:01 -0400 Subject: [PATCH 49/55] 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) --- lisp/emacs-lisp/package.el | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ecf833b5473..9a6d1d7319d 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)) From 232bb691c1095574b85b358c7f33a46d2ea79f29 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 May 2020 11:19:54 +0300 Subject: [PATCH 50/55] ; * etc/NEWS: Mention new customization options for package.el. --- etc/NEWS | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index eb73bd64e05..32b59cb76fc 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 +++ From f8581bcf6a1942ebd331cae20e32945a3a86a3d1 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 23 May 2020 13:56:09 +0200 Subject: [PATCH 51/55] Reject invalid characters in XML strings (Bug#41094). * lisp/xml.el (xml-escape-string): Search for invalid characters. (xml-invalid-character): New error symbol. * test/lisp/xml-tests.el (xml-print-invalid-cdata): New unit test. * etc/NEWS: Document new behavior. --- etc/NEWS | 7 +++++++ lisp/xml.el | 13 ++++++++++++- test/lisp/xml-tests.el | 10 ++++++++++ 3 files changed, 29 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 32b59cb76fc..efad273da6c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -393,6 +393,13 @@ 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. +** xml.el + +*** XML serialization functions now reject invalid characters. +Previously 'xml-print' would produce invalid XML when given a string +with characters that are not valid in XML (see +https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. + * New Modes and Packages in Emacs 28.1 diff --git a/lisp/xml.el b/lisp/xml.el index dc774a202cf..767cf042846 100644 --- a/lisp/xml.el +++ b/lisp/xml.el @@ -1023,9 +1023,17 @@ entity references (e.g., replace each & with &). XML character data must not contain & or < characters, nor the > character under some circumstances. The XML spec does not impose restriction on \" or \\=', but we just substitute for these too -\(as is permitted by the spec)." +\(as is permitted by the spec). + +If STRING contains characters that are invalid in XML (as defined +by https://www.w3.org/TR/xml/#charsets), signal an error of type +`xml-invalid-character'." (with-temp-buffer (insert string) + (goto-char (point-min)) + (when (re-search-forward + "[^\u0009\u000A\u000D\u0020-\uD7FF\uE000-\uFFFD\U00010000-\U0010FFFF]") + (signal 'xml-invalid-character (list (char-before) (match-beginning 0)))) (dolist (substitution '(("&" . "&") ("<" . "<") (">" . ">") @@ -1036,6 +1044,9 @@ restriction on \" or \\=', but we just substitute for these too (replace-match (cdr substitution) t t nil))) (buffer-string))) +(define-error 'xml-invalid-character "Invalid XML character" + 'wrong-type-argument) + (defun xml-debug-print-internal (xml indent-string) "Outputs the XML tree in the current buffer. The first line is indented with INDENT-STRING." diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el index 57e685cd347..72c78d00e3e 100644 --- a/test/lisp/xml-tests.el +++ b/test/lisp/xml-tests.el @@ -164,6 +164,16 @@ Parser is called with and without 'symbol-qnames argument.") (should (equal (cdr xml-parse-test--namespace-attribute-qnames) (xml-parse-region nil nil nil nil 'symbol-qnames))))) +(ert-deftest xml-print-invalid-cdata () + "Check that Bug#41094 is fixed." + (with-temp-buffer + (should (equal (should-error (xml-print '((foo () "\0"))) + :type 'xml-invalid-character) + '(xml-invalid-character 0 1))) + (should (equal (should-error (xml-print '((foo () "\u00FF \xFF"))) + :type 'xml-invalid-character) + '(xml-invalid-character #x3FFFFF 3))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: From 1a6d59eebaff919b38792450edfae7912f6639b3 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 May 2020 15:14:27 +0300 Subject: [PATCH 52/55] Improve the documentation of setting up fontsets * doc/lispref/display.texi (Fontsets): Improve the accuracy of a cross-reference to "Character Properties". * doc/emacs/mule.texi (Fontsets, Modifying Fontsets): Improve the documentation of fontsets and how to modify them. --- doc/emacs/mule.texi | 88 +++++++++++++++++++++++++++++----------- doc/lispref/display.texi | 6 +-- 2 files changed, 68 insertions(+), 26 deletions(-) diff --git a/doc/emacs/mule.texi b/doc/emacs/mule.texi index e3fe20c76f8..373c7b55817 100644 --- a/doc/emacs/mule.texi +++ b/doc/emacs/mule.texi @@ -1326,16 +1326,17 @@ stored in the system and the available font names are defined by the system, fontsets are defined within Emacs itself. Once you have defined a fontset, you can use it within Emacs by specifying its name, anywhere that you could use a single font. Of course, Emacs fontsets -can use only the fonts that the system supports. If some characters +can use only the fonts that your system supports. If some characters appear on the screen as empty boxes or hex codes, this means that the fontset in use for them has no font for those characters. In this case, or if the characters are shown, but not as well as you would -like, you may need to install extra fonts. Your operating system may -have optional fonts that you can install; or you can install the GNU -Intlfonts package, which includes fonts for most supported -scripts.@footnote{If you run Emacs on X, you may need to inform the X -server about the location of the newly installed fonts with commands -such as: +like, you may need to install extra fonts or modify the fontset to use +specific fonts already installed on your system (see below). Your +operating system may have optional fonts that you can install; or you +can install the GNU Intlfonts package, which includes fonts for most +supported scripts.@footnote{If you run Emacs on X, you may need to +inform the X server about the location of the newly installed fonts +with commands such as: @c FIXME? I feel like this may be out of date. @c E.g., the intlfonts tarfile is ~ 10 years old. @@ -1376,14 +1377,20 @@ explicitly requested, despite its name. @w{@kbd{M-x describe-fontset}} command. It prompts for a fontset name, defaulting to the one used by the current frame, and then displays all the subranges of characters and the fonts assigned to -them in that fontset. +them in that fontset. To see which fonts Emacs is using in a session +started without a specific fontset (which is what happens normally), +type @kbd{fontset-default @key{RET}} at the prompt, or just +@kbd{@key{RET}} to describe the fontset used by the current frame. A fontset does not necessarily specify a font for every character code. If a fontset specifies no font for a certain character, or if it specifies a font that does not exist on your system, then it cannot display that character properly. It will display that character as a -hex code or thin space or an empty box instead. (@xref{Text Display, , -glyphless characters}, for details.) +hex code or thin space or an empty box instead. (@xref{Text Display, +, glyphless characters}, for details.) Or a fontset might specify a +font for some range of characters, but you may not like their visual +appearance. If this happens, you may wish to modify your fontset; see +@ref{Modifying Fontsets}, for how to do that. @node Defining Fontsets @section Defining Fontsets @@ -1542,10 +1549,10 @@ call this function explicitly to create a fontset. Fontsets do not always have to be created from scratch. If only minor changes are required it may be easier to modify an existing -fontset. Modifying @samp{fontset-default} will also affect other -fontsets that use it as a fallback, so can be an effective way of -fixing problems with the fonts that Emacs chooses for a particular -script. +fontset, usually @samp{fontset-default}. Modifying +@samp{fontset-default} will also affect other fontsets that use it as +a fallback, so can be an effective way of fixing problems with the +fonts that Emacs chooses for a particular script. Fontsets can be modified using the function @code{set-fontset-font}, specifying a character, a charset, a script, or a range of characters @@ -1553,26 +1560,61 @@ to modify the font for, and a font specification for the font to be used. Some examples are: @example -;; Use Liberation Mono for latin-3 charset. -(set-fontset-font "fontset-default" 'iso-8859-3 - "Liberation Mono") - ;; Prefer a big5 font for han characters. (set-fontset-font "fontset-default" 'han (font-spec :registry "big5") nil 'prepend) -;; Use DejaVu Sans Mono as a fallback in fontset-startup -;; before resorting to fontset-default. -(set-fontset-font "fontset-startup" nil "DejaVu Sans Mono" - nil 'append) - ;; Use MyPrivateFont for the Unicode private use area. (set-fontset-font "fontset-default" '(#xe000 . #xf8ff) "MyPrivateFont") +;; Use Liberation Mono for latin-3 charset. +(set-fontset-font "fontset-default" 'iso-8859-3 + "Liberation Mono") + +;; Use DejaVu Sans Mono as a fallback in fontset-startup +;; before resorting to fontset-default. +(set-fontset-font "fontset-startup" nil "DejaVu Sans Mono" + nil 'append) @end example +@noindent +@xref{Fontsets, , , elisp, GNU Emacs Lisp Reference Manual}, for more +details about using the @code{set-fontset-font} function. + +@cindex script of a character +@cindex codepoint of a character +If you don't know the character's codepoint or the script to which it +belongs, you can ask Emacs. With point at the character, type +@w{@kbd{C-u C-x =}} (@code{what-cursor-position}), and this +information, together with much more, will be displayed in the +@file{*Help*} buffer that Emacs pops up. @xref{Position Info}. For +example, Japanese characters belong to the @samp{kana} script, but +Japanese text also mixes them with Chinese characters so the following +uses the @samp{han} script to set up Emacs to use the @samp{Kochi +Gothic} font for Japanese text: + +@example +(set-fontset-font "fontset-default" 'han "Kochi Gothic") +@end example + +@noindent +@cindex CKJ characters +(For convenience, the @samp{han} script in Emacs is set up to support +all of the Chinese, Japanese, and Korean, a.k.a.@: @acronym{CJK}, +characters, not just Chinese characters.) + +@vindex script-representative-chars +For the list of known scripts, see the variable +@code{script-representative-chars}. + +Fontset settings like those above only affect characters that the +default font doesn't support, so if the @samp{Kochi Gothic} font +covers Latin characters, it will not be used for displaying Latin +scripts, since the default font used by Emacs usually covers Basic +Latin. + @cindex ignore font @cindex fonts, how to ignore @vindex face-ignored-fonts diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index e655f2f0cae..588e2217b9b 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -3600,9 +3600,9 @@ characters in the range @var{from} and @var{to} (inclusive). @var{character} may be a charset (@pxref{Character Sets}). In that case, use @var{font-spec} for all the characters in the charset. -@var{character} may be a script name (@pxref{Character Properties}). -In that case, use @var{font-spec} for all the characters belonging to -the script. +@var{character} may be a script name (@pxref{Character Properties, +char-script-table}). In that case, use @var{font-spec} for all the +characters belonging to the script. @var{character} may be @code{nil}, which means to use @var{font-spec} for any character which no font-spec is specified. From d6a0b66a0cf44389c7474a60dd23cbf666e78537 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 23 May 2020 09:33:41 -0400 Subject: [PATCH 53/55] * lisp/subr.el (save-match-data): Clarify use in docstring --- lisp/subr.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/subr.el b/lisp/subr.el index 33194e4ffa2..2b3231b879b 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4088,7 +4088,11 @@ MODES is as for `set-default-file-modes'." ;; now, but it generates slower code. (defmacro save-match-data (&rest body) "Execute the BODY forms, restoring the global value of the match data. -The value returned is the value of the last form in BODY." +The value returned is the value of the last form in BODY. +NOTE: The convention in Elisp is that any function, except for a few +exceptions like car/assoc/+/goto-char, can clobber the match data, +so `save-match-data' should normally be used to save *your* match data +rather than your caller's match data." ;; It is better not to use backquote here, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. From 9e977c497257ff13bfb2579f8a14ca9b43791115 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 23 May 2020 10:38:53 -0700 Subject: [PATCH 54/55] Restore check for Emacs 20.2 bytecodes * src/eval.c (Ffetch_bytecode): Check for multibyte bytecodes here too. Problem reported by Stefan Monnier in: https://lists.gnu.org/r/emacs-devel/2020-05/msg02876.html --- src/eval.c | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/eval.c b/src/eval.c index be2af2d041b..959adea6467 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3202,7 +3202,19 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, else error ("Invalid byte code"); } - ASET (object, COMPILED_BYTECODE, XCAR (tem)); + + Lisp_Object bytecode = XCAR (tem); + if (STRING_MULTIBYTE (bytecode)) + { + /* BYTECODE must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and now + such a byte-code string is loaded as multibyte with raw 8-bit + characters converted to multibyte form. Convert them back to + the original unibyte form. */ + bytecode = Fstring_as_unibyte (bytecode); + } + + ASET (object, COMPILED_BYTECODE, bytecode); ASET (object, COMPILED_CONSTANTS, XCDR (tem)); } } From e021c2dc2279e0fd3a5331f9ea661e4d39c2e840 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 23 May 2020 12:55:13 -0700 Subject: [PATCH 55/55] Port etags FALLTHROUGH to C2X Problem reported by Ashish SHUKLA in: https://lists.gnu.org/r/emacs-devel/2020-05/msg03013.html * lib-src/etags.c (C_entries): Move label so that FALLTHROUGH precedes a case label, as draft C2X specifies. --- lib-src/etags.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib-src/etags.c b/lib-src/etags.c index eee2c596262..4672e3491da 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -4197,9 +4197,9 @@ C_entries (int c_ext, FILE *inf) break; } FALLTHROUGH; - resetfvdef: case '#': case '~': case '&': case '%': case '/': case '|': case '^': case '!': case '.': case '?': + resetfvdef: if (definedef != dnone) break; /* These surely cannot follow a function tag in C. */