aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorAndrea Corallo2020-05-24 10:20:23 +0100
committerAndrea Corallo2020-05-24 10:20:23 +0100
commit9daffe9cfe82d3b1e1e9fa8929dbb40cfed60f0f (patch)
treec9e78cbb4e151dc3c3996a65cf1eedab19248fb4
parentf5dceed09a8234548d5b3acb76d443569533cab9 (diff)
parente021c2dc2279e0fd3a5331f9ea661e4d39c2e840 (diff)
downloademacs-9daffe9cfe82d3b1e1e9fa8929dbb40cfed60f0f.tar.gz
emacs-9daffe9cfe82d3b1e1e9fa8929dbb40cfed60f0f.zip
Merge remote-tracking branch 'savannah/master' into HEAD
-rw-r--r--doc/emacs/killing.texi2
-rw-r--r--doc/emacs/mule.texi84
-rw-r--r--doc/lispintro/emacs-lisp-intro.texi5
-rw-r--r--doc/lispref/control.texi1
-rw-r--r--doc/lispref/display.texi6
-rw-r--r--doc/lispref/elisp.texi2
-rw-r--r--doc/lispref/eval.texi21
-rw-r--r--doc/lispref/lists.texi16
-rw-r--r--doc/lispref/objects.texi93
-rw-r--r--doc/lispref/sequences.texi25
-rw-r--r--doc/lispref/strings.texi11
-rw-r--r--etc/NEWS47
-rw-r--r--etc/TODO64
-rw-r--r--lib-src/etags.c2
-rw-r--r--lisp/calculator.el10
-rw-r--r--lisp/cedet/ede.el7
-rw-r--r--lisp/doc-view.el4
-rw-r--r--lisp/emacs-lisp/package.el28
-rw-r--r--lisp/emacs-lisp/syntax.el35
-rw-r--r--lisp/gnus/gnus-art.el14
-rw-r--r--lisp/gnus/gnus-registry.el36
-rw-r--r--lisp/ido.el19
-rw-r--r--lisp/json.el576
-rw-r--r--lisp/jsonrpc.el50
-rw-r--r--lisp/language/tibet-util.el14
-rw-r--r--lisp/mouse.el2
-rw-r--r--lisp/net/eww.el30
-rw-r--r--lisp/net/shr.el84
-rw-r--r--lisp/net/tramp-archive.el7
-rw-r--r--lisp/net/tramp-rclone.el13
-rw-r--r--lisp/net/webjump.el5
-rw-r--r--lisp/obsolete/levents.el292
-rw-r--r--lisp/org/org-agenda.el5
-rw-r--r--lisp/password-cache.el3
-rw-r--r--lisp/progmodes/cc-langs.el10
-rw-r--r--lisp/progmodes/cc-mode.el2
-rw-r--r--lisp/progmodes/project.el153
-rw-r--r--lisp/progmodes/python.el21
-rw-r--r--lisp/progmodes/which-func.el97
-rw-r--r--lisp/progmodes/xref.el4
-rw-r--r--lisp/subr.el6
-rw-r--r--lisp/vc/vc-dir.el36
-rw-r--r--lisp/vc/vc-git.el4
-rw-r--r--lisp/vc/vc-hooks.el2
-rw-r--r--lisp/version.el4
-rw-r--r--lisp/xml.el13
-rw-r--r--src/alloc.c53
-rw-r--r--src/buffer.c40
-rw-r--r--src/bytecode.c28
-rw-r--r--src/emacs.c5
-rw-r--r--src/eval.c62
-rw-r--r--src/fns.c51
-rw-r--r--src/lisp.h2
-rw-r--r--src/lread.c26
-rw-r--r--src/w32.c12
-rw-r--r--test/lisp/electric-tests.el18
-rw-r--r--test/lisp/emacs-lisp/syntax-tests.el67
-rw-r--r--test/lisp/json-tests.el865
-rw-r--r--test/lisp/net/webjump-tests.el73
-rw-r--r--test/lisp/xml-tests.el10
-rw-r--r--test/src/buffer-tests.el6
61 files changed, 2064 insertions, 1219 deletions
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,
727and for changing text into or out of such formats. 727and for changing text into or out of such formats.
728 728
729@cindex mark rectangle 729@cindex mark rectangle
730@cindex region-rectangle
731@cindex rectangular region
730 To specify a rectangle for a command to work on, set the mark at one 732 To specify a rectangle for a command to work on, set the mark at one
731corner and point at the opposite corner. The rectangle thus specified 733corner and point at the opposite corner. The rectangle thus specified
732is called the @dfn{region-rectangle}. If point and the mark are in 734is called the @dfn{region-rectangle}. If point and the mark are in
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
1326system, fontsets are defined within Emacs itself. Once you have 1326system, fontsets are defined within Emacs itself. Once you have
1327defined a fontset, you can use it within Emacs by specifying its name, 1327defined a fontset, you can use it within Emacs by specifying its name,
1328anywhere that you could use a single font. Of course, Emacs fontsets 1328anywhere that you could use a single font. Of course, Emacs fontsets
1329can use only the fonts that the system supports. If some characters 1329can use only the fonts that your system supports. If some characters
1330appear on the screen as empty boxes or hex codes, this means that the 1330appear on the screen as empty boxes or hex codes, this means that the
1331fontset in use for them has no font for those characters. In this 1331fontset in use for them has no font for those characters. In this
1332case, or if the characters are shown, but not as well as you would 1332case, or if the characters are shown, but not as well as you would
1333like, you may need to install extra fonts. Your operating system may 1333like, you may need to install extra fonts or modify the fontset to use
1334have optional fonts that you can install; or you can install the GNU 1334specific fonts already installed on your system (see below). Your
1335Intlfonts package, which includes fonts for most supported 1335operating system may have optional fonts that you can install; or you
1336scripts.@footnote{If you run Emacs on X, you may need to inform the X 1336can install the GNU Intlfonts package, which includes fonts for most
1337server about the location of the newly installed fonts with commands 1337supported scripts.@footnote{If you run Emacs on X, you may need to
1338such as: 1338inform the X server about the location of the newly installed fonts
1339with commands such as:
1339@c FIXME? I feel like this may be out of date. 1340@c FIXME? I feel like this may be out of date.
1340@c E.g., the intlfonts tarfile is ~ 10 years old. 1341@c E.g., the intlfonts tarfile is ~ 10 years old.
1341 1342
@@ -1376,14 +1377,20 @@ explicitly requested, despite its name.
1376@w{@kbd{M-x describe-fontset}} command. It prompts for a fontset 1377@w{@kbd{M-x describe-fontset}} command. It prompts for a fontset
1377name, defaulting to the one used by the current frame, and then 1378name, defaulting to the one used by the current frame, and then
1378displays all the subranges of characters and the fonts assigned to 1379displays all the subranges of characters and the fonts assigned to
1379them in that fontset. 1380them in that fontset. To see which fonts Emacs is using in a session
1381started without a specific fontset (which is what happens normally),
1382type @kbd{fontset-default @key{RET}} at the prompt, or just
1383@kbd{@key{RET}} to describe the fontset used by the current frame.
1380 1384
1381 A fontset does not necessarily specify a font for every character 1385 A fontset does not necessarily specify a font for every character
1382code. If a fontset specifies no font for a certain character, or if 1386code. If a fontset specifies no font for a certain character, or if
1383it specifies a font that does not exist on your system, then it cannot 1387it specifies a font that does not exist on your system, then it cannot
1384display that character properly. It will display that character as a 1388display that character properly. It will display that character as a
1385hex code or thin space or an empty box instead. (@xref{Text Display, , 1389hex code or thin space or an empty box instead. (@xref{Text Display,
1386glyphless characters}, for details.) 1390, glyphless characters}, for details.) Or a fontset might specify a
1391font for some range of characters, but you may not like their visual
1392appearance. If this happens, you may wish to modify your fontset; see
1393@ref{Modifying Fontsets}, for how to do that.
1387 1394
1388@node Defining Fontsets 1395@node Defining Fontsets
1389@section Defining Fontsets 1396@section Defining Fontsets
@@ -1542,10 +1549,10 @@ call this function explicitly to create a fontset.
1542 1549
1543 Fontsets do not always have to be created from scratch. If only 1550 Fontsets do not always have to be created from scratch. If only
1544minor changes are required it may be easier to modify an existing 1551minor changes are required it may be easier to modify an existing
1545fontset. Modifying @samp{fontset-default} will also affect other 1552fontset, usually @samp{fontset-default}. Modifying
1546fontsets that use it as a fallback, so can be an effective way of 1553@samp{fontset-default} will also affect other fontsets that use it as
1547fixing problems with the fonts that Emacs chooses for a particular 1554a fallback, so can be an effective way of fixing problems with the
1548script. 1555fonts that Emacs chooses for a particular script.
1549 1556
1550Fontsets can be modified using the function @code{set-fontset-font}, 1557Fontsets can be modified using the function @code{set-fontset-font},
1551specifying a character, a charset, a script, or a range of characters 1558specifying 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
1553used. Some examples are: 1560used. Some examples are:
1554 1561
1555@example 1562@example
1556;; Use Liberation Mono for latin-3 charset.
1557(set-fontset-font "fontset-default" 'iso-8859-3
1558 "Liberation Mono")
1559
1560;; Prefer a big5 font for han characters. 1563;; Prefer a big5 font for han characters.
1561(set-fontset-font "fontset-default" 1564(set-fontset-font "fontset-default"
1562 'han (font-spec :registry "big5") 1565 'han (font-spec :registry "big5")
1563 nil 'prepend) 1566 nil 'prepend)
1564 1567
1568;; Use MyPrivateFont for the Unicode private use area.
1569(set-fontset-font "fontset-default" '(#xe000 . #xf8ff)
1570 "MyPrivateFont")
1571
1572;; Use Liberation Mono for latin-3 charset.
1573(set-fontset-font "fontset-default" 'iso-8859-3
1574 "Liberation Mono")
1575
1565;; Use DejaVu Sans Mono as a fallback in fontset-startup 1576;; Use DejaVu Sans Mono as a fallback in fontset-startup
1566;; before resorting to fontset-default. 1577;; before resorting to fontset-default.
1567(set-fontset-font "fontset-startup" nil "DejaVu Sans Mono" 1578(set-fontset-font "fontset-startup" nil "DejaVu Sans Mono"
1568 nil 'append) 1579 nil 'append)
1580@end example
1569 1581
1570;; Use MyPrivateFont for the Unicode private use area. 1582@noindent
1571(set-fontset-font "fontset-default" '(#xe000 . #xf8ff) 1583@xref{Fontsets, , , elisp, GNU Emacs Lisp Reference Manual}, for more
1572 "MyPrivateFont") 1584details about using the @code{set-fontset-font} function.
1585
1586@cindex script of a character
1587@cindex codepoint of a character
1588If you don't know the character's codepoint or the script to which it
1589belongs, you can ask Emacs. With point at the character, type
1590@w{@kbd{C-u C-x =}} (@code{what-cursor-position}), and this
1591information, together with much more, will be displayed in the
1592@file{*Help*} buffer that Emacs pops up. @xref{Position Info}. For
1593example, Japanese characters belong to the @samp{kana} script, but
1594Japanese text also mixes them with Chinese characters so the following
1595uses the @samp{han} script to set up Emacs to use the @samp{Kochi
1596Gothic} font for Japanese text:
1573 1597
1598@example
1599(set-fontset-font "fontset-default" 'han "Kochi Gothic")
1574@end example 1600@end example
1575 1601
1602@noindent
1603@cindex CKJ characters
1604(For convenience, the @samp{han} script in Emacs is set up to support
1605all of the Chinese, Japanese, and Korean, a.k.a.@: @acronym{CJK},
1606characters, not just Chinese characters.)
1607
1608@vindex script-representative-chars
1609For the list of known scripts, see the variable
1610@code{script-representative-chars}.
1611
1612Fontset settings like those above only affect characters that the
1613default font doesn't support, so if the @samp{Kochi Gothic} font
1614covers Latin characters, it will not be used for displaying Latin
1615scripts, since the default font used by Emacs usually covers Basic
1616Latin.
1617
1576@cindex ignore font 1618@cindex ignore font
1577@cindex fonts, how to ignore 1619@cindex fonts, how to ignore
1578@vindex face-ignored-fonts 1620@vindex face-ignored-fonts
diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi
index 7484ce57607..f6dd77a3d96 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
7317works is to experiment. We will start with the @code{setcar} function. 7317works is to experiment. We will start with the @code{setcar} function.
7318 7318
7319@need 1200 7319@need 1200
7320@cindex constant lists
7321@cindex mutable lists
7322First, we can make a list and then set the value of a variable to the 7320First, we can make a list and then set the value of a variable to the
7323list, using the @code{setq} special form. Because we intend to use 7321list, using the @code{setq} special form. Because we intend to use
7324@code{setcar} to change the list, this @code{setq} should not use the 7322@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
7327tried to change part of the program while running it. Generally 7325tried to change part of the program while running it. Generally
7328speaking an Emacs Lisp program's components should be constant (or 7326speaking an Emacs Lisp program's components should be constant (or
7329unchanged) while the program is running. So we instead construct an 7327unchanged) while the program is running. So we instead construct an
7330animal list that is @dfn{mutable} (or changeable) by using the 7328animal list by using the @code{list} function, as follows:
7331@code{list} function, as follows:
7332 7329
7333@smallexample 7330@smallexample
7334(setq animals (list 'antelope 'giraffe 'lion 'tiger)) 7331(setq animals (list 'antelope 'giraffe 'lion 'tiger))
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index c601e3af9bc..58f93366fe9 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1905,6 +1905,7 @@ variables precisely as they were at the time of the error.
1905@subsubsection Writing Code to Handle Errors 1905@subsubsection Writing Code to Handle Errors
1906@cindex error handler 1906@cindex error handler
1907@cindex handling errors 1907@cindex handling errors
1908@cindex handle Lisp errors
1908@cindex forms for handling errors 1909@cindex forms for handling errors
1909 1910
1910 The usual effect of signaling an error is to terminate the command 1911 The usual effect of signaling an error is to terminate the command
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index e53f0e9f60c..3d738b9965f 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -3597,9 +3597,9 @@ characters in the range @var{from} and @var{to} (inclusive).
3597@var{character} may be a charset (@pxref{Character Sets}). In that 3597@var{character} may be a charset (@pxref{Character Sets}). In that
3598case, use @var{font-spec} for all the characters in the charset. 3598case, use @var{font-spec} for all the characters in the charset.
3599 3599
3600@var{character} may be a script name (@pxref{Character Properties}). 3600@var{character} may be a script name (@pxref{Character Properties,
3601In that case, use @var{font-spec} for all the characters belonging to 3601char-script-table}). In that case, use @var{font-spec} for all the
3602the script. 3602characters belonging to the script.
3603 3603
3604@var{character} may be @code{nil}, which means to use @var{font-spec} 3604@var{character} may be @code{nil}, which means to use @var{font-spec}
3605for any character which no font-spec is specified. 3605for any character which no font-spec is specified.
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
297* Circular Objects:: Read syntax for circular structure. 297* Circular Objects:: Read syntax for circular structure.
298* Type Predicates:: Tests related to types. 298* Type Predicates:: Tests related to types.
299* Equality Predicates:: Tests of equality between any two objects. 299* Equality Predicates:: Tests of equality between any two objects.
300* Constants and Mutability:: Whether an object's value can change. 300* Mutability:: Some objects should not be modified.
301 301
302Programming Types 302Programming Types
303 303
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.
158@end group 158@end group
159@end example 159@end example
160 160
161 A self-evaluating form yields constant conses, vectors and strings, and you 161 A self-evaluating form yields a value that becomes part of the program,
162should not attempt to modify their contents via @code{setcar}, @code{aset} or 162and you should not try to modify it via @code{setcar}, @code{aset} or
163similar operations. The Lisp interpreter might unify the constants 163similar operations. The Lisp interpreter might unify the constants
164yielded by your program's self-evaluating forms, so that these 164yielded by your program's self-evaluating forms, so that these
165constants might share structure. @xref{Constants and Mutability}. 165constants might share structure. @xref{Mutability}.
166 166
167 It is common to write numbers, characters, strings, and even vectors 167 It is common to write numbers, characters, strings, and even vectors
168in Lisp code, taking advantage of the fact that they self-evaluate. 168in Lisp code, taking advantage of the fact that they self-evaluate.
@@ -564,8 +564,8 @@ and vectors.)
564 564
565@defspec quote object 565@defspec quote object
566This special form returns @var{object}, without evaluating it. 566This special form returns @var{object}, without evaluating it.
567The returned value is a constant, and should not be modified. 567The returned value might be shared and should not be modified.
568@xref{Constants and Mutability}. 568@xref{Self-Evaluating Forms}.
569@end defspec 569@end defspec
570 570
571@cindex @samp{'} for quoting 571@cindex @samp{'} for quoting
@@ -608,9 +608,9 @@ Here are some examples of expressions that use @code{quote}:
608 608
609 Although the expressions @code{(list '+ 1 2)} and @code{'(+ 1 2)} 609 Although the expressions @code{(list '+ 1 2)} and @code{'(+ 1 2)}
610both yield lists equal to @code{(+ 1 2)}, the former yields a 610both yield lists equal to @code{(+ 1 2)}, the former yields a
611freshly-minted mutable list whereas the latter yields a constant list 611freshly-minted mutable list whereas the latter yields a list
612built from conses that may be shared with other constants. 612built from conses that might be shared and should not be modified.
613@xref{Constants and Mutability}. 613@xref{Self-Evaluating Forms}.
614 614
615 Other quoting constructs include @code{function} (@pxref{Anonymous 615 Other quoting constructs include @code{function} (@pxref{Anonymous
616Functions}), which causes an anonymous lambda expression written in Lisp 616Functions}), which causes an anonymous lambda expression written in Lisp
@@ -710,8 +710,9 @@ Here are some examples:
710@end example 710@end example
711 711
712If a subexpression of a backquote construct has no substitutions or 712If a subexpression of a backquote construct has no substitutions or
713splices, it acts like @code{quote} in that it yields constant conses, 713splices, it acts like @code{quote} in that it yields conses,
714vectors and strings that should not be modified. 714vectors and strings that might be shared and should not be modified.
715@xref{Self-Evaluating Forms}.
715 716
716@node Eval 717@node Eval
717@section Eval 718@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
873operations because they change existing list structure. 873operations because they change existing list structure.
874Destructive operations should be applied only to mutable lists, 874Destructive operations should be applied only to mutable lists,
875that is, lists constructed via @code{cons}, @code{list} or similar 875that is, lists constructed via @code{cons}, @code{list} or similar
876operations. Lists created by quoting are constants and should not be 876operations. Lists created by quoting are part of the program and
877changed by destructive operations. @xref{Constants and Mutability}. 877should not be changed by destructive operations. @xref{Mutability}.
878 878
879@cindex CL note---@code{rplaca} vs @code{setcar} 879@cindex CL note---@code{rplaca} vs @code{setcar}
880@quotation 880@quotation
@@ -911,7 +911,7 @@ value @var{object}. For example:
911 911
912@example 912@example
913@group 913@group
914(setq x (list 1 2)) ; @r{Create a mutable list.} 914(setq x (list 1 2))
915 @result{} (1 2) 915 @result{} (1 2)
916@end group 916@end group
917@group 917@group
@@ -931,7 +931,7 @@ these lists. Here is an example:
931 931
932@example 932@example
933@group 933@group
934;; @r{Create two mutable lists that are partly shared.} 934;; @r{Create two lists that are partly shared.}
935(setq x1 (list 'a 'b 'c)) 935(setq x1 (list 'a 'b 'c))
936 @result{} (a b c) 936 @result{} (a b c)
937(setq x2 (cons 'z (cdr x1))) 937(setq x2 (cons 'z (cdr x1)))
@@ -1022,11 +1022,11 @@ reached via the @sc{cdr}.
1022 1022
1023@example 1023@example
1024@group 1024@group
1025(setq x (list 1 2 3)) ; @r{Create a mutable list.} 1025(setq x (list 1 2 3))
1026 @result{} (1 2 3) 1026 @result{} (1 2 3)
1027@end group 1027@end group
1028@group 1028@group
1029(setcdr x '(4)) ; @r{Modify the list's tail to be a constant list.} 1029(setcdr x '(4))
1030 @result{} (4) 1030 @result{} (4)
1031@end group 1031@end group
1032@group 1032@group
@@ -1135,11 +1135,11 @@ Unlike @code{append} (@pxref{Building Lists}), the @var{lists} are
1135 1135
1136@example 1136@example
1137@group 1137@group
1138(setq x (list 1 2 3)) ; @r{Create a mutable list.} 1138(setq x (list 1 2 3))
1139 @result{} (1 2 3) 1139 @result{} (1 2 3)
1140@end group 1140@end group
1141@group 1141@group
1142(nconc x '(4 5)) ; @r{Modify the list's tail to be a constant list.} 1142(nconc x '(4 5))
1143 @result{} (1 2 3 4 5) 1143 @result{} (1 2 3 4 5)
1144@end group 1144@end group
1145@group 1145@group
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index cd037d663da..83066744121 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
46Lisp variables can only take on values of a certain type. 46Lisp variables can only take on values of a certain type.
47@xref{Variables with Restricted Values}.) 47@xref{Variables with Restricted Values}.)
48 48
49 Some Lisp objects are @dfn{constant}: their values should never change.
50Others are @dfn{mutable}: their values can be changed via destructive
51operations that involve side effects.
52
53 This chapter describes the purpose, printed representation, and read 49 This chapter describes the purpose, printed representation, and read
54syntax of each of the standard types in GNU Emacs Lisp. Details on how 50syntax of each of the standard types in GNU Emacs Lisp. Details on how
55to use these types can be found in later chapters. 51to use these types can be found in later chapters.
@@ -63,7 +59,7 @@ to use these types can be found in later chapters.
63* Circular Objects:: Read syntax for circular structure. 59* Circular Objects:: Read syntax for circular structure.
64* Type Predicates:: Tests related to types. 60* Type Predicates:: Tests related to types.
65* Equality Predicates:: Tests of equality between any two objects. 61* Equality Predicates:: Tests of equality between any two objects.
66* Constants and Mutability:: Whether an object's value can change. 62* Mutability:: Some objects should not be modified.
67@end menu 63@end menu
68 64
69@node Printed Representation 65@node Printed Representation
@@ -2383,51 +2379,58 @@ that for two strings to be equal, they have the same text properties.
2383@end example 2379@end example
2384@end defun 2380@end defun
2385 2381
2386@node Constants and Mutability 2382@node Mutability
2387@section Constants and Mutability 2383@section Mutability
2388@cindex constants
2389@cindex mutable objects 2384@cindex mutable objects
2390 2385
2391 Some Lisp objects are constant: their values should never change 2386 Some Lisp objects should never change. For example, the Lisp
2392during a single execution of Emacs running well-behaved Lisp code. 2387expression @code{"aaa"} yields a string, but you should not change
2393For example, you can create a new integer by calculating one, but you 2388its contents. And some objects cannot be changed; for example,
2394cannot modify the value of an existing integer. 2389although you can create a new number by calculating one, Lisp provides
2395 2390no operation to change the value of an existing number.
2396 Other Lisp objects are mutable: it is safe to change their values 2391
2397via destructive operations involving side effects. For example, an 2392 Other Lisp objects are @dfn{mutable}: it is safe to change their
2398existing marker can be changed by moving the marker to point to 2393values via destructive operations involving side effects. For
2399somewhere else. 2394example, an existing marker can be changed by moving the marker to
2400 2395point to somewhere else.
2401 Although all numbers are constants and all markers are 2396
2402mutable, some types contain both constant and mutable members. These 2397 Although numbers never change and all markers are mutable,
2403types include conses, vectors, strings, and symbols. For example, the string 2398some types have members some of which are mutable and others not. These
2404literal @code{"aaa"} yields a constant string, whereas the function 2399types include conses, vectors, and strings. For example,
2405call @code{(make-string 3 ?a)} yields a mutable string that can be 2400although @code{"cons"} and @code{(symbol-name 'cons)} both yield
2401strings that should not be changed, @code{(copy-sequence "cons")} and
2402@code{(make-string 3 ?a)} both yield mutable strings that can be
2406changed via later calls to @code{aset}. 2403changed via later calls to @code{aset}.
2407 2404
2408 A mutable object can become constant if it is part of an expression 2405 A mutable object stops being mutable if it is part of an expression
2409that is evaluated. The reverse does not occur: constant objects 2406that is evaluated. For example:
2410should stay constant. 2407
2411 2408@example
2412 Trying to modify a constant variable signals an error 2409(let* ((x (list 0.5))
2413(@pxref{Constant Variables}). 2410 (y (eval (list 'quote x))))
2414A program should not attempt to modify other types of constants because the 2411 (setcar x 1.5) ;; The program should not do this.
2415resulting behavior is undefined: the Lisp interpreter might or might 2412 y)
2416not detect the error, and if it does not detect the error the 2413@end example
2417interpreter can behave unpredictably thereafter. Another way to put 2414
2418this is that although mutable objects are safe to change and constant 2415@noindent
2419variables reliably prevent attempts to change them, other constants 2416Although the list @code{(0.5)} was mutable when it was created, it should not
2420are not safely mutable: if a misbehaving program tries to change such a 2417have been changed via @code{setcar} because it given to @code{eval}. The
2421constant then the constant's value might actually change, or the 2418reverse does not occur: an object that should not be changed never
2422program might crash or worse. This problem occurs 2419becomes mutable afterwards.
2423with types that have both constant and mutable members, and that have 2420
2424mutators like @code{setcar} and @code{aset} that are valid on mutable 2421 If a program attempts to change objects that should not be
2425objects but hazardous on constants. 2422changed, the resulting behavior is undefined: the Lisp interpreter
2426 2423might signal an error, or it might crash or behave unpredictably in
2427 When the same constant occurs multiple times in a program, the Lisp 2424other ways.@footnote{This is the behavior specified for languages like
2425Common Lisp and C for constants, and this differs from languages like
2426JavaScript and Python where an interpreter is required to signal an
2427error if a program attempts to change an immutable object. Ideally the Emacs
2428Lisp interpreter will evolve in latter direction.}
2429
2430 When similar constants occur as parts of a program, the Lisp
2428interpreter might save time or space by reusing existing constants or 2431interpreter might save time or space by reusing existing constants or
2429constant components. For example, @code{(eq "abc" "abc")} returns 2432their components. For example, @code{(eq "abc" "abc")} returns
2430@code{t} if the interpreter creates only one instance of the string 2433@code{t} if the interpreter creates only one instance of the string
2431constant @code{"abc"}, and returns @code{nil} if it creates two 2434literal @code{"abc"}, and returns @code{nil} if it creates two
2432instances. Lisp programs should be written so that they work 2435instances. Lisp programs should be written so that they work
2433regardless of whether this optimization is in use. 2436regardless 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.
183 183
184@example 184@example
185@group 185@group
186(setq bar (list 1 2)) ; @r{Create a mutable list.} 186(setq bar (list 1 2))
187 @result{} (1 2) 187 @result{} (1 2)
188@end group 188@end group
189@group 189@group
190(setq x (vector 'foo bar)) ; @r{Create a mutable vector.} 190(setq x (vector 'foo bar))
191 @result{} [foo (1 2)] 191 @result{} [foo (1 2)]
192@end group 192@end group
193@group 193@group
@@ -278,7 +278,7 @@ Unlike @code{reverse} the original @var{sequence} may be modified.
278 278
279@example 279@example
280@group 280@group
281(setq x (list 'a 'b 'c)) ; @r{Create a mutable list.} 281(setq x (list 'a 'b 'c))
282 @result{} (a b c) 282 @result{} (a b c)
283@end group 283@end group
284@group 284@group
@@ -320,7 +320,7 @@ presented graphically:
320 For the vector, it is even simpler because you don't need setq: 320 For the vector, it is even simpler because you don't need setq:
321 321
322@example 322@example
323(setq x (copy-sequence [1 2 3 4])) ; @r{Create a mutable vector.} 323(setq x (copy-sequence [1 2 3 4]))
324 @result{} [1 2 3 4] 324 @result{} [1 2 3 4]
325(nreverse x) 325(nreverse x)
326 @result{} [4 3 2 1] 326 @result{} [4 3 2 1]
@@ -331,6 +331,7 @@ x
331Note that unlike @code{reverse}, this function doesn't work with strings. 331Note that unlike @code{reverse}, this function doesn't work with strings.
332Although you can alter string data by using @code{aset}, it is strongly 332Although you can alter string data by using @code{aset}, it is strongly
333encouraged to treat strings as immutable even when they are mutable. 333encouraged to treat strings as immutable even when they are mutable.
334@xref{Mutability}.
334 335
335@end defun 336@end defun
336 337
@@ -374,7 +375,7 @@ appears in a different position in the list due to the change of
374 375
375@example 376@example
376@group 377@group
377(setq nums (list 1 3 2 6 5 4 0)) ; @r{Create a mutable list.} 378(setq nums (list 1 3 2 6 5 4 0))
378 @result{} (1 3 2 6 5 4 0) 379 @result{} (1 3 2 6 5 4 0)
379@end group 380@end group
380@group 381@group
@@ -1228,7 +1229,7 @@ This function sets the @var{index}th element of @var{array} to be
1228 1229
1229@example 1230@example
1230@group 1231@group
1231(setq w (vector 'foo 'bar 'baz)) ; @r{Create a mutable vector.} 1232(setq w (vector 'foo 'bar 'baz))
1232 @result{} [foo bar baz] 1233 @result{} [foo bar baz]
1233(aset w 0 'fu) 1234(aset w 0 'fu)
1234 @result{} fu 1235 @result{} fu
@@ -1237,7 +1238,7 @@ w
1237@end group 1238@end group
1238 1239
1239@group 1240@group
1240;; @r{@code{copy-sequence} creates a mutable string.} 1241;; @r{@code{copy-sequence} copies the string to be modified later.}
1241(setq x (copy-sequence "asdfasfd")) 1242(setq x (copy-sequence "asdfasfd"))
1242 @result{} "asdfasfd" 1243 @result{} "asdfasfd"
1243(aset x 3 ?Z) 1244(aset x 3 ?Z)
@@ -1247,9 +1248,7 @@ x
1247@end group 1248@end group
1248@end example 1249@end example
1249 1250
1250The @var{array} should be mutable; that is, it should not be a constant, 1251The @var{array} should be mutable. @xref{Mutability}.
1251such as the constants created via quoting or via self-evaluating forms.
1252@xref{Constants and Mutability}.
1253 1252
1254If @var{array} is a string and @var{object} is not a character, a 1253If @var{array} is a string and @var{object} is not a character, a
1255@code{wrong-type-argument} error results. The function converts a 1254@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}.
1262 1261
1263@example 1262@example
1264@group 1263@group
1265;; @r{Create a mutable vector and then fill it with zeros.}
1266(setq a (copy-sequence [a b c d e f g])) 1264(setq a (copy-sequence [a b c d e f g]))
1267 @result{} [a b c d e f g] 1265 @result{} [a b c d e f g]
1268(fillarray a 0) 1266(fillarray a 0)
@@ -1271,7 +1269,6 @@ a
1271 @result{} [0 0 0 0 0 0 0] 1269 @result{} [0 0 0 0 0 0 0]
1272@end group 1270@end group
1273@group 1271@group
1274;; @r{Create a mutable string and then fill it with "-".}
1275(setq s (copy-sequence "When in the course")) 1272(setq s (copy-sequence "When in the course"))
1276 @result{} "When in the course" 1273 @result{} "When in the course"
1277(fillarray s ?-) 1274(fillarray s ?-)
@@ -1310,8 +1307,8 @@ same way in Lisp input.
1310evaluation: the result of evaluating it is the same vector. This does 1307evaluation: the result of evaluating it is the same vector. This does
1311not evaluate or even examine the elements of the vector. 1308not evaluate or even examine the elements of the vector.
1312@xref{Self-Evaluating Forms}. Vectors written with square brackets 1309@xref{Self-Evaluating Forms}. Vectors written with square brackets
1313are constants and should not be modified via @code{aset} or other 1310should not be modified via @code{aset} or other destructive
1314destructive operations. @xref{Constants and Mutability}. 1311operations. @xref{Mutability}.
1315 1312
1316 Here are examples illustrating these principles: 1313 Here are examples illustrating these principles:
1317 1314
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.
49 49
50 Since strings are arrays, and therefore sequences as well, you can 50 Since strings are arrays, and therefore sequences as well, you can
51operate on them with the general array and sequence functions documented 51operate on them with the general array and sequence functions documented
52in @ref{Sequences Arrays Vectors}. For example, you can access or 52in @ref{Sequences Arrays Vectors}. For example, you can access
53change individual characters in a string using the functions @code{aref} 53individual characters in a string using the function @code{aref}
54and @code{aset} (@pxref{Array Functions}). However, you should not 54(@pxref{Array Functions}).
55try to change the contents of constant strings (@pxref{Modifying Strings}).
56 55
57 There are two text representations for non-@acronym{ASCII} 56 There are two text representations for non-@acronym{ASCII}
58characters in Emacs strings (and in buffers): unibyte and multibyte. 57characters in Emacs strings (and in buffers): unibyte and multibyte.
@@ -382,9 +381,7 @@ usual value is @w{@code{"[ \f\t\n\r\v]+"}}.
382@cindex string modification 381@cindex string modification
383 382
384 You can alter the contents of a mutable string via operations 383 You can alter the contents of a mutable string via operations
385described in this section. However, you should not try to use these 384described in this section. @xref{Mutability}.
386operations to alter the contents of a constant string.
387@xref{Constants and Mutability}.
388 385
389 The most basic way to alter the contents of an existing string is with 386 The most basic way to alter the contents of an existing string is with
390@code{aset} (@pxref{Array Functions}). @code{(aset @var{string} 387@code{aset} (@pxref{Array Functions}). @code{(aset @var{string}
diff --git a/etc/NEWS b/etc/NEWS
index 303036ece34..efad273da6c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -139,6 +139,9 @@ directories with the help of new command 'dired-vc-next-action'.
139*** New commands 'vc-dir-mark-registered-files' (bound to '* r') and 139*** New commands 'vc-dir-mark-registered-files' (bound to '* r') and
140'vc-dir-mark-unregistered-files'. 140'vc-dir-mark-unregistered-files'.
141 141
142*** Support for bookmark.el.
143Bookmark locations can refer to VC directory buffers.
144
142** Gnus 145** Gnus
143 146
144--- 147---
@@ -226,6 +229,12 @@ key binding
226/ m package-menu-filter-marked 229/ m package-menu-filter-marked
227/ / package-menu-filter-clear 230/ / package-menu-filter-clear
228 231
232---
233+++ Column widths in 'list-packages' display can now be customized.
234See the new user options 'package-name-column-width',
235'package-version-column-width', 'package-status-column-width', and
236'package-archive-column-width'.
237
229** gdb-mi 238** gdb-mi
230 239
231+++ 240+++
@@ -353,6 +362,44 @@ symbol property to the browsing functions. With a new command
353'browse-url-with-browser-kind', an URL can explicitly be browsed with 362'browse-url-with-browser-kind', an URL can explicitly be browsed with
354either an internal or external browser. 363either an internal or external browser.
355 364
365** SHR
366
367---
368*** The command 'shr-browse-url' now supports custom mailto handlers.
369Clicking on or otherwise following a 'mailto:' link in a HTML buffer
370rendered by SHR previously invoked the command 'browse-url-mailto'.
371This is still the case by default, but if you customize
372'browse-url-mailto-function' or 'browse-url-handlers' to call some
373other function, it will now be called instead of the default.
374
375** EWW
376
377---
378*** The command 'eww-follow-link' now supports custom mailto handlers.
379The function that is invoked when clicking on or otherwise following a
380'mailto:' link in an EWW buffer can now be customized. For more
381information, see the related entry about 'shr-browse-url' above.
382
383** Project
384
385*** New user option 'project-vc-merge-submodules'.
386
387** json.el
388
389---
390*** JSON number parsing is now stricter.
391Numbers with a leading plus sign, leading zeros, or a missing integer
392component are now rejected by 'json-read' and friends. This makes
393them more compliant with the JSON specification and consistent with
394the native JSON parsing functions.
395
396** xml.el
397
398*** XML serialization functions now reject invalid characters.
399Previously 'xml-print' would produce invalid XML when given a string
400with characters that are not valid in XML (see
401https://www.w3.org/TR/xml/#charsets). Now it rejects such strings.
402
356 403
357* New Modes and Packages in Emacs 28.1 404* New Modes and Packages in Emacs 28.1
358 405
diff --git a/etc/TODO b/etc/TODO
index 20262a77e97..0f908def768 100644
--- a/etc/TODO
+++ b/etc/TODO
@@ -220,10 +220,23 @@ https://lists.gnu.org/r/emacs-devel/2013-11/msg00515.html
220 width fonts. However, more features are still needed to achieve this. 220 width fonts. However, more features are still needed to achieve this.
221 221
222** Support ligatures out of the box 222** Support ligatures out of the box
223For the list of typographical ligatures, see 223For the list of frequently-used typographical ligatures, see
224 224
225 https://en.wikipedia.org/wiki/Orthographic_ligature#Ligatures_in_Unicode_(Latin_alphabets) 225 https://en.wikipedia.org/wiki/Orthographic_ligature#Ligatures_in_Unicode_(Latin_alphabets)
226 226
227(Note that in general, the number of possible ligatures can be much
228larger, and there's no way, in principle, to specify the superset of
229all the ligatures that could exist. Each font can support different
230ligatures. The reliable way of supporting any and all ligatures is to
231hand all text to be displayed to the shaping engine and get back the
232font glyphs to display that text. However, doing this is impossible
233with the current design of the Emacs display engine, since it examines
234buffer text one character at a time, and implements character
235composition by calls to Lisp, which makes doing this for every
236character impractically slow. Therefore, the rest of this item
237describes a limited form of ligature support which is compatible with
238the current display engine design and uses automatic compositions.)
239
227For Text and derived modes, the job is to figure out which ligatures 240For Text and derived modes, the job is to figure out which ligatures
228we want to support, how to let the user customize that, and probably 241we want to support, how to let the user customize that, and probably
229define a minor mode for automatic ligation (as some contexts might not 242define 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
237needed for each programming language, and provide user options to turn 250needed for each programming language, and provide user options to turn
238this on and off. 251this on and off.
239 252
240The implementation should use the infrastructure for character 253The implementation should use the infrastructure for automatic
241compositions, i.e., we should define appropriate regexp-based rules 254character compositions, i.e., we should define appropriate
242for character sequences that need to be composed into ligatures, and 255regexp-based rules for character sequences that need to be composed
243populate composition-function-table with those rules. See 256into ligatures, and populate composition-function-table with those
244composite.el for examples of this, and also grep lisp/language/*.el 257rules. See composite.el for examples of this, and also grep
245for references to composition-function-table. 258lisp/language/*.el for references to composition-function-table.
246 259
247One problem with character compositions that will need to be solved is 260One problem with character compositions that will need to be solved is
248that composition-function-table, the char-table which holds the 261that composition-function-table, the char-table which holds the
@@ -259,11 +272,46 @@ way of preventing the ligation from happening. One possibility is to
259have a ZWNJ character separate these ASCII characters; another 272have a ZWNJ character separate these ASCII characters; another
260possibility is to introduce a special text property that prevents 273possibility is to introduce a special text property that prevents
261character composition, and place that property on the relevant parts 274character composition, and place that property on the relevant parts
262of the mode line. 275of the mode line. Yet another possibility would be to write a
276specialized composition function, which would detect that it is called
277on mode-line strings, and return nil to signal that composition is not
278possible in this case; then use that function in the rules for
279ligatures stored in composition-function-table.
263 280
264The prettify-symbols-mode should be deprecated once ligature support 281The prettify-symbols-mode should be deprecated once ligature support
265is in place. 282is in place.
266 283
284A related, but somewhat independent, feature is being able to move the
285cursor "into a ligature", whereby cursor motion commands shows some
286pseudo-cursor on some part of a ligature. For example, if "ffi" is
287displayed as a ligature, then moving by one buffer position should
288show the middle part of the ligature's glyph similar to the cursor
289display: some special background and perhaps also a special
290foreground. There are two possible ways of figuring out the offset at
291which to display the pseudo-cursor:
292
293 . Arbitrarily divide the ligature's glyph width W into N parts,
294 where N is the number of codepoints composed into the ligature, then
295 move that pseudo-cursor by W/N pixels each time a cursor-motion
296 command is invoked;
297 . Use the font information. For example, HarfBuzz has the
298 hb_ot_layout_get_ligature_carets API for that purpose. However,
299 it could be that few fonts actually have that information recorded
300 in them, in which case the previous heuristics will be needed as
301 fallback.
302
303One subtle issue needs to be resolved to have this feature of
304"sub-glyph" cursor movement inside composed characters. The way Emacs
305currently displays the default block cursor is by simply redrawing the
306glyph at point in reverse video. So Emacs currently doesn't have a
307way of displaying a cursor that "covers" only part of a glyph. To
308make this happen, the display code will probably need to be changed to
309draw the cursor as part of drawing the foreground and/or background of
310the corresponding glyph, which is against the current flow of the
311display code: it generally first completely draws the background and
312foreground of the entire text that needs to be redrawn, and only then
313draws the cursor where it should be placed.
314
267** Support for Stylistic Sets 315** Support for Stylistic Sets
268This will allow using "alternate glyphs" supported by modern fonts. 316This will allow using "alternate glyphs" supported by modern fonts.
269For an overview of this feature, see 317For an overview of this feature, see
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)
4197 break; 4197 break;
4198 } 4198 }
4199 FALLTHROUGH; 4199 FALLTHROUGH;
4200 resetfvdef:
4201 case '#': case '~': case '&': case '%': case '/': 4200 case '#': case '~': case '&': case '%': case '/':
4202 case '|': case '^': case '!': case '.': case '?': 4201 case '|': case '^': case '!': case '.': case '?':
4202 resetfvdef:
4203 if (definedef != dnone) 4203 if (definedef != dnone)
4204 break; 4204 break;
4205 /* These surely cannot follow a function tag in C. */ 4205 /* These surely cannot follow a function tag in C. */
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."
858 "Convert the given STR to a number, according to the value of 858 "Convert the given STR to a number, according to the value of
859`calculator-input-radix'." 859`calculator-input-radix'."
860 (if calculator-input-radix 860 (if calculator-input-radix
861 (string-to-number str (cadr (assq calculator-input-radix 861 (string-to-number str (cadr (assq calculator-input-radix
862 '((bin 2) (oct 8) (hex 16))))) 862 '((bin 2) (oct 8) (hex 16)))))
863 (let* ((str (replace-regexp-in-string 863 ;; Allow entry of "1.e3".
864 "\\.\\([^0-9].*\\)?$" ".0\\1" str)) 864 (let ((str (replace-regexp-in-string (rx "." (any "eE")) "e" str)))
865 (str (replace-regexp-in-string
866 "[eE][+-]?\\([^0-9].*\\)?$" "e0\\1" str)))
867 (float (string-to-number str))))) 865 (float (string-to-number str)))))
868 866
869(defun calculator-push-curnum () 867(defun calculator-push-curnum ()
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."
1515 (when project-dir 1515 (when project-dir
1516 (ede-directory-get-open-project project-dir 'ROOT)))) 1516 (ede-directory-get-open-project project-dir 'ROOT))))
1517 1517
1518(cl-defmethod project-roots ((project ede-project)) 1518(cl-defmethod project-root ((project ede-project))
1519 (list (ede-project-root-directory project))) 1519 (ede-project-root-directory project))
1520
1521;;; FIXME: Could someone look into implementing `project-ignores' for
1522;;; EDE and/or a faster `project-files'?
1520 1523
1521(add-hook 'project-find-functions #'project-try-ede) 1524(add-hook 'project-find-functions #'project-try-ede)
1522 1525
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."
2050 (when (memq (selected-frame) (alist-get 'frames attrs)) 2050 (when (memq (selected-frame) (alist-get 'frames attrs))
2051 (let ((geom (alist-get 'geometry attrs))) 2051 (let ((geom (alist-get 'geometry attrs)))
2052 (when geom 2052 (when geom
2053 (setq monitor-top (nth 0 geom)) 2053 (setq monitor-left (nth 0 geom))
2054 (setq monitor-left (nth 1 geom)) 2054 (setq monitor-top (nth 1 geom))
2055 (setq monitor-width (nth 2 geom)) 2055 (setq monitor-width (nth 2 geom))
2056 (setq monitor-height (nth 3 geom)))))) 2056 (setq monitor-height (nth 3 geom))))))
2057 (let ((frame (make-frame 2057 (let ((frame (make-frame
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 95659840ad5..808e4f34fc5 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -397,6 +397,26 @@ synchronously."
397 :type 'boolean 397 :type 'boolean
398 :version "25.1") 398 :version "25.1")
399 399
400(defcustom package-name-column-width 30
401 "Column width for the Package name in the package menu."
402 :type 'number
403 :version "28.1")
404
405(defcustom package-version-column-width 14
406 "Column width for the Package version in the package menu."
407 :type 'number
408 :version "28.1")
409
410(defcustom package-status-column-width 12
411 "Column width for the Package status in the package menu."
412 :type 'number
413 :version "28.1")
414
415(defcustom package-archive-column-width 8
416 "Column width for the Package status in the package menu."
417 :type 'number
418 :version "28.1")
419
400 420
401;;; `package-desc' object definition 421;;; `package-desc' object definition
402;; This is the struct used internally to represent packages. 422;; This is the struct used internally to represent packages.
@@ -2750,11 +2770,11 @@ Letters do not insert themselves; instead, they are commands.
2750 (package-menu--transaction-status 2770 (package-menu--transaction-status
2751 package-menu--transaction-status))) 2771 package-menu--transaction-status)))
2752 (setq tabulated-list-format 2772 (setq tabulated-list-format
2753 `[("Package" 18 package-menu--name-predicate) 2773 `[("Package" ,package-name-column-width package-menu--name-predicate)
2754 ("Version" 13 package-menu--version-predicate) 2774 ("Version" ,package-version-column-width package-menu--version-predicate)
2755 ("Status" 10 package-menu--status-predicate) 2775 ("Status" ,package-status-column-width package-menu--status-predicate)
2756 ,@(if (cdr package-archives) 2776 ,@(if (cdr package-archives)
2757 '(("Archive" 10 package-menu--archive-predicate))) 2777 `(("Archive" ,package-archive-column-width package-menu--archive-predicate)))
2758 ("Description" 0 package-menu--description-predicate)]) 2778 ("Description" 0 package-menu--description-predicate)])
2759 (setq tabulated-list-padding 2) 2779 (setq tabulated-list-padding 2)
2760 (setq tabulated-list-sort-key (cons "Status" nil)) 2780 (setq tabulated-list-sort-key (cons "Status" nil))
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."))
139 (point-max)))) 139 (point-max))))
140 (cons beg end)) 140 (cons beg end))
141 141
142(defun syntax-propertize--shift-groups (re n) 142(defun syntax-propertize--shift-groups-and-backrefs (re n)
143 (replace-regexp-in-string 143 (let ((new-re (replace-regexp-in-string
144 "\\\\(\\?\\([0-9]+\\):" 144 "\\\\(\\?\\([0-9]+\\):"
145 (lambda (s) 145 (lambda (s)
146 (replace-match 146 (replace-match
147 (number-to-string (+ n (string-to-number (match-string 1 s)))) 147 (number-to-string
148 t t s 1)) 148 (+ n (string-to-number (match-string 1 s))))
149 re t t)) 149 t t s 1))
150 re t t))
151 (pos 0))
152 (while (string-match "\\\\\\([0-9]+\\)" new-re pos)
153 (setq pos (+ 1 (match-beginning 1)))
154 (when (save-match-data
155 ;; With \N, the \ must be in a subregexp context, i.e.,
156 ;; not in a character class or in a \{\} repetition.
157 (subregexp-context-p new-re (match-beginning 0)))
158 (let ((shifted (+ n (string-to-number (match-string 1 new-re)))))
159 (when (> shifted 9)
160 (error "There may be at most nine back-references"))
161 (setq new-re (replace-match (number-to-string shifted)
162 t t new-re 1)))))
163 new-re))
150 164
151(defmacro syntax-propertize-precompile-rules (&rest rules) 165(defmacro syntax-propertize-precompile-rules (&rest rules)
152 "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. 166 "Return a precompiled form of RULES to pass to `syntax-propertize-rules'.
@@ -190,7 +204,8 @@ for subsequent HIGHLIGHTs.
190Also SYNTAX is free to move point, in which case RULES may not be applied to 204Also SYNTAX is free to move point, in which case RULES may not be applied to
191some parts of the text or may be applied several times to other parts. 205some parts of the text or may be applied several times to other parts.
192 206
193Note: back-references in REGEXPs do not work." 207Note: There may be at most nine back-references in the REGEXPs of
208all RULES in total."
194 (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. 209 (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step.
195 (form &rest 210 (form &rest
196 (numberp 211 (numberp
@@ -219,7 +234,7 @@ Note: back-references in REGEXPs do not work."
219 ;; tell when *this* match 0 has succeeded. 234 ;; tell when *this* match 0 has succeeded.
220 (cl-incf offset) 235 (cl-incf offset)
221 (setq re (concat "\\(" re "\\)"))) 236 (setq re (concat "\\(" re "\\)")))
222 (setq re (syntax-propertize--shift-groups re offset)) 237 (setq re (syntax-propertize--shift-groups-and-backrefs re offset))
223 (let ((code '()) 238 (let ((code '())
224 (condition 239 (condition
225 (cond 240 (cond
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."
5833 "" "...")) 5833 "" "..."))
5834 (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) 5834 (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
5835 (buffer-size))) 5835 (buffer-size)))
5836 (help-echo "mouse-2: toggle the MIME part; down-mouse-3: more options")
5836 gnus-tmp-type-long b e) 5837 gnus-tmp-type-long b e)
5837 (when (string-match ".*/" gnus-tmp-name) 5838 (when (string-match ".*/" gnus-tmp-name)
5838 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) 5839 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
@@ -5841,6 +5842,16 @@ all parts."
5841 (concat "; " gnus-tmp-name)))) 5842 (concat "; " gnus-tmp-name))))
5842 (unless (equal gnus-tmp-description "") 5843 (unless (equal gnus-tmp-description "")
5843 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) 5844 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
5845 (when (zerop gnus-tmp-length)
5846 (setq gnus-tmp-type-long
5847 (concat
5848 gnus-tmp-type-long
5849 (substitute-command-keys
5850 (concat "\\<gnus-summary-mode-map> (not downloaded, "
5851 "\\[gnus-summary-show-complete-article] to fetch.)"))))
5852 (setq help-echo
5853 (concat "Type \\[gnus-summary-show-complete-article] "
5854 "to download complete article. " help-echo)))
5844 (setq b (point)) 5855 (setq b (point))
5845 (gnus-eval-format 5856 (gnus-eval-format
5846 gnus-mime-button-line-format gnus-mime-button-line-format-alist 5857 gnus-mime-button-line-format gnus-mime-button-line-format-alist
@@ -5859,8 +5870,7 @@ all parts."
5859 'keymap gnus-mime-button-map 5870 'keymap gnus-mime-button-map
5860 'face gnus-article-button-face 5871 'face gnus-article-button-face
5861 'follow-link t 5872 'follow-link t
5862 'help-echo 5873 'help-echo help-echo)))
5863 "mouse-2: toggle the MIME part; down-mouse-3: more options")))
5864 5874
5865(defvar gnus-displaying-mime nil) 5875(defvar gnus-displaying-mime nil)
5866 5876
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'."
485 (when from 485 (when from
486 (setq entry (cons (delete from (assoc 'group entry)) 486 (setq entry (cons (delete from (assoc 'group entry))
487 (assq-delete-all 'group entry)))) 487 (assq-delete-all 'group entry))))
488 488 ;; Only keep the entry if the message is going to a new group, or
489 (dolist (kv `((group ,to) 489 ;; it's still in some previous group.
490 (sender ,sender) 490 (when (or to (alist-get 'group entry))
491 (recipient ,@recipients) 491 (dolist (kv `((group ,to)
492 (subject ,subject))) 492 (sender ,sender)
493 (when (cadr kv) 493 (recipient ,@recipients)
494 (let ((new (or (assq (car kv) entry) 494 (subject ,subject)))
495 (list (car kv))))) 495 (when (cadr kv)
496 (dolist (toadd (cdr kv)) 496 (let ((new (or (assq (car kv) entry)
497 (unless (member toadd new) 497 (list (car kv)))))
498 (setq new (append new (list toadd))))) 498 (dolist (toadd (cdr kv))
499 (setq entry (cons new 499 (unless (member toadd new)
500 (assq-delete-all (car kv) entry)))))) 500 (setq new (append new (list toadd)))))
501 (gnus-message 10 "Gnus registry: new entry for %s is %S" 501 (setq entry (cons new
502 id 502 (assq-delete-all (car kv) entry))))))
503 entry) 503 (gnus-message 10 "Gnus registry: new entry for %s is %S"
504 (gnus-registry-insert db id entry))) 504 id
505 entry)
506 (gnus-registry-insert db id entry))))
505 507
506;; Function for nn{mail|imap}-split-fancy: look up all references in 508;; Function for nn{mail|imap}-split-fancy: look up all references in
507;; the cache and if a match is found, return that group. 509;; the cache and if a match is found, return that group.
diff --git a/lisp/ido.el b/lisp/ido.el
index 81883402add..ad71d468cb4 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -499,11 +499,14 @@ This means that \\[ido-complete] must always be followed by \\[ido-exit-minibuff
499even when there is only one unique completion." 499even when there is only one unique completion."
500 :type 'boolean) 500 :type 'boolean)
501 501
502(defcustom ido-cannot-complete-command 'ido-completion-help 502(defcustom ido-cannot-complete-command #'ido-completion-auto-help
503 "Command run when `ido-complete' can't complete any more. 503 "Command run when `ido-complete' can't complete any more.
504The most useful values are `ido-completion-help', which pops up a 504The most useful values are `ido-completion-help', which pops up a
505window with completion alternatives, or `ido-next-match' or 505window with completion alternatives; `ido-completion-auto-help',
506`ido-prev-match', which cycle the buffer list." 506which does the same but respects the value of
507`completion-auto-help'; and `ido-next-match' or `ido-prev-match',
508which cycle the buffer list."
509 :version "28.1"
507 :type 'function) 510 :type 'function)
508 511
509 512
@@ -1546,7 +1549,7 @@ This function also adds a hook to the minibuffer."
1546 ((> (prefix-numeric-value arg) 0) 'both) 1549 ((> (prefix-numeric-value arg) 0) 'both)
1547 (t nil))) 1550 (t nil)))
1548 1551
1549 (ido-everywhere (if ido-everywhere 1 -1)) 1552 (ido-everywhere (if (and ido-mode ido-everywhere) 1 -1))
1550 1553
1551 (when ido-mode 1554 (when ido-mode
1552 (ido-common-initialization) 1555 (ido-common-initialization)
@@ -3926,6 +3929,14 @@ If `ido-change-word-sub' cannot be found in WORD, return nil."
3926 (when (bobp) 3929 (when (bobp)
3927 (next-completion 1))))) 3930 (next-completion 1)))))
3928 3931
3932(defun ido-completion-auto-help ()
3933 "Call `ido-completion-help' if `completion-auto-help' is non-nil."
3934 (interactive)
3935 ;; Note: `completion-auto-help' could also be `lazy', but this value
3936 ;; is irrelevant to ido, which is fundamentally eager, so it is
3937 ;; treated the same as t.
3938 (when completion-auto-help
3939 (ido-completion-help)))
3929 3940
3930(defun ido-completion-help () 3941(defun ido-completion-help ()
3931 "Show possible completions in the `ido-completion-buffer'." 3942 "Show possible completions in the `ido-completion-buffer'."
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 @@
3;; Copyright (C) 2006-2020 Free Software Foundation, Inc. 3;; Copyright (C) 2006-2020 Free Software Foundation, Inc.
4 4
5;; Author: Theresa O'Connor <ted@oconnor.cx> 5;; Author: Theresa O'Connor <ted@oconnor.cx>
6;; Version: 1.4 6;; Version: 1.5
7;; Keywords: convenience 7;; Keywords: convenience
8 8
9;; This file is part of GNU Emacs. 9;; This file is part of GNU Emacs.
@@ -29,11 +29,11 @@
29;; Learn all about JSON here: <URL:http://json.org/>. 29;; Learn all about JSON here: <URL:http://json.org/>.
30 30
31;; The user-serviceable entry points for the parser are the functions 31;; The user-serviceable entry points for the parser are the functions
32;; `json-read' and `json-read-from-string'. The encoder has a single 32;; `json-read' and `json-read-from-string'. The encoder has a single
33;; entry point, `json-encode'. 33;; entry point, `json-encode'.
34 34
35;; Since there are several natural representations of key-value pair 35;; Since there are several natural representations of key-value pair
36;; mappings in elisp (alist, plist, hash-table), `json-read' allows you 36;; mappings in Elisp (alist, plist, hash-table), `json-read' allows you
37;; to specify which you'd prefer (see `json-object-type' and 37;; to specify which you'd prefer (see `json-object-type' and
38;; `json-array-type'). 38;; `json-array-type').
39 39
@@ -55,6 +55,7 @@
55;;; Code: 55;;; Code:
56 56
57(require 'map) 57(require 'map)
58(require 'seq)
58(require 'subr-x) 59(require 'subr-x)
59 60
60;; Parameters 61;; Parameters
@@ -113,8 +114,10 @@ Used only when `json-encoding-pretty-print' is non-nil.")
113 "If non-nil, then the output of `json-encode' will be pretty-printed.") 114 "If non-nil, then the output of `json-encode' will be pretty-printed.")
114 115
115(defvar json-encoding-lisp-style-closings nil 116(defvar json-encoding-lisp-style-closings nil
116 "If non-nil, ] and } closings will be formatted lisp-style, 117 "If non-nil, delimiters ] and } will be formatted Lisp-style.
117without indentation.") 118This means they will be placed on the same line as the last
119element of the respective array or object, without indentation.
120Used only when `json-encoding-pretty-print' is non-nil.")
118 121
119(defvar json-encoding-object-sort-predicate nil 122(defvar json-encoding-object-sort-predicate nil
120 "Sorting predicate for JSON object keys during encoding. 123 "Sorting predicate for JSON object keys during encoding.
@@ -124,88 +127,81 @@ instance, setting this to `string<' will have JSON object keys
124ordered alphabetically.") 127ordered alphabetically.")
125 128
126(defvar json-pre-element-read-function nil 129(defvar json-pre-element-read-function nil
127 "Function called (if non-nil) by `json-read-array' and 130 "If non-nil, a function to call before reading a JSON array or object.
128`json-read-object' right before reading a JSON array or object, 131It is called by `json-read-array' and `json-read-object',
129respectively. The function is called with one argument, which is 132respectively, with one argument, which is the current JSON key.")
130the current JSON key.")
131 133
132(defvar json-post-element-read-function nil 134(defvar json-post-element-read-function nil
133 "Function called (if non-nil) by `json-read-array' and 135 "If non-nil, a function to call after reading a JSON array or object.
134`json-read-object' right after reading a JSON array or object, 136It is called by `json-read-array' and `json-read-object',
135respectively.") 137respectively, with no arguments.")
136 138
137 139
138 140
139;;; Utilities 141;;; Utilities
140 142
141(defun json-join (strings separator) 143(define-obsolete-function-alias 'json-join #'string-join "28.1")
142 "Join STRINGS with SEPARATOR."
143 (mapconcat 'identity strings separator))
144 144
145(defun json-alist-p (list) 145(defun json-alist-p (list)
146 "Non-null if and only if LIST is an alist with simple keys." 146 "Non-nil if and only if LIST is an alist with simple keys."
147 (while (consp list) 147 (declare (pure t) (side-effect-free error-free))
148 (setq list (if (and (consp (car list)) 148 (while (and (consp (car-safe list))
149 (atom (caar list))) 149 (atom (caar list))
150 (cdr list) 150 (setq list (cdr list))))
151 'not-alist)))
152 (null list)) 151 (null list))
153 152
154(defun json-plist-p (list) 153(defun json-plist-p (list)
155 "Non-null if and only if LIST is a plist with keyword keys." 154 "Non-nil if and only if LIST is a plist with keyword keys."
156 (while (consp list) 155 (declare (pure t) (side-effect-free error-free))
157 (setq list (if (and (keywordp (car list)) 156 (while (and (keywordp (car-safe list))
158 (consp (cdr list))) 157 (consp (cdr list))
159 (cddr list) 158 (setq list (cddr list))))
160 'not-plist)))
161 (null list)) 159 (null list))
162 160
163(defun json--plist-reverse (plist) 161(defun json--plist-nreverse (plist)
164 "Return a copy of PLIST in reverse order. 162 "Return PLIST in reverse order.
165Unlike `reverse', this keeps the property-value pairs intact." 163Unlike `nreverse', this keeps the ordering of each property
166 (let (res) 164relative to its value intact. Like `nreverse', this function may
167 (while plist 165destructively modify PLIST to produce the result."
168 (let ((prop (pop plist)) 166 (let (prev (next (cddr plist)))
169 (val (pop plist))) 167 (while next
170 (push val res) 168 (setcdr (cdr plist) prev)
171 (push prop res))) 169 (setq prev plist plist next next (cddr next))
172 res)) 170 (setcdr (cdr plist) prev)))
173 171 plist)
174(defun json--plist-to-alist (plist) 172
175 "Return an alist of the property-value pairs in PLIST." 173(defmacro json--with-indentation (&rest body)
176 (let (res) 174 "Evaluate BODY with the correct indentation for JSON encoding.
177 (while plist 175This macro binds `json--encoding-current-indentation' according
178 (let ((prop (pop plist)) 176to `json-encoding-pretty-print' around BODY."
179 (val (pop plist))) 177 (declare (debug t) (indent 0))
180 (push (cons prop val) res)))
181 (nreverse res)))
182
183(defmacro json--with-indentation (body)
184 `(let ((json--encoding-current-indentation 178 `(let ((json--encoding-current-indentation
185 (if json-encoding-pretty-print 179 (if json-encoding-pretty-print
186 (concat json--encoding-current-indentation 180 (concat json--encoding-current-indentation
187 json-encoding-default-indentation) 181 json-encoding-default-indentation)
188 ""))) 182 "")))
189 ,body)) 183 ,@body))
190 184
191;; Reader utilities 185;; Reader utilities
192 186
193(define-inline json-advance (&optional n) 187(define-inline json-advance (&optional n)
194 "Advance N characters forward." 188 "Advance N characters forward, or 1 character if N is nil.
189On reaching the end of the accessible region of the buffer, stop
190and signal an error."
195 (inline-quote (forward-char ,n))) 191 (inline-quote (forward-char ,n)))
196 192
197(define-inline json-peek () 193(define-inline json-peek ()
198 "Return the character at point." 194 "Return the character at point.
195At the end of the accessible region of the buffer, return 0."
199 (inline-quote (following-char))) 196 (inline-quote (following-char)))
200 197
201(define-inline json-pop () 198(define-inline json-pop ()
202 "Advance past the character at point, returning it." 199 "Advance past the character at point, returning it.
200Signal `json-end-of-file' if called at the end of the buffer."
203 (inline-quote 201 (inline-quote
204 (let ((char (json-peek))) 202 (prog1 (or (char-after)
205 (if (zerop char) 203 (signal 'json-end-of-file ()))
206 (signal 'json-end-of-file nil) 204 (json-advance))))
207 (json-advance)
208 char))))
209 205
210(define-inline json-skip-whitespace () 206(define-inline json-skip-whitespace ()
211 "Skip past the whitespace at point." 207 "Skip past the whitespace at point."
@@ -213,7 +209,7 @@ Unlike `reverse', this keeps the property-value pairs intact."
213 ;; https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf 209 ;; https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf
214 ;; or https://tools.ietf.org/html/rfc7159#section-2 for the 210 ;; or https://tools.ietf.org/html/rfc7159#section-2 for the
215 ;; definition of whitespace in JSON. 211 ;; definition of whitespace in JSON.
216 (inline-quote (skip-chars-forward "\t\r\n "))) 212 (inline-quote (skip-chars-forward "\t\n\r ")))
217 213
218 214
219 215
@@ -236,8 +232,8 @@ Unlike `reverse', this keeps the property-value pairs intact."
236;;; Paths 232;;; Paths
237 233
238(defvar json--path '() 234(defvar json--path '()
239 "Used internally by `json-path-to-position' to keep track of 235 "Keeps track of the path during recursive calls to `json-read'.
240the path during recursive calls to `json-read'.") 236Used internally by `json-path-to-position'.")
241 237
242(defun json--record-path (key) 238(defun json--record-path (key)
243 "Record the KEY to the current JSON path. 239 "Record the KEY to the current JSON path.
@@ -248,7 +244,7 @@ Used internally by `json-path-to-position'."
248 "Check if the last parsed JSON structure passed POSITION. 244 "Check if the last parsed JSON structure passed POSITION.
249Used internally by `json-path-to-position'." 245Used internally by `json-path-to-position'."
250 (let ((start (caar json--path))) 246 (let ((start (caar json--path)))
251 (when (< start position (+ (point) 1)) 247 (when (< start position (1+ (point)))
252 (throw :json-path (list :path (nreverse (mapcar #'cdr json--path)) 248 (throw :json-path (list :path (nreverse (mapcar #'cdr json--path))
253 :match-start start 249 :match-start start
254 :match-end (point))))) 250 :match-end (point)))))
@@ -266,13 +262,13 @@ properties:
266:path -- A list of strings and numbers forming the path to 262:path -- A list of strings and numbers forming the path to
267 the JSON element at the given position. Strings 263 the JSON element at the given position. Strings
268 denote object names, while numbers denote array 264 denote object names, while numbers denote array
269 indexes. 265 indices.
270 266
271:match-start -- Position where the matched JSON element begins. 267:match-start -- Position where the matched JSON element begins.
272 268
273:match-end -- Position where the matched JSON element ends. 269:match-end -- Position where the matched JSON element ends.
274 270
275This can for instance be useful to determine the path to a JSON 271This can, for instance, be useful to determine the path to a JSON
276element in a deeply nested structure." 272element in a deeply nested structure."
277 (save-excursion 273 (save-excursion
278 (unless string 274 (unless string
@@ -280,7 +276,7 @@ element in a deeply nested structure."
280 (let* ((json--path '()) 276 (let* ((json--path '())
281 (json-pre-element-read-function #'json--record-path) 277 (json-pre-element-read-function #'json--record-path)
282 (json-post-element-read-function 278 (json-post-element-read-function
283 (apply-partially #'json--check-position position)) 279 (lambda () (json--check-position position)))
284 (path (catch :json-path 280 (path (catch :json-path
285 (if string 281 (if string
286 (json-read-from-string string) 282 (json-read-from-string string)
@@ -290,38 +286,33 @@ element in a deeply nested structure."
290 286
291;;; Keywords 287;;; Keywords
292 288
293(defvar json-keywords '("true" "false" "null") 289(defconst json-keywords '("true" "false" "null")
294 "List of JSON keywords.") 290 "List of JSON keywords.")
291(make-obsolete-variable 'json-keywords "it is no longer used." "28.1")
295 292
296;; Keyword parsing 293;; Keyword parsing
297 294
295;; Characters that can follow a JSON value.
296(rx-define json--post-value (| (in "\t\n\r ,]}") eos))
297
298(defun json-read-keyword (keyword) 298(defun json-read-keyword (keyword)
299 "Read a JSON keyword at point. 299 "Read the expected JSON KEYWORD at point."
300KEYWORD is the keyword expected." 300 (prog1 (cond ((equal keyword "true") t)
301 (unless (member keyword json-keywords) 301 ((equal keyword "false") json-false)
302 (signal 'json-unknown-keyword (list keyword))) 302 ((equal keyword "null") json-null)
303 (mapc (lambda (char) 303 (t (signal 'json-unknown-keyword (list keyword))))
304 (when (/= char (json-peek)) 304 (or (looking-at-p keyword)
305 (signal 'json-unknown-keyword 305 (signal 'json-unknown-keyword (list (thing-at-point 'word))))
306 (list (save-excursion 306 (json-advance (length keyword))
307 (backward-word-strictly 1) 307 (or (looking-at-p (rx json--post-value))
308 (thing-at-point 'word))))) 308 (signal 'json-unknown-keyword (list (thing-at-point 'word))))
309 (json-advance)) 309 (json-skip-whitespace)))
310 keyword)
311 (json-skip-whitespace)
312 (unless (looking-at "\\([],}]\\|$\\)")
313 (signal 'json-unknown-keyword
314 (list (save-excursion
315 (backward-word-strictly 1)
316 (thing-at-point 'word)))))
317 (cond ((string-equal keyword "true") t)
318 ((string-equal keyword "false") json-false)
319 ((string-equal keyword "null") json-null)))
320 310
321;; Keyword encoding 311;; Keyword encoding
322 312
323(defun json-encode-keyword (keyword) 313(defun json-encode-keyword (keyword)
324 "Encode KEYWORD as a JSON value." 314 "Encode KEYWORD as a JSON value."
315 (declare (side-effect-free t))
325 (cond ((eq keyword t) "true") 316 (cond ((eq keyword t) "true")
326 ((eq keyword json-false) "false") 317 ((eq keyword json-false) "false")
327 ((eq keyword json-null) "null"))) 318 ((eq keyword json-null) "null")))
@@ -330,37 +321,31 @@ KEYWORD is the keyword expected."
330 321
331;; Number parsing 322;; Number parsing
332 323
333(defun json-read-number (&optional sign) 324(rx-define json--number
334 "Read the JSON number following point. 325 (: (? ?-) ; Sign.
335The optional SIGN argument is for internal use. 326 (| (: (in "1-9") (* digit)) ?0) ; Integer.
336 327 (? ?. (+ digit)) ; Fraction.
337N.B.: Only numbers which can fit in Emacs Lisp's native number 328 (? (in "Ee") (? (in ?+ ?-)) (+ digit)))) ; Exponent.
338representation will be parsed correctly." 329
339 ;; If SIGN is non-nil, the number is explicitly signed. 330(defun json-read-number (&optional _sign)
340 (let ((number-regexp 331 "Read the JSON number following point."
341 "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?")) 332 (declare (advertised-calling-convention () "28.1"))
342 (cond ((and (null sign) (= (json-peek) ?-)) 333 (or (looking-at (rx json--number))
343 (json-advance) 334 (signal 'json-number-format (list (point))))
344 (- (json-read-number t))) 335 (goto-char (match-end 0))
345 ((and (null sign) (= (json-peek) ?+)) 336 (prog1 (string-to-number (match-string 0))
346 (json-advance) 337 (or (looking-at-p (rx json--post-value))
347 (json-read-number t)) 338 (signal 'json-number-format (list (point))))
348 ((and (looking-at number-regexp) 339 (json-skip-whitespace)))
349 (or (match-beginning 1)
350 (match-beginning 2)))
351 (goto-char (match-end 0))
352 (string-to-number (match-string 0)))
353 (t (signal 'json-number-format (list (point)))))))
354 340
355;; Number encoding 341;; Number encoding
356 342
357(defun json-encode-number (number) 343(defalias 'json-encode-number #'number-to-string
358 "Return a JSON representation of NUMBER." 344 "Return a JSON representation of NUMBER.")
359 (format "%s" number))
360 345
361;;; Strings 346;;; Strings
362 347
363(defvar json-special-chars 348(defconst json-special-chars
364 '((?\" . ?\") 349 '((?\" . ?\")
365 (?\\ . ?\\) 350 (?\\ . ?\\)
366 (?b . ?\b) 351 (?b . ?\b)
@@ -368,7 +353,7 @@ representation will be parsed correctly."
368 (?n . ?\n) 353 (?n . ?\n)
369 (?r . ?\r) 354 (?r . ?\r)
370 (?t . ?\t)) 355 (?t . ?\t))
371 "Characters which are escaped in JSON, with their elisp counterparts.") 356 "Characters which are escaped in JSON, with their Elisp counterparts.")
372 357
373;; String parsing 358;; String parsing
374 359
@@ -378,48 +363,47 @@ representation will be parsed correctly."
378 363
379(defun json-read-escaped-char () 364(defun json-read-escaped-char ()
380 "Read the JSON string escaped character at point." 365 "Read the JSON string escaped character at point."
381 ;; Skip over the '\' 366 ;; Skip over the '\'.
382 (json-advance) 367 (json-advance)
383 (let* ((char (json-pop)) 368 (let ((char (json-pop)))
384 (special (assq char json-special-chars)))
385 (cond 369 (cond
386 (special (cdr special)) 370 ((cdr (assq char json-special-chars)))
387 ((not (eq char ?u)) char) 371 ((/= char ?u) char)
388 ;; Special-case UTF-16 surrogate pairs, 372 ;; Special-case UTF-16 surrogate pairs,
389 ;; cf. <https://tools.ietf.org/html/rfc7159#section-7>. Note that 373 ;; cf. <https://tools.ietf.org/html/rfc7159#section-7>. Note that
390 ;; this clause overlaps with the next one and therefore has to 374 ;; this clause overlaps with the next one and therefore has to
391 ;; come first. 375 ;; come first.
392 ((looking-at 376 ((looking-at
393 (rx (group (any "Dd") (any "89ABab") (= 2 (any xdigit))) 377 (rx (group (any "Dd") (any "89ABab") (= 2 xdigit))
394 "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any xdigit))))) 378 "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 xdigit))))
395 (json-advance 10) 379 (json-advance 10)
396 (json--decode-utf-16-surrogates 380 (json--decode-utf-16-surrogates
397 (string-to-number (match-string 1) 16) 381 (string-to-number (match-string 1) 16)
398 (string-to-number (match-string 2) 16))) 382 (string-to-number (match-string 2) 16)))
399 ((looking-at (rx (= 4 xdigit))) 383 ((looking-at (rx (= 4 xdigit)))
400 (let ((hex (match-string 0))) 384 (json-advance 4)
401 (json-advance 4) 385 (string-to-number (match-string 0) 16))
402 (string-to-number hex 16)))
403 (t 386 (t
404 (signal 'json-string-escape (list (point))))))) 387 (signal 'json-string-escape (list (point)))))))
405 388
406(defun json-read-string () 389(defun json-read-string ()
407 "Read the JSON string at point." 390 "Read the JSON string at point."
408 (unless (= (json-peek) ?\") 391 ;; Skip over the '"'.
409 (signal 'json-string-format (list "doesn't start with `\"'!")))
410 ;; Skip over the '"'
411 (json-advance) 392 (json-advance)
412 (let ((characters '()) 393 (let ((characters '())
413 (char (json-peek))) 394 (char (json-peek)))
414 (while (not (= char ?\")) 395 (while (/= char ?\")
415 (when (< char 32) 396 (when (< char 32)
416 (signal 'json-string-format (list (prin1-char char)))) 397 (if (zerop char)
398 (signal 'json-end-of-file ())
399 (signal 'json-string-format (list char))))
417 (push (if (= char ?\\) 400 (push (if (= char ?\\)
418 (json-read-escaped-char) 401 (json-read-escaped-char)
419 (json-pop)) 402 (json-advance)
403 char)
420 characters) 404 characters)
421 (setq char (json-peek))) 405 (setq char (json-peek)))
422 ;; Skip over the '"' 406 ;; Skip over the '"'.
423 (json-advance) 407 (json-advance)
424 (if characters 408 (if characters
425 (concat (nreverse characters)) 409 (concat (nreverse characters))
@@ -427,29 +411,47 @@ representation will be parsed correctly."
427 411
428;; String encoding 412;; String encoding
429 413
414;; Escape only quotation mark, backslash, and the control
415;; characters U+0000 to U+001F (RFC 4627, ECMA-404).
416(rx-define json--escape (in ?\" ?\\ cntrl))
417
418(defvar json--long-string-threshold 200
419 "Length above which strings are considered long for JSON encoding.
420It is generally faster to manipulate such strings in a buffer
421rather than directly.")
422
423(defvar json--string-buffer nil
424 "Buffer used for encoding Lisp strings as JSON.
425Initialized lazily by `json-encode-string'.")
426
430(defun json-encode-string (string) 427(defun json-encode-string (string)
431 "Return a JSON representation of STRING." 428 "Return a JSON representation of STRING."
432 ;; Reimplement the meat of `replace-regexp-in-string', for 429 ;; Try to avoid buffer overhead in trivial cases, while also
433 ;; performance (bug#20154). 430 ;; avoiding searching pathological strings for escape characters.
434 (let ((l (length string)) 431 ;; Since `string-match-p' doesn't take a LIMIT argument, we use
435 (start 0) 432 ;; string length as our heuristic. See also bug#20154.
436 res mb) 433 (if (and (< (length string) json--long-string-threshold)
437 ;; Only escape quotation mark, backslash and the control 434 (not (string-match-p (rx json--escape) string)))
438 ;; characters U+0000 to U+001F (RFC 4627, ECMA-404). 435 (concat "\"" string "\"")
439 (while (setq mb (string-match "[\"\\[:cntrl:]]" string start)) 436 (with-current-buffer
440 (let* ((c (aref string mb)) 437 (or json--string-buffer
441 (special (rassq c json-special-chars))) 438 (with-current-buffer (generate-new-buffer " *json-string*")
442 (push (substring string start mb) res) 439 ;; This seems to afford decent performance gains.
443 (push (if special 440 (setq-local inhibit-modification-hooks t)
444 ;; Special JSON character (\n, \r, etc.). 441 (setq json--string-buffer (current-buffer))))
445 (string ?\\ (car special)) 442 (insert ?\" string)
446 ;; Fallback: UCS code point in \uNNNN form. 443 (goto-char (1+ (point-min)))
447 (format "\\u%04x" c)) 444 (while (re-search-forward (rx json--escape) nil 'move)
448 res) 445 (let ((char (preceding-char)))
449 (setq start (1+ mb)))) 446 (delete-char -1)
450 (push (substring string start l) res) 447 (insert ?\\ (or
451 (push "\"" res) 448 ;; Special JSON character (\n, \r, etc.).
452 (apply #'concat "\"" (nreverse res)))) 449 (car (rassq char json-special-chars))
450 ;; Fallback: UCS code point in \uNNNN form.
451 (format "u%04x" char)))))
452 (insert ?\")
453 ;; Empty buffer for next invocation.
454 (delete-and-extract-region (point-min) (point-max)))))
453 455
454(defun json-encode-key (object) 456(defun json-encode-key (object)
455 "Return a JSON representation of OBJECT. 457 "Return a JSON representation of OBJECT.
@@ -460,15 +462,13 @@ this signals `json-key-format'."
460 (signal 'json-key-format (list object))) 462 (signal 'json-key-format (list object)))
461 encoded)) 463 encoded))
462 464
463;;; JSON Objects 465;;; Objects
464 466
465(defun json-new-object () 467(defun json-new-object ()
466 "Create a new Elisp object corresponding to a JSON object. 468 "Create a new Elisp object corresponding to an empty JSON object.
467Please see the documentation of `json-object-type'." 469Please see the documentation of `json-object-type'."
468 (cond ((eq json-object-type 'hash-table) 470 (and (eq json-object-type 'hash-table)
469 (make-hash-table :test 'equal)) 471 (make-hash-table :test #'equal)))
470 (t
471 ())))
472 472
473(defun json-add-to-object (object key value) 473(defun json-add-to-object (object key value)
474 "Add a new KEY -> VALUE association to OBJECT. 474 "Add a new KEY -> VALUE association to OBJECT.
@@ -476,10 +476,10 @@ Returns the updated object, which you should save, e.g.:
476 (setq obj (json-add-to-object obj \"foo\" \"bar\")) 476 (setq obj (json-add-to-object obj \"foo\" \"bar\"))
477Please see the documentation of `json-object-type' and `json-key-type'." 477Please see the documentation of `json-object-type' and `json-key-type'."
478 (let ((json-key-type 478 (let ((json-key-type
479 (or json-key-type 479 (cond (json-key-type)
480 (cdr (assq json-object-type '((hash-table . string) 480 ((eq json-object-type 'hash-table) 'string)
481 (alist . symbol) 481 ((eq json-object-type 'alist) 'symbol)
482 (plist . keyword))))))) 482 ((eq json-object-type 'plist) 'keyword))))
483 (setq key 483 (setq key
484 (cond ((eq json-key-type 'string) 484 (cond ((eq json-key-type 'string)
485 key) 485 key)
@@ -499,13 +499,13 @@ Please see the documentation of `json-object-type' and `json-key-type'."
499 499
500(defun json-read-object () 500(defun json-read-object ()
501 "Read the JSON object at point." 501 "Read the JSON object at point."
502 ;; Skip over the "{" 502 ;; Skip over the '{'.
503 (json-advance) 503 (json-advance)
504 (json-skip-whitespace) 504 (json-skip-whitespace)
505 ;; read key/value pairs until "}" 505 ;; Read key/value pairs until '}'.
506 (let ((elements (json-new-object)) 506 (let ((elements (json-new-object))
507 key value) 507 key value)
508 (while (not (= (json-peek) ?})) 508 (while (/= (json-peek) ?\})
509 (json-skip-whitespace) 509 (json-skip-whitespace)
510 (setq key (json-read-string)) 510 (setq key (json-read-string))
511 (json-skip-whitespace) 511 (json-skip-whitespace)
@@ -520,94 +520,94 @@ Please see the documentation of `json-object-type' and `json-key-type'."
520 (funcall json-post-element-read-function)) 520 (funcall json-post-element-read-function))
521 (setq elements (json-add-to-object elements key value)) 521 (setq elements (json-add-to-object elements key value))
522 (json-skip-whitespace) 522 (json-skip-whitespace)
523 (when (/= (json-peek) ?}) 523 (when (/= (json-peek) ?\})
524 (if (= (json-peek) ?,) 524 (if (= (json-peek) ?,)
525 (json-advance) 525 (json-advance)
526 (signal 'json-object-format (list "," (json-peek)))))) 526 (signal 'json-object-format (list "," (json-peek))))))
527 ;; Skip over the "}" 527 ;; Skip over the '}'.
528 (json-advance) 528 (json-advance)
529 (pcase json-object-type 529 (pcase json-object-type
530 ('alist (nreverse elements)) 530 ('alist (nreverse elements))
531 ('plist (json--plist-reverse elements)) 531 ('plist (json--plist-nreverse elements))
532 (_ elements)))) 532 (_ elements))))
533 533
534;; Hash table encoding 534;; Hash table encoding
535 535
536(defun json-encode-hash-table (hash-table) 536(defun json-encode-hash-table (hash-table)
537 "Return a JSON representation of HASH-TABLE." 537 "Return a JSON representation of HASH-TABLE."
538 (if json-encoding-object-sort-predicate 538 (cond ((hash-table-empty-p hash-table) "{}")
539 (json-encode-alist (map-into hash-table 'list)) 539 (json-encoding-object-sort-predicate
540 (format "{%s%s}" 540 (json--encode-alist (map-pairs hash-table) t))
541 (json-join 541 (t
542 (let (r) 542 (let ((kv-sep (if json-encoding-pretty-print ": " ":"))
543 (json--with-indentation 543 result)
544 (maphash 544 (json--with-indentation
545 (lambda (k v) 545 (maphash
546 (push (format 546 (lambda (k v)
547 (if json-encoding-pretty-print 547 (push (concat json--encoding-current-indentation
548 "%s%s: %s" 548 (json-encode-key k)
549 "%s%s:%s") 549 kv-sep
550 json--encoding-current-indentation 550 (json-encode v))
551 (json-encode-key k) 551 result))
552 (json-encode v)) 552 hash-table))
553 r)) 553 (concat "{"
554 hash-table)) 554 (string-join (nreverse result) json-encoding-separator)
555 r) 555 (and json-encoding-pretty-print
556 json-encoding-separator) 556 (not json-encoding-lisp-style-closings)
557 (if (or (not json-encoding-pretty-print) 557 json--encoding-current-indentation)
558 json-encoding-lisp-style-closings) 558 "}")))))
559 ""
560 json--encoding-current-indentation))))
561 559
562;; List encoding (including alists and plists) 560;; List encoding (including alists and plists)
563 561
564(defun json-encode-alist (alist) 562(defun json--encode-alist (alist &optional destructive)
565 "Return a JSON representation of ALIST." 563 "Return a JSON representation of ALIST.
564DESTRUCTIVE non-nil means it is safe to modify ALIST by
565side-effects."
566 (when json-encoding-object-sort-predicate 566 (when json-encoding-object-sort-predicate
567 (setq alist 567 (setq alist (sort (if destructive alist (copy-sequence alist))
568 (sort alist (lambda (a b) 568 (lambda (a b)
569 (funcall json-encoding-object-sort-predicate 569 (funcall json-encoding-object-sort-predicate
570 (car a) (car b)))))) 570 (car a) (car b))))))
571 (format "{%s%s}" 571 (concat "{"
572 (json-join 572 (let ((kv-sep (if json-encoding-pretty-print ": " ":")))
573 (json--with-indentation 573 (json--with-indentation
574 (mapcar (lambda (cons) 574 (mapconcat (lambda (cons)
575 (format (if json-encoding-pretty-print 575 (concat json--encoding-current-indentation
576 "%s%s: %s" 576 (json-encode-key (car cons))
577 "%s%s:%s") 577 kv-sep
578 json--encoding-current-indentation 578 (json-encode (cdr cons))))
579 (json-encode-key (car cons)) 579 alist
580 (json-encode (cdr cons)))) 580 json-encoding-separator)))
581 alist)) 581 (and json-encoding-pretty-print
582 json-encoding-separator) 582 (not json-encoding-lisp-style-closings)
583 (if (or (not json-encoding-pretty-print) 583 json--encoding-current-indentation)
584 json-encoding-lisp-style-closings) 584 "}"))
585 "" 585
586 json--encoding-current-indentation))) 586(defun json-encode-alist (alist)
587 "Return a JSON representation of ALIST."
588 (if alist (json--encode-alist alist) "{}"))
587 589
588(defun json-encode-plist (plist) 590(defun json-encode-plist (plist)
589 "Return a JSON representation of PLIST." 591 "Return a JSON representation of PLIST."
590 (if json-encoding-object-sort-predicate 592 (cond ((null plist) "{}")
591 (json-encode-alist (json--plist-to-alist plist)) 593 (json-encoding-object-sort-predicate
592 (let (result) 594 (json--encode-alist (map-pairs plist) t))
593 (json--with-indentation 595 (t
594 (while plist 596 (let ((kv-sep (if json-encoding-pretty-print ": " ":"))
595 (push (concat
596 json--encoding-current-indentation
597 (json-encode-key (car plist))
598 (if json-encoding-pretty-print
599 ": "
600 ":")
601 (json-encode (cadr plist)))
602 result) 597 result)
603 (setq plist (cddr plist)))) 598 (json--with-indentation
604 (concat "{" 599 (while plist
605 (json-join (nreverse result) json-encoding-separator) 600 (push (concat json--encoding-current-indentation
606 (if (and json-encoding-pretty-print 601 (json-encode-key (pop plist))
607 (not json-encoding-lisp-style-closings)) 602 kv-sep
608 json--encoding-current-indentation 603 (json-encode (pop plist)))
609 "") 604 result)))
610 "}")))) 605 (concat "{"
606 (string-join (nreverse result) json-encoding-separator)
607 (and json-encoding-pretty-print
608 (not json-encoding-lisp-style-closings)
609 json--encoding-current-indentation)
610 "}")))))
611 611
612(defun json-encode-list (list) 612(defun json-encode-list (list)
613 "Return a JSON representation of LIST. 613 "Return a JSON representation of LIST.
@@ -625,15 +625,17 @@ become JSON objects."
625 625
626(defun json-read-array () 626(defun json-read-array ()
627 "Read the JSON array at point." 627 "Read the JSON array at point."
628 ;; Skip over the "[" 628 ;; Skip over the '['.
629 (json-advance) 629 (json-advance)
630 (json-skip-whitespace) 630 (json-skip-whitespace)
631 ;; read values until "]" 631 ;; Read values until ']'.
632 (let (elements) 632 (let (elements
633 (while (not (= (json-peek) ?\])) 633 (len 0))
634 (while (/= (json-peek) ?\])
634 (json-skip-whitespace) 635 (json-skip-whitespace)
635 (when json-pre-element-read-function 636 (when json-pre-element-read-function
636 (funcall json-pre-element-read-function (length elements))) 637 (funcall json-pre-element-read-function len)
638 (setq len (1+ len)))
637 (push (json-read) elements) 639 (push (json-read) elements)
638 (when json-post-element-read-function 640 (when json-post-element-read-function
639 (funcall json-post-element-read-function)) 641 (funcall json-post-element-read-function))
@@ -641,8 +643,8 @@ become JSON objects."
641 (when (/= (json-peek) ?\]) 643 (when (/= (json-peek) ?\])
642 (if (= (json-peek) ?,) 644 (if (= (json-peek) ?,)
643 (json-advance) 645 (json-advance)
644 (signal 'json-array-format (list ?, (json-peek)))))) 646 (signal 'json-array-format (list "," (json-peek))))))
645 ;; Skip over the "]" 647 ;; Skip over the ']'.
646 (json-advance) 648 (json-advance)
647 (pcase json-array-type 649 (pcase json-array-type
648 ('vector (nreverse (vconcat elements))) 650 ('vector (nreverse (vconcat elements)))
@@ -653,42 +655,43 @@ become JSON objects."
653(defun json-encode-array (array) 655(defun json-encode-array (array)
654 "Return a JSON representation of ARRAY." 656 "Return a JSON representation of ARRAY."
655 (if (and json-encoding-pretty-print 657 (if (and json-encoding-pretty-print
656 (> (length array) 0)) 658 (not (seq-empty-p array)))
657 (concat 659 (concat
660 "["
658 (json--with-indentation 661 (json--with-indentation
659 (concat (format "[%s" json--encoding-current-indentation) 662 (concat json--encoding-current-indentation
660 (json-join (mapcar 'json-encode array) 663 (mapconcat #'json-encode array
661 (format "%s%s" 664 (concat json-encoding-separator
662 json-encoding-separator
663 json--encoding-current-indentation)))) 665 json--encoding-current-indentation))))
664 (format "%s]" 666 (unless json-encoding-lisp-style-closings
665 (if json-encoding-lisp-style-closings 667 json--encoding-current-indentation)
666 "" 668 "]")
667 json--encoding-current-indentation)))
668 (concat "[" 669 (concat "["
669 (mapconcat 'json-encode array json-encoding-separator) 670 (mapconcat #'json-encode array json-encoding-separator)
670 "]"))) 671 "]")))
671 672
672 673
673 674
674;;; JSON reader. 675;;; Reader
675 676
676(defmacro json-readtable-dispatch (char) 677(defmacro json-readtable-dispatch (char)
677 "Dispatch reader function for CHAR." 678 "Dispatch reader function for CHAR at point.
678 (declare (debug (symbolp))) 679If CHAR is nil, signal `json-end-of-file'."
679 (let ((table 680 (declare (debug t))
680 '((?t json-read-keyword "true") 681 (macroexp-let2 nil char char
681 (?f json-read-keyword "false") 682 `(cond ,@(map-apply
682 (?n json-read-keyword "null") 683 (lambda (key expr)
683 (?{ json-read-object) 684 `((eq ,char ,key) ,expr))
684 (?\[ json-read-array) 685 `((?\" ,#'json-read-string)
685 (?\" json-read-string))) 686 (?\[ ,#'json-read-array)
686 res) 687 (?\{ ,#'json-read-object)
687 (dolist (c '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) 688 (?n ,#'json-read-keyword "null")
688 (push (list c 'json-read-number) table)) 689 (?f ,#'json-read-keyword "false")
689 (pcase-dolist (`(,c . ,rest) table) 690 (?t ,#'json-read-keyword "true")
690 (push `((eq ,char ,c) (,@rest)) res)) 691 ,@(mapcar (lambda (c) (list c #'json-read-number))
691 `(cond ,@res (t (signal 'json-readtable-error (list ,char)))))) 692 '(?- ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))))
693 (,char (signal 'json-readtable-error (list ,char)))
694 (t (signal 'json-end-of-file ())))))
692 695
693(defun json-read () 696(defun json-read ()
694 "Parse and return the JSON object following point. 697 "Parse and return the JSON object following point.
@@ -706,10 +709,7 @@ you will get the following structure returned:
706 ((c . :json-false))]) 709 ((c . :json-false))])
707 (b . \"foo\"))" 710 (b . \"foo\"))"
708 (json-skip-whitespace) 711 (json-skip-whitespace)
709 (let ((char (json-peek))) 712 (json-readtable-dispatch (char-after)))
710 (if (zerop char)
711 (signal 'json-end-of-file nil)
712 (json-readtable-dispatch char))))
713 713
714;; Syntactic sugar for the reader 714;; Syntactic sugar for the reader
715 715
@@ -724,12 +724,11 @@ you will get the following structure returned:
724 "Read the first JSON object contained in FILE and return it." 724 "Read the first JSON object contained in FILE and return it."
725 (with-temp-buffer 725 (with-temp-buffer
726 (insert-file-contents file) 726 (insert-file-contents file)
727 (goto-char (point-min))
728 (json-read))) 727 (json-read)))
729 728
730 729
731 730
732;;; JSON encoder 731;;; Encoder
733 732
734(defun json-encode (object) 733(defun json-encode (object)
735 "Return a JSON representation of OBJECT as a string. 734 "Return a JSON representation of OBJECT as a string.
@@ -737,20 +736,21 @@ you will get the following structure returned:
737OBJECT should have a structure like one returned by `json-read'. 736OBJECT should have a structure like one returned by `json-read'.
738If an error is detected during encoding, an error based on 737If an error is detected during encoding, an error based on
739`json-error' is signaled." 738`json-error' is signaled."
740 (cond ((memq object (list t json-null json-false)) 739 (cond ((eq object t) (json-encode-keyword object))
741 (json-encode-keyword object)) 740 ((eq object json-null) (json-encode-keyword object))
742 ((stringp object) (json-encode-string object)) 741 ((eq object json-false) (json-encode-keyword object))
743 ((keywordp object) (json-encode-string 742 ((stringp object) (json-encode-string object))
744 (substring (symbol-name object) 1))) 743 ((keywordp object) (json-encode-string
745 ((listp object) (json-encode-list object)) 744 (substring (symbol-name object) 1)))
746 ((symbolp object) (json-encode-string 745 ((listp object) (json-encode-list object))
747 (symbol-name object))) 746 ((symbolp object) (json-encode-string
748 ((numberp object) (json-encode-number object)) 747 (symbol-name object)))
749 ((arrayp object) (json-encode-array object)) 748 ((numberp object) (json-encode-number object))
750 ((hash-table-p object) (json-encode-hash-table object)) 749 ((arrayp object) (json-encode-array object))
751 (t (signal 'json-error (list object))))) 750 ((hash-table-p object) (json-encode-hash-table object))
752 751 (t (signal 'json-error (list object)))))
753;; Pretty printing & minimizing 752
753;;; Pretty printing & minimizing
754 754
755(defun json-pretty-print-buffer (&optional minimize) 755(defun json-pretty-print-buffer (&optional minimize)
756 "Pretty-print current buffer. 756 "Pretty-print current buffer.
@@ -769,9 +769,9 @@ MAX-SECS.")
769With prefix argument MINIMIZE, minimize it instead." 769With prefix argument MINIMIZE, minimize it instead."
770 (interactive "r\nP") 770 (interactive "r\nP")
771 (let ((json-encoding-pretty-print (null minimize)) 771 (let ((json-encoding-pretty-print (null minimize))
772 ;; Distinguish an empty objects from 'null' 772 ;; Distinguish an empty object from 'null'.
773 (json-null :json-null) 773 (json-null :json-null)
774 ;; Ensure that ordering is maintained 774 ;; Ensure that ordering is maintained.
775 (json-object-type 'alist) 775 (json-object-type 'alist)
776 (orig-buf (current-buffer)) 776 (orig-buf (current-buffer))
777 error) 777 error)
@@ -800,9 +800,7 @@ With prefix argument MINIMIZE, minimize it instead."
800 ;; them. 800 ;; them.
801 (let ((space (buffer-substring 801 (let ((space (buffer-substring
802 (point) 802 (point)
803 (+ (point) 803 (+ (point) (skip-chars-forward " \t\n"))))
804 (skip-chars-forward
805 " \t\n" (point-max)))))
806 (json (json-read))) 804 (json (json-read)))
807 (setq pos (point)) ; End of last good json-read. 805 (setq pos (point)) ; End of last good json-read.
808 (set-buffer tmp-buf) 806 (set-buffer tmp-buf)
@@ -832,14 +830,14 @@ With prefix argument MINIMIZE, minimize it instead."
832 "Pretty-print current buffer with object keys ordered. 830 "Pretty-print current buffer with object keys ordered.
833With prefix argument MINIMIZE, minimize it instead." 831With prefix argument MINIMIZE, minimize it instead."
834 (interactive "P") 832 (interactive "P")
835 (let ((json-encoding-object-sort-predicate 'string<)) 833 (let ((json-encoding-object-sort-predicate #'string<))
836 (json-pretty-print-buffer minimize))) 834 (json-pretty-print-buffer minimize)))
837 835
838(defun json-pretty-print-ordered (begin end &optional minimize) 836(defun json-pretty-print-ordered (begin end &optional minimize)
839 "Pretty-print the region with object keys ordered. 837 "Pretty-print the region with object keys ordered.
840With prefix argument MINIMIZE, minimize it instead." 838With prefix argument MINIMIZE, minimize it instead."
841 (interactive "r\nP") 839 (interactive "r\nP")
842 (let ((json-encoding-object-sort-predicate 'string<)) 840 (let ((json-encoding-object-sort-predicate #'string<))
843 (json-pretty-print begin end minimize))) 841 (json-pretty-print begin end minimize)))
844 842
845(provide 'json) 843(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 @@
37;;; Code: 37;;; Code:
38 38
39(require 'cl-lib) 39(require 'cl-lib)
40(require 'json)
41(require 'eieio) 40(require 'eieio)
42(eval-when-compile (require 'subr-x)) 41(eval-when-compile (require 'subr-x))
43(require 'warnings) 42(require 'warnings)
@@ -470,26 +469,35 @@ With optional CLEANUP, kill any associated buffers."
470;;; 469;;;
471(define-error 'jsonrpc-error "jsonrpc-error") 470(define-error 'jsonrpc-error "jsonrpc-error")
472 471
473(defun jsonrpc--json-read () 472(defalias 'jsonrpc--json-read
474 "Read JSON object in buffer, move point to end of buffer." 473 (if (fboundp 'json-parse-buffer)
475 ;; TODO: I guess we can make these macros if/when jsonrpc.el 474 (lambda ()
476 ;; goes into Emacs core. 475 (json-parse-buffer :object-type 'plist
477 (cond ((fboundp 'json-parse-buffer) (json-parse-buffer 476 :null-object nil
478 :object-type 'plist 477 :false-object :json-false))
479 :null-object nil 478 (require 'json)
480 :false-object :json-false)) 479 (defvar json-object-type)
481 (t (let ((json-object-type 'plist)) 480 (declare-function json-read "json" ())
482 (json-read))))) 481 (lambda ()
483 482 (let ((json-object-type 'plist))
484(defun jsonrpc--json-encode (object) 483 (json-read))))
485 "Encode OBJECT into a JSON string." 484 "Read JSON object in buffer, move point to end of buffer.")
486 (cond ((fboundp 'json-serialize) (json-serialize 485
487 object 486(defalias 'jsonrpc--json-encode
488 :false-object :json-false 487 (if (fboundp 'json-serialize)
489 :null-object nil)) 488 (lambda (object)
490 (t (let ((json-false :json-false) 489 (json-serialize object
491 (json-null nil)) 490 :false-object :json-false
492 (json-encode object))))) 491 :null-object nil))
492 (require 'json)
493 (defvar json-false)
494 (defvar json-null)
495 (declare-function json-encode "json" (object))
496 (lambda (object)
497 (let ((json-false :json-false)
498 (json-null nil))
499 (json-encode object))))
500 "Encode OBJECT into a JSON string.")
493 501
494(cl-defun jsonrpc--reply 502(cl-defun jsonrpc--reply
495 (connection id &key (result nil result-supplied-p) (error nil error-supplied-p)) 503 (connection id &key (result nil result-supplied-p) (error nil error-supplied-p))
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 @@
43 ("་" . "་") 43 ("་" . "་")
44 ("༔" . "༔") 44 ("༔" . "༔")
45 ;; Yes these are dirty. But ... 45 ;; Yes these are dirty. But ...
46 ("༎ ༎" . ,(compose-string "༎ ༎" 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎])) 46 ("༎ ༎" . ,(compose-string (copy-sequence "༎ ༎")
47 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎]))
47 ("༄༅༅" . ,(compose-string 48 ("༄༅༅" . ,(compose-string
48 "࿁࿂࿂࿂" 0 4 49 (copy-sequence "࿁࿂࿂࿂") 0 4
49 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂ (Br . Bl) ?࿂])) 50 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂ (Br . Bl) ?࿂]))
50 ("༄༅" . ,(compose-string "࿁࿂࿂" 0 3 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂])) 51 ("༄༅" . ,(compose-string (copy-sequence "࿁࿂࿂")
51 ("༆" . ,(compose-string "࿁࿂༙" 0 3 [?࿁ (Br . Bl) ?࿂ (br . tr) ?༙])) 52 0 3 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂]))
52 ("༄" . ,(compose-string "࿁࿂" 0 2 [?࿁ (Br . Bl) ?࿂])))) 53 ("༆" . ,(compose-string (copy-sequence "࿁࿂༙")
54 0 3 [?࿁ (Br . Bl) ?࿂ (br . tr) ?༙]))
55 ("༄" . ,(compose-string (copy-sequence "࿁࿂")
56 0 2 [?࿁ (Br . Bl) ?࿂]))))
53 57
54;;;###autoload 58;;;###autoload
55(defun tibetan-char-p (ch) 59(defun tibetan-char-p (ch)
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."
2580 :type '(choice 2580 :type '(choice
2581 (const :tag "Do not show tooltips" nil) 2581 (const :tag "Do not show tooltips" nil)
2582 (const :tag "Show all text" t) 2582 (const :tag "Show all text" t)
2583 (integer :tag "Show characters (max)" 256)) 2583 (integer :tag "Max number of characters to show" 256))
2584 :version "26.1") 2584 :version "26.1")
2585 2585
2586(defcustom mouse-drag-and-drop-region-show-cursor t 2586(defcustom mouse-drag-and-drop-region-show-cursor t
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."
307 (insert (format "Loading %s..." url)) 307 (insert (format "Loading %s..." url))
308 (goto-char (point-min))) 308 (goto-char (point-min)))
309 (let ((url-mime-accept-string eww-accept-content-types)) 309 (let ((url-mime-accept-string eww-accept-content-types))
310 (url-retrieve url 'eww-render 310 (url-retrieve url #'eww-render
311 (list url nil (current-buffer))))) 311 (list url nil (current-buffer)))))
312 312
313(put 'eww 'browse-url-browser-kind 'internal) 313(function-put 'eww 'browse-url-browser-kind 'internal)
314 314
315(defun eww--dwim-expand-url (url) 315(defun eww--dwim-expand-url (url)
316 (setq url (string-trim url)) 316 (setq url (string-trim url))
@@ -375,8 +375,8 @@ engine used."
375 (let ((region-string (buffer-substring (region-beginning) (region-end)))) 375 (let ((region-string (buffer-substring (region-beginning) (region-end))))
376 (if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string)) 376 (if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string))
377 (eww region-string) 377 (eww region-string)
378 (call-interactively 'eww))) 378 (call-interactively #'eww)))
379 (call-interactively 'eww))) 379 (call-interactively #'eww)))
380 380
381(defun eww-open-in-new-buffer () 381(defun eww-open-in-new-buffer ()
382 "Fetch link at point in a new EWW buffer." 382 "Fetch link at point in a new EWW buffer."
@@ -1013,7 +1013,7 @@ just re-display the HTML already fetched."
1013 (eww-display-html 'utf-8 url (plist-get eww-data :dom) 1013 (eww-display-html 'utf-8 url (plist-get eww-data :dom)
1014 (point) (current-buffer))) 1014 (point) (current-buffer)))
1015 (let ((url-mime-accept-string eww-accept-content-types)) 1015 (let ((url-mime-accept-string eww-accept-content-types))
1016 (url-retrieve url 'eww-render 1016 (url-retrieve url #'eww-render
1017 (list url (point) (current-buffer) encode)))))) 1017 (list url (point) (current-buffer) encode))))))
1018 1018
1019;; Form support. 1019;; Form support.
@@ -1576,8 +1576,10 @@ If EXTERNAL is double prefix, browse in new buffer."
1576 (cond 1576 (cond
1577 ((not url) 1577 ((not url)
1578 (message "No link under point")) 1578 (message "No link under point"))
1579 ((string-match "^mailto:" url) 1579 ((string-match-p "\\`mailto:" url)
1580 (browse-url-mail url)) 1580 ;; This respects the user options `browse-url-handlers'
1581 ;; and `browse-url-mailto-function'.
1582 (browse-url url))
1581 ((and (consp external) (<= (car external) 4)) 1583 ((and (consp external) (<= (car external) 4))
1582 (funcall browse-url-secondary-browser-function url) 1584 (funcall browse-url-secondary-browser-function url)
1583 (shr--blink-link)) 1585 (shr--blink-link))
@@ -1615,7 +1617,7 @@ Use link at point if there is one, else the current page's URL."
1615 (eww-current-url)))) 1617 (eww-current-url))))
1616 (if (not url) 1618 (if (not url)
1617 (message "No URL under point") 1619 (message "No URL under point")
1618 (url-retrieve url 'eww-download-callback (list url))))) 1620 (url-retrieve url #'eww-download-callback (list url)))))
1619 1621
1620(defun eww-download-callback (status url) 1622(defun eww-download-callback (status url)
1621 (unless (plist-get status :error) 1623 (unless (plist-get status :error)
@@ -2128,12 +2130,12 @@ entries (if any) will be removed from the list.
2128Only the properties listed in `eww-desktop-data-save' are included. 2130Only the properties listed in `eww-desktop-data-save' are included.
2129Generally, the list should not include the (usually overly large) 2131Generally, the list should not include the (usually overly large)
2130:dom, :source and :text properties." 2132:dom, :source and :text properties."
2131 (let ((history (mapcar 'eww-desktop-data-1 2133 (let ((history (mapcar #'eww-desktop-data-1
2132 (cons eww-data eww-history)))) 2134 (cons eww-data eww-history))))
2133 (list :history (if eww-desktop-remove-duplicates 2135 (list :history (if eww-desktop-remove-duplicates
2134 (cl-remove-duplicates 2136 (cl-remove-duplicates
2135 history :test 'eww-desktop-history-duplicate) 2137 history :test #'eww-desktop-history-duplicate)
2136 history)))) 2138 history))))
2137 2139
2138(defun eww-restore-desktop (file-name buffer-name misc-data) 2140(defun eww-restore-desktop (file-name buffer-name misc-data)
2139 "Restore an eww buffer from its desktop file record. 2141 "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."
135This is used for cid: URLs, and the function is called with the 135This is used for cid: URLs, and the function is called with the
136cid: URL as the argument.") 136cid: URL as the argument.")
137 137
138(defvar shr-put-image-function 'shr-put-image 138(defvar shr-put-image-function #'shr-put-image
139 "Function called to put image and alt string.") 139 "Function called to put image and alt string.")
140 140
141(defface shr-strike-through '((t :strike-through t)) 141(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
365 (shr-copy-url url))) 365 (shr-copy-url url)))
366 366
367(defun shr--current-link-region () 367(defun shr--current-link-region ()
368 (let ((current (get-text-property (point) 'shr-url)) 368 "Return the start and end positions of the URL at point, if any.
369 start) 369Value is a pair of positions (START . END) if there is a non-nil
370 (save-excursion 370`shr-url' text property at point; otherwise nil."
371 ;; Go to the beginning. 371 (when (get-text-property (point) 'shr-url)
372 (while (and (not (bobp)) 372 (let* ((end (or (next-single-property-change (point) 'shr-url)
373 (equal (get-text-property (point) 'shr-url) current)) 373 (point-max)))
374 (forward-char -1)) 374 (beg (or (previous-single-property-change end 'shr-url)
375 (unless (equal (get-text-property (point) 'shr-url) current) 375 (point-min))))
376 (forward-char 1)) 376 (cons beg end))))
377 (setq start (point))
378 ;; Go to the end.
379 (while (and (not (eobp))
380 (equal (get-text-property (point) 'shr-url) current))
381 (forward-char 1))
382 (list start (point)))))
383 377
384(defun shr--blink-link () 378(defun shr--blink-link ()
385 (let* ((region (shr--current-link-region)) 379 "Briefly fontify URL at point with the face `shr-selected-link'."
386 (overlay (make-overlay (car region) (cadr region)))) 380 (when-let* ((region (shr--current-link-region))
381 (overlay (make-overlay (car region) (cdr region))))
387 (overlay-put overlay 'face 'shr-selected-link) 382 (overlay-put overlay 'face 'shr-selected-link)
388 (run-at-time 1 nil (lambda () 383 (run-at-time 1 nil (lambda ()
389 (delete-overlay overlay))))) 384 (delete-overlay overlay)))))
@@ -437,7 +432,7 @@ the URL of the image to the kill buffer instead."
437 (if (not url) 432 (if (not url)
438 (message "No image under point") 433 (message "No image under point")
439 (message "Inserting %s..." url) 434 (message "Inserting %s..." url)
440 (url-retrieve url 'shr-image-fetched 435 (url-retrieve url #'shr-image-fetched
441 (list (current-buffer) (1- (point)) (point-marker)) 436 (list (current-buffer) (1- (point)) (point-marker))
442 t)))) 437 t))))
443 438
@@ -463,7 +458,7 @@ size, and full-buffer size."
463 (when (> (- (point) start) 2) 458 (when (> (- (point) start) 2)
464 (delete-region start (1- (point))))) 459 (delete-region start (1- (point)))))
465 (message "Inserting %s..." url) 460 (message "Inserting %s..." url)
466 (url-retrieve url 'shr-image-fetched 461 (url-retrieve url #'shr-image-fetched
467 (list (current-buffer) (1- (point)) (point-marker) 462 (list (current-buffer) (1- (point)) (point-marker)
468 (list (cons 'size 463 (list (cons 'size
469 (cond ((or (eq size 'default) 464 (cond ((or (eq size 'default)
@@ -493,7 +488,7 @@ size, and full-buffer size."
493 ((fboundp function) 488 ((fboundp function)
494 (apply function dom args)) 489 (apply function dom args))
495 (t 490 (t
496 (apply 'shr-generic dom args))))) 491 (apply #'shr-generic dom args)))))
497 492
498(defun shr-descend (dom) 493(defun shr-descend (dom)
499 (let ((function 494 (let ((function
@@ -730,9 +725,10 @@ size, and full-buffer size."
730 (let ((gap-start (point)) 725 (let ((gap-start (point))
731 (face (get-text-property (point) 'face))) 726 (face (get-text-property (point) 'face)))
732 ;; Extend the background to the end of the line. 727 ;; Extend the background to the end of the line.
733 (if face 728 (insert ?\n)
734 (insert (propertize "\n" 'face (shr-face-background face))) 729 (when face
735 (insert "\n")) 730 (put-text-property (1- (point)) (point)
731 'face (shr-face-background face)))
736 (shr-indent) 732 (shr-indent)
737 (when (and (> (1- gap-start) (point-min)) 733 (when (and (> (1- gap-start) (point-min))
738 (get-text-property (point) 'shr-url) 734 (get-text-property (point) 'shr-url)
@@ -935,12 +931,11 @@ size, and full-buffer size."
935 931
936(defun shr-indent () 932(defun shr-indent ()
937 (when (> shr-indentation 0) 933 (when (> shr-indentation 0)
938 (insert 934 (if (not shr-use-fonts)
939 (if (not shr-use-fonts) 935 (insert-char ?\s shr-indentation)
940 (make-string shr-indentation ?\s) 936 (insert ?\s)
941 (propertize " " 937 (put-text-property (1- (point)) (point)
942 'display 938 'display `(space :width (,shr-indentation))))))
943 `(space :width (,shr-indentation)))))))
944 939
945(defun shr-fontize-dom (dom &rest types) 940(defun shr-fontize-dom (dom &rest types)
946 (let ((start (point))) 941 (let ((start (point)))
@@ -987,16 +982,11 @@ the mouse click event."
987 (cond 982 (cond
988 ((not url) 983 ((not url)
989 (message "No link under point")) 984 (message "No link under point"))
990 ((string-match "^mailto:" url) 985 (external
991 (browse-url-mail url)) 986 (funcall browse-url-secondary-browser-function url)
987 (shr--blink-link))
992 (t 988 (t
993 (if external 989 (browse-url url (xor new-window browse-url-new-window-flag))))))
994 (progn
995 (funcall browse-url-secondary-browser-function url)
996 (shr--blink-link))
997 (browse-url url (if new-window
998 (not browse-url-new-window-flag)
999 browse-url-new-window-flag)))))))
1000 990
1001(defun shr-save-contents (directory) 991(defun shr-save-contents (directory)
1002 "Save the contents from URL in a file." 992 "Save the contents from URL in a file."
@@ -1005,7 +995,7 @@ the mouse click event."
1005 (if (not url) 995 (if (not url)
1006 (message "No link under point") 996 (message "No link under point")
1007 (url-retrieve (shr-encode-url url) 997 (url-retrieve (shr-encode-url url)
1008 'shr-store-contents (list url directory))))) 998 #'shr-store-contents (list url directory)))))
1009 999
1010(defun shr-store-contents (status url directory) 1000(defun shr-store-contents (status url directory)
1011 (unless (plist-get status :error) 1001 (unless (plist-get status :error)
@@ -1156,7 +1146,6 @@ width/height instead."
1156 1146
1157;; url-cache-extract autoloads url-cache. 1147;; url-cache-extract autoloads url-cache.
1158(declare-function url-cache-create-filename "url-cache" (url)) 1148(declare-function url-cache-create-filename "url-cache" (url))
1159(autoload 'browse-url-mail "browse-url")
1160 1149
1161(defun shr-get-image-data (url) 1150(defun shr-get-image-data (url)
1162 "Get image data for URL. 1151 "Get image data for URL.
@@ -1230,7 +1219,7 @@ START, and END. Note that START and END should be markers."
1230 (funcall shr-put-image-function 1219 (funcall shr-put-image-function
1231 image (buffer-substring start end)) 1220 image (buffer-substring start end))
1232 (delete-region (point) end)))) 1221 (delete-region (point) end))))
1233 (url-retrieve url 'shr-image-fetched 1222 (url-retrieve url #'shr-image-fetched
1234 (list (current-buffer) start end) 1223 (list (current-buffer) start end)
1235 t t))))) 1224 t t)))))
1236 1225
@@ -1679,7 +1668,7 @@ The preference is a float determined from `shr-prefer-media-type'."
1679 (or alt ""))) 1668 (or alt "")))
1680 (insert " ") 1669 (insert " ")
1681 (url-queue-retrieve 1670 (url-queue-retrieve
1682 (shr-encode-url url) 'shr-image-fetched 1671 (shr-encode-url url) #'shr-image-fetched
1683 (list (current-buffer) start (set-marker (make-marker) (point)) 1672 (list (current-buffer) start (set-marker (make-marker) (point))
1684 (list :width width :height height)) 1673 (list :width width :height height))
1685 t 1674 t
@@ -2006,12 +1995,11 @@ BASE is the URL of the HTML being rendered."
2006 (cond 1995 (cond
2007 ((null tbodies) 1996 ((null tbodies)
2008 dom) 1997 dom)
2009 ((= (length tbodies) 1) 1998 ((null (cdr tbodies))
2010 (car tbodies)) 1999 (car tbodies))
2011 (t 2000 (t
2012 ;; Table with multiple tbodies. Convert into a single tbody. 2001 ;; Table with multiple tbodies. Convert into a single tbody.
2013 `(tbody nil ,@(cl-reduce 'append 2002 `(tbody nil ,@(mapcan #'dom-non-text-children tbodies))))))
2014 (mapcar 'dom-non-text-children tbodies)))))))
2015 2003
2016(defun shr--fix-tbody (tbody) 2004(defun shr--fix-tbody (tbody)
2017 (nconc (list 'tbody (dom-attributes tbody)) 2005 (nconc (list 'tbody (dom-attributes tbody))
@@ -2311,8 +2299,8 @@ flags that control whether to collect or render objects."
2311 (dolist (column row) 2299 (dolist (column row)
2312 (aset natural-widths i (max (aref natural-widths i) column)) 2300 (aset natural-widths i (max (aref natural-widths i) column))
2313 (setq i (1+ i))))) 2301 (setq i (1+ i)))))
2314 (let ((extra (- (apply '+ (append suggested-widths nil)) 2302 (let ((extra (- (apply #'+ (append suggested-widths nil))
2315 (apply '+ (append widths nil)) 2303 (apply #'+ (append widths nil))
2316 (* shr-table-separator-pixel-width (1+ (length widths))))) 2304 (* shr-table-separator-pixel-width (1+ (length widths)))))
2317 (expanded-columns 0)) 2305 (expanded-columns 0))
2318 ;; We have extra, unused space, so divide this space amongst the 2306 ;; We have extra, unused space, so divide this space amongst the
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 95cbfb8c22a..24ee6fa51f3 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -109,7 +109,7 @@
109 109
110(eval-when-compile (require 'cl-lib)) 110(eval-when-compile (require 'cl-lib))
111;; Sometimes, compilation fails with "Variable binding depth exceeds 111;; Sometimes, compilation fails with "Variable binding depth exceeds
112;; max-specpdl-size". 112;; max-specpdl-size". Shall be fixed in Emacs 27.
113(eval-and-compile 113(eval-and-compile
114 (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs))) 114 (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs)))
115 115
@@ -318,7 +318,10 @@ arguments to pass to the OPERATION."
318 318
319 (let* ((filename (apply #'tramp-archive-file-name-for-operation 319 (let* ((filename (apply #'tramp-archive-file-name-for-operation
320 operation args)) 320 operation args))
321 (archive (tramp-archive-file-name-archive filename))) 321 (archive (tramp-archive-file-name-archive filename))
322 ;; Sometimes, it fails with "Variable binding depth exceeds
323 ;; max-specpdl-size". Shall be fixed in Emacs 27.
324 (max-specpdl-size (* 2 max-specpdl-size)))
322 325
323 ;; `filename' could be a quoted file name. Or the file 326 ;; `filename' could be a quoted file name. Or the file
324 ;; archive could be a directory, see Bug#30293. 327 ;; 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."
477 (with-tramp-connection-property 477 (with-tramp-connection-property
478 (tramp-get-connection-process vec) "rclone-pid" 478 (tramp-get-connection-process vec) "rclone-pid"
479 (catch 'pid 479 (catch 'pid
480 (dolist (pid (list-system-processes)) ;; "pidof rclone" ? 480 (dolist
481 (pid
482 ;; Until Emacs 25, `process-attributes' could
483 ;; crash Emacs for some processes. So we use
484 ;; "pidof", which might not work everywhere.
485 (if (<= emacs-major-version 25)
486 (let ((default-directory temporary-file-directory))
487 (mapcar
488 #'string-to-number
489 (split-string
490 (shell-command-to-string "pidof rclone"))))
491 (list-system-processes)))
481 (and (string-match-p 492 (and (string-match-p
482 (regexp-quote 493 (regexp-quote
483 (format "rclone mount %s:" (tramp-file-name-host vec))) 494 (format "rclone mount %s:" (tramp-file-name-host vec)))
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 @@
1;;; webjump.el --- programmable Web hotlist 1;;; webjump.el --- programmable Web hotlist -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 1996-1997, 2001-2020 Free Software Foundation, Inc. 3;; Copyright (C) 1996-1997, 2001-2020 Free Software Foundation, Inc.
4 4
@@ -323,8 +323,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke
323 323
324(defun webjump-read-url-choice (what urls &optional default) 324(defun webjump-read-url-choice (what urls &optional default)
325 ;; Note: Convert this to use `webjump-read-choice' someday. 325 ;; Note: Convert this to use `webjump-read-choice' someday.
326 (let* ((completions (mapcar (function (lambda (n) (cons n n))) 326 (let* ((completions (mapcar (lambda (n) (cons n n)) urls))
327 urls))
328 (input (completing-read (concat what 327 (input (completing-read (concat what
329 ;;(if default " (RET for default)" "") 328 ;;(if default " (RET for default)" "")
330 ": ") 329 ": ")
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 @@
1;;; levents.el --- emulate the Lucid event data type and associated functions
2
3;; Copyright (C) 1993, 2001-2020 Free Software Foundation, Inc.
4
5;; Maintainer: emacs-devel@gnu.org
6;; Keywords: emulations
7;; Obsolete-since: 23.2
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; Things we cannot emulate in Lisp:
27;; It is not possible to emulate current-mouse-event as a variable,
28;; though it is not hard to obtain the data from (this-command-keys).
29
30;; We do not have a variable unread-command-event;
31;; instead, we have the more general unread-command-events.
32
33;; Our read-key-sequence and read-char are not precisely
34;; compatible with those in Lucid Emacs, but they should work ok.
35
36;;; Code:
37
38(defun next-command-event (event)
39 (error "You must rewrite to use `read-command-event' instead of `next-command-event'"))
40
41(defun next-event (event)
42 (error "You must rewrite to use `read-event' instead of `next-event'"))
43
44(defun dispatch-event (event)
45 (error "`dispatch-event' not supported"))
46
47;; Make events of type eval, menu and timeout
48;; execute properly.
49
50(define-key global-map [menu] 'execute-eval-event)
51(define-key global-map [timeout] 'execute-eval-event)
52(define-key global-map [eval] 'execute-eval-event)
53
54(defun execute-eval-event (event)
55 (interactive "e")
56 (funcall (nth 1 event) (nth 2 event)))
57
58(put 'eval 'event-symbol-elements '(eval))
59(put 'menu 'event-symbol-elements '(eval))
60(put 'timeout 'event-symbol-elements '(eval))
61
62(defun allocate-event ()
63 "Return an empty event structure.
64In this emulation, it returns nil."
65 nil)
66
67(defun button-press-event-p (obj)
68 "True if the argument is a mouse-button-press event object."
69 (and (consp obj) (symbolp (car obj))
70 (memq 'down (get (car obj) 'event-symbol-elements))))
71
72(defun button-release-event-p (obj)
73 "True if the argument is a mouse-button-release event object."
74 (and (consp obj) (symbolp (car obj))
75 (or (memq 'click (get (car obj) 'event-symbol-elements))
76 (memq 'drag (get (car obj) 'event-symbol-elements)))))
77
78(defun button-event-p (obj)
79 "True if the argument is a mouse-button press or release event object."
80 (and (consp obj) (symbolp (car obj))
81 (or (memq 'click (get (car obj) 'event-symbol-elements))
82 (memq 'down (get (car obj) 'event-symbol-elements))
83 (memq 'drag (get (car obj) 'event-symbol-elements)))))
84
85(defun mouse-event-p (obj)
86 "True if the argument is a mouse-button press or release event object."
87 (and (consp obj) (symbolp (car obj))
88 (or (eq (car obj) 'mouse-movement)
89 (memq 'click (get (car obj) 'event-symbol-elements))
90 (memq 'down (get (car obj) 'event-symbol-elements))
91 (memq 'drag (get (car obj) 'event-symbol-elements)))))
92
93(defun character-to-event (ch &optional event)
94 "Converts a numeric ASCII value to an event structure, replete with
95bucky bits. The character is the first argument, and the event to fill
96in is the second. This function contains knowledge about what the codes
97mean -- for example, the number 9 is converted to the character Tab,
98not the distinct character Control-I.
99
100Beware that character-to-event and event-to-character are not strictly
101inverse functions, since events contain much more information than the
102ASCII character set can encode."
103 ch)
104
105(defun copy-event (event1 &optional event2)
106 "Make a copy of the given event object.
107In this emulation, `copy-event' just returns its argument."
108 event1)
109
110(defun deallocate-event (event)
111 "Allow the given event structure to be reused.
112In actual Lucid Emacs, you MUST NOT use this event object after
113calling this function with it. You will lose. It is not necessary to
114call this function, as event objects are garbage- collected like all
115other objects; however, it may be more efficient to explicitly
116deallocate events when you are sure that this is safe.
117
118This emulation does not actually deallocate or reuse events
119except via garbage collection and `cons'."
120 nil)
121
122(defun enqueue-eval-event: (function object)
123 "Add an eval event to the back of the queue.
124It will be the next event read after all pending events."
125 (setq unread-command-events
126 (nconc unread-command-events
127 (list (list 'eval function object)))))
128
129(defun eval-event-p (obj)
130 "True if the argument is an eval or menu event object."
131 (eq (car-safe obj) 'eval))
132
133(defun event-button (event)
134 "Return the button-number of the given mouse-button-press event."
135 (let ((sym (car (get (car event) 'event-symbol-elements))))
136 (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3)
137 (mouse-4 . 4) (mouse-5 . 5))))))
138
139(defun event-function (event)
140 "Return the callback function of the given timeout, menu, or eval event."
141 (nth 1 event))
142
143(defun event-key (event)
144 "Return the KeySym of the given key-press event.
145The value is an ASCII printing character (not upper case) or a symbol."
146 (if (symbolp event)
147 (car (get event 'event-symbol-elements))
148 (let ((base (logand event (1- (ash 1 18)))))
149 (downcase (if (< base 32) (logior base 64) base)))))
150
151(defun event-object (event)
152 "Return the function argument of the given timeout, menu, or eval event."
153 (nth 2 event))
154
155(defun event-point (event)
156 "Return the character position of the given mouse-related event.
157If the event did not occur over a window, or did
158not occur over text, then this returns nil. Otherwise, it returns an index
159into the buffer visible in the event's window."
160 (posn-point (event-end event)))
161
162;; Return position of start of line LINE in WINDOW.
163;; If LINE is nil, return the last position
164;; visible in WINDOW.
165(defun event-closest-point-1 (window &optional line)
166 (let* ((total (- (window-height window)
167 (if (window-minibuffer-p window)
168 0 1)))
169 (distance (or line total)))
170 (save-excursion
171 (goto-char (window-start window))
172 (if (= (vertical-motion distance) distance)
173 (if (not line)
174 (forward-char -1)))
175 (point))))
176
177(defun event-closest-point (event &optional start-window)
178 "Return the nearest position to where EVENT ended its motion.
179This is computed for the window where EVENT's motion started,
180or for window WINDOW if that is specified."
181 (or start-window (setq start-window (posn-window (event-start event))))
182 (if (eq start-window (posn-window (event-end event)))
183 (if (eq (event-point event) 'vertical-line)
184 (event-closest-point-1 start-window
185 (cdr (posn-col-row (event-end event))))
186 (if (eq (event-point event) 'mode-line)
187 (event-closest-point-1 start-window)
188 (event-point event)))
189 ;; EVENT ended in some other window.
190 (let* ((end-w (posn-window (event-end event)))
191 (end-w-top)
192 (w-top (nth 1 (window-edges start-window))))
193 (setq end-w-top
194 (if (windowp end-w)
195 (nth 1 (window-edges end-w))
196 (/ (cdr (posn-x-y (event-end event)))
197 (frame-char-height end-w))))
198 (if (>= end-w-top w-top)
199 (event-closest-point-1 start-window)
200 (window-start start-window)))))
201
202(defun event-process (event)
203 "Return the process of the given process-output event."
204 (nth 1 event))
205
206(defun event-timestamp (event)
207 "Return the timestamp of the given event object.
208In Lucid Emacs, this works for any kind of event.
209In this emulation, it returns nil for non-mouse-related events."
210 (and (listp event)
211 (posn-timestamp (event-end event))))
212
213(defun event-to-character (event &optional lenient)
214 "Return the closest ASCII approximation to the given event object.
215If the event isn't a keypress, this returns nil.
216If the second argument is non-nil, then this is lenient in its
217translation; it will ignore modifier keys other than control and meta,
218and will ignore the shift modifier on those characters which have no
219shifted ASCII equivalent (Control-Shift-A for example, will be mapped to
220the same ASCII code as Control-A.) If the second arg is nil, then nil
221will be returned for events which have no direct ASCII equivalent."
222 (if (symbolp event)
223 (and lenient
224 (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9)
225 (return . 10) (enter . 10)))))
226 ;; Our interpretation is, ASCII means anything a number can represent.
227 (if (integerp event)
228 event nil)))
229
230(defun event-window (event)
231 "Return the window of the given mouse-related event object."
232 (posn-window (event-end event)))
233
234(defun event-x (event)
235 "Return the X position in characters of the given mouse-related event."
236 (/ (car (posn-col-row (event-end event)))
237 (frame-char-width (window-frame (event-window event)))))
238
239(defun event-x-pixel (event)
240 "Return the X position in pixels of the given mouse-related event."
241 (car (posn-col-row (event-end event))))
242
243(defun event-y (event)
244 "Return the Y position in characters of the given mouse-related event."
245 (/ (cdr (posn-col-row (event-end event)))
246 (frame-char-height (window-frame (event-window event)))))
247
248(defun event-y-pixel (event)
249 "Return the Y position in pixels of the given mouse-related event."
250 (cdr (posn-col-row (event-end event))))
251
252(defun key-press-event-p (obj)
253 "True if the argument is a keyboard event object."
254 (or (integerp obj)
255 (and (symbolp obj)
256 (get obj 'event-symbol-elements))))
257
258(defun menu-event-p (obj)
259 "True if the argument is a menu event object."
260 (eq (car-safe obj) 'menu))
261
262(defun motion-event-p (obj)
263 "True if the argument is a mouse-motion event object."
264 (eq (car-safe obj) 'mouse-movement))
265
266(defun read-command-event ()
267 "Return the next keyboard or mouse event; execute other events.
268This is similar to the function `next-command-event' of Lucid Emacs,
269but different in that it returns the event rather than filling in
270an existing event object."
271 (let (event)
272 (while (progn
273 (setq event (read-event))
274 (not (or (key-press-event-p event)
275 (button-press-event-p event)
276 (button-release-event-p event)
277 (menu-event-p event))))
278 (let ((type (car-safe event)))
279 (cond ((eq type 'eval)
280 (funcall (nth 1 event) (nth 2 event)))
281 ((eq type 'switch-frame)
282 (select-frame (nth 1 event))))))
283 event))
284
285(defun process-event-p (obj)
286 "True if the argument is a process-output event object.
287GNU Emacs 19 does not currently generate process-output events."
288 (eq (car-safe obj) 'process))
289
290(provide 'levents)
291
292;;; levents.el ends here
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'."
2995 (erase-buffer) 2995 (erase-buffer)
2996 (insert (eval-when-compile 2996 (insert (eval-when-compile
2997 (let ((header 2997 (let ((header
2998 "Press key for an agenda command: 2998 (copy-sequence
2999 "Press key for an agenda command:
2999-------------------------------- < Buffer, subtree/region restriction 3000-------------------------------- < Buffer, subtree/region restriction
3000a Agenda for current week or day > Remove restriction 3001a Agenda for current week or day > Remove restriction
3001t List of all TODO entries e Export agenda views 3002t List of all TODO entries e Export agenda views
@@ -3004,7 +3005,7 @@ s Search for keywords M Like m, but only TODO entries
3004/ Multi-occur S Like s, but only TODO entries 3005/ Multi-occur S Like s, but only TODO entries
3005? Find :FLAGGED: entries C Configure custom agenda commands 3006? Find :FLAGGED: entries C Configure custom agenda commands
3006* Toggle sticky agenda views # List stuck projects (!=configure) 3007* Toggle sticky agenda views # List stuck projects (!=configure)
3007") 3008"))
3008 (start 0)) 3009 (start 0))
3009 (while (string-match 3010 (while (string-match
3010 "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)" 3011 "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)"
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 @@
31;; ;; Minibuffer prompt for password. 31;; ;; Minibuffer prompt for password.
32;; => "foo" 32;; => "foo"
33;; 33;;
34;; (password-cache-add "test" (copy-sequence "foo")) 34;; (password-cache-add "test" (read-passwd "Password? "))
35;; ;; Minibuffer prompt from read-passwd, which returns "foo".
35;; => nil 36;; => nil
36 37
37;; (password-read "Password? " "test") 38;; (password-read "Password? " "test")
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.
3412The end of the first submatch is taken as the end of the operator. 3412The end of the first submatch is taken as the end of the operator.
3413Identifier syntax is in effect when this is matched (see 3413Identifier syntax is in effect when this is matched (see
3414`c-identifier-syntax-table')." 3414`c-identifier-syntax-table')."
3415 t (if (c-lang-const c-type-modifier-kwds) 3415 t (if (or (c-lang-const c-type-modifier-kwds) (c-lang-const c-modifier-kwds))
3416 (concat (regexp-opt (c-lang-const c-type-modifier-kwds) t) "\\>") 3416 (concat
3417 (regexp-opt (c--delete-duplicates
3418 (append (c-lang-const c-type-modifier-kwds)
3419 (c-lang-const c-modifier-kwds))
3420 :test 'string-equal)
3421 t)
3422 "\\>")
3417 ;; Default to a regexp that never matches. 3423 ;; Default to a regexp that never matches.
3418 regexp-unmatchable) 3424 regexp-unmatchable)
3419 ;; Check that there's no "=" afterwards to avoid matching tokens 3425 ;; Check that there's no "=" afterwards to avoid matching tokens
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."
795 (set (make-local-variable 'outline-level) 'c-outline-level) 795 (set (make-local-variable 'outline-level) 'c-outline-level)
796 (set (make-local-variable 'add-log-current-defun-function) 796 (set (make-local-variable 'add-log-current-defun-function)
797 (lambda () 797 (lambda ()
798 (or (c-cpp-define-name) (c-defun-name)))) 798 (or (c-cpp-define-name) (car (c-defun-name-and-limits nil)))))
799 (let ((rfn (assq mode c-require-final-newline))) 799 (let ((rfn (assq mode c-require-final-newline)))
800 (when rfn 800 (when rfn
801 (if (boundp 'mode-require-final-newline) 801 (if (boundp 'mode-require-final-newline)
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 198f040fb29..c72e9d94b1c 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1,7 +1,7 @@
1;;; project.el --- Operations on the current project -*- lexical-binding: t; -*- 1;;; project.el --- Operations on the current project -*- lexical-binding: t; -*-
2 2
3;; Copyright (C) 2015-2020 Free Software Foundation, Inc. 3;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
4;; Version: 0.1.3 4;; Version: 0.2.0
5;; Package-Requires: ((emacs "26.3")) 5;; Package-Requires: ((emacs "26.3"))
6 6
7;; This is a GNU ELPA :core package. Avoid using functionality that 7;; This is a GNU ELPA :core package. Avoid using functionality that
@@ -40,7 +40,7 @@
40;; Infrastructure: 40;; Infrastructure:
41;; 41;;
42;; Function `project-current', to determine the current project 42;; Function `project-current', to determine the current project
43;; instance, and 5 (at the moment) generic functions that act on it. 43;; instance, and 4 (at the moment) generic functions that act on it.
44;; This list is to be extended in future versions. 44;; This list is to be extended in future versions.
45;; 45;;
46;; Utils: 46;; Utils:
@@ -122,14 +122,25 @@ is not a part of a detectable project either, return a
122(defun project--find-in-directory (dir) 122(defun project--find-in-directory (dir)
123 (run-hook-with-args-until-success 'project-find-functions dir)) 123 (run-hook-with-args-until-success 'project-find-functions dir))
124 124
125(cl-defgeneric project-roots (project) 125(cl-defgeneric project-root (project)
126 "Return the list of directory roots of the current project. 126 "Return root directory of the current project.
127
128It usually contains the main build file, dependencies
129configuration file, etc. Though neither is mandatory.
127 130
128Most often it's just one directory which contains the project 131The directory name must be absolute."
129build file and everything else in the project. But in more 132 (car (project-roots project)))
130advanced configurations, a project can span multiple directories.
131 133
132The directory names should be absolute.") 134(cl-defgeneric project-roots (project)
135 "Return the list containing the current project root.
136
137The function is obsolete, all projects have one main root anyway,
138and the rest should be possible to express through
139`project-external-roots'."
140 ;; FIXME: Can we specify project's version here?
141 ;; FIXME: Could we make this affect cl-defmethod calls too?
142 (declare (obsolete project-root "0.3.0"))
143 (list (project-root project)))
133 144
134;; FIXME: Add MODE argument, like in `ede-source-paths'? 145;; FIXME: Add MODE argument, like in `ede-source-paths'?
135(cl-defgeneric project-external-roots (_project) 146(cl-defgeneric project-external-roots (_project)
@@ -138,18 +149,14 @@ The directory names should be absolute.")
138It's the list of directories outside of the project that are 149It's the list of directories outside of the project that are
139still related to it. If the project deals with source code then, 150still related to it. If the project deals with source code then,
140depending on the languages used, this list should include the 151depending on the languages used, this list should include the
141headers search path, load path, class path, and so on. 152headers search path, load path, class path, and so on."
142
143The rule of thumb for whether to include a directory here, and
144not in `project-roots', is whether its contents are meant to be
145edited together with the rest of the project."
146 nil) 153 nil)
147 154
148(cl-defgeneric project-ignores (_project _dir) 155(cl-defgeneric project-ignores (_project _dir)
149 "Return the list of glob patterns to ignore inside DIR. 156 "Return the list of glob patterns to ignore inside DIR.
150Patterns can match both regular files and directories. 157Patterns can match both regular files and directories.
151To root an entry, start it with `./'. To match directories only, 158To root an entry, start it with `./'. To match directories only,
152end it with `/'. DIR must be one of `project-roots' or 159end it with `/'. DIR must be either `project-root' or one of
153`project-external-roots'." 160`project-external-roots'."
154 ;; TODO: Document and support regexp ignores as used by Hg. 161 ;; TODO: Document and support regexp ignores as used by Hg.
155 ;; TODO: Support whitelist entries. 162 ;; TODO: Support whitelist entries.
@@ -170,13 +177,13 @@ end it with `/'. DIR must be one of `project-roots' or
170 (t 177 (t
171 (complete-with-action action all-files string pred))))) 178 (complete-with-action action all-files string pred)))))
172 179
173(cl-defmethod project-roots ((project (head transient))) 180(cl-defmethod project-root ((project (head transient)))
174 (list (cdr project))) 181 (cdr project))
175 182
176(cl-defgeneric project-files (project &optional dirs) 183(cl-defgeneric project-files (project &optional dirs)
177 "Return a list of files in directories DIRS in PROJECT. 184 "Return a list of files in directories DIRS in PROJECT.
178DIRS is a list of absolute directories; it should be some 185DIRS is a list of absolute directories; it should be some
179subset of the project roots and external roots. 186subset of the project root and external roots.
180 187
181The default implementation uses `find-program'. PROJECT is used 188The default implementation uses `find-program'. PROJECT is used
182to find the list of ignores for each directory." 189to find the list of ignores for each directory."
@@ -184,7 +191,8 @@ to find the list of ignores for each directory."
184 (lambda (dir) 191 (lambda (dir)
185 (project--files-in-directory dir 192 (project--files-in-directory dir
186 (project--dir-ignores project dir))) 193 (project--dir-ignores project dir)))
187 (or dirs (project-roots project)))) 194 (or dirs
195 (list (project-root project)))))
188 196
189(defun project--files-in-directory (dir ignores &optional files) 197(defun project--files-in-directory (dir ignores &optional files)
190 (require 'find-dired) 198 (require 'find-dired)
@@ -223,7 +231,7 @@ to find the list of ignores for each directory."
223 local-files)))) 231 local-files))))
224 232
225(defgroup project-vc nil 233(defgroup project-vc nil
226 "Project implementation using the VC package." 234 "Project implementation based on the VC package."
227 :version "25.1" 235 :version "25.1"
228 :group 'tools) 236 :group 'tools)
229 237
@@ -232,6 +240,15 @@ to find the list of ignores for each directory."
232 :type '(repeat string) 240 :type '(repeat string)
233 :safe 'listp) 241 :safe 'listp)
234 242
243(defcustom project-vc-merge-submodules t
244 "Non-nil to consider submodules part of the parent project.
245
246After changing this variable (using Customize or .dir-locals.el)
247you might have to restart Emacs to see the effect."
248 :type 'boolean
249 :package-version '(project . "0.2.0")
250 :safe 'booleanp)
251
235;; FIXME: Using the current approach, major modes are supposed to set 252;; FIXME: Using the current approach, major modes are supposed to set
236;; this variable to a buffer-local value. So we don't have access to 253;; this variable to a buffer-local value. So we don't have access to
237;; the "external roots" of language A from buffers of language B, which 254;; the "external roots" of language A from buffers of language B, which
@@ -273,38 +290,48 @@ backend implementation of `project-external-roots'.")
273 (pcase backend 290 (pcase backend
274 ('Git 291 ('Git
275 ;; Don't stop at submodule boundary. 292 ;; Don't stop at submodule boundary.
276 ;; Note: It's not necessarily clear-cut what should be
277 ;; considered a "submodule" in the sense that some users
278 ;; may setup things equivalent to "git-submodule"s using
279 ;; "git worktree" instead (for example).
280 ;; FIXME: Also it may be the case that some users would consider
281 ;; a submodule as its own project. So there's a good chance
282 ;; we will need to let the user tell us what is their intention.
283 (or (vc-file-getprop dir 'project-git-root) 293 (or (vc-file-getprop dir 'project-git-root)
284 (let* ((root (vc-call-backend backend 'root dir)) 294 (let ((root (vc-call-backend backend 'root dir)))
285 (gitfile (expand-file-name ".git" root)))
286 (vc-file-setprop 295 (vc-file-setprop
287 dir 'project-git-root 296 dir 'project-git-root
288 (cond 297 (if (and
289 ((file-directory-p gitfile) 298 ;; FIXME: Invalidate the cache when the value
290 root) 299 ;; of this variable changes.
291 ((with-temp-buffer 300 project-vc-merge-submodules
292 (insert-file-contents gitfile) 301 (project--submodule-p root))
293 (goto-char (point-min)) 302 (let* ((parent (file-name-directory
294 ;; Kind of a hack to distinguish a submodule from 303 (directory-file-name root))))
295 ;; other cases of .git files pointing elsewhere. 304 (vc-call-backend backend 'root parent))
296 (looking-at "gitdir: [./]+/\\.git/modules/")) 305 root)))))
297 (let* ((parent (file-name-directory
298 (directory-file-name root))))
299 (vc-call-backend backend 'root parent)))
300 (t root)))
301 )))
302 ('nil nil) 306 ('nil nil)
303 (_ (ignore-errors (vc-call-backend backend 'root dir)))))) 307 (_ (ignore-errors (vc-call-backend backend 'root dir))))))
304 (and root (cons 'vc root)))) 308 (and root (cons 'vc root))))
305 309
306(cl-defmethod project-roots ((project (head vc))) 310(defun project--submodule-p (root)
307 (list (cdr project))) 311 ;; XXX: We only support Git submodules for now.
312 ;;
313 ;; For submodules, at least, we expect the users to prefer them to
314 ;; be considered part of the parent project. For those who don't,
315 ;; there is the custom var now.
316 ;;
317 ;; Some users may also set up things equivalent to Git submodules
318 ;; using "git worktree" (for example). However, we expect that most
319 ;; of them would prefer to treat those as separate projects anyway.
320 (let* ((gitfile (expand-file-name ".git" root)))
321 (cond
322 ((file-directory-p gitfile)
323 nil)
324 ((with-temp-buffer
325 (insert-file-contents gitfile)
326 (goto-char (point-min))
327 ;; Kind of a hack to distinguish a submodule from
328 ;; other cases of .git files pointing elsewhere.
329 (looking-at "gitdir: [./]+/\\.git/modules/"))
330 t)
331 (t nil))))
332
333(cl-defmethod project-root ((project (head vc)))
334 (cdr project))
308 335
309(cl-defmethod project-external-roots ((project (head vc))) 336(cl-defmethod project-external-roots ((project (head vc)))
310 (project-subtract-directories 337 (project-subtract-directories
@@ -312,7 +339,7 @@ backend implementation of `project-external-roots'.")
312 (mapcar 339 (mapcar
313 #'file-name-as-directory 340 #'file-name-as-directory
314 (funcall project-vc-external-roots-function))) 341 (funcall project-vc-external-roots-function)))
315 (project-roots project))) 342 (list (project-root project))))
316 343
317(cl-defmethod project-files ((project (head vc)) &optional dirs) 344(cl-defmethod project-files ((project (head vc)) &optional dirs)
318 (cl-mapcan 345 (cl-mapcan
@@ -330,7 +357,8 @@ backend implementation of `project-external-roots'.")
330 (project--files-in-directory 357 (project--files-in-directory
331 dir 358 dir
332 (project--dir-ignores project dir))))) 359 (project--dir-ignores project dir)))))
333 (or dirs (project-roots project)))) 360 (or dirs
361 (list (project-root project)))))
334 362
335(declare-function vc-git--program-version "vc-git") 363(declare-function vc-git--program-version "vc-git")
336(declare-function vc-git--run-command-string "vc-git") 364(declare-function vc-git--run-command-string "vc-git")
@@ -372,7 +400,9 @@ backend implementation of `project-external-roots'.")
372 submodules))) 400 submodules)))
373 (setq files 401 (setq files
374 (apply #'nconc files sub-files))) 402 (apply #'nconc files sub-files)))
375 files)) 403 ;; 'git ls-files' returns duplicate entries for merge conflicts.
404 ;; XXX: Better solutions welcome, but this seems cheap enough.
405 (delete-consecutive-dups files)))
376 (`Hg 406 (`Hg
377 (let ((default-directory (expand-file-name (file-name-as-directory dir))) 407 (let ((default-directory (expand-file-name (file-name-as-directory dir)))
378 args) 408 args)
@@ -471,7 +501,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
471 (let* ((pr (project-current t)) 501 (let* ((pr (project-current t))
472 (files 502 (files
473 (if (not current-prefix-arg) 503 (if (not current-prefix-arg)
474 (project-files pr (project-roots pr)) 504 (project-files pr)
475 (let ((dir (read-directory-name "Base directory: " 505 (let ((dir (read-directory-name "Base directory: "
476 nil default-directory t))) 506 nil default-directory t)))
477 (project--files-in-directory dir 507 (project--files-in-directory dir
@@ -482,9 +512,8 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
482 nil))) 512 nil)))
483 513
484(defun project--dir-ignores (project dir) 514(defun project--dir-ignores (project dir)
485 (let* ((roots (project-roots project)) 515 (let ((root (project-root project)))
486 (root (cl-find dir roots :test #'file-in-directory-p))) 516 (if (not (file-in-directory-p dir root))
487 (if (not root)
488 (project-ignores nil nil) ;The defaults. 517 (project-ignores nil nil) ;The defaults.
489 (let ((ignores (project-ignores project root))) 518 (let ((ignores (project-ignores project root)))
490 (if (file-equal-p root dir) 519 (if (file-equal-p root dir)
@@ -502,8 +531,8 @@ pattern to search for."
502 (require 'xref) 531 (require 'xref)
503 (let* ((pr (project-current t)) 532 (let* ((pr (project-current t))
504 (files 533 (files
505 (project-files pr (append 534 (project-files pr (cons
506 (project-roots pr) 535 (project-root pr)
507 (project-external-roots pr))))) 536 (project-external-roots pr)))))
508 (xref--show-xrefs 537 (xref--show-xrefs
509 (apply-partially #'project--find-regexp-in-files regexp files) 538 (apply-partially #'project--find-regexp-in-files regexp files)
@@ -541,23 +570,23 @@ pattern to search for."
541 570
542;;;###autoload 571;;;###autoload
543(defun project-find-file () 572(defun project-find-file ()
544 "Visit a file (with completion) in the current project's roots. 573 "Visit a file (with completion) in the current project.
545The completion default is the filename at point, if one is 574The completion default is the filename at point, if one is
546recognized." 575recognized."
547 (interactive) 576 (interactive)
548 (let* ((pr (project-current t)) 577 (let* ((pr (project-current t))
549 (dirs (project-roots pr))) 578 (dirs (list (project-root pr))))
550 (project-find-file-in (thing-at-point 'filename) dirs pr))) 579 (project-find-file-in (thing-at-point 'filename) dirs pr)))
551 580
552;;;###autoload 581;;;###autoload
553(defun project-or-external-find-file () 582(defun project-or-external-find-file ()
554 "Visit a file (with completion) in the current project's roots or external roots. 583 "Visit a file (with completion) in the current project or external roots.
555The completion default is the filename at point, if one is 584The completion default is the filename at point, if one is
556recognized." 585recognized."
557 (interactive) 586 (interactive)
558 (let* ((pr (project-current t)) 587 (let* ((pr (project-current t))
559 (dirs (append 588 (dirs (cons
560 (project-roots pr) 589 (project-root pr)
561 (project-external-roots pr)))) 590 (project-external-roots pr))))
562 (project-find-file-in (thing-at-point 'filename) dirs pr))) 591 (project-find-file-in (thing-at-point 'filename) dirs pr)))
563 592
@@ -660,5 +689,13 @@ loop using the command \\[fileloop-continue]."
660 from to (project-files (project-current t)) 'default) 689 from to (project-files (project-current t)) 'default)
661 (fileloop-continue)) 690 (fileloop-continue))
662 691
692;;;###autoload
693(defun project-compile ()
694 "Run `compile' in the project root."
695 (interactive)
696 (let* ((pr (project-current t))
697 (default-directory (project-root pr)))
698 (call-interactively 'compile)))
699
663(provide 'project) 700(provide 'project)
664;;; project.el ends here 701;;; project.el ends here
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 @@
261(require 'ansi-color) 261(require 'ansi-color)
262(require 'cl-lib) 262(require 'cl-lib)
263(require 'comint) 263(require 'comint)
264(require 'json)
265(require 'tramp-sh) 264(require 'tramp-sh)
266 265
267;; Avoid compiler warnings 266;; Avoid compiler warnings
@@ -2276,6 +2275,18 @@ Do not set this variable directly, instead use
2276Do not set this variable directly, instead use 2275Do not set this variable directly, instead use
2277`python-shell-prompt-set-calculated-regexps'.") 2276`python-shell-prompt-set-calculated-regexps'.")
2278 2277
2278(defalias 'python--parse-json-array
2279 (if (fboundp 'json-parse-string)
2280 (lambda (string)
2281 (json-parse-string string :array-type 'list))
2282 (require 'json)
2283 (defvar json-array-type)
2284 (declare-function json-read-from-string "json" (string))
2285 (lambda (string)
2286 (let ((json-array-type 'list))
2287 (json-read-from-string string))))
2288 "Parse the JSON array in STRING into a Lisp list.")
2289
2279(defun python-shell-prompt-detect () 2290(defun python-shell-prompt-detect ()
2280 "Detect prompts for the current `python-shell-interpreter'. 2291 "Detect prompts for the current `python-shell-interpreter'.
2281When prompts can be retrieved successfully from the 2292When prompts can be retrieved successfully from the
@@ -2324,11 +2335,11 @@ detection and just returns nil."
2324 (catch 'prompts 2335 (catch 'prompts
2325 (dolist (line (split-string output "\n" t)) 2336 (dolist (line (split-string output "\n" t))
2326 (let ((res 2337 (let ((res
2327 ;; Check if current line is a valid JSON array 2338 ;; Check if current line is a valid JSON array.
2328 (and (string= (substring line 0 2) "[\"") 2339 (and (string-prefix-p "[\"" line)
2329 (ignore-errors 2340 (ignore-errors
2330 ;; Return prompts as a list, not vector 2341 ;; Return prompts as a list.
2331 (append (json-read-from-string line) nil))))) 2342 (python--parse-json-array line)))))
2332 ;; The list must contain 3 strings, where the first 2343 ;; The list must contain 3 strings, where the first
2333 ;; is the input prompt, the second is the block 2344 ;; is the input prompt, the second is the block
2334 ;; prompt and the last one is the output prompt. The 2345 ;; prompt and the last one is the output prompt. The
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
186 "Non-nil means display current function name in mode line. 186 "Non-nil means display current function name in mode line.
187This makes a difference only if `which-function-mode' is non-nil.") 187This makes a difference only if `which-function-mode' is non-nil.")
188 188
189(add-hook 'find-file-hook 'which-func-ff-hook t) 189(add-hook 'after-change-major-mode-hook 'which-func-ff-hook t)
190 190
191(defun which-func-try-to-enable () 191(defun which-func-try-to-enable ()
192 (unless (or (not which-function-mode) 192 (unless (or (not which-function-mode)
@@ -195,7 +195,7 @@ This makes a difference only if `which-function-mode' is non-nil.")
195 (member major-mode which-func-modes))))) 195 (member major-mode which-func-modes)))))
196 196
197(defun which-func-ff-hook () 197(defun which-func-ff-hook ()
198 "File find hook for Which Function mode. 198 "`after-change-major-mode-hook' for Which Function mode.
199It creates the Imenu index for the buffer, if necessary." 199It creates the Imenu index for the buffer, if necessary."
200 (which-func-try-to-enable) 200 (which-func-try-to-enable)
201 201
@@ -282,52 +282,55 @@ If no function name is found, return nil."
282 (when (null name) 282 (when (null name)
283 (setq name (add-log-current-defun))) 283 (setq name (add-log-current-defun)))
284 ;; If Imenu is loaded, try to make an index alist with it. 284 ;; If Imenu is loaded, try to make an index alist with it.
285 ;; If `add-log-current-defun' ran and gave nil, accept that.
285 (when (and (null name) 286 (when (and (null name)
286 (boundp 'imenu--index-alist) 287 (null add-log-current-defun-function))
287 (or (null imenu--index-alist) 288 (when (and (null name)
288 ;; Update if outdated 289 (boundp 'imenu--index-alist)
289 (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick)) 290 (or (null imenu--index-alist)
290 (null which-function-imenu-failed)) 291 ;; Update if outdated
291 (ignore-errors (imenu--make-index-alist t)) 292 (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick))
292 (unless imenu--index-alist 293 (null which-function-imenu-failed))
293 (set (make-local-variable 'which-function-imenu-failed) t))) 294 (ignore-errors (imenu--make-index-alist t))
294 ;; If we have an index alist, use it. 295 (unless imenu--index-alist
295 (when (and (null name) 296 (set (make-local-variable 'which-function-imenu-failed) t)))
296 (boundp 'imenu--index-alist) imenu--index-alist) 297 ;; If we have an index alist, use it.
297 (let ((alist imenu--index-alist) 298 (when (and (null name)
298 (minoffset (point-max)) 299 (boundp 'imenu--index-alist) imenu--index-alist)
299 offset pair mark imstack namestack) 300 (let ((alist imenu--index-alist)
300 ;; Elements of alist are either ("name" . marker), or 301 (minoffset (point-max))
301 ;; ("submenu" ("name" . marker) ... ). The list can be 302 offset pair mark imstack namestack)
302 ;; arbitrarily nested. 303 ;; Elements of alist are either ("name" . marker), or
303 (while (or alist imstack) 304 ;; ("submenu" ("name" . marker) ... ). The list can be
304 (if (null alist) 305 ;; arbitrarily nested.
305 (setq alist (car imstack) 306 (while (or alist imstack)
306 namestack (cdr namestack) 307 (if (null alist)
307 imstack (cdr imstack)) 308 (setq alist (car imstack)
308 309 namestack (cdr namestack)
309 (setq pair (car-safe alist) 310 imstack (cdr imstack))
310 alist (cdr-safe alist)) 311
311 312 (setq pair (car-safe alist)
312 (cond 313 alist (cdr-safe alist))
313 ((atom pair)) ; Skip anything not a cons. 314
314 315 (cond
315 ((imenu--subalist-p pair) 316 ((atom pair)) ; Skip anything not a cons.
316 (setq imstack (cons alist imstack) 317
317 namestack (cons (car pair) namestack) 318 ((imenu--subalist-p pair)
318 alist (cdr pair))) 319 (setq imstack (cons alist imstack)
319 320 namestack (cons (car pair) namestack)
320 ((or (number-or-marker-p (setq mark (cdr pair))) 321 alist (cdr pair)))
321 (and (overlayp mark) 322
322 (setq mark (overlay-start mark)))) 323 ((or (number-or-marker-p (setq mark (cdr pair)))
323 (when (and (>= (setq offset (- (point) mark)) 0) 324 (and (overlayp mark)
324 (< offset minoffset)) ; Find the closest item. 325 (setq mark (overlay-start mark))))
325 (setq minoffset offset 326 (when (and (>= (setq offset (- (point) mark)) 0)
326 name (if (null which-func-imenu-joiner-function) 327 (< offset minoffset)) ; Find the closest item.
327 (car pair) 328 (setq minoffset offset
328 (funcall 329 name (if (null which-func-imenu-joiner-function)
329 which-func-imenu-joiner-function 330 (car pair)
330 (reverse (cons (car pair) namestack)))))))))))) 331 (funcall
332 which-func-imenu-joiner-function
333 (reverse (cons (car pair) namestack)))))))))))))
331 ;; Filter the name if requested. 334 ;; Filter the name if requested.
332 (when name 335 (when name
333 (if which-func-cleanup-function 336 (if which-func-cleanup-function
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
268 (lambda (dir) 268 (lambda (dir)
269 (xref-references-in-directory identifier dir)) 269 (xref-references-in-directory identifier dir))
270 (let ((pr (project-current t))) 270 (let ((pr (project-current t)))
271 (append 271 (cons
272 (project-roots pr) 272 (project-root pr)
273 (project-external-roots pr))))) 273 (project-external-roots pr)))))
274 274
275(cl-defgeneric xref-backend-apropos (backend pattern) 275(cl-defgeneric xref-backend-apropos (backend pattern)
diff --git a/lisp/subr.el b/lisp/subr.el
index 971bce36b77..683e44123d7 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -4117,7 +4117,11 @@ MODES is as for `set-default-file-modes'."
4117;; now, but it generates slower code. 4117;; now, but it generates slower code.
4118(defmacro save-match-data (&rest body) 4118(defmacro save-match-data (&rest body)
4119 "Execute the BODY forms, restoring the global value of the match data. 4119 "Execute the BODY forms, restoring the global value of the match data.
4120The value returned is the value of the last form in BODY." 4120The value returned is the value of the last form in BODY.
4121NOTE: The convention in Elisp is that any function, except for a few
4122exceptions like car/assoc/+/goto-char, can clobber the match data,
4123so `save-match-data' should normally be used to save *your* match data
4124rather than your caller's match data."
4121 ;; It is better not to use backquote here, 4125 ;; It is better not to use backquote here,
4122 ;; because that makes a bootstrapping problem 4126 ;; because that makes a bootstrapping problem
4123 ;; if you need to recompile all the Lisp files using interpreted code. 4127 ;; if you need to recompile all the Lisp files using interpreted code.
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.
1106 (set (make-local-variable 'vc-dir-backend) use-vc-backend) 1106 (set (make-local-variable 'vc-dir-backend) use-vc-backend)
1107 (set (make-local-variable 'desktop-save-buffer) 1107 (set (make-local-variable 'desktop-save-buffer)
1108 'vc-dir-desktop-buffer-misc-data) 1108 'vc-dir-desktop-buffer-misc-data)
1109 (setq-local bookmark-make-record-function #'vc-dir-bookmark-make-record)
1109 (setq buffer-read-only t) 1110 (setq buffer-read-only t)
1110 (when (boundp 'tool-bar-map) 1111 (when (boundp 'tool-bar-map)
1111 (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map)) 1112 (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map))
@@ -1466,6 +1467,41 @@ These are the commands available for use in the file status buffer:
1466 '(vc-dir-mode . vc-dir-restore-desktop-buffer)) 1467 '(vc-dir-mode . vc-dir-restore-desktop-buffer))
1467 1468
1468 1469
1470;;; Support for bookmark.el (adapted from what info.el does).
1471
1472(declare-function bookmark-make-record-default
1473 "bookmark" (&optional no-file no-context posn))
1474(declare-function bookmark-prop-get "bookmark" (bookmark prop))
1475(declare-function bookmark-default-handler "bookmark" (bmk))
1476(declare-function bookmark-get-bookmark-record "bookmark" (bmk))
1477
1478(defun vc-dir-bookmark-make-record ()
1479 "Make record used to bookmark a `vc-dir' buffer.
1480This implements the `bookmark-make-record-function' type for
1481`vc-dir' buffers."
1482 (let* ((bookmark-name
1483 (concat "(" (symbol-name vc-dir-backend) ") "
1484 (file-name-nondirectory
1485 (directory-file-name default-directory))))
1486 (defaults (list bookmark-name default-directory)))
1487 `(,bookmark-name
1488 ,@(bookmark-make-record-default 'no-file)
1489 (filename . ,default-directory)
1490 (handler . vc-dir-bookmark-jump)
1491 (defaults . ,defaults))))
1492
1493;;;###autoload
1494(defun vc-dir-bookmark-jump (bmk)
1495 "Provides the bookmark-jump behavior for a `vc-dir' buffer.
1496This implements the `handler' function interface for the record
1497type returned by `vc-dir-bookmark-make-record'."
1498 (let* ((file (bookmark-prop-get bmk 'filename))
1499 (buf (save-window-excursion
1500 (vc-dir file) (current-buffer))))
1501 (bookmark-default-handler
1502 `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk)))))
1503
1504
1469(provide 'vc-dir) 1505(provide 'vc-dir)
1470 1506
1471;;; vc-dir.el ends here 1507;;; vc-dir.el ends here
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 @@
72;; by git, so it's probably 72;; by git, so it's probably
73;; not a good idea. 73;; not a good idea.
74;; - merge-news (file) see `merge-file' 74;; - merge-news (file) see `merge-file'
75;; - mark-resolved (file) OK
75;; - steal-lock (file &optional revision) NOT NEEDED 76;; - steal-lock (file &optional revision) NOT NEEDED
76;; HISTORY FUNCTIONS 77;; HISTORY FUNCTIONS
77;; * print-log (files buffer &optional shortlog start-revision limit) OK 78;; * 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\"."
1530(defun vc-git-rename-file (old new) 1531(defun vc-git-rename-file (old new)
1531 (vc-git-command nil 0 (list old new) "mv" "-f" "--")) 1532 (vc-git-command nil 0 (list old new) "mv" "-f" "--"))
1532 1533
1534(defun vc-git-mark-resolved (files)
1535 (vc-git-command nil 0 files "add"))
1536
1533(defvar vc-git-extra-menu-map 1537(defvar vc-git-extra-menu-map
1534 (let ((map (make-sparse-keymap))) 1538 (let ((map (make-sparse-keymap)))
1535 (define-key map [git-grep] 1539 (define-key map [git-grep]
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:
498 "Return the repository version from which FILE was checked out. 498 "Return the repository version from which FILE was checked out.
499If FILE is not registered, this function always returns nil." 499If FILE is not registered, this function always returns nil."
500 (or (vc-file-getprop file 'vc-working-revision) 500 (or (vc-file-getprop file 'vc-working-revision)
501 (progn 501 (let ((default-directory (file-name-directory file)))
502 (setq backend (or backend (vc-backend file))) 502 (setq backend (or backend (vc-backend file)))
503 (when backend 503 (when backend
504 (vc-file-setprop file 'vc-working-revision 504 (vc-file-setprop file 'vc-working-revision
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.
163Optional argument DIR is a directory to use instead of `source-directory'." 163Optional argument DIR is a directory to use instead of `source-directory'."
164 (emacs-repository-branch-git (or dir source-directory))) 164 (emacs-repository-branch-git (or dir source-directory)))
165 165
166;; We put version info into the executable in the form that `ident' uses.
167(purecopy (concat "\n$Id: " (subst-char-in-string ?\n ?\s (emacs-version))
168 " $\n"))
169
170;;; version.el ends here 166;;; version.el ends here
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 &amp;).
1023XML character data must not contain & or < characters, nor the > 1023XML character data must not contain & or < characters, nor the >
1024character under some circumstances. The XML spec does not impose 1024character under some circumstances. The XML spec does not impose
1025restriction on \" or \\=', but we just substitute for these too 1025restriction on \" or \\=', but we just substitute for these too
1026\(as is permitted by the spec)." 1026\(as is permitted by the spec).
1027
1028If STRING contains characters that are invalid in XML (as defined
1029by https://www.w3.org/TR/xml/#charsets), signal an error of type
1030`xml-invalid-character'."
1027 (with-temp-buffer 1031 (with-temp-buffer
1028 (insert string) 1032 (insert string)
1033 (goto-char (point-min))
1034 (when (re-search-forward
1035 "[^\u0009\u000A\u000D\u0020-\uD7FF\uE000-\uFFFD\U00010000-\U0010FFFF]")
1036 (signal 'xml-invalid-character (list (char-before) (match-beginning 0))))
1029 (dolist (substitution '(("&" . "&amp;") 1037 (dolist (substitution '(("&" . "&amp;")
1030 ("<" . "&lt;") 1038 ("<" . "&lt;")
1031 (">" . "&gt;") 1039 (">" . "&gt;")
@@ -1036,6 +1044,9 @@ restriction on \" or \\=', but we just substitute for these too
1036 (replace-match (cdr substitution) t t nil))) 1044 (replace-match (cdr substitution) t t nil)))
1037 (buffer-string))) 1045 (buffer-string)))
1038 1046
1047(define-error 'xml-invalid-character "Invalid XML character"
1048 'wrong-type-argument)
1049
1039(defun xml-debug-print-internal (xml indent-string) 1050(defun xml-debug-print-internal (xml indent-string)
1040 "Outputs the XML tree in the current buffer. 1051 "Outputs the XML tree in the current buffer.
1041The first line is indented with INDENT-STRING." 1052The first line is indented with INDENT-STRING."
diff --git a/src/alloc.c b/src/alloc.c
index d6ba4d97905..76d49d2efd6 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3429,23 +3429,6 @@ usage: (vector &rest OBJECTS) */)
3429 return val; 3429 return val;
3430} 3430}
3431 3431
3432void
3433make_byte_code (struct Lisp_Vector *v)
3434{
3435 /* Don't allow the global zero_vector to become a byte code object. */
3436 eassert (0 < v->header.size);
3437
3438 if (v->header.size > 1 && STRINGP (v->contents[1])
3439 && STRING_MULTIBYTE (v->contents[1]))
3440 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3441 earlier because they produced a raw 8-bit string for byte-code
3442 and now such a byte-code string is loaded as multibyte while
3443 raw 8-bit characters converted to multibyte form. Thus, now we
3444 must convert them back to the original unibyte form. */
3445 v->contents[1] = Fstring_as_unibyte (v->contents[1]);
3446 XSETPVECTYPE (v, PVEC_COMPILED);
3447}
3448
3449DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, 3432DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3450 doc: /* Create a byte-code object with specified arguments as elements. 3433 doc: /* Create a byte-code object with specified arguments as elements.
3451The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant 3434The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
@@ -3464,8 +3447,14 @@ stack before executing the byte-code.
3464usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) 3447usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3465 (ptrdiff_t nargs, Lisp_Object *args) 3448 (ptrdiff_t nargs, Lisp_Object *args)
3466{ 3449{
3467 Lisp_Object val = make_uninit_vector (nargs); 3450 if (! ((FIXNUMP (args[COMPILED_ARGLIST])
3468 struct Lisp_Vector *p = XVECTOR (val); 3451 || CONSP (args[COMPILED_ARGLIST])
3452 || NILP (args[COMPILED_ARGLIST]))
3453 && STRINGP (args[COMPILED_BYTECODE])
3454 && !STRING_MULTIBYTE (args[COMPILED_BYTECODE])
3455 && VECTORP (args[COMPILED_CONSTANTS])
3456 && FIXNATP (args[COMPILED_STACK_DEPTH])))
3457 error ("Invalid byte-code object");
3469 3458
3470 /* We used to purecopy everything here, if purify-flag was set. This worked 3459 /* We used to purecopy everything here, if purify-flag was set. This worked
3471 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be 3460 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
@@ -3474,10 +3463,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
3474 copied into pure space, including its free variables, which is sometimes 3463 copied into pure space, including its free variables, which is sometimes
3475 just wasteful and other times plainly wrong (e.g. those free vars may want 3464 just wasteful and other times plainly wrong (e.g. those free vars may want
3476 to be setcar'd). */ 3465 to be setcar'd). */
3477 3466 Lisp_Object val = Fvector (nargs, args);
3478 memcpy (p->contents, args, nargs * sizeof *args); 3467 XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED);
3479 make_byte_code (p);
3480 XSETCOMPILED (val, p);
3481 return val; 3468 return val;
3482} 3469}
3483 3470
@@ -5019,8 +5006,9 @@ mark_stack (char const *bottom, char const *end)
5019#endif 5006#endif
5020} 5007}
5021 5008
5022/* This is a trampoline function that flushes registers to the stack, 5009/* flush_stack_call_func is the trampoline function that flushes
5023 and then calls FUNC. ARG is passed through to FUNC verbatim. 5010 registers to the stack, and then calls FUNC. ARG is passed through
5011 to FUNC verbatim.
5024 5012
5025 This function must be called whenever Emacs is about to release the 5013 This function must be called whenever Emacs is about to release the
5026 global interpreter lock. This lets the garbage collector easily 5014 global interpreter lock. This lets the garbage collector easily
@@ -5028,7 +5016,20 @@ mark_stack (char const *bottom, char const *end)
5028 Lisp. 5016 Lisp.
5029 5017
5030 It is invalid to run any Lisp code or to allocate any GC memory 5018 It is invalid to run any Lisp code or to allocate any GC memory
5031 from FUNC. */ 5019 from FUNC.
5020
5021 Note: all register spilling is done in flush_stack_call_func before
5022 flush_stack_call_func1 is activated.
5023
5024 flush_stack_call_func1 is responsible for identifying the stack
5025 address range to be scanned. It *must* be carefully kept as
5026 noinline to make sure that registers has been spilled before it is
5027 called, otherwise given __builtin_frame_address (0) typically
5028 returns the frame pointer (base pointer) and not the stack pointer
5029 [1] GC will miss to scan callee-saved registers content
5030 (Bug#41357).
5031
5032 [1] <https://gcc.gnu.org/onlinedocs/gcc/Return-Address.html>. */
5032 5033
5033NO_INLINE void 5034NO_INLINE void
5034flush_stack_call_func1 (void (*func) (void *arg), void *arg) 5035flush_stack_call_func1 (void (*func) (void *arg), void *arg)
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);
119static struct Lisp_Overlay * copy_overlays (struct buffer *, struct Lisp_Overlay *); 119static struct Lisp_Overlay * copy_overlays (struct buffer *, struct Lisp_Overlay *);
120static void modify_overlay (struct buffer *, ptrdiff_t, ptrdiff_t); 120static void modify_overlay (struct buffer *, ptrdiff_t, ptrdiff_t);
121static Lisp_Object buffer_lisp_local_variables (struct buffer *, bool); 121static Lisp_Object buffer_lisp_local_variables (struct buffer *, bool);
122static Lisp_Object buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym);
122 123
123static void 124static void
124CHECK_OVERLAY (Lisp_Object x) 125CHECK_OVERLAY (Lisp_Object x)
@@ -1300,6 +1301,25 @@ buffer_lisp_local_variables (struct buffer *buf, bool clone)
1300 return result; 1301 return result;
1301} 1302}
1302 1303
1304
1305/* If the variable at position index OFFSET in buffer BUF has a
1306 buffer-local value, return (name . value). If SYM is non-nil,
1307 it replaces name. */
1308
1309static Lisp_Object
1310buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym)
1311{
1312 int idx = PER_BUFFER_IDX (offset);
1313 if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
1314 && SYMBOLP (PER_BUFFER_SYMBOL (offset)))
1315 {
1316 sym = NILP (sym) ? PER_BUFFER_SYMBOL (offset) : sym;
1317 Lisp_Object val = per_buffer_value (buf, offset);
1318 return EQ (val, Qunbound) ? sym : Fcons (sym, val);
1319 }
1320 return Qnil;
1321}
1322
1303DEFUN ("buffer-local-variables", Fbuffer_local_variables, 1323DEFUN ("buffer-local-variables", Fbuffer_local_variables,
1304 Sbuffer_local_variables, 0, 1, 0, 1324 Sbuffer_local_variables, 0, 1, 0,
1305 doc: /* Return an alist of variables that are buffer-local in BUFFER. 1325 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. */)
1311{ 1331{
1312 struct buffer *buf = decode_buffer (buffer); 1332 struct buffer *buf = decode_buffer (buffer);
1313 Lisp_Object result = buffer_lisp_local_variables (buf, 0); 1333 Lisp_Object result = buffer_lisp_local_variables (buf, 0);
1334 Lisp_Object tem;
1314 1335
1315 /* Add on all the variables stored in special slots. */ 1336 /* Add on all the variables stored in special slots. */
1316 { 1337 {
1317 int offset, idx; 1338 int offset;
1318 1339
1319 FOR_EACH_PER_BUFFER_OBJECT_AT (offset) 1340 FOR_EACH_PER_BUFFER_OBJECT_AT (offset)
1320 { 1341 {
1321 idx = PER_BUFFER_IDX (offset); 1342 tem = buffer_local_variables_1 (buf, offset, Qnil);
1322 if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) 1343 if (!NILP (tem))
1323 && SYMBOLP (PER_BUFFER_SYMBOL (offset))) 1344 result = Fcons (tem, result);
1324 {
1325 Lisp_Object sym = PER_BUFFER_SYMBOL (offset);
1326 Lisp_Object val = per_buffer_value (buf, offset);
1327 result = Fcons (EQ (val, Qunbound) ? sym : Fcons (sym, val),
1328 result);
1329 }
1330 } 1345 }
1331 } 1346 }
1332 1347
1348 tem = buffer_local_variables_1 (buf, PER_BUFFER_VAR_OFFSET (undo_list),
1349 intern ("buffer-undo-list"));
1350 if (!NILP (tem))
1351 result = Fcons (tem, result);
1352
1333 return result; 1353 return result;
1334} 1354}
1335 1355
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.
319If the third argument is incorrect, Emacs may crash. */) 319If the third argument is incorrect, Emacs may crash. */)
320 (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) 320 (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
321{ 321{
322 if (! (STRINGP (bytestr) && VECTORP (vector) && FIXNATP (maxdepth)))
323 error ("Invalid byte-code");
324
325 if (STRING_MULTIBYTE (bytestr))
326 {
327 /* BYTESTR must have been produced by Emacs 20.2 or earlier
328 because it produced a raw 8-bit string for byte-code and now
329 such a byte-code string is loaded as multibyte with raw 8-bit
330 characters converted to multibyte form. Convert them back to
331 the original unibyte form. */
332 bytestr = Fstring_as_unibyte (bytestr);
333 }
334
322 return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); 335 return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL);
323} 336}
324 337
@@ -344,21 +357,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
344 int volatile this_op = 0; 357 int volatile this_op = 0;
345#endif 358#endif
346 359
347 CHECK_STRING (bytestr); 360 eassert (!STRING_MULTIBYTE (bytestr));
348 CHECK_VECTOR (vector);
349 CHECK_FIXNAT (maxdepth);
350 361
351 ptrdiff_t const_length = ASIZE (vector); 362 ptrdiff_t const_length = ASIZE (vector);
352 363 ptrdiff_t bytestr_length = SCHARS (bytestr);
353 if (STRING_MULTIBYTE (bytestr))
354 /* BYTESTR must have been produced by Emacs 20.2 or the earlier
355 because they produced a raw 8-bit string for byte-code and now
356 such a byte-code string is loaded as multibyte while raw 8-bit
357 characters converted to multibyte form. Thus, now we must
358 convert them back to the originally intended unibyte form. */
359 bytestr = Fstring_as_unibyte (bytestr);
360
361 ptrdiff_t bytestr_length = SBYTES (bytestr);
362 Lisp_Object *vectorp = XVECTOR (vector)->contents; 364 Lisp_Object *vectorp = XVECTOR (vector)->contents;
363 365
364 unsigned char quitcounter = 1; 366 unsigned char quitcounter = 1;
diff --git a/src/emacs.c b/src/emacs.c
index e75cb588349..93a837a44ef 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -124,6 +124,11 @@ static const char emacs_version[] = PACKAGE_VERSION;
124static const char emacs_copyright[] = COPYRIGHT; 124static const char emacs_copyright[] = COPYRIGHT;
125static const char emacs_bugreport[] = PACKAGE_BUGREPORT; 125static const char emacs_bugreport[] = PACKAGE_BUGREPORT;
126 126
127/* Put version info into the executable in the form that 'ident' uses. */
128char const EXTERNALLY_VISIBLE RCS_Id[]
129 = "$Id" ": GNU Emacs " PACKAGE_VERSION
130 " (" EMACS_CONFIGURATION " " EMACS_CONFIG_FEATURES ") $";
131
127/* Empty lisp strings. To avoid having to build any others. */ 132/* Empty lisp strings. To avoid having to build any others. */
128Lisp_Object empty_unibyte_string, empty_multibyte_string; 133Lisp_Object empty_unibyte_string, empty_multibyte_string;
129 134
diff --git a/src/eval.c b/src/eval.c
index 1091b082552..37d466f69ed 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2913,6 +2913,21 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
2913 } 2913 }
2914} 2914}
2915 2915
2916/* Call the compiled Lisp function FUN. If we have not yet read FUN's
2917 bytecode string and constants vector, fetch them from the file first. */
2918
2919static Lisp_Object
2920fetch_and_exec_byte_code (Lisp_Object fun, Lisp_Object syms_left,
2921 ptrdiff_t nargs, Lisp_Object *args)
2922{
2923 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
2924 Ffetch_bytecode (fun);
2925 return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
2926 AREF (fun, COMPILED_CONSTANTS),
2927 AREF (fun, COMPILED_STACK_DEPTH),
2928 syms_left, nargs, args);
2929}
2930
2916static Lisp_Object 2931static Lisp_Object
2917apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) 2932apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count)
2918{ 2933{
@@ -2977,9 +2992,6 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
2977 } 2992 }
2978 else if (COMPILEDP (fun)) 2993 else if (COMPILEDP (fun))
2979 { 2994 {
2980 ptrdiff_t size = PVSIZE (fun);
2981 if (size <= COMPILED_STACK_DEPTH)
2982 xsignal1 (Qinvalid_function, fun);
2983 syms_left = AREF (fun, COMPILED_ARGLIST); 2995 syms_left = AREF (fun, COMPILED_ARGLIST);
2984 if (FIXNUMP (syms_left)) 2996 if (FIXNUMP (syms_left))
2985 /* A byte-code object with an integer args template means we 2997 /* A byte-code object with an integer args template means we
@@ -2991,15 +3003,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
2991 argument-binding code below instead (as do all interpreted 3003 argument-binding code below instead (as do all interpreted
2992 functions, even lexically bound ones). */ 3004 functions, even lexically bound ones). */
2993 { 3005 {
2994 /* If we have not actually read the bytecode string 3006 return fetch_and_exec_byte_code (fun, syms_left, nargs, arg_vector);
2995 and constants vector yet, fetch them from the file. */
2996 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
2997 Ffetch_bytecode (fun);
2998 return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
2999 AREF (fun, COMPILED_CONSTANTS),
3000 AREF (fun, COMPILED_STACK_DEPTH),
3001 syms_left,
3002 nargs, arg_vector);
3003 } 3007 }
3004 lexenv = Qnil; 3008 lexenv = Qnil;
3005 } 3009 }
@@ -3068,16 +3072,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
3068 if (CONSP (fun)) 3072 if (CONSP (fun))
3069 val = Fprogn (XCDR (XCDR (fun))); 3073 val = Fprogn (XCDR (XCDR (fun)));
3070 else 3074 else
3071 { 3075 val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL);
3072 /* If we have not actually read the bytecode string
3073 and constants vector yet, fetch them from the file. */
3074 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3075 Ffetch_bytecode (fun);
3076 val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3077 AREF (fun, COMPILED_CONSTANTS),
3078 AREF (fun, COMPILED_STACK_DEPTH),
3079 Qnil, 0, 0);
3080 }
3081 3076
3082 return unbind_to (count, val); 3077 return unbind_to (count, val);
3083} 3078}
@@ -3162,9 +3157,6 @@ lambda_arity (Lisp_Object fun)
3162 } 3157 }
3163 else if (COMPILEDP (fun)) 3158 else if (COMPILEDP (fun))
3164 { 3159 {
3165 ptrdiff_t size = PVSIZE (fun);
3166 if (size <= COMPILED_STACK_DEPTH)
3167 xsignal1 (Qinvalid_function, fun);
3168 syms_left = AREF (fun, COMPILED_ARGLIST); 3160 syms_left = AREF (fun, COMPILED_ARGLIST);
3169 if (FIXNUMP (syms_left)) 3161 if (FIXNUMP (syms_left))
3170 return get_byte_code_arity (syms_left); 3162 return get_byte_code_arity (syms_left);
@@ -3207,13 +3199,11 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
3207 3199
3208 if (COMPILEDP (object)) 3200 if (COMPILEDP (object))
3209 { 3201 {
3210 ptrdiff_t size = PVSIZE (object);
3211 if (size <= COMPILED_STACK_DEPTH)
3212 xsignal1 (Qinvalid_function, object);
3213 if (CONSP (AREF (object, COMPILED_BYTECODE))) 3202 if (CONSP (AREF (object, COMPILED_BYTECODE)))
3214 { 3203 {
3215 tem = read_doc_string (AREF (object, COMPILED_BYTECODE)); 3204 tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
3216 if (!CONSP (tem)) 3205 if (! (CONSP (tem) && STRINGP (XCAR (tem))
3206 && VECTORP (XCDR (tem))))
3217 { 3207 {
3218 tem = AREF (object, COMPILED_BYTECODE); 3208 tem = AREF (object, COMPILED_BYTECODE);
3219 if (CONSP (tem) && STRINGP (XCAR (tem))) 3209 if (CONSP (tem) && STRINGP (XCAR (tem)))
@@ -3221,7 +3211,19 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
3221 else 3211 else
3222 error ("Invalid byte code"); 3212 error ("Invalid byte code");
3223 } 3213 }
3224 ASET (object, COMPILED_BYTECODE, XCAR (tem)); 3214
3215 Lisp_Object bytecode = XCAR (tem);
3216 if (STRING_MULTIBYTE (bytecode))
3217 {
3218 /* BYTECODE must have been produced by Emacs 20.2 or earlier
3219 because it produced a raw 8-bit string for byte-code and now
3220 such a byte-code string is loaded as multibyte with raw 8-bit
3221 characters converted to multibyte form. Convert them back to
3222 the original unibyte form. */
3223 bytecode = Fstring_as_unibyte (bytecode);
3224 }
3225
3226 ASET (object, COMPILED_BYTECODE, bytecode);
3225 ASET (object, COMPILED_CONSTANTS, XCDR (tem)); 3227 ASET (object, COMPILED_CONSTANTS, XCDR (tem));
3226 } 3228 }
3227 } 3229 }
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. */)
2508 } 2508 }
2509 else if (STRINGP (array)) 2509 else if (STRINGP (array))
2510 { 2510 {
2511 register unsigned char *p = SDATA (array); 2511 unsigned char *p = SDATA (array);
2512 int charval;
2513 CHECK_CHARACTER (item); 2512 CHECK_CHARACTER (item);
2514 charval = XFIXNAT (item); 2513 int charval = XFIXNAT (item);
2515 size = SCHARS (array); 2514 size = SCHARS (array);
2516 if (STRING_MULTIBYTE (array)) 2515 if (size != 0)
2517 { 2516 {
2517 CHECK_IMPURE (array, XSTRING (array));
2518 unsigned char str[MAX_MULTIBYTE_LENGTH]; 2518 unsigned char str[MAX_MULTIBYTE_LENGTH];
2519 int len = CHAR_STRING (charval, str); 2519 int len;
2520 ptrdiff_t size_byte = SBYTES (array); 2520 if (STRING_MULTIBYTE (array))
2521 ptrdiff_t product; 2521 len = CHAR_STRING (charval, str);
2522 else
2523 {
2524 str[0] = charval;
2525 len = 1;
2526 }
2522 2527
2523 if (INT_MULTIPLY_WRAPV (size, len, &product) || product != size_byte) 2528 ptrdiff_t size_byte = SBYTES (array);
2524 error ("Attempt to change byte length of a string"); 2529 if (len == 1 && size == size_byte)
2525 for (idx = 0; idx < size_byte; idx++) 2530 memset (p, str[0], size);
2526 *p++ = str[idx % len]; 2531 else
2532 {
2533 ptrdiff_t product;
2534 if (INT_MULTIPLY_WRAPV (size, len, &product)
2535 || product != size_byte)
2536 error ("Attempt to change byte length of a string");
2537 for (idx = 0; idx < size_byte; idx++)
2538 *p++ = str[idx % len];
2539 }
2527 } 2540 }
2528 else
2529 for (idx = 0; idx < size; idx++)
2530 p[idx] = charval;
2531 } 2541 }
2532 else if (BOOL_VECTOR_P (array)) 2542 else if (BOOL_VECTOR_P (array))
2533 return bool_vector_fill (array, item); 2543 return bool_vector_fill (array, item);
@@ -2542,12 +2552,15 @@ DEFUN ("clear-string", Fclear_string, Sclear_string,
2542This makes STRING unibyte and may change its length. */) 2552This makes STRING unibyte and may change its length. */)
2543 (Lisp_Object string) 2553 (Lisp_Object string)
2544{ 2554{
2545 ptrdiff_t len;
2546 CHECK_STRING (string); 2555 CHECK_STRING (string);
2547 len = SBYTES (string); 2556 ptrdiff_t len = SBYTES (string);
2548 memset (SDATA (string), 0, len); 2557 if (len != 0 || STRING_MULTIBYTE (string))
2549 STRING_SET_CHARS (string, len); 2558 {
2550 STRING_SET_UNIBYTE (string); 2559 CHECK_IMPURE (string, XSTRING (string));
2560 memset (SDATA (string), 0, len);
2561 STRING_SET_CHARS (string, len);
2562 STRING_SET_UNIBYTE (string);
2563 }
2551 return Qnil; 2564 return Qnil;
2552} 2565}
2553 2566
diff --git a/src/lisp.h b/src/lisp.h
index 9e4d53ccf17..4c0057b2552 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1343,7 +1343,6 @@ dead_object (void)
1343#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) 1343#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW))
1344#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) 1344#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL))
1345#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) 1345#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR))
1346#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED))
1347#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) 1346#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER))
1348#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) 1347#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
1349#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) 1348#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
@@ -3943,7 +3942,6 @@ build_string (const char *str)
3943 3942
3944extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); 3943extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
3945extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object); 3944extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object);
3946extern void make_byte_code (struct Lisp_Vector *);
3947extern struct Lisp_Vector *allocate_vector (ptrdiff_t); 3945extern struct Lisp_Vector *allocate_vector (ptrdiff_t);
3948extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t); 3946extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t);
3949 3947
diff --git a/src/lread.c b/src/lread.c
index 01f359ca581..46725d9b0ff 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -3030,8 +3030,26 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
3030 struct Lisp_Vector *vec; 3030 struct Lisp_Vector *vec;
3031 tmp = read_vector (readcharfun, 1); 3031 tmp = read_vector (readcharfun, 1);
3032 vec = XVECTOR (tmp); 3032 vec = XVECTOR (tmp);
3033 if (vec->header.size == 0) 3033 if (! (COMPILED_STACK_DEPTH < vec->header.size
3034 invalid_syntax ("Empty byte-code object"); 3034 && (FIXNUMP (vec->contents[COMPILED_ARGLIST])
3035 || CONSP (vec->contents[COMPILED_ARGLIST])
3036 || NILP (vec->contents[COMPILED_ARGLIST]))
3037 && ((STRINGP (vec->contents[COMPILED_BYTECODE])
3038 && VECTORP (vec->contents[COMPILED_CONSTANTS]))
3039 || CONSP (vec->contents[COMPILED_BYTECODE]))
3040 && FIXNATP (vec->contents[COMPILED_STACK_DEPTH])))
3041 invalid_syntax ("Invalid byte-code object");
3042
3043 if (STRING_MULTIBYTE (AREF (tmp, COMPILED_BYTECODE)))
3044 {
3045 /* BYTESTR must have been produced by Emacs 20.2 or earlier
3046 because it produced a raw 8-bit string for byte-code and
3047 now such a byte-code string is loaded as multibyte with
3048 raw 8-bit characters converted to multibyte form.
3049 Convert them back to the original unibyte form. */
3050 ASET (tmp, COMPILED_BYTECODE,
3051 Fstring_as_unibyte (AREF (tmp, COMPILED_BYTECODE)));
3052 }
3035 3053
3036 if (COMPILED_DOC_STRING < vec->header.size 3054 if (COMPILED_DOC_STRING < vec->header.size
3037 && EQ (AREF (tmp, COMPILED_DOC_STRING), make_fixnum (0))) 3055 && EQ (AREF (tmp, COMPILED_DOC_STRING), make_fixnum (0)))
@@ -3050,7 +3068,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
3050 ASET (tmp, COMPILED_DOC_STRING, make_ufixnum (hash)); 3068 ASET (tmp, COMPILED_DOC_STRING, make_ufixnum (hash));
3051 } 3069 }
3052 3070
3053 make_byte_code (vec); 3071 XSETPVECTYPE (vec, PVEC_COMPILED);
3054 return tmp; 3072 return tmp;
3055 } 3073 }
3056 if (c == '(') 3074 if (c == '(')
@@ -3888,8 +3906,6 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag)
3888{ 3906{
3889 Lisp_Object tem = read_list (1, readcharfun); 3907 Lisp_Object tem = read_list (1, readcharfun);
3890 ptrdiff_t size = list_length (tem); 3908 ptrdiff_t size = list_length (tem);
3891 if (bytecodeflag && size <= COMPILED_STACK_DEPTH)
3892 error ("Invalid byte code");
3893 Lisp_Object vector = make_nil_vector (size); 3909 Lisp_Object vector = make_nil_vector (size);
3894 3910
3895 Lisp_Object *ptr = XVECTOR (vector)->contents; 3911 Lisp_Object *ptr = XVECTOR (vector)->contents;
diff --git a/src/w32.c b/src/w32.c
index d01a45029d8..38bbc496563 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -6519,7 +6519,15 @@ acl_get_file (const char *fname, acl_type_t type)
6519 if (!get_file_security (fname, si, psd, sd_len, &sd_len)) 6519 if (!get_file_security (fname, si, psd, sd_len, &sd_len))
6520 { 6520 {
6521 xfree (psd); 6521 xfree (psd);
6522 errno = EIO; 6522 err = GetLastError ();
6523 if (err == ERROR_NOT_SUPPORTED)
6524 errno = ENOTSUP;
6525 else if (err == ERROR_FILE_NOT_FOUND
6526 || err == ERROR_PATH_NOT_FOUND
6527 || err == ERROR_INVALID_NAME)
6528 errno = ENOENT;
6529 else
6530 errno = EIO;
6523 psd = NULL; 6531 psd = NULL;
6524 } 6532 }
6525 } 6533 }
@@ -6530,6 +6538,8 @@ acl_get_file (const char *fname, acl_type_t type)
6530 be encoded in the current ANSI codepage. */ 6538 be encoded in the current ANSI codepage. */
6531 || err == ERROR_INVALID_NAME) 6539 || err == ERROR_INVALID_NAME)
6532 errno = ENOENT; 6540 errno = ENOENT;
6541 else if (err == ERROR_NOT_SUPPORTED)
6542 errno = ENOTSUP;
6533 else 6543 else
6534 errno = EIO; 6544 errno = EIO;
6535 } 6545 }
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
@@ -547,6 +547,24 @@ baz\"\""
547 (should (equal "" (buffer-string)))))) 547 (should (equal "" (buffer-string))))))
548 548
549 549
550;;; Undoing
551(ert-deftest electric-pair-undo-unrelated-state ()
552 "Make sure `electric-pair-mode' does not confuse `undo' (bug#39680)."
553 (with-temp-buffer
554 (buffer-enable-undo)
555 (electric-pair-local-mode)
556 (let ((last-command-event ?\())
557 (ert-simulate-command '(self-insert-command 1)))
558 (undo-boundary)
559 (let ((last-command-event ?a))
560 (ert-simulate-command '(self-insert-command 1)))
561 (undo-boundary)
562 (ert-simulate-command '(undo))
563 (let ((last-command-event ?\())
564 (ert-simulate-command '(self-insert-command 1)))
565 (should (string= (buffer-string) "(())"))))
566
567
550;;; Electric newlines between pairs 568;;; Electric newlines between pairs
551;;; TODO: better tests 569;;; TODO: better tests
552(ert-deftest electric-pair-open-extra-newline () 570(ert-deftest electric-pair-open-extra-newline ()
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 @@
1;;; syntax-tests.el --- tests for syntax.el -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2020 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Code:
21
22(require 'ert)
23(require 'syntax)
24
25(ert-deftest syntax-propertize--shift-groups-and-backrefs ()
26 "Test shifting of numbered groups and back-references in regexps."
27 ;; A numbered group must be shifted.
28 (should
29 (string=
30 (syntax-propertize--shift-groups-and-backrefs
31 "\\(?2:[abc]+\\)foobar" 2)
32 "\\(?4:[abc]+\\)foobar"))
33 ;; A back-reference \1 on a normal sub-regexp context must be
34 ;; shifted.
35 (should
36 (string=
37 (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\1" 2)
38 "\\(a\\)\\3"))
39 ;; Shifting must not happen if the \1 appears in a character class,
40 ;; or in a \{\} repetition construct (although \1 isn't valid there
41 ;; anyway).
42 (let ((rx-with-class "\\(a\\)[\\1-2]")
43 (rx-with-rep "\\(a\\)\\{1,\\1\\}"))
44 (should
45 (string=
46 (syntax-propertize--shift-groups-and-backrefs rx-with-class 2)
47 rx-with-class))
48 (should
49 (string=
50 (syntax-propertize--shift-groups-and-backrefs rx-with-rep 2)
51 rx-with-rep)))
52 ;; Now numbered groups and back-references in combination.
53 (should
54 (string=
55 (syntax-propertize--shift-groups-and-backrefs
56 "\\(?2:[abc]+\\)foo\\(\\2\\)" 2)
57 "\\(?4:[abc]+\\)foo\\(\\4\\)"))
58 ;; Emacs supports only the back-references \1,...,\9, so when a
59 ;; shift would result in \10 or more, an error must be signalled.
60 (should-error
61 (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\3" 7)))
62
63;; Local Variables:
64;; no-byte-compile: t
65;; End:
66
67;;; syntax-tests.el ends here.
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 @@
21 21
22(require 'ert) 22(require 'ert)
23(require 'json) 23(require 'json)
24(require 'map)
25(require 'seq)
26
27(eval-when-compile
28 (require 'cl-lib))
24 29
25(defmacro json-tests--with-temp-buffer (content &rest body) 30(defmacro json-tests--with-temp-buffer (content &rest body)
26 "Create a temporary buffer with CONTENT and evaluate BODY there. 31 "Create a temporary buffer with CONTENT and evaluate BODY there.
27Point is moved to beginning of the buffer." 32Point is moved to beginning of the buffer."
28 (declare (indent 1)) 33 (declare (debug t) (indent 1))
29 `(with-temp-buffer 34 `(with-temp-buffer
30 (insert ,content) 35 (insert ,content)
31 (goto-char (point-min)) 36 (goto-char (point-min))
@@ -33,66 +38,107 @@ Point is moved to beginning of the buffer."
33 38
34;;; Utilities 39;;; Utilities
35 40
36(ert-deftest test-json-join ()
37 (should (equal (json-join '() ", ") ""))
38 (should (equal (json-join '("a" "b" "c") ", ") "a, b, c")))
39
40(ert-deftest test-json-alist-p () 41(ert-deftest test-json-alist-p ()
41 (should (json-alist-p '())) 42 (should (json-alist-p '()))
42 (should (json-alist-p '((a 1) (b 2) (c 3)))) 43 (should (json-alist-p '((()))))
43 (should (json-alist-p '((:a 1) (:b 2) (:c 3)))) 44 (should (json-alist-p '((a))))
44 (should (json-alist-p '(("a" 1) ("b" 2) ("c" 3)))) 45 (should (json-alist-p '((a . 1))))
46 (should (json-alist-p '((a . 1) (b 2) (c))))
47 (should (json-alist-p '((:a) (:b 2) (:c . 3))))
48 (should (json-alist-p '(("a" . 1) ("b" 2) ("c"))))
49 (should-not (json-alist-p '(())))
50 (should-not (json-alist-p '(a)))
51 (should-not (json-alist-p '(a . 1)))
52 (should-not (json-alist-p '((a . 1) . [])))
53 (should-not (json-alist-p '((a . 1) [])))
45 (should-not (json-alist-p '(:a :b :c))) 54 (should-not (json-alist-p '(:a :b :c)))
46 (should-not (json-alist-p '(:a 1 :b 2 :c 3))) 55 (should-not (json-alist-p '(:a 1 :b 2 :c 3)))
47 (should-not (json-alist-p '((:a 1) (:b 2) 3)))) 56 (should-not (json-alist-p '((:a 1) (:b 2) 3)))
57 (should-not (json-alist-p '((:a 1) (:b 2) ())))
58 (should-not (json-alist-p '(((a) 1) (b 2) (c 3))))
59 (should-not (json-alist-p []))
60 (should-not (json-alist-p [(a . 1)]))
61 (should-not (json-alist-p #s(hash-table))))
48 62
49(ert-deftest test-json-plist-p () 63(ert-deftest test-json-plist-p ()
50 (should (json-plist-p '())) 64 (should (json-plist-p '()))
65 (should (json-plist-p '(:a 1)))
51 (should (json-plist-p '(:a 1 :b 2 :c 3))) 66 (should (json-plist-p '(:a 1 :b 2 :c 3)))
67 (should (json-plist-p '(:a :b)))
68 (should (json-plist-p '(:a :b :c :d)))
69 (should-not (json-plist-p '(a)))
70 (should-not (json-plist-p '(a 1)))
52 (should-not (json-plist-p '(a 1 b 2 c 3))) 71 (should-not (json-plist-p '(a 1 b 2 c 3)))
53 (should-not (json-plist-p '("a" 1 "b" 2 "c" 3))) 72 (should-not (json-plist-p '("a" 1 "b" 2 "c" 3)))
73 (should-not (json-plist-p '(:a)))
54 (should-not (json-plist-p '(:a :b :c))) 74 (should-not (json-plist-p '(:a :b :c)))
55 (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))) 75 (should-not (json-plist-p '(:a 1 :b 2 :c)))
56 76 (should-not (json-plist-p '((:a 1))))
57(ert-deftest test-json-plist-reverse () 77 (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))
58 (should (equal (json--plist-reverse '()) '())) 78 (should-not (json-plist-p []))
59 (should (equal (json--plist-reverse '(:a 1)) '(:a 1))) 79 (should-not (json-plist-p [:a 1]))
60 (should (equal (json--plist-reverse '(:a 1 :b 2 :c 3)) 80 (should-not (json-plist-p #s(hash-table))))
81
82(ert-deftest test-json-plist-nreverse ()
83 (should (equal (json--plist-nreverse '()) '()))
84 (should (equal (json--plist-nreverse (list :a 1)) '(:a 1)))
85 (should (equal (json--plist-nreverse (list :a 1 :b 2)) '(:b 2 :a 1)))
86 (should (equal (json--plist-nreverse (list :a 1 :b 2 :c 3))
61 '(:c 3 :b 2 :a 1)))) 87 '(:c 3 :b 2 :a 1))))
62 88
63(ert-deftest test-json-plist-to-alist ()
64 (should (equal (json--plist-to-alist '()) '()))
65 (should (equal (json--plist-to-alist '(:a 1)) '((:a . 1))))
66 (should (equal (json--plist-to-alist '(:a 1 :b 2 :c 3))
67 '((:a . 1) (:b . 2) (:c . 3)))))
68
69(ert-deftest test-json-advance () 89(ert-deftest test-json-advance ()
70 (json-tests--with-temp-buffer "{ \"a\": 1 }" 90 (json-tests--with-temp-buffer "{ \"a\": 1 }"
71 (json-advance 0) 91 (json-advance 0)
72 (should (= (point) (point-min))) 92 (should (bobp))
93 (json-advance)
94 (should (= (point) (1+ (point-min))))
95 (json-advance 0)
96 (should (= (point) (1+ (point-min))))
97 (json-advance 1)
98 (should (= (point) (+ (point-min) 2)))
73 (json-advance 3) 99 (json-advance 3)
74 (should (= (point) (+ (point-min) 3))))) 100 (should (= (point) (+ (point-min) 5)))))
75 101
76(ert-deftest test-json-peek () 102(ert-deftest test-json-peek ()
77 (json-tests--with-temp-buffer "" 103 (json-tests--with-temp-buffer ""
78 (should (zerop (json-peek)))) 104 (should (zerop (json-peek))))
79 (json-tests--with-temp-buffer "{ \"a\": 1 }" 105 (json-tests--with-temp-buffer "{ \"a\": 1 }"
80 (should (equal (json-peek) ?{)))) 106 (should (= (json-peek) ?\{))
107 (goto-char (1- (point-max)))
108 (should (= (json-peek) ?\}))
109 (json-advance)
110 (should (zerop (json-peek)))))
81 111
82(ert-deftest test-json-pop () 112(ert-deftest test-json-pop ()
83 (json-tests--with-temp-buffer "" 113 (json-tests--with-temp-buffer ""
84 (should-error (json-pop) :type 'json-end-of-file)) 114 (should-error (json-pop) :type 'json-end-of-file))
85 (json-tests--with-temp-buffer "{ \"a\": 1 }" 115 (json-tests--with-temp-buffer "{ \"a\": 1 }"
86 (should (equal (json-pop) ?{)) 116 (should (= (json-pop) ?\{))
87 (should (= (point) (+ (point-min) 1))))) 117 (should (= (point) (1+ (point-min))))
118 (goto-char (1- (point-max)))
119 (should (= (json-pop) ?\}))
120 (should-error (json-pop) :type 'json-end-of-file)))
88 121
89(ert-deftest test-json-skip-whitespace () 122(ert-deftest test-json-skip-whitespace ()
123 (json-tests--with-temp-buffer ""
124 (json-skip-whitespace)
125 (should (bobp))
126 (should (eobp)))
127 (json-tests--with-temp-buffer "{}"
128 (json-skip-whitespace)
129 (should (bobp))
130 (json-advance)
131 (json-skip-whitespace)
132 (should (= (point) (1+ (point-min))))
133 (json-advance)
134 (json-skip-whitespace)
135 (should (eobp)))
90 (json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }" 136 (json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }"
91 (json-skip-whitespace) 137 (json-skip-whitespace)
92 (should (equal (char-after) ?\f))) 138 (should (= (json-peek) ?\f)))
93 (json-tests--with-temp-buffer "\t\r\n\t { \"a\": 1 }" 139 (json-tests--with-temp-buffer "\t\r\n\t { \"a\": 1 }"
94 (json-skip-whitespace) 140 (json-skip-whitespace)
95 (should (equal (char-after) ?{)))) 141 (should (= (json-peek) ?\{))))
96 142
97;;; Paths 143;;; Paths
98 144
@@ -113,59 +159,243 @@ Point is moved to beginning of the buffer."
113(ert-deftest test-json-path-to-position-no-match () 159(ert-deftest test-json-path-to-position-no-match ()
114 (let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}") 160 (let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}")
115 (matched-path (json-path-to-position 5 json-string))) 161 (matched-path (json-path-to-position 5 json-string)))
116 (should (null matched-path)))) 162 (should-not matched-path)))
117 163
118;;; Keywords 164;;; Keywords
119 165
120(ert-deftest test-json-read-keyword () 166(ert-deftest test-json-read-keyword ()
121 (json-tests--with-temp-buffer "true" 167 (json-tests--with-temp-buffer "true"
122 (should (json-read-keyword "true"))) 168 (should (eq (json-read-keyword "true") t))
169 (should (eobp)))
170 (json-tests--with-temp-buffer "true "
171 (should (eq (json-read-keyword "true") t))
172 (should (eobp)))
173 (json-tests--with-temp-buffer "true}"
174 (should (eq (json-read-keyword "true") t))
175 (should (= (point) (+ (point-min) 4))))
176 (json-tests--with-temp-buffer "true false"
177 (should (eq (json-read-keyword "true") t))
178 (should (= (point) (+ (point-min) 5))))
179 (json-tests--with-temp-buffer "true }"
180 (should (eq (json-read-keyword "true") t))
181 (should (= (point) (+ (point-min) 5))))
182 (json-tests--with-temp-buffer "true |"
183 (should (eq (json-read-keyword "true") t))
184 (should (= (point) (+ (point-min) 5))))
185 (json-tests--with-temp-buffer "false"
186 (let ((json-false 'false))
187 (should (eq (json-read-keyword "false") 'false)))
188 (should (eobp)))
189 (json-tests--with-temp-buffer "null"
190 (let ((json-null 'null))
191 (should (eq (json-read-keyword "null") 'null)))
192 (should (eobp))))
193
194(ert-deftest test-json-read-keyword-invalid ()
195 (json-tests--with-temp-buffer ""
196 (should (equal (should-error (json-read-keyword ""))
197 '(json-unknown-keyword "")))
198 (should (equal (should-error (json-read-keyword "true"))
199 '(json-unknown-keyword ()))))
123 (json-tests--with-temp-buffer "true" 200 (json-tests--with-temp-buffer "true"
124 (should-error 201 (should (equal (should-error (json-read-keyword "false"))
125 (json-read-keyword "false") :type 'json-unknown-keyword)) 202 '(json-unknown-keyword "true"))))
126 (json-tests--with-temp-buffer "foo" 203 (json-tests--with-temp-buffer "foo"
127 (should-error 204 (should (equal (should-error (json-read-keyword "foo"))
128 (json-read-keyword "foo") :type 'json-unknown-keyword))) 205 '(json-unknown-keyword "foo")))
206 (should (equal (should-error (json-read-keyword "bar"))
207 '(json-unknown-keyword "bar"))))
208 (json-tests--with-temp-buffer " true"
209 (should (equal (should-error (json-read-keyword "true"))
210 '(json-unknown-keyword ()))))
211 (json-tests--with-temp-buffer "truefalse"
212 (should (equal (should-error (json-read-keyword "true"))
213 '(json-unknown-keyword "truefalse"))))
214 (json-tests--with-temp-buffer "true|"
215 (should (equal (should-error (json-read-keyword "true"))
216 '(json-unknown-keyword "true")))))
129 217
130(ert-deftest test-json-encode-keyword () 218(ert-deftest test-json-encode-keyword ()
131 (should (equal (json-encode-keyword t) "true")) 219 (should (equal (json-encode-keyword t) "true"))
132 (should (equal (json-encode-keyword json-false) "false")) 220 (let ((json-false 'false))
133 (should (equal (json-encode-keyword json-null) "null"))) 221 (should (equal (json-encode-keyword 'false) "false"))
222 (should (equal (json-encode-keyword json-false) "false")))
223 (let ((json-null 'null))
224 (should (equal (json-encode-keyword 'null) "null"))
225 (should (equal (json-encode-keyword json-null) "null"))))
134 226
135;;; Numbers 227;;; Numbers
136 228
137(ert-deftest test-json-read-number () 229(ert-deftest test-json-read-integer ()
138 (json-tests--with-temp-buffer "3" 230 (json-tests--with-temp-buffer "0 "
139 (should (= (json-read-number) 3))) 231 (should (= (json-read-number) 0))
140 (json-tests--with-temp-buffer "-5" 232 (should (eobp)))
141 (should (= (json-read-number) -5))) 233 (json-tests--with-temp-buffer "-0 "
142 (json-tests--with-temp-buffer "123.456" 234 (should (= (json-read-number) 0))
143 (should (= (json-read-number) 123.456))) 235 (should (eobp)))
144 (json-tests--with-temp-buffer "1e3" 236 (json-tests--with-temp-buffer "3 "
145 (should (= (json-read-number) 1e3))) 237 (should (= (json-read-number) 3))
146 (json-tests--with-temp-buffer "2e+3" 238 (should (eobp)))
147 (should (= (json-read-number) 2e3))) 239 (json-tests--with-temp-buffer "-10 "
148 (json-tests--with-temp-buffer "3E3" 240 (should (= (json-read-number) -10))
149 (should (= (json-read-number) 3e3))) 241 (should (eobp)))
150 (json-tests--with-temp-buffer "1e-7" 242 (json-tests--with-temp-buffer (format "%d " (1+ most-positive-fixnum))
151 (should (= (json-read-number) 1e-7))) 243 (should (= (json-read-number) (1+ most-positive-fixnum)))
152 (json-tests--with-temp-buffer "abc" 244 (should (eobp)))
153 (should-error (json-read-number) :type 'json-number-format))) 245 (json-tests--with-temp-buffer (format "%d " (1- most-negative-fixnum))
246 (should (= (json-read-number) (1- most-negative-fixnum)))
247 (should (eobp))))
248
249(ert-deftest test-json-read-fraction ()
250 (json-tests--with-temp-buffer "0.0 "
251 (should (= (json-read-number) 0.0))
252 (should (eobp)))
253 (json-tests--with-temp-buffer "-0.0 "
254 (should (= (json-read-number) 0.0))
255 (should (eobp)))
256 (json-tests--with-temp-buffer "0.01 "
257 (should (= (json-read-number) 0.01))
258 (should (eobp)))
259 (json-tests--with-temp-buffer "-0.01 "
260 (should (= (json-read-number) -0.01))
261 (should (eobp)))
262 (json-tests--with-temp-buffer "123.456 "
263 (should (= (json-read-number) 123.456))
264 (should (eobp)))
265 (json-tests--with-temp-buffer "-123.456 "
266 (should (= (json-read-number) -123.456))
267 (should (eobp))))
268
269(ert-deftest test-json-read-exponent ()
270 (json-tests--with-temp-buffer "0e0 "
271 (should (= (json-read-number) 0e0))
272 (should (eobp)))
273 (json-tests--with-temp-buffer "-0E0 "
274 (should (= (json-read-number) 0e0))
275 (should (eobp)))
276 (json-tests--with-temp-buffer "-0E+0 "
277 (should (= (json-read-number) 0e0))
278 (should (eobp)))
279 (json-tests--with-temp-buffer "0e-0 "
280 (should (= (json-read-number) 0e0))
281 (should (eobp)))
282 (json-tests--with-temp-buffer "12e34 "
283 (should (= (json-read-number) 12e34))
284 (should (eobp)))
285 (json-tests--with-temp-buffer "-12E34 "
286 (should (= (json-read-number) -12e34))
287 (should (eobp)))
288 (json-tests--with-temp-buffer "-12E+34 "
289 (should (= (json-read-number) -12e34))
290 (should (eobp)))
291 (json-tests--with-temp-buffer "12e-34 "
292 (should (= (json-read-number) 12e-34))
293 (should (eobp))))
294
295(ert-deftest test-json-read-fraction-exponent ()
296 (json-tests--with-temp-buffer "0.0e0 "
297 (should (= (json-read-number) 0.0e0))
298 (should (eobp)))
299 (json-tests--with-temp-buffer "-0.0E0 "
300 (should (= (json-read-number) 0.0e0))
301 (should (eobp)))
302 (json-tests--with-temp-buffer "0.12E-0 "
303 (should (= (json-read-number) 0.12e0))
304 (should (eobp)))
305 (json-tests--with-temp-buffer "-12.34e+56 "
306 (should (= (json-read-number) -12.34e+56))
307 (should (eobp))))
308
309(ert-deftest test-json-read-number-invalid ()
310 (cl-flet ((read (str)
311 ;; Return error and point resulting from reading STR.
312 (json-tests--with-temp-buffer str
313 (cons (should-error (json-read-number)) (point)))))
314 ;; POS is where each of its STRINGS becomes invalid.
315 (pcase-dolist (`(,pos . ,strings)
316 '((1 "" "+" "-" "." "e" "e1" "abc" "++0" "++1"
317 "+0" "+0.0" "+12" "+12.34" "+12.34e56"
318 ".0" "+.0" "-.0" ".12" "+.12" "-.12"
319 ".e0" "+.e0" "-.e0" ".0e0" "+.0e0" "-.0e0")
320 (2 "01" "1ee1" "1e++1")
321 (3 "-01")
322 (4 "0.0.0" "1.1.1" "1e1e1")
323 (5 "-0.0.0" "-1.1.1")))
324 ;; Expected error and point.
325 (let ((res `((json-number-format ,pos) . ,pos)))
326 (dolist (str strings)
327 (should (equal (read str) res)))))))
154 328
155(ert-deftest test-json-encode-number () 329(ert-deftest test-json-encode-number ()
330 (should (equal (json-encode-number 0) "0"))
331 (should (equal (json-encode-number -0) "0"))
156 (should (equal (json-encode-number 3) "3")) 332 (should (equal (json-encode-number 3) "3"))
157 (should (equal (json-encode-number -5) "-5")) 333 (should (equal (json-encode-number -5) "-5"))
158 (should (equal (json-encode-number 123.456) "123.456"))) 334 (should (equal (json-encode-number 123.456) "123.456"))
335 (let ((bignum (1+ most-positive-fixnum)))
336 (should (equal (json-encode-number bignum)
337 (number-to-string bignum)))))
159 338
160;; Strings 339;;; Strings
161 340
162(ert-deftest test-json-read-escaped-char () 341(ert-deftest test-json-read-escaped-char ()
163 (json-tests--with-temp-buffer "\\\"" 342 (json-tests--with-temp-buffer "\\\""
164 (should (equal (json-read-escaped-char) ?\")))) 343 (should (= (json-read-escaped-char) ?\"))
344 (should (eobp)))
345 (json-tests--with-temp-buffer "\\\\ "
346 (should (= (json-read-escaped-char) ?\\))
347 (should (= (point) (+ (point-min) 2))))
348 (json-tests--with-temp-buffer "\\b "
349 (should (= (json-read-escaped-char) ?\b))
350 (should (= (point) (+ (point-min) 2))))
351 (json-tests--with-temp-buffer "\\f "
352 (should (= (json-read-escaped-char) ?\f))
353 (should (= (point) (+ (point-min) 2))))
354 (json-tests--with-temp-buffer "\\n "
355 (should (= (json-read-escaped-char) ?\n))
356 (should (= (point) (+ (point-min) 2))))
357 (json-tests--with-temp-buffer "\\r "
358 (should (= (json-read-escaped-char) ?\r))
359 (should (= (point) (+ (point-min) 2))))
360 (json-tests--with-temp-buffer "\\t "
361 (should (= (json-read-escaped-char) ?\t))
362 (should (= (point) (+ (point-min) 2))))
363 (json-tests--with-temp-buffer "\\x "
364 (should (= (json-read-escaped-char) ?x))
365 (should (= (point) (+ (point-min) 2))))
366 (json-tests--with-temp-buffer "\\ud800\\uDC00 "
367 (should (= (json-read-escaped-char) #x10000))
368 (should (= (point) (+ (point-min) 12))))
369 (json-tests--with-temp-buffer "\\ud7ff\\udc00 "
370 (should (= (json-read-escaped-char) #xd7ff))
371 (should (= (point) (+ (point-min) 6))))
372 (json-tests--with-temp-buffer "\\uffff "
373 (should (= (json-read-escaped-char) #xffff))
374 (should (= (point) (+ (point-min) 6))))
375 (json-tests--with-temp-buffer "\\ufffff "
376 (should (= (json-read-escaped-char) #xffff))
377 (should (= (point) (+ (point-min) 6)))))
378
379(ert-deftest test-json-read-escaped-char-invalid ()
380 (json-tests--with-temp-buffer ""
381 (should-error (json-read-escaped-char)))
382 (json-tests--with-temp-buffer "\\"
383 (should-error (json-read-escaped-char) :type 'json-end-of-file))
384 (json-tests--with-temp-buffer "\\ufff "
385 (should (equal (should-error (json-read-escaped-char))
386 (list 'json-string-escape (+ (point-min) 2)))))
387 (json-tests--with-temp-buffer "\\ufffg "
388 (should (equal (should-error (json-read-escaped-char))
389 (list 'json-string-escape (+ (point-min) 2))))))
165 390
166(ert-deftest test-json-read-string () 391(ert-deftest test-json-read-string ()
392 (json-tests--with-temp-buffer ""
393 (should-error (json-read-string)))
167 (json-tests--with-temp-buffer "\"formfeed\f\"" 394 (json-tests--with-temp-buffer "\"formfeed\f\""
168 (should-error (json-read-string) :type 'json-string-format)) 395 (should (equal (should-error (json-read-string))
396 '(json-string-format ?\f))))
397 (json-tests--with-temp-buffer "\"\""
398 (should (equal (json-read-string) "")))
169 (json-tests--with-temp-buffer "\"foo \\\"bar\\\"\"" 399 (json-tests--with-temp-buffer "\"foo \\\"bar\\\"\""
170 (should (equal (json-read-string) "foo \"bar\""))) 400 (should (equal (json-read-string) "foo \"bar\"")))
171 (json-tests--with-temp-buffer "\"abcαβγ\"" 401 (json-tests--with-temp-buffer "\"abcαβγ\""
@@ -175,57 +405,117 @@ Point is moved to beginning of the buffer."
175 ;; Bug#24784 405 ;; Bug#24784
176 (json-tests--with-temp-buffer "\"\\uD834\\uDD1E\"" 406 (json-tests--with-temp-buffer "\"\\uD834\\uDD1E\""
177 (should (equal (json-read-string) "\U0001D11E"))) 407 (should (equal (json-read-string) "\U0001D11E")))
408 (json-tests--with-temp-buffer "f"
409 (should-error (json-read-string) :type 'json-end-of-file))
178 (json-tests--with-temp-buffer "foo" 410 (json-tests--with-temp-buffer "foo"
179 (should-error (json-read-string) :type 'json-string-format))) 411 (should-error (json-read-string) :type 'json-end-of-file)))
180 412
181(ert-deftest test-json-encode-string () 413(ert-deftest test-json-encode-string ()
414 (should (equal (json-encode-string "") "\"\""))
415 (should (equal (json-encode-string "a") "\"a\""))
182 (should (equal (json-encode-string "foo") "\"foo\"")) 416 (should (equal (json-encode-string "foo") "\"foo\""))
183 (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\"")) 417 (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\""))
184 (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t") 418 (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t")
185 "\"\\nasdфыв\\u001f\u007ffgh\\t\""))) 419 "\"\\nasdфыв\\u001f\u007ffgh\\t\"")))
186 420
187(ert-deftest test-json-encode-key () 421(ert-deftest test-json-encode-key ()
422 (should (equal (json-encode-key "") "\"\""))
423 (should (equal (json-encode-key '##) "\"\""))
424 (should (equal (json-encode-key :) "\"\""))
188 (should (equal (json-encode-key "foo") "\"foo\"")) 425 (should (equal (json-encode-key "foo") "\"foo\""))
189 (should (equal (json-encode-key 'foo) "\"foo\"")) 426 (should (equal (json-encode-key 'foo) "\"foo\""))
190 (should (equal (json-encode-key :foo) "\"foo\"")) 427 (should (equal (json-encode-key :foo) "\"foo\""))
191 (should-error (json-encode-key 5) :type 'json-key-format) 428 (should (equal (should-error (json-encode-key 5))
192 (should-error (json-encode-key ["foo"]) :type 'json-key-format) 429 '(json-key-format 5)))
193 (should-error (json-encode-key '("foo")) :type 'json-key-format)) 430 (should (equal (should-error (json-encode-key ["foo"]))
431 '(json-key-format ["foo"])))
432 (should (equal (should-error (json-encode-key '("foo")))
433 '(json-key-format ("foo")))))
194 434
195;;; Objects 435;;; Objects
196 436
197(ert-deftest test-json-new-object () 437(ert-deftest test-json-new-object ()
198 (let ((json-object-type 'alist)) 438 (let ((json-object-type 'alist))
199 (should (equal (json-new-object) '()))) 439 (should-not (json-new-object)))
200 (let ((json-object-type 'plist)) 440 (let ((json-object-type 'plist))
201 (should (equal (json-new-object) '()))) 441 (should-not (json-new-object)))
202 (let* ((json-object-type 'hash-table) 442 (let* ((json-object-type 'hash-table)
203 (json-object (json-new-object))) 443 (json-object (json-new-object)))
204 (should (hash-table-p json-object)) 444 (should (hash-table-p json-object))
205 (should (= (hash-table-count json-object) 0)))) 445 (should (map-empty-p json-object))
446 (should (eq (hash-table-test json-object) #'equal))))
206 447
207(ert-deftest test-json-add-to-object () 448(ert-deftest test-json-add-to-alist ()
208 (let* ((json-object-type 'alist) 449 (let* ((json-object-type 'alist)
209 (json-key-type nil)
210 (obj (json-new-object))) 450 (obj (json-new-object)))
211 (setq obj (json-add-to-object obj "a" 1)) 451 (let ((json-key-type nil))
212 (setq obj (json-add-to-object obj "b" 2)) 452 (setq obj (json-add-to-object obj "a" 1))
213 (should (equal (assq 'a obj) '(a . 1))) 453 (setq obj (json-add-to-object obj "b" 2))
214 (should (equal (assq 'b obj) '(b . 2)))) 454 (should (equal (assq 'a obj) '(a . 1)))
455 (should (equal (assq 'b obj) '(b . 2))))
456 (let ((json-key-type 'symbol))
457 (setq obj (json-add-to-object obj "c" 3))
458 (setq obj (json-add-to-object obj "d" 4))
459 (should (equal (assq 'c obj) '(c . 3)))
460 (should (equal (assq 'd obj) '(d . 4))))
461 (let ((json-key-type 'keyword))
462 (setq obj (json-add-to-object obj "e" 5))
463 (setq obj (json-add-to-object obj "f" 6))
464 (should (equal (assq :e obj) '(:e . 5)))
465 (should (equal (assq :f obj) '(:f . 6))))
466 (let ((json-key-type 'string))
467 (setq obj (json-add-to-object obj "g" 7))
468 (setq obj (json-add-to-object obj "h" 8))
469 (should (equal (assoc "g" obj) '("g" . 7)))
470 (should (equal (assoc "h" obj) '("h" . 8))))))
471
472(ert-deftest test-json-add-to-plist ()
215 (let* ((json-object-type 'plist) 473 (let* ((json-object-type 'plist)
216 (json-key-type nil)
217 (obj (json-new-object))) 474 (obj (json-new-object)))
218 (setq obj (json-add-to-object obj "a" 1)) 475 (let ((json-key-type nil))
219 (setq obj (json-add-to-object obj "b" 2)) 476 (setq obj (json-add-to-object obj "a" 1))
220 (should (= (plist-get obj :a) 1)) 477 (setq obj (json-add-to-object obj "b" 2))
221 (should (= (plist-get obj :b) 2))) 478 (should (= (plist-get obj :a) 1))
479 (should (= (plist-get obj :b) 2)))
480 (let ((json-key-type 'keyword))
481 (setq obj (json-add-to-object obj "c" 3))
482 (setq obj (json-add-to-object obj "d" 4))
483 (should (= (plist-get obj :c) 3))
484 (should (= (plist-get obj :d) 4)))
485 (let ((json-key-type 'symbol))
486 (setq obj (json-add-to-object obj "e" 5))
487 (setq obj (json-add-to-object obj "f" 6))
488 (should (= (plist-get obj 'e) 5))
489 (should (= (plist-get obj 'f) 6)))
490 (let ((json-key-type 'string))
491 (setq obj (json-add-to-object obj "g" 7))
492 (setq obj (json-add-to-object obj "h" 8))
493 (should (= (lax-plist-get obj "g") 7))
494 (should (= (lax-plist-get obj "h") 8)))))
495
496(ert-deftest test-json-add-to-hash-table ()
222 (let* ((json-object-type 'hash-table) 497 (let* ((json-object-type 'hash-table)
223 (json-key-type nil)
224 (obj (json-new-object))) 498 (obj (json-new-object)))
225 (setq obj (json-add-to-object obj "a" 1)) 499 (let ((json-key-type nil))
226 (setq obj (json-add-to-object obj "b" 2)) 500 (setq obj (json-add-to-object obj "a" 1))
227 (should (= (gethash "a" obj) 1)) 501 (setq obj (json-add-to-object obj "b" 2))
228 (should (= (gethash "b" obj) 2)))) 502 (should (= (gethash "a" obj) 1))
503 (should (= (gethash "b" obj) 2)))
504 (let ((json-key-type 'string))
505 (setq obj (json-add-to-object obj "c" 3))
506 (setq obj (json-add-to-object obj "d" 4))
507 (should (= (gethash "c" obj) 3))
508 (should (= (gethash "d" obj) 4)))
509 (let ((json-key-type 'symbol))
510 (setq obj (json-add-to-object obj "e" 5))
511 (setq obj (json-add-to-object obj "f" 6))
512 (should (= (gethash 'e obj) 5))
513 (should (= (gethash 'f obj) 6)))
514 (let ((json-key-type 'keyword))
515 (setq obj (json-add-to-object obj "g" 7))
516 (setq obj (json-add-to-object obj "h" 8))
517 (should (= (gethash :g obj) 7))
518 (should (= (gethash :h obj) 8)))))
229 519
230(ert-deftest test-json-read-object () 520(ert-deftest test-json-read-object ()
231 (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" 521 (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }"
@@ -238,94 +528,384 @@ Point is moved to beginning of the buffer."
238 (let* ((json-object-type 'hash-table) 528 (let* ((json-object-type 'hash-table)
239 (hash-table (json-read-object))) 529 (hash-table (json-read-object)))
240 (should (= (gethash "a" hash-table) 1)) 530 (should (= (gethash "a" hash-table) 1))
241 (should (= (gethash "b" hash-table) 2)))) 531 (should (= (gethash "b" hash-table) 2)))))
532
533(ert-deftest test-json-read-object-empty ()
534 (json-tests--with-temp-buffer "{}"
535 (let ((json-object-type 'alist))
536 (should-not (save-excursion (json-read-object))))
537 (let ((json-object-type 'plist))
538 (should-not (save-excursion (json-read-object))))
539 (let* ((json-object-type 'hash-table)
540 (hash-table (json-read-object)))
541 (should (hash-table-p hash-table))
542 (should (map-empty-p hash-table)))))
543
544(ert-deftest test-json-read-object-invalid ()
545 (json-tests--with-temp-buffer "{ \"a\" 1, \"b\": 2 }"
546 (should (equal (should-error (json-read-object))
547 '(json-object-format ":" ?1))))
242 (json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }" 548 (json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }"
243 (should-error (json-read-object) :type 'json-object-format))) 549 (should (equal (should-error (json-read-object))
550 '(json-object-format "," ?\")))))
551
552(ert-deftest test-json-read-object-function ()
553 (let* ((pre nil)
554 (post nil)
555 (keys '("b" "a"))
556 (json-pre-element-read-function
557 (lambda (key)
558 (setq pre 'pre)
559 (should (equal key (pop keys)))))
560 (json-post-element-read-function
561 (lambda () (setq post 'post))))
562 (json-tests--with-temp-buffer "{ \"b\": 2, \"a\": 1 }"
563 (json-read-object)
564 (should (eq pre 'pre))
565 (should (eq post 'post)))))
244 566
245(ert-deftest test-json-encode-hash-table () 567(ert-deftest test-json-encode-hash-table ()
246 (let ((hash-table (make-hash-table)) 568 (let ((json-encoding-object-sort-predicate nil)
247 (json-encoding-object-sort-predicate 'string<)
248 (json-encoding-pretty-print nil)) 569 (json-encoding-pretty-print nil))
249 (puthash :a 1 hash-table) 570 (should (equal (json-encode-hash-table #s(hash-table)) "{}"))
250 (puthash :b 2 hash-table) 571 (should (equal (json-encode-hash-table #s(hash-table data (a 1)))
251 (puthash :c 3 hash-table) 572 "{\"a\":1}"))
252 (should (equal (json-encode hash-table) 573 (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1)))
253 "{\"a\":1,\"b\":2,\"c\":3}")))) 574 '("{\"a\":1,\"b\":2}" "{\"b\":2,\"a\":1}")))
254 575 (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1)))
255(ert-deftest json-encode-simple-alist () 576 '("{\"a\":1,\"b\":2,\"c\":3}"
256 (let ((json-encoding-pretty-print nil)) 577 "{\"a\":1,\"c\":3,\"b\":2}"
257 (should (equal (json-encode '((a . 1) (b . 2))) 578 "{\"b\":2,\"a\":1,\"c\":3}"
258 "{\"a\":1,\"b\":2}")))) 579 "{\"b\":2,\"c\":3,\"a\":1}"
259 580 "{\"c\":3,\"a\":1,\"b\":2}"
260(ert-deftest test-json-encode-plist () 581 "{\"c\":3,\"b\":2,\"a\":1}")))))
261 (let ((plist '(:a 1 :b 2)) 582
583(ert-deftest test-json-encode-hash-table-pretty ()
584 (let ((json-encoding-object-sort-predicate nil)
585 (json-encoding-pretty-print t)
586 (json-encoding-default-indentation " ")
587 (json-encoding-lisp-style-closings nil))
588 (should (equal (json-encode-hash-table #s(hash-table)) "{}"))
589 (should (equal (json-encode-hash-table #s(hash-table data (a 1)))
590 "{\n \"a\": 1\n}"))
591 (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1)))
592 '("{\n \"a\": 1,\n \"b\": 2\n}"
593 "{\n \"b\": 2,\n \"a\": 1\n}")))
594 (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1)))
595 '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3\n}"
596 "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2\n}"
597 "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3\n}"
598 "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1\n}"
599 "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2\n}"
600 "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}")))))
601
602(ert-deftest test-json-encode-hash-table-lisp-style ()
603 (let ((json-encoding-object-sort-predicate nil)
604 (json-encoding-pretty-print t)
605 (json-encoding-default-indentation " ")
606 (json-encoding-lisp-style-closings t))
607 (should (equal (json-encode-hash-table #s(hash-table)) "{}"))
608 (should (equal (json-encode-hash-table #s(hash-table data (a 1)))
609 "{\n \"a\": 1}"))
610 (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1)))
611 '("{\n \"a\": 1,\n \"b\": 2}"
612 "{\n \"b\": 2,\n \"a\": 1}")))
613 (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1)))
614 '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3}"
615 "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2}"
616 "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3}"
617 "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1}"
618 "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2}"
619 "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}")))))
620
621(ert-deftest test-json-encode-hash-table-sort ()
622 (let ((json-encoding-object-sort-predicate #'string<)
262 (json-encoding-pretty-print nil)) 623 (json-encoding-pretty-print nil))
263 (should (equal (json-encode plist) "{\"a\":1,\"b\":2}")))) 624 (pcase-dolist (`(,in . ,out)
264 625 '((#s(hash-table) . "{}")
265(ert-deftest test-json-encode-plist-with-sort-predicate () 626 (#s(hash-table data (a 1)) . "{\"a\":1}")
266 (let ((plist '(:c 3 :a 1 :b 2)) 627 (#s(hash-table data (b 2 a 1)) . "{\"a\":1,\"b\":2}")
267 (json-encoding-object-sort-predicate 'string<) 628 (#s(hash-table data (c 3 b 2 a 1))
629 . "{\"a\":1,\"b\":2,\"c\":3}")))
630 (let ((copy (map-pairs in)))
631 (should (equal (json-encode-hash-table in) out))
632 ;; Ensure sorting isn't destructive.
633 (should (seq-set-equal-p (map-pairs in) copy))))))
634
635(ert-deftest test-json-encode-alist ()
636 (let ((json-encoding-object-sort-predicate nil)
268 (json-encoding-pretty-print nil)) 637 (json-encoding-pretty-print nil))
269 (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}")))) 638 (should (equal (json-encode-alist ()) "{}"))
639 (should (equal (json-encode-alist '((a . 1))) "{\"a\":1}"))
640 (should (equal (json-encode-alist '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}"))
641 (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1)))
642 "{\"c\":3,\"b\":2,\"a\":1}"))))
643
644(ert-deftest test-json-encode-alist-pretty ()
645 (let ((json-encoding-object-sort-predicate nil)
646 (json-encoding-pretty-print t)
647 (json-encoding-default-indentation " ")
648 (json-encoding-lisp-style-closings nil))
649 (should (equal (json-encode-alist ()) "{}"))
650 (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1\n}"))
651 (should (equal (json-encode-alist '((b . 2) (a . 1)))
652 "{\n \"b\": 2,\n \"a\": 1\n}"))
653 (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1)))
654 "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}"))))
655
656(ert-deftest test-json-encode-alist-lisp-style ()
657 (let ((json-encoding-object-sort-predicate nil)
658 (json-encoding-pretty-print t)
659 (json-encoding-default-indentation " ")
660 (json-encoding-lisp-style-closings t))
661 (should (equal (json-encode-alist ()) "{}"))
662 (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1}"))
663 (should (equal (json-encode-alist '((b . 2) (a . 1)))
664 "{\n \"b\": 2,\n \"a\": 1}"))
665 (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1)))
666 "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}"))))
667
668(ert-deftest test-json-encode-alist-sort ()
669 (let ((json-encoding-object-sort-predicate #'string<)
670 (json-encoding-pretty-print nil))
671 (pcase-dolist (`(,in . ,out)
672 '((() . "{}")
673 (((a . 1)) . "{\"a\":1}")
674 (((b . 2) (a . 1)) . "{\"a\":1,\"b\":2}")
675 (((c . 3) (b . 2) (a . 1))
676 . "{\"a\":1,\"b\":2,\"c\":3}")))
677 (let ((copy (copy-alist in)))
678 (should (equal (json-encode-alist in) out))
679 ;; Ensure sorting isn't destructive (bug#40693).
680 (should (equal in copy))))))
270 681
271(ert-deftest test-json-encode-alist-with-sort-predicate () 682(ert-deftest test-json-encode-plist ()
272 (let ((alist '((:c . 3) (:a . 1) (:b . 2))) 683 (let ((json-encoding-object-sort-predicate nil)
273 (json-encoding-object-sort-predicate 'string<)
274 (json-encoding-pretty-print nil)) 684 (json-encoding-pretty-print nil))
275 (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}")))) 685 (should (equal (json-encode-plist ()) "{}"))
686 (should (equal (json-encode-plist '(:a 1)) "{\"a\":1}"))
687 (should (equal (json-encode-plist '(:b 2 :a 1)) "{\"b\":2,\"a\":1}"))
688 (should (equal (json-encode-plist '(:c 3 :b 2 :a 1))
689 "{\"c\":3,\"b\":2,\"a\":1}"))))
690
691(ert-deftest test-json-encode-plist-pretty ()
692 (let ((json-encoding-object-sort-predicate nil)
693 (json-encoding-pretty-print t)
694 (json-encoding-default-indentation " ")
695 (json-encoding-lisp-style-closings nil))
696 (should (equal (json-encode-plist ()) "{}"))
697 (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1\n}"))
698 (should (equal (json-encode-plist '(:b 2 :a 1))
699 "{\n \"b\": 2,\n \"a\": 1\n}"))
700 (should (equal (json-encode-plist '(:c 3 :b 2 :a 1))
701 "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}"))))
702
703(ert-deftest test-json-encode-plist-lisp-style ()
704 (let ((json-encoding-object-sort-predicate nil)
705 (json-encoding-pretty-print t)
706 (json-encoding-default-indentation " ")
707 (json-encoding-lisp-style-closings t))
708 (should (equal (json-encode-plist ()) "{}"))
709 (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1}"))
710 (should (equal (json-encode-plist '(:b 2 :a 1))
711 "{\n \"b\": 2,\n \"a\": 1}"))
712 (should (equal (json-encode-plist '(:c 3 :b 2 :a 1))
713 "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}"))))
714
715(ert-deftest test-json-encode-plist-sort ()
716 (let ((json-encoding-object-sort-predicate #'string<)
717 (json-encoding-pretty-print nil))
718 (pcase-dolist (`(,in . ,out)
719 '((() . "{}")
720 ((:a 1) . "{\"a\":1}")
721 ((:b 2 :a 1) . "{\"a\":1,\"b\":2}")
722 ((:c 3 :b 2 :a 1) . "{\"a\":1,\"b\":2,\"c\":3}")))
723 (let ((copy (copy-sequence in)))
724 (should (equal (json-encode-plist in) out))
725 ;; Ensure sorting isn't destructive.
726 (should (equal in copy))))))
276 727
277(ert-deftest test-json-encode-list () 728(ert-deftest test-json-encode-list ()
278 (let ((json-encoding-pretty-print nil)) 729 (let ((json-encoding-object-sort-predicate nil)
279 (should (equal (json-encode-list '(:a 1 :b 2)) 730 (json-encoding-pretty-print nil))
280 "{\"a\":1,\"b\":2}")) 731 (should (equal (json-encode-list ()) "{}"))
281 (should (equal (json-encode-list '((:a . 1) (:b . 2))) 732 (should (equal (json-encode-list '(a)) "[\"a\"]"))
282 "{\"a\":1,\"b\":2}")) 733 (should (equal (json-encode-list '(:a)) "[\"a\"]"))
283 (should (equal (json-encode-list '(1 2 3 4)) "[1,2,3,4]")))) 734 (should (equal (json-encode-list '("a")) "[\"a\"]"))
735 (should (equal (json-encode-list '(a 1)) "[\"a\",1]"))
736 (should (equal (json-encode-list '("a" 1)) "[\"a\",1]"))
737 (should (equal (json-encode-list '(:a 1)) "{\"a\":1}"))
738 (should (equal (json-encode-list '((a . 1))) "{\"a\":1}"))
739 (should (equal (json-encode-list '((:a . 1))) "{\"a\":1}"))
740 (should (equal (json-encode-list '(:b 2 :a)) "[\"b\",2,\"a\"]"))
741 (should (equal (json-encode-list '(4 3 2 1)) "[4,3,2,1]"))
742 (should (equal (json-encode-list '(b 2 a 1)) "[\"b\",2,\"a\",1]"))
743 (should (equal (json-encode-list '(:b 2 :a 1)) "{\"b\":2,\"a\":1}"))
744 (should (equal (json-encode-list '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}"))
745 (should (equal (json-encode-list '((:b . 2) (:a . 1)))
746 "{\"b\":2,\"a\":1}"))
747 (should (equal (json-encode-list '((a) 1)) "[[\"a\"],1]"))
748 (should (equal (json-encode-list '((:a) 1)) "[[\"a\"],1]"))
749 (should (equal (json-encode-list '(("a") 1)) "[[\"a\"],1]"))
750 (should (equal (json-encode-list '((a 1) 2)) "[[\"a\",1],2]"))
751 (should (equal (json-encode-list '((:a 1) 2)) "[{\"a\":1},2]"))
752 (should (equal (json-encode-list '(((a . 1)) 2)) "[{\"a\":1},2]"))
753 (should (equal (json-encode-list '(:a 1 :b (2))) "{\"a\":1,\"b\":[2]}"))
754 (should (equal (json-encode-list '((a . 1) (b 2))) "{\"a\":1,\"b\":[2]}"))
755 (should-error (json-encode-list '(a . 1)) :type 'wrong-type-argument)
756 (should-error (json-encode-list '((a . 1) 2)) :type 'wrong-type-argument)
757 (should (equal (should-error (json-encode-list []))
758 '(json-error [])))
759 (should (equal (should-error (json-encode-list [a]))
760 '(json-error [a])))))
284 761
285;;; Arrays 762;;; Arrays
286 763
287(ert-deftest test-json-read-array () 764(ert-deftest test-json-read-array ()
288 (let ((json-array-type 'vector)) 765 (let ((json-array-type 'vector))
766 (json-tests--with-temp-buffer "[]"
767 (should (equal (json-read-array) [])))
768 (json-tests--with-temp-buffer "[ ]"
769 (should (equal (json-read-array) [])))
770 (json-tests--with-temp-buffer "[1]"
771 (should (equal (json-read-array) [1])))
289 (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" 772 (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]"
290 (should (equal (json-read-array) [1 2 "a" "b"])))) 773 (should (equal (json-read-array) [1 2 "a" "b"]))))
291 (let ((json-array-type 'list)) 774 (let ((json-array-type 'list))
775 (json-tests--with-temp-buffer "[]"
776 (should-not (json-read-array)))
777 (json-tests--with-temp-buffer "[ ]"
778 (should-not (json-read-array)))
779 (json-tests--with-temp-buffer "[1]"
780 (should (equal (json-read-array) '(1))))
292 (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" 781 (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]"
293 (should (equal (json-read-array) '(1 2 "a" "b"))))) 782 (should (equal (json-read-array) '(1 2 "a" "b")))))
294 (json-tests--with-temp-buffer "[1 2]" 783 (json-tests--with-temp-buffer "[1 2]"
295 (should-error (json-read-array) :type 'json-error))) 784 (should (equal (should-error (json-read-array))
785 '(json-array-format "," ?2)))))
786
787(ert-deftest test-json-read-array-function ()
788 (let* ((pre nil)
789 (post nil)
790 (keys '(0 1))
791 (json-pre-element-read-function
792 (lambda (key)
793 (setq pre 'pre)
794 (should (equal key (pop keys)))))
795 (json-post-element-read-function
796 (lambda () (setq post 'post))))
797 (json-tests--with-temp-buffer "[1, 0]"
798 (json-read-array)
799 (should (eq pre 'pre))
800 (should (eq post 'post)))))
296 801
297(ert-deftest test-json-encode-array () 802(ert-deftest test-json-encode-array ()
298 (let ((json-encoding-pretty-print nil)) 803 (let ((json-encoding-object-sort-predicate nil)
299 (should (equal (json-encode-array [1 2 "a" "b"]) 804 (json-encoding-pretty-print nil))
300 "[1,2,\"a\",\"b\"]")))) 805 (should (equal (json-encode-array ()) "[]"))
806 (should (equal (json-encode-array []) "[]"))
807 (should (equal (json-encode-array '(1)) "[1]"))
808 (should (equal (json-encode-array '[1]) "[1]"))
809 (should (equal (json-encode-array '(2 1)) "[2,1]"))
810 (should (equal (json-encode-array '[2 1]) "[2,1]"))
811 (should (equal (json-encode-array '[:b a 2 1]) "[\"b\",\"a\",2,1]"))))
812
813(ert-deftest test-json-encode-array-pretty ()
814 (let ((json-encoding-object-sort-predicate nil)
815 (json-encoding-pretty-print t)
816 (json-encoding-default-indentation " ")
817 (json-encoding-lisp-style-closings nil))
818 (should (equal (json-encode-array ()) "[]"))
819 (should (equal (json-encode-array []) "[]"))
820 (should (equal (json-encode-array '(1)) "[\n 1\n]"))
821 (should (equal (json-encode-array '[1]) "[\n 1\n]"))
822 (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1\n]"))
823 (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1\n]"))
824 (should (equal (json-encode-array '[:b a 2 1])
825 "[\n \"b\",\n \"a\",\n 2,\n 1\n]"))))
826
827(ert-deftest test-json-encode-array-lisp-style ()
828 (let ((json-encoding-object-sort-predicate nil)
829 (json-encoding-pretty-print t)
830 (json-encoding-default-indentation " ")
831 (json-encoding-lisp-style-closings t))
832 (should (equal (json-encode-array ()) "[]"))
833 (should (equal (json-encode-array []) "[]"))
834 (should (equal (json-encode-array '(1)) "[\n 1]"))
835 (should (equal (json-encode-array '[1]) "[\n 1]"))
836 (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1]"))
837 (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1]"))
838 (should (equal (json-encode-array '[:b a 2 1])
839 "[\n \"b\",\n \"a\",\n 2,\n 1]"))))
301 840
302;;; Reader 841;;; Reader
303 842
304(ert-deftest test-json-read () 843(ert-deftest test-json-read ()
305 (json-tests--with-temp-buffer "{ \"a\": 1 }" 844 (pcase-dolist (`(,fn . ,contents)
306 ;; We don't care exactly what the return value is (that is tested 845 '((json-read-string "\"\"" "\"a\"")
307 ;; in `test-json-read-object'), but it should parse without error. 846 (json-read-array "[]" "[1]")
308 (should (json-read))) 847 (json-read-object "{}" "{\"a\":1}")
848 (json-read-keyword "null" "false" "true")
849 (json-read-number
850 "-0" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")))
851 (dolist (content contents)
852 ;; Check that leading whitespace is skipped.
853 (dolist (str (list content (concat " " content)))
854 (cl-letf* ((called nil)
855 ((symbol-function fn)
856 (lambda (&rest _) (setq called t))))
857 (json-tests--with-temp-buffer str
858 ;; We don't care exactly what the return value is (that is
859 ;; tested elsewhere), but it should parse without error.
860 (should (json-read))
861 (should called)))))))
862
863(ert-deftest test-json-read-invalid ()
309 (json-tests--with-temp-buffer "" 864 (json-tests--with-temp-buffer ""
310 (should-error (json-read) :type 'json-end-of-file)) 865 (should-error (json-read) :type 'json-end-of-file))
311 (json-tests--with-temp-buffer "xxx" 866 (json-tests--with-temp-buffer " "
312 (let ((err (should-error (json-read) :type 'json-readtable-error))) 867 (should-error (json-read) :type 'json-end-of-file))
313 (should (equal (cdr err) '(?x)))))) 868 (json-tests--with-temp-buffer "x"
869 (should (equal (should-error (json-read))
870 '(json-readtable-error ?x))))
871 (json-tests--with-temp-buffer " x"
872 (should (equal (should-error (json-read))
873 '(json-readtable-error ?x)))))
314 874
315(ert-deftest test-json-read-from-string () 875(ert-deftest test-json-read-from-string ()
316 (let ((json-string "{ \"a\": 1 }")) 876 (dolist (str '("\"\"" "\"a\"" "[]" "[1]" "{}" "{\"a\":1}"
317 (json-tests--with-temp-buffer json-string 877 "null" "false" "true" "0" "123"))
318 (should (equal (json-read-from-string json-string) 878 (json-tests--with-temp-buffer str
879 (should (equal (json-read-from-string str)
319 (json-read)))))) 880 (json-read))))))
320 881
321;;; JSON encoder 882;;; Encoder
322 883
323(ert-deftest test-json-encode () 884(ert-deftest test-json-encode ()
885 (should (equal (json-encode t) "true"))
886 (let ((json-null 'null))
887 (should (equal (json-encode json-null) "null")))
888 (let ((json-false 'false))
889 (should (equal (json-encode json-false) "false")))
890 (should (equal (json-encode "") "\"\""))
324 (should (equal (json-encode "foo") "\"foo\"")) 891 (should (equal (json-encode "foo") "\"foo\""))
892 (should (equal (json-encode :) "\"\""))
893 (should (equal (json-encode :foo) "\"foo\""))
894 (should (equal (json-encode '(1)) "[1]"))
895 (should (equal (json-encode 'foo) "\"foo\""))
896 (should (equal (json-encode 0) "0"))
897 (should (equal (json-encode 123) "123"))
898 (let ((json-encoding-object-sort-predicate nil)
899 (json-encoding-pretty-print nil))
900 (should (equal (json-encode []) "[]"))
901 (should (equal (json-encode [1]) "[1]"))
902 (should (equal (json-encode #s(hash-table)) "{}"))
903 (should (equal (json-encode #s(hash-table data (a 1))) "{\"a\":1}")))
325 (with-temp-buffer 904 (with-temp-buffer
326 (should-error (json-encode (current-buffer)) :type 'json-error))) 905 (should (equal (should-error (json-encode (current-buffer)))
906 (list 'json-error (current-buffer))))))
327 907
328;;; Pretty-print 908;;; Pretty printing & minimizing
329 909
330(defun json-tests-equal-pretty-print (original &optional expected) 910(defun json-tests-equal-pretty-print (original &optional expected)
331 "Abort current test if pretty-printing ORIGINAL does not yield EXPECTED. 911 "Abort current test if pretty-printing ORIGINAL does not yield EXPECTED.
@@ -351,46 +931,45 @@ nil, ORIGINAL should stay unchanged by pretty-printing."
351 (json-tests-equal-pretty-print "0.123")) 931 (json-tests-equal-pretty-print "0.123"))
352 932
353(ert-deftest test-json-pretty-print-object () 933(ert-deftest test-json-pretty-print-object ()
354 ;; empty (regression test for bug#24252) 934 ;; Empty (regression test for bug#24252).
355 (json-tests-equal-pretty-print 935 (json-tests-equal-pretty-print "{}")
356 "{}" 936 ;; One pair.
357 "{\n}")
358 ;; one pair
359 (json-tests-equal-pretty-print 937 (json-tests-equal-pretty-print
360 "{\"key\":1}" 938 "{\"key\":1}"
361 "{\n \"key\": 1\n}") 939 "{\n \"key\": 1\n}")
362 ;; two pairs 940 ;; Two pairs.
363 (json-tests-equal-pretty-print 941 (json-tests-equal-pretty-print
364 "{\"key1\":1,\"key2\":2}" 942 "{\"key1\":1,\"key2\":2}"
365 "{\n \"key1\": 1,\n \"key2\": 2\n}") 943 "{\n \"key1\": 1,\n \"key2\": 2\n}")
366 ;; embedded object 944 ;; Nested object.
367 (json-tests-equal-pretty-print 945 (json-tests-equal-pretty-print
368 "{\"foo\":{\"key\":1}}" 946 "{\"foo\":{\"key\":1}}"
369 "{\n \"foo\": {\n \"key\": 1\n }\n}") 947 "{\n \"foo\": {\n \"key\": 1\n }\n}")
370 ;; embedded array 948 ;; Nested array.
371 (json-tests-equal-pretty-print 949 (json-tests-equal-pretty-print
372 "{\"key\":[1,2]}" 950 "{\"key\":[1,2]}"
373 "{\n \"key\": [\n 1,\n 2\n ]\n}")) 951 "{\n \"key\": [\n 1,\n 2\n ]\n}"))
374 952
375(ert-deftest test-json-pretty-print-array () 953(ert-deftest test-json-pretty-print-array ()
376 ;; empty 954 ;; Empty.
377 (json-tests-equal-pretty-print "[]") 955 (json-tests-equal-pretty-print "[]")
378 ;; one item 956 ;; One item.
379 (json-tests-equal-pretty-print 957 (json-tests-equal-pretty-print
380 "[1]" 958 "[1]"
381 "[\n 1\n]") 959 "[\n 1\n]")
382 ;; two items 960 ;; Two items.
383 (json-tests-equal-pretty-print 961 (json-tests-equal-pretty-print
384 "[1,2]" 962 "[1,2]"
385 "[\n 1,\n 2\n]") 963 "[\n 1,\n 2\n]")
386 ;; embedded object 964 ;; Nested object.
387 (json-tests-equal-pretty-print 965 (json-tests-equal-pretty-print
388 "[{\"key\":1}]" 966 "[{\"key\":1}]"
389 "[\n {\n \"key\": 1\n }\n]") 967 "[\n {\n \"key\": 1\n }\n]")
390 ;; embedded array 968 ;; Nested array.
391 (json-tests-equal-pretty-print 969 (json-tests-equal-pretty-print
392 "[[1,2]]" 970 "[[1,2]]"
393 "[\n [\n 1,\n 2\n ]\n]")) 971 "[\n [\n 1,\n 2\n ]\n]"))
394 972
395(provide 'json-tests) 973(provide 'json-tests)
974
396;;; json-tests.el ends here 975;;; json-tests.el ends here
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 @@
1;;; webjump-tests.el --- Tests for webjump.el -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2020 Free Software Foundation, Inc.
4
5;; Author: Simen Heggestøyl <simenheg@gmail.com>
6;; Keywords:
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
22
23;;; Commentary:
24
25;;
26
27;;; Code:
28
29(require 'ert)
30(require 'webjump)
31
32(ert-deftest webjump-tests-builtin ()
33 (should (equal (webjump-builtin '[name] "gnu.org") "gnu.org")))
34
35(ert-deftest webjump-tests-builtin-check-args ()
36 (should (webjump-builtin-check-args [1 2 3] "Foo" 2))
37 (should-error (webjump-builtin-check-args [1 2 3] "Foo" 3)))
38
39(ert-deftest webjump-tests-mirror-default ()
40 (should (equal (webjump-mirror-default
41 '("https://ftp.gnu.org/pub/gnu/"
42 "https://ftpmirror.gnu.org"))
43 "https://ftp.gnu.org/pub/gnu/")))
44
45(ert-deftest webjump-tests-null-or-blank-string-p ()
46 (should (webjump-null-or-blank-string-p nil))
47 (should (webjump-null-or-blank-string-p ""))
48 (should (webjump-null-or-blank-string-p " "))
49 (should-not (webjump-null-or-blank-string-p " . ")))
50
51(ert-deftest webjump-tests-url-encode ()
52 (should (equal (webjump-url-encode "") ""))
53 (should (equal (webjump-url-encode "a b c") "a+b+c"))
54 (should (equal (webjump-url-encode "foo?") "foo%3F"))
55 (should (equal (webjump-url-encode "/foo\\") "/foo%5C"))
56 (should (equal (webjump-url-encode "f&o") "f%26o")))
57
58(ert-deftest webjump-tests-url-fix ()
59 (should (equal (webjump-url-fix nil) ""))
60 (should (equal (webjump-url-fix "/tmp/") "file:///tmp/"))
61 (should (equal (webjump-url-fix "gnu.org") "http://gnu.org/"))
62 (should (equal (webjump-url-fix "ftp.x.org") "ftp://ftp.x.org/"))
63 (should (equal (webjump-url-fix "https://gnu.org")
64 "https://gnu.org/")))
65
66(ert-deftest webjump-tests-url-fix-trailing-slash ()
67 (should (equal (webjump-url-fix-trailing-slash "https://gnu.org")
68 "https://gnu.org/"))
69 (should (equal (webjump-url-fix-trailing-slash "https://gnu.org/")
70 "https://gnu.org/")))
71
72(provide 'webjump-tests)
73;;; webjump-tests.el ends here
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.")
164 (should (equal (cdr xml-parse-test--namespace-attribute-qnames) 164 (should (equal (cdr xml-parse-test--namespace-attribute-qnames)
165 (xml-parse-region nil nil nil nil 'symbol-qnames))))) 165 (xml-parse-region nil nil nil nil 'symbol-qnames)))))
166 166
167(ert-deftest xml-print-invalid-cdata ()
168 "Check that Bug#41094 is fixed."
169 (with-temp-buffer
170 (should (equal (should-error (xml-print '((foo () "\0")))
171 :type 'xml-invalid-character)
172 '(xml-invalid-character 0 1)))
173 (should (equal (should-error (xml-print '((foo () "\u00FF \xFF")))
174 :type 'xml-invalid-character)
175 '(xml-invalid-character #x3FFFFF 3)))))
176
167;; Local Variables: 177;; Local Variables:
168;; no-byte-compile: t 178;; no-byte-compile: t
169;; End: 179;; End:
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."
1327 (set-buffer-multibyte t) 1327 (set-buffer-multibyte t)
1328 (buffer-string))))))) 1328 (buffer-string)))))))
1329 1329
1330;; https://debbugs.gnu.org/33492
1331(ert-deftest buffer-tests-buffer-local-variables-undo ()
1332 "Test that `buffer-undo-list' appears in `buffer-local-variables'."
1333 (with-temp-buffer
1334 (should (assq 'buffer-undo-list (buffer-local-variables)))))
1335
1330;;; buffer-tests.el ends here 1336;;; buffer-tests.el ends here