mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'savannah/master' into HEAD

Browse source
This commit is contained in:
Andrea Corallo 2020-09-26 15:31:50 +02:00
commit 06acf681d6
86 changed files with 1818 additions and 1292 deletions
Download patch file Download diff file Expand all files Collapse all files

9
CONTRIBUTE
View file

@ -257,13 +257,12 @@ them right the first time, so here are guidelines for formatting them:
- There is no standard or recommended way to identify revisions in
ChangeLog entries. Using Git SHA1 values limits the usability of
the references to Git, and will become much less useful if Emacs
switches to a different VCS. So we recommend against that.
switches to a different VCS. So we recommend against doing only that.
One way to identify revisions is by quoting their summary line.
Another is with an action stamp - an RFC3339 date followed by !
followed by the committer's email - for example,
"2014-01-16T05:43:35Z!esr@thyrsus.com". Often, "my previous commit"
will suffice.
Prefixing the summary with the commit date can give useful context
(use 'git show -s "--pretty=format:%cd \"%s\"" --date=short HASH' to
produce that). Often, "my previous commit" will suffice.
- There is no need to mention files such as NEWS and MAINTAINERS, or
to indicate regeneration of files such as 'lib/gnulib.mk', in the

11
admin/cus-test.el
View file

@ -370,7 +370,9 @@ This function is suitable for batch mode. E.g., invoke
in the Emacs source directory.
Normally only tests options belonging to files in loaddefs.el.
If optional argument ALL is non-nil, test all files with defcustoms."
If optional argument ALL is non-nil, test all files with defcustoms.
Returns a list of variables with suspicious types."
(interactive)
(and noninteractive
command-line-args-left
@ -382,9 +384,12 @@ If optional argument ALL is non-nil, test all files with defcustoms."
(message "Running %s" 'cus-test-apropos)
(cus-test-apropos "")
(if (not cus-test-errors)
(message "No problems found")
(progn
(message "No problems found")
nil)
(message "The following options might have problems:")
(cus-test-message cus-test-errors)))
(cus-test-message cus-test-errors)
cus-test-errors))
(defun cus-test-deps ()
"Run a verbose version of `custom-load-symbol' on all atoms.

2
build-aux/update-subdirs
View file

@ -26,7 +26,7 @@ for file in *; do
*.elc | *.el | term | RCS | CVS | Old | . | .. | =* | *~ | *.orig | *.rej)
;;
*)
if [ -d $file ]; then
if [ -d "$file" ]; then
if [ "$file" = "obsolete" ]; then
subdirs="$subdirs \"$file\""
else

5
doc/emacs/basic.texi
View file

@ -311,13 +311,16 @@ Position 1 is the beginning of the buffer.
@kindex M-g M-g
@kindex M-g g
@findex goto-line
@findex goto-line-relative
Read a number @var{n} and move point to the beginning of line number
@var{n} (@code{goto-line}). Line 1 is the beginning of the buffer. If
point is on or just after a number in the buffer, that is the default
for @var{n}. Just type @key{RET} in the minibuffer to use it. You can
also specify @var{n} by giving @kbd{M-g M-g} a numeric prefix argument.
@xref{Select Buffer}, for the behavior of @kbd{M-g M-g} when you give it
a plain prefix argument.
a plain prefix argument. Alternatively, you can use the command
@code{goto-line-relative} to move point to the line relative to the
accessible portion of the narrowed buffer.
@item M-g @key{TAB}
@kindex M-g TAB

7
doc/emacs/display.texi
View file

@ -1452,9 +1452,10 @@ the displayed column number to count from one, you may set
@cindex narrowing, and line number display
If you have narrowed the buffer (@pxref{Narrowing}), the displayed
line number is relative to the accessible portion of the buffer.
Thus, it isn't suitable as an argument to @code{goto-line}. (Use
@code{what-line} command to see the line number relative to the whole
file.)
Thus, it isn't suitable as an argument to @code{goto-line}. (The
command @code{what-line} shows the line number relative to the whole
file.) You can use @code{goto-line-relative} command to move point to
the line relative to the accessible portion of the narrowed buffer.
@vindex line-number-display-limit
If the buffer is very large (larger than the value of

24
doc/emacs/frames.texi
View file

@ -214,22 +214,24 @@ speed is linked to how fast you move the wheel. This mode also
supports increasing or decreasing the height of the default face, by
default bound to scrolling with the @key{Ctrl} modifier.
Emacs also supports horizontal scrolling with the @key{Shift} modifier.
@vindex mouse-wheel-tilt-scroll
@vindex mouse-wheel-flip-direction
Emacs can also support horizontal scrolling if your mouse's wheel can
be tilted, or if your touchpad supports it. This feature is off by
default; the variable @code{mouse-wheel-tilt-scroll} turns it on, if
you customize it to a non-@code{nil} value. By default, tilting the
mouse wheel scrolls the window's view horizontally in the direction of
the tilt: e.g., tilting to the right scrolls the window to the right,
so that the text displayed in the window moves horizontally to the
left. If you'd like to reverse the direction of horizontal scrolling,
customize the variable @code{mouse-wheel-flip-direction} to a
non-@code{nil} value.
If your mouse's wheel can be tilted, or if your touchpad supports it,
then you can also enable horizontal scrolling by customizing the
variable @code{mouse-wheel-tilt-scroll} to a non-@code{nil} value.
By default, tilting the mouse wheel scrolls the window's view
horizontally in the direction of the tilt: e.g., tilting to the right
scrolls the window to the right, so that the text displayed in the
window moves horizontally to the left. If you'd like to reverse the
direction of horizontal scrolling, customize the variable
@code{mouse-wheel-flip-direction} to a non-@code{nil} value.
When the mouse pointer is over an image in Image mode, @pxref{Image Mode},
scrolling the mouse wheel with the @key{Ctrl} modifier scales the image
under the mouse pointer.
under the mouse pointer, and scrolling the mouse wheel with the
@key{Shift} modifier scrolls the image horizontally.
@node Word and Line Mouse

3
doc/lispref/processes.texi
View file

@ -1576,7 +1576,8 @@ from previous output.
@defun set-process-buffer process buffer
This function sets the buffer associated with @var{process} to
@var{buffer}. If @var{buffer} is @code{nil}, the process becomes
associated with no buffer.
associated with no buffer; if non-@code{nil}, the process mark will be
set to point to the end of @var{buffer}.
@end defun
@defun get-buffer-process buffer-or-name

10
doc/lispref/strings.texi
View file

@ -656,6 +656,16 @@ optional argument @var{ignore-case} is non-@code{nil}, the comparison
ignores case differences.
@end defun
@defun string-search needle haystack &optional start-pos
Return the position of the first instance of @var{needle} in
@var{haystack}, both of which are strings. If @var{start-pos} is
non-@code{nil}, start searching from that position in @var{needle}.
Return @code{nil} if no match was found.
This function only considers the characters in the strings when doing
the comparison; text properties are ignored. Matching is always
case-sensitive.
@end defun
@defun compare-strings string1 start1 end1 string2 start2 end2 &optional ignore-case
This function compares a specified part of @var{string1} with a
specified part of @var{string2}. The specified part of @var{string1}

78
doc/misc/tramp.texi
View file

@ -1622,7 +1622,7 @@ support this command.
@subsection Tunneling with ssh
With ssh, you could use the @code{ProxyCommand} entry in
With @command{ssh}, you could use the @option{ProxyCommand} entry in
@file{~/.ssh/config}:
@example
@ -1802,8 +1802,8 @@ in such files, it can return host names only.
@item @code{tramp-parse-sconfig}
@findex tramp-parse-sconfig
This function returns the host nicknames defined by @code{Host} entries
in @file{~/.ssh/config} style files.
This function returns the host nicknames defined by @option{Host}
entries in @file{~/.ssh/config} style files.
@item @code{tramp-parse-shostkeys}
@findex tramp-parse-shostkeys
@ -2281,10 +2281,10 @@ example below:
@end lisp
@vindex password-word-equivalents
This variable is, by default, initialised from
This user option is, by default, initialised from
@code{password-word-equivalents} when @value{tramp} is loaded, and it
is usually more convenient to add new passphrases to that variable
instead of altering this variable.
is usually more convenient to add new passphrases to that user option
instead of altering this user option.
Similar localization may be necessary for handling wrong password
prompts, for which @value{tramp} uses @code{tramp-wrong-passwd-regexp}.
@ -2725,7 +2725,7 @@ corresponding password; otherwise there is no way to decrypt your
encrypted files.
@defopt tramp-crypt-save-encfs-config-remote
If this user option is non-nil (the default), the @option{encfs}
If this user option is non-@code{nil} (the default), the @option{encfs}
configuration file @file{.encfs6.xml} is also kept in the encrypted
remote directory. It depends on you, whether you regard the password
protection of this file as sufficient. The advantage would be, that
@ -3186,7 +3186,7 @@ or a string describing the signal, when the process has been
interrupted. Since it cannot be determined reliably whether a remote
process has been interrupted, @code{process-file} returns always the
exit code. When the user option
@code{process-file-return-signal-string} is non-nil,
@code{process-file-return-signal-string} is non-@code{nil},
@code{process-file} regards all exit codes greater than 128 as an
indication that the process has been interrupted, and returns a
respective string.
@ -3317,8 +3317,8 @@ whatever reason, then replace @code{(getenv "DISPLAY")} with a
hard-coded, fixed name. Note that using @code{:0} for X11 display name
here will not work as expected.
An alternate approach is specify @code{ForwardX11 yes} or
@code{ForwardX11Trusted yes} in @file{~/.ssh/config} on the local
An alternate approach is specify @option{ForwardX11 yes} or
@option{ForwardX11Trusted yes} in @file{~/.ssh/config} on the local
host.
@ -3392,22 +3392,22 @@ continuous output.
@vindex shell-file-name
@vindex shell-command-switch
@code{shell-command} uses the variables @code{shell-file-name} and
@code{shell-command-switch} in order to determine which shell to run.
For remote hosts, their default values are @file{/bin/sh} and
@option{-c}, respectively (except for the @option{adb} method, which
uses @file{/system/bin/sh}). Like the variables in the previous
section, these variables can be changed via connection-local
variables.
@code{shell-command} uses the user option @code{shell-file-name} and
the variable @code{shell-command-switch} in order to determine which
shell to run. For remote hosts, their default values are
@file{/bin/sh} and @option{-c}, respectively (except for the
@option{adb} method, which uses @file{/system/bin/sh}). Like the
variables in the previous section, these variables can be changed via
connection-local variables.
@vindex async-shell-command-width
@vindex COLUMNS@r{, environment variable}
If Emacs supports the variable @code{async-shell-command-width} (since
@w{Emacs 27}), @value{tramp} cares about its value for asynchronous
shell commands. It specifies the number of display columns for
command output. For synchronous shell commands, a similar effect can
be achieved by adding the environment variable @env{COLUMNS} to
@code{tramp-remote-process-environment}.
If Emacs supports the user option @code{async-shell-command-width}
(since @w{Emacs 27}), @value{tramp} cares about its value for
asynchronous shell commands. It specifies the number of display
columns for command output. For synchronous shell commands, a similar
effect can be achieved by adding the environment variable
@env{COLUMNS} to @code{tramp-remote-process-environment}.
@subsection Running @code{eshell} on a remote host
@ -3583,7 +3583,7 @@ It works only for connection methods defined in @file{tramp-sh.el} and
It does not support interactive user authentication. With
@option{ssh}-based methods, this can be avoided by using a password
agent like @command{ssh-agent}, using public key authentication, or
using @code{ControlMaster} options.
using @option{ControlMaster} options.
@item
It cannot be killed via @code{interrupt-process}.
@ -3606,7 +3606,7 @@ In order to gain even more performance, it is recommended to bind
@code{tramp-verbose} to 0 when running @code{make-process} or
@code{start-file-process}. Furthermore, you might set
@code{tramp-use-ssh-controlmaster-options} to @code{nil} in order to
bypass @value{tramp}'s handling of the @code{ControlMaster} options,
bypass @value{tramp}'s handling of the @option{ControlMaster} options,
and use your own settings in @file{~/.ssh/config}.
@ -3681,8 +3681,8 @@ On all buffers, which have a @code{buffer-file-name} matching
prompted for modification in the minibuffer. The buffers are marked
modified, and must be saved explicitly.
If user option @code{tramp-confirm-rename-file-names} is nil, changing
the file name happens without confirmation. This requires a
If user option @code{tramp-confirm-rename-file-names} is @code{nil},
changing the file name happens without confirmation. This requires a
matching entry in @code{tramp-default-rename-alist}.
Remote buffers related to the remote connection identified by
@ -3721,8 +3721,8 @@ Tramp infers by default, such as @samp{@trampfn{method,user@@host,}}).
name of @code{source} when calling @code{tramp-rename-files}.
@code{source} could also be a Lisp form, which will be evaluated. The
result must be a string or nil, which is interpreted as a regular
expression which always matches.
result must be a string or @code{nil}, which is interpreted as a
regular expression which always matches.
Example entries:
@ -4302,17 +4302,17 @@ Host *
@item
@value{tramp} does not use default @command{ssh} @code{ControlPath}
@value{tramp} does not use default @command{ssh} @option{ControlPath}
@value{tramp} overwrites @code{ControlPath} settings when initiating
@value{tramp} overwrites @option{ControlPath} settings when initiating
@command{ssh} sessions. @value{tramp} does this to fend off a stall
if a master session opened outside the Emacs session is no longer
open. That is why @value{tramp} prompts for the password again even
if there is an @command{ssh} already open.
@vindex tramp-ssh-controlmaster-options
Some @command{ssh} versions support a @code{ControlPersist} option,
which allows you to set the @code{ControlPath} provided the variable
Some @command{ssh} versions support a @option{ControlPersist} option,
which allows you to set the @option{ControlPath} provided the variable
@code{tramp-ssh-controlmaster-options} is customized as follows:
@lisp
@ -4337,12 +4337,16 @@ this @code{nil} setting:
(customize-set-variable 'tramp-use-ssh-controlmaster-options nil)
@end lisp
This shall also be set to @code{nil} if you use the
@option{ProxyCommand} or @option{ProxyJump} options in your
@command{ssh} configuration.
@item
On multi-hop connections, @value{tramp} does not use @command{ssh}
@code{ControlMaster}
@option{ControlMaster}
In order to use the @code{ControlMaster} option, @value{tramp} must
In order to use the @option{ControlMaster} option, @value{tramp} must
check whether the @command{ssh} client supports this option. This is
only possible on the local host, for the first hop. @value{tramp}
does not use this option on proxy hosts.
@ -4365,7 +4369,7 @@ supported on your proxy host.
@item
@value{tramp} does not connect to Samba or MS Windows hosts running
SMB1 connection protocol.
SMB1 connection protocol
@vindex tramp-smb-options
Recent versions of @command{smbclient} do not support old connection
@ -4592,7 +4596,7 @@ completion can further reduce key strokes: @kbd{C-x C-f
@value{prefix}ssh@value{postfixhop}x @key{TAB}}.
@item
Use environment variables to expand long strings
Use environment variables to expand long strings:
For long file names, set up environment variables that are expanded in
the minibuffer. Environment variables are set either outside Emacs or

66
etc/NEWS
View file

@ -134,6 +134,13 @@ the mouse cursor is on the scroll bars, fringes, margins, header line,
and mode line. ('mwheel-mode' is enabled by default on most graphical
displays.)
---
** Mouse wheel scrolling now defaults to one line at a time.
+++
** Mouse wheel scrolling with Shift modifier now scrolls horizontally.
This works in text buffers and over images.
---
** The default value of 'frame-title-format' and 'icon-title-format' has changed.
These variables are used to display the title bar of visible frames
@ -171,6 +178,13 @@ Each buffer will keep a separate history of line numbers used with
'goto-line'. This should help making faster the process of finding
line numbers that were previously jumped to.
+++
** New command 'goto-line-relative' to use in a narrowed buffer.
It moves point to the line relative to the accessible portion of the
narrowed buffer. 'M-g M-g' in Info is rebound to this command.
When 'widen-automatically' is non-nil, 'goto-line' widens the narrowed
buffer to be able to move point to the inaccessible portion.
+++
** When 'suggest-key-bindings' is non-nil, the completion list of 'M-x'
shows equivalent key bindings for all commands that have them.
@ -204,6 +218,12 @@ trying to be non-destructive.
* Changes in Specialized Modes and Packages in Emacs 28.1
** Ruby mode
*** 'ruby-use-smie' is declared obsolete.
SMIE is now always enabled and 'ruby-use-smie' only controls whether
indentation is done using SMIE or with the old ad-hoc code.
---
** Specific warnings can now be disabled from the warning buffer.
When a warning is displayed to the user, the resulting buffer now has
@ -468,7 +488,7 @@ changed so that all the recipients are put in the "To" header in these
instances.
+++
*** New function to start Emacs in Message mode to send an email.
*** New command to start Emacs in Message mode to send an email.
Emacs can be defined as a handler for the "x-scheme-handler/mailto"
MIME type with the following command: "emacs -f message-mailto %u".
An "emacs-mail.desktop" file has been included, suitable for
@ -551,7 +571,7 @@ definition.
*** New user option 'eldoc-display-truncation-message'.
If non-nil (the default), eldoc will display a message saying
something like "(Documentation truncated. Use `M-x eldoc-doc-buffer'
to see rest" when a message has been truncated. If nil, truncated
to see rest)" when a message has been truncated. If nil, truncated
messages will be marked with just "..." at the end.
+++
@ -633,7 +653,7 @@ equivalent to '(map (:sym sym))'.
** Package
+++
*** New functions to filter the package list.
*** New commands to filter the package list.
The filter command key bindings are as follows:
key binding
@ -689,6 +709,9 @@ case-insensitive matching of messages when the old behavior is
required, but the recommended solution is to use a correctly matching
regexp instead.
---
*** Messages from ShellCheck are now recognized.
---
*** Messages from Visual Studio that mention column numbers are now recognized.
@ -790,12 +813,12 @@ Formerly, one could do the same by setting
'browse-url-browser-function' to such an alist. This usage is still
supported but deprecated.
*** Categorization of browsing functions in internal vs. external.
All standard browsing functions such as 'browse-url-firefox',
*** Categorization of browsing commands in internal vs. external.
All standard browsing commands such as 'browse-url-firefox',
'browse-url-mail', or 'eww' have been categorized into internal (URL
is browsed in Emacs) or external (an external application is spawned
with the URL). This is done by adding a 'browse-url-browser-kind'
symbol property to the browsing functions. With a new command
symbol property to the browsing commands. With a new command
'browse-url-with-browser-kind', an URL can explicitly be browsed with
either an internal or external browser.
@ -874,7 +897,7 @@ This can be used to download data via an external command. If nil
(the default), then 'url-retrieve' is used.
+++
*** New Emacs command line convenience function.
*** New Emacs command line convenience command.
The 'eww-browse' command has been added, which allows you to register
Emacs as a MIME handler for "text/x-uri", and will call 'eww' on the
supplied URL. Usage example: "emacs -f eww-browse https://gnu.org".
@ -1042,11 +1065,18 @@ window after starting). This variable defaults to nil.
** Miscellaneous
---
*** 'zap-up-to-char' now uses 'read-char-from-minibuffer'.
This allows navigating through the history of characters that have
been input. This is mostly useful for characters that have complex
input methods where inputting the character again may involve many
keystrokes.
+++
*** Interactive regular expression search now uses faces for sub-groups.
E.g., 'C-M-s foo-\([0-9]+\)' will now use the 'isearch-group-1' face
on the part of the regexp that matches the sub-expression "[0-9]+".
This is controlled by the 'search-highlight-submatches' variable.
This is controlled by the 'search-highlight-submatches' user option.
---
*** New user option 'reveal-auto-hide'.
@ -1148,7 +1178,7 @@ to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list.
** xwidget-webkit mode
*** New xwidget functions.
*** New xwidget commands.
'xwidget-webkit-uri' (return the current URL), 'xwidget-webkit-title'
(return the current title), and 'xwidget-webkit-goto-history' (goto a
point in history).
@ -1190,7 +1220,7 @@ Clicking the dictionary name changes the current dictionary.
several time zones. It is hoped that the new names are more
discoverable.
The following functions have been renamed:
The following commands have been renamed:
'display-time-world' to 'world-clock'
'display-time-world-mode' to 'world-clock-mode'
@ -1225,7 +1255,13 @@ type symbols. Both functions propagate D-Bus errors.
messages, contain the error name of that message now.
---
*** D-Bus events keep the type information of their arguments.
*** D-Bus messages can be monitored with new function 'dbus-register-monitor'.
---
*** D-Bus events have changed their internal structure.
They carry now the destination and the error-name of an event. They
also keep the type information of their arguments. Use the
'dbus-event-*' accessor functions.
** CPerl Mode
@ -1267,6 +1303,9 @@ directory instead of the default directory.
* Incompatible Lisp Changes in Emacs 28.1
** 'set-process-buffer' now updates the process mark.
The mark will be set to point to the end of the new buffer.
+++
** Some properties from completion tables are now preserved.
If 'minibuffer-allow-text-properties' is non-nil, doing completion
@ -1394,6 +1433,11 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el.
* Lisp Changes in Emacs 28.1
+++
*** New function 'string-search'.
This function takes two string parameters and returns the position of
the first instance of the first string in the latter.
+++
*** New function 'process-lines-ignore-status'.
This is like 'process-lines', but does not signal an error if the

7
etc/TODO
View file

@ -924,17 +924,14 @@ features of that interface could be implemented NS.
**** Smooth scrolling -- maybe not a good idea
Today, by default, scrolling with a trackpad makes the text move in
steps of five lines. (Scrolling with SHIFT scrolls one line at a time.)
steps of one line. (Scrolling with SHIFT scrolls horizontally.)
The "mac" port provides smooth, pixel-based, scrolling. This is a very
popular features. However, there are drawbacks to this method: what
popular feature. However, there are drawbacks to this method: what
happens if only a fraction of a line is visible at the top of a
window, is the partially visible text considered part of the window or
not? (Technically, what should 'window-start' return.)
An alternative would be to make one-line scrolling the default on NS
(or in Emacs in general).
Note: This feature might not be allowed to be implemented until also
implemented in Emacs for a free system.

8
etc/compilation.txt
View file

@ -536,6 +536,14 @@ cc-1070 cc: WARNING File = linkl.c, Line = 38
cf90-113 f90comp: ERROR NSE, File = Hoved.f90, Line = 16, Column = 3
* ShellCheck
In autogen.sh line 38:
autoconf_min=`sed -n 's/^ *AC_PREREQ(\([0-9\.]*\)).*/\1/p' configure.ac`
^----------^ SC2034: autoconf_min appears unused. Verify use (or export if used externally).
^-- SC2006: Use $(...) notation instead of legacy backticked `...`.
* Sun Ada (VADS, Solaris)
symbol: sun-ada

85
lisp/allout-widgets.el
View file

@ -209,21 +209,6 @@ See `allout-widgets-mode' for allout widgets mode features."
:group 'allout-widgets)
(make-obsolete-variable 'allout-widgets-item-image-properties-xemacs nil "28.1")
;;;_ . Developer
;;;_ = allout-widgets-run-unit-tests-on-load
(defcustom allout-widgets-run-unit-tests-on-load nil
"When non-nil, unit tests will be run at end of loading allout-widgets.
Generally, allout widgets code developers are the only ones who'll want to
set this.
\(If set, this makes it an even better practice to exercise changes by
doing byte-compilation with a repeat count, so the file is loaded after
compilation.)
See `allout-widgets-run-unit-tests' to see what's run."
:version "24.1"
:type 'boolean
:group 'allout-widgets-developer)
;;;_ = allout-widgets-time-decoration-activity
(defcustom allout-widgets-time-decoration-activity nil
"Retain timing info of the last cooperative redecoration.
@ -1353,64 +1338,6 @@ FROM and TO must be in increasing order, as must be the pairs in RANGES."
(setq new-ranges (nreverse new-ranges))
(if ranges (setq new-ranges (append new-ranges ranges)))
(list (if included-from t) new-ranges)))
;;;_ > allout-test-range-overlaps ()
(defun allout-test-range-overlaps ()
"`allout-range-overlaps' unit tests."
(let* (ranges
got
(try (lambda (from to)
(setq got (allout-range-overlaps from to ranges))
(setq ranges (cadr got))
got)))
;; ;; biggie:
;; (setq ranges nil)
;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall
;; ;; ~ 13 seconds for doing repeated funcall
;; (message "time-trial: %s, resulting size %s"
;; (time-trial
;; '(let ((size 10000)
;; doing)
;; (dotimes (count size)
;; (setq doing (random size))
;; (funcall try doing (+ doing (random 5)))
;; ;;(list doing (+ doing (random 5)))
;; )))
;; (length ranges))
;; (sit-for 2)
;; fresh:
(setq ranges nil)
(cl-assert (equal (funcall try 3 5) '(nil ((3 5)))))
;; add range at end:
(cl-assert (equal (funcall try 10 12) '(nil ((3 5) (10 12)))))
;; add range at beginning:
(cl-assert (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12)))))
;; insert range somewhere in the middle:
(cl-assert (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12)))))
;; consolidate some:
(cl-assert (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12)))))
;; add more:
(cl-assert (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17)))))
;; add more:
(cl-assert (equal (funcall try 20 22)
'(nil ((1 2) (3 9) (10 12) (15 17) (20 22)))))
;; encompass more:
(cl-assert (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22)))))
;; encompass all:
(cl-assert (equal (funcall try 2 25) '(t ((1 25)))))
;; fresh slate:
(setq ranges nil)
(cl-assert (equal (funcall try 20 25) '(nil ((20 25)))))
(cl-assert (equal (funcall try 30 35) '(nil ((20 25) (30 35)))))
(cl-assert (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35)))))
(cl-assert (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35)))))
(cl-assert (equal (funcall try 10 30) '(t ((10 35)))))
(cl-assert (equal (funcall try 5 6) '(nil ((5 6) (10 35)))))
(cl-assert (equal (funcall try 2 100) '(t ((2 100)))))
(setq ranges nil)
))
;;;_ > allout-widgetize-buffer (&optional doing)
(defun allout-widgetize-buffer (&optional doing)
"EXAMPLE FUNCTION. Widgetize items in buffer using allout-chart-subtree.
@ -2380,18 +2307,6 @@ The elements of LIST are not copied, just the list structure itself."
(overlays-in start end)))))
(length button-overlays)))
;;;_ : Run unit tests:
(defun allout-widgets-run-unit-tests ()
(message "Running allout-widget tests...")
(allout-test-range-overlaps)
(message "Running allout-widget tests... Done.")
(sit-for .5))
(when allout-widgets-run-unit-tests-on-load
(allout-widgets-run-unit-tests))
;;;_ : provide
(provide 'allout-widgets)

146
lisp/allout.el
View file

@ -77,7 +77,6 @@
;;;_* Dependency loads
(require 'overlay)
(eval-when-compile (require 'cl-lib))
;;;_* USER CUSTOMIZATION VARIABLES:
@ -840,20 +839,6 @@ for restoring when all encryptions are established.")
(defgroup allout-developer nil
"Allout settings developers care about, including topic encryption and more."
:group 'allout)
;;;_ = allout-run-unit-tests-on-load
(defcustom allout-run-unit-tests-on-load nil
"When non-nil, unit tests will be run at end of loading the allout module.
Generally, allout code developers are the only ones who'll want to set this.
\(If set, this makes it an even better practice to exercise changes by
doing byte-compilation with a repeat count, so the file is loaded after
compilation.)
See `allout-run-unit-tests' to see what's run."
:type 'boolean
:group 'allout-developer)
;;;_ + Miscellaneous customization
;;;_ = allout-enable-file-variable-adjustment
@ -6518,136 +6503,7 @@ If BEG is bigger than END we return 0."
(isearch-repeat 'forward)
(isearch-mode t)))
;;;_ #11 Unit tests -- this should be last item before "Provide"
;;;_ > allout-run-unit-tests ()
(defun allout-run-unit-tests ()
"Run the various allout unit tests."
(message "Running allout tests...")
(allout-test-resumptions)
(message "Running allout tests... Done.")
(sit-for .5))
;;;_ : test resumptions:
;;;_ > allout-tests-obliterate-variable (name)
(defun allout-tests-obliterate-variable (name)
"Completely unbind variable with NAME."
(if (local-variable-p name (current-buffer)) (kill-local-variable name))
(while (boundp name) (makunbound name)))
;;;_ > allout-test-resumptions ()
(defvar allout-tests-globally-unbound nil
"Fodder for allout resumptions tests -- defvar just for byte compiler.")
(defvar allout-tests-globally-true nil
"Fodder for allout resumptions tests -- defvar just for byte compiler.")
(defvar allout-tests-locally-true nil
"Fodder for allout resumptions tests -- defvar just for byte compiler.")
(defun allout-test-resumptions ()
;; FIXME: Use ERT.
"Exercise allout resumptions."
;; for each resumption case, we also test that the right local/global
;; scopes are affected during resumption effects:
;; ensure that previously unbound variables return to the unbound state.
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-add-resumptions '(allout-tests-globally-unbound t))
(cl-assert (not (default-boundp 'allout-tests-globally-unbound)))
(cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
(cl-assert (boundp 'allout-tests-globally-unbound))
(cl-assert (equal allout-tests-globally-unbound t))
(allout-do-resumptions)
(cl-assert (not (local-variable-p 'allout-tests-globally-unbound
(current-buffer))))
(cl-assert (not (boundp 'allout-tests-globally-unbound))))
;; ensure that variable with prior global value is resumed
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-globally-true)
(setq allout-tests-globally-true t)
(allout-add-resumptions '(allout-tests-globally-true nil))
(cl-assert (equal (default-value 'allout-tests-globally-true) t))
(cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer)))
(cl-assert (equal allout-tests-globally-true nil))
(allout-do-resumptions)
(cl-assert (not (local-variable-p 'allout-tests-globally-true
(current-buffer))))
(cl-assert (boundp 'allout-tests-globally-true))
(cl-assert (equal allout-tests-globally-true t)))
;; ensure that prior local value is resumed
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-locally-true)
(set (make-local-variable 'allout-tests-locally-true) t)
(cl-assert (not (default-boundp 'allout-tests-locally-true))
nil (concat "Test setup mistake -- variable supposed to"
" not have global binding, but it does."))
(cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))
nil (concat "Test setup mistake -- variable supposed to have"
" local binding, but it lacks one."))
(allout-add-resumptions '(allout-tests-locally-true nil))
(cl-assert (not (default-boundp 'allout-tests-locally-true)))
(cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
(cl-assert (equal allout-tests-locally-true nil))
(allout-do-resumptions)
(cl-assert (boundp 'allout-tests-locally-true))
(cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
(cl-assert (equal allout-tests-locally-true t))
(cl-assert (not (default-boundp 'allout-tests-locally-true))))
;; ensure that last of multiple resumptions holds, for various scopes.
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-tests-obliterate-variable 'allout-tests-globally-true)
(setq allout-tests-globally-true t)
(allout-tests-obliterate-variable 'allout-tests-locally-true)
(set (make-local-variable 'allout-tests-locally-true) t)
(allout-add-resumptions '(allout-tests-globally-unbound t)
'(allout-tests-globally-true nil)
'(allout-tests-locally-true nil))
(allout-add-resumptions '(allout-tests-globally-unbound 2)
'(allout-tests-globally-true 3)
'(allout-tests-locally-true 4))
;; reestablish many of the basic conditions are maintained after re-add:
(cl-assert (not (default-boundp 'allout-tests-globally-unbound)))
(cl-assert (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
(cl-assert (equal allout-tests-globally-unbound 2))
(cl-assert (default-boundp 'allout-tests-globally-true))
(cl-assert (local-variable-p 'allout-tests-globally-true (current-buffer)))
(cl-assert (equal allout-tests-globally-true 3))
(cl-assert (not (default-boundp 'allout-tests-locally-true)))
(cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
(cl-assert (equal allout-tests-locally-true 4))
(allout-do-resumptions)
(cl-assert (not (local-variable-p 'allout-tests-globally-unbound
(current-buffer))))
(cl-assert (not (boundp 'allout-tests-globally-unbound)))
(cl-assert (not (local-variable-p 'allout-tests-globally-true
(current-buffer))))
(cl-assert (boundp 'allout-tests-globally-true))
(cl-assert (equal allout-tests-globally-true t))
(cl-assert (boundp 'allout-tests-locally-true))
(cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
(cl-assert (equal allout-tests-locally-true t))
(cl-assert (not (default-boundp 'allout-tests-locally-true))))
;; ensure that deliberately unbinding registered variables doesn't foul things
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-tests-obliterate-variable 'allout-tests-globally-true)
(setq allout-tests-globally-true t)
(allout-tests-obliterate-variable 'allout-tests-locally-true)
(set (make-local-variable 'allout-tests-locally-true) t)
(allout-add-resumptions '(allout-tests-globally-unbound t)
'(allout-tests-globally-true nil)
'(allout-tests-locally-true nil))
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-tests-obliterate-variable 'allout-tests-globally-true)
(allout-tests-obliterate-variable 'allout-tests-locally-true)
(allout-do-resumptions))
)
;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
(when allout-run-unit-tests-on-load
(allout-run-unit-tests))
;;;_ #12 Provide
;;;_ #11 Provide
(provide 'allout)
;;;_* Local emacs vars.

14
lisp/apropos.el
View file

@ -863,14 +863,12 @@ Optional arg BUFFER (default: current buffer) is the buffer to check."
(setq apropos-accumulator (cons (list symb (apropos-score-str var) nil var)
apropos-accumulator))))))
(let ((apropos-multi-type nil))
(if (> emacs-major-version 20)
(apropos-print
nil "\n----------------\n"
(format "Buffer `%s' has the following local variables\nmatching %s`%s':"
(buffer-name buffer)
(if (consp pattern) "keywords " "")
pattern))
(apropos-print nil "\n----------------\n"))))
(apropos-print
nil "\n----------------\n"
(format "Buffer `%s' has the following local variables\nmatching %s`%s':"
(buffer-name buffer)
(if (consp pattern) "keywords " "")
pattern))))
;;;###autoload
(defun apropos-documentation (pattern &optional do-all)

10
lisp/cedet/ede/detect.el
View file

@ -35,16 +35,6 @@
(require 'ede/auto) ;; Autoload settings.
(when (or (<= emacs-major-version 23)
;; predicate as name added in Emacs 24.2
(and (= emacs-major-version 24)
(< emacs-minor-version 2)))
(message "Loading CEDET fallback autoload library.")
(require 'cedet/dominate
(expand-file-name "../../../etc/fallback-libraries/dominate.el"
(file-name-directory load-file-name))))
;;; BASIC PROJECT SCAN
;;
(defun ede--detect-stop-scan-p (dir)

15
lisp/cedet/ede/proj-elisp.el
View file

@ -153,18 +153,9 @@ Bonus: Return a cons cell: (COMPILED . UPTODATE)."
(let* ((fsrc (expand-file-name src dir))
(elc (concat (file-name-sans-extension fsrc) ".elc")))
(with-no-warnings
(if (< emacs-major-version 24)
;; Does not have `byte-recompile-file'
(if (or (not (file-exists-p elc))
(file-newer-than-file-p fsrc elc))
(progn
(setq comp (1+ comp))
(byte-compile-file fsrc))
(setq utd (1+ utd)))
(if (eq (byte-recompile-file fsrc nil 0) t)
(setq comp (1+ comp))
(setq utd (1+ utd)))))))
(if (eq (byte-recompile-file fsrc nil 0) t)
(setq comp (1+ comp))
(setq utd (1+ utd))))))
(oref obj source))
(message "All Emacs Lisp sources are up to date in %s" (eieio-object-name obj))

3
lisp/cedet/semantic/bovine/grammar.el
View file

@ -143,8 +143,7 @@ expanded from elsewhere."
form (cdr form))
;; Hack for dealing with new reading of unquotes outside of
;; backquote (introduced in 2010-12-06T16:37:26Z!monnier@iro.umontreal.ca).
(when (and (>= emacs-major-version 24)
(listp first)
(when (and (listp first)
(or (equal (car first) '\,)
(equal (car first) '\,@)))
(if (listp (cadr first))

17
lisp/cedet/semantic/ede-grammar.el
View file

@ -142,19 +142,10 @@ Lays claim to all -by.el, and -wy.el files."
(match-string 1 package)))
(src (ede-expand-filename obj fname))
(csrc (concat (file-name-sans-extension src) ".elc")))
(if (< emacs-major-version 24)
;; Does not have `byte-recompile-file'
(if (or (not (file-exists-p csrc))
(file-newer-than-file-p src csrc))
(progn
(setq comp (1+ comp))
(byte-compile-file src))
(setq utd (1+ utd)))
;; Emacs 24 and newer
(with-no-warnings
(if (eq (byte-recompile-file src nil 0) t)
(setq comp (1+ comp))
(setq utd (1+ utd))))))))
(with-no-warnings
(if (eq (byte-recompile-file src nil 0) t)
(setq comp (1+ comp))
(setq utd (1+ utd)))))))
(oref obj source))
(message "All Semantic Grammar sources are up to date in %s" (eieio-object-name obj))
(cons comp utd)))

3
lisp/cedet/semantic/lex.el
View file

@ -1701,9 +1701,6 @@ If there is no error, then the last value of FORMS is returned."
`(let* ((semantic-lex-unterminated-syntax-end-function
(lambda (,syntax ,start ,end)
(throw ',symbol ,syntax)))
;; Delete the below when semantic-flex is fully retired.
(semantic-flex-unterminated-syntax-end-function
semantic-lex-unterminated-syntax-end-function)
(,ret (catch ',symbol
(save-excursion
,@forms

121
lisp/completion.el
View file

@ -399,13 +399,6 @@ Used to decide whether to save completions.")
:up)
(t :neither))))))
;; Tests -
;; (cmpl-string-case-type "123ABCDEF456") --> :up
;; (cmpl-string-case-type "123abcdef456") --> :down
;; (cmpl-string-case-type "123aBcDeF456") --> :mixed
;; (cmpl-string-case-type "123456") --> :neither
;; (cmpl-string-case-type "Abcde123") --> :capitalized
(defun cmpl-coerce-string-case (string case-type)
(cond ((eq case-type :down) (downcase string))
((eq case-type :up) (upcase string))
@ -424,12 +417,6 @@ Used to decide whether to save completions.")
;; as is
string-to-coerce))))
;; Tests -
;; (cmpl-merge-string-cases "AbCdEf456" "abc") --> AbCdEf456
;; (cmpl-merge-string-cases "abcdef456" "ABC") --> ABCDEF456
;; (cmpl-merge-string-cases "ABCDEF456" "Abc") --> Abcdef456
;; (cmpl-merge-string-cases "ABCDEF456" "abc") --> abcdef456
(defun cmpl-hours-since-origin ()
(floor (time-convert nil 'integer) 3600))
@ -1226,45 +1213,6 @@ String must be longer than `completion-prefix-min-length'."
(set cmpl-db-prefix-symbol nil)))))
(error "Unknown completion `%s'" completion-string))))
;; Tests --
;; - Add and Find -
;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
;; (find-exact-completion "banana") --> ("banana" 0 nil 0)
;; (find-exact-completion "bana") --> nil
;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
;; (add-completion-to-head "banish") --> ("banish" 0 nil 0)
;; (find-exact-completion "banish") --> ("banish" 0 nil 0)
;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
;;
;; - Deleting -
;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
;; (delete-completion "banner")
;; (find-exact-completion "banner") --> nil
;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
;; (delete-completion "banana")
;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banish" ...))
;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
;; (delete-completion "banner")
;; (delete-completion "banish")
;; (find-cmpl-prefix-entry "ban") --> nil
;; (delete-completion "banner") --> error
;;
;; - Tail -
;; (add-completion-to-tail-if-new "banana") --> ("banana" 0 nil 0)
;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
;; (add-completion-to-tail-if-new "banish") --> ("banish" 0 nil 0)
;; (car (find-cmpl-prefix-entry "ban")) -->(("banana" ...) ("banish" ...))
;; (cdr (find-cmpl-prefix-entry "ban")) -->(("banish" ...))
;;
;;---------------------------------------------------------------------------
;; Database Update :: Interface level routines
@ -1361,29 +1309,6 @@ Completions added this way will automatically be saved if
(set-completion-num-uses entry 1)
(setq cmpl-completions-accepted-p t)))))))
;; Tests --
;; - Add and Find -
;; (add-completion "banana" 5 10)
;; (find-exact-completion "banana") --> ("banana" 5 10 0)
;; (add-completion "banana" 6)
;; (find-exact-completion "banana") --> ("banana" 6 10 0)
;; (add-completion "banish")
;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
;;
;; - Accepting -
;; (setq completion-to-accept "banana")
;; (accept-completion)
;; (find-exact-completion "banana") --> ("banana" 7 10)
;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
;; (setq completion-to-accept "banish")
;; (add-completion "banner")
;; (car (find-cmpl-prefix-entry "ban"))
;; --> (("banner" ...) ("banish" 1 ...) ("banana" 7 ...))
;;
;; - Deleting -
;; (kill-completion "banish")
;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banana" ...))
;;---------------------------------------------------------------------------
;; Searching the database
@ -1505,46 +1430,6 @@ If there are no more entries, try cdabbrev and then return only a string."
;; Completely unsuccessful, return nil
))
;; Tests --
;; - Add and Find -
;; (add-completion "banana")
;; (completion-search-reset "ban")
;; (completion-search-next 0) --> "banana"
;;
;; - Discrimination -
;; (add-completion "cumberland")
;; (add-completion "cumberbund")
;; cumbering
;; (completion-search-reset "cumb")
;; (completion-search-peek t) --> "cumberbund"
;; (completion-search-next 0) --> "cumberbund"
;; (completion-search-peek t) --> "cumberland"
;; (completion-search-next 1) --> "cumberland"
;; (completion-search-peek nil) --> nil
;; (completion-search-next 2) --> "cumbering" {cdabbrev}
;; (completion-search-next 3) --> nil or "cumming"{depends on context}
;; (completion-search-next 1) --> "cumberland"
;; (completion-search-peek t) --> "cumbering" {cdabbrev}
;;
;; - Accepting -
;; (completion-search-next 1) --> "cumberland"
;; (setq completion-to-accept "cumberland")
;; (completion-search-reset "foo")
;; (completion-search-reset "cum")
;; (completion-search-next 0) --> "cumberland"
;;
;; - Deleting -
;; (kill-completion "cumberland")
;; cummings
;; (completion-search-reset "cum")
;; (completion-search-next 0) --> "cumberbund"
;; (completion-search-next 1) --> "cummings"
;;
;; - Ignoring Capitalization -
;; (completion-search-reset "CuMb")
;; (completion-search-next 0) --> "cumberbund"
;;-----------------------------------------------
;; COMPLETE
@ -1733,12 +1618,6 @@ Prefix args ::
"\n(\\(\\w*:\\)?def\\(\\w\\|\\s_\\)*\\s +(*"
"A regexp that searches for Lisp definition form.")
;; Tests -
;; (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) -> 8
;; (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) -> 9
;; (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) -> 10
;; (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) -> 9
;; Parses all the definition names from a Lisp mode buffer and adds them to
;; the completion database.
(defun add-completions-from-lisp-buffer ()

4
lisp/dired.el
View file

@ -4062,10 +4062,10 @@ only in the active region if `dired-mark-region' is non-nil."
(if fn (backup-file-name-p fn))))
"backup file")))
(defun dired-change-marks (old new)
(defun dired-change-marks (&optional old new)
"Change all OLD marks to NEW marks.
OLD and NEW are both characters used to mark files."
(declare (advertised-calling-convention '(old new) "28.1"))
(declare (advertised-calling-convention (old new) "28.1"))
(interactive
(let* ((cursor-in-echo-area t)
(old (progn (message "Change (old mark): ") (read-char)))

4
lisp/emacs-lisp/byte-opt.el
View file

@ -1173,7 +1173,8 @@
degrees-to-radians
radians-to-degrees rassq rassoc read-from-string regexp-quote
region-beginning region-end reverse round
sin sqrt string string< string= string-equal string-lessp string-to-char
sin sqrt string string< string= string-equal string-lessp
string-search string-to-char
string-to-number substring
sxhash sxhash-equal sxhash-eq sxhash-eql
symbol-function symbol-name symbol-plist symbol-value string-make-unibyte
@ -1263,6 +1264,7 @@
floor ceiling round truncate
ffloor fceiling fround ftruncate
string= string-equal string< string-lessp
string-search
consp atom listp nlistp propert-list-p
sequencep arrayp vectorp stringp bool-vector-p hash-table-p
null not

4
lisp/emacs-lisp/eldoc.el
View file

@ -510,6 +510,10 @@ Honor most of `eldoc-echo-area-use-multiline-p'."
(> (+ (length single-doc) (length single-doc-sym) 2) width))
single-doc)
((> available 1)
;; The message takes one extra line, so if we don't
;; display that, we have one extra line to use.
(unless eldoc-display-truncation-message
(setq available (1+ available)))
(with-current-buffer (eldoc-doc-buffer)
(cl-loop
initially

171
lisp/emacs-lisp/lisp.el
View file

@ -55,7 +55,7 @@ This affects `insert-parentheses' and `insert-pair'."
"If non-nil, `forward-sexp' delegates to this function.
Should take the same arguments and behave similarly to `forward-sexp'.")
(defun forward-sexp (&optional arg)
(defun forward-sexp (&optional arg interactive)
"Move forward across one balanced expression (sexp).
With ARG, do it that many times. Negative arg -N means move
backward across N balanced expressions. This command assumes
@ -64,23 +64,32 @@ point is not in a string or comment. Calls
If unable to move over a sexp, signal `scan-error' with three
arguments: a message, the start of the obstacle (usually a
parenthesis or list marker of some kind), and end of the
obstacle."
(interactive "^p")
(or arg (setq arg 1))
(if forward-sexp-function
(funcall forward-sexp-function arg)
(goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
(if (< arg 0) (backward-prefix-chars))))
obstacle. If INTERACTIVE is non-nil, as it is interactively,
report errors as appropriate for this kind of usage."
(interactive "^p\nd")
(if interactive
(condition-case _
(forward-sexp arg nil)
(scan-error (user-error (if (> arg 0)
"No next sexp"
"No previous sexp"))))
(or arg (setq arg 1))
(if forward-sexp-function
(funcall forward-sexp-function arg)
(goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
(if (< arg 0) (backward-prefix-chars)))))
(defun backward-sexp (&optional arg)
(defun backward-sexp (&optional arg interactive)
"Move backward across one balanced expression (sexp).
With ARG, do it that many times. Negative arg -N means
move forward across N balanced expressions.
This command assumes point is not in a string or comment.
Uses `forward-sexp' to do the work."
(interactive "^p")
Uses `forward-sexp' to do the work.
If INTERACTIVE is non-nil, as it is interactively,
report errors as appropriate for this kind of usage."
(interactive "^p\nd")
(or arg (setq arg 1))
(forward-sexp (- arg)))
(forward-sexp (- arg) interactive))
(defun mark-sexp (&optional arg allow-extend)
"Set mark ARG sexps from point.
@ -99,50 +108,78 @@ This command assumes point is not in a string or comment."
(set-mark
(save-excursion
(goto-char (mark))
(forward-sexp arg)
(condition-case error
(forward-sexp arg)
(scan-error
(user-error (if (equal (cadr error)
"Containing expression ends prematurely")
"No more sexp to select"
(cadr error)))))
(point))))
(t
(push-mark
(save-excursion
(forward-sexp (prefix-numeric-value arg))
(condition-case error
(forward-sexp (prefix-numeric-value arg))
(scan-error
(user-error (if (equal (cadr error)
"Containing expression ends prematurely")
"No sexp to select"
(cadr error)))))
(point))
nil t))))
(defun forward-list (&optional arg)
(defun forward-list (&optional arg interactive)
"Move forward across one balanced group of parentheses.
This command will also work on other parentheses-like expressions
defined by the current language mode.
With ARG, do it that many times.
Negative arg -N means move backward across N groups of parentheses.
This command assumes point is not in a string or comment."
(interactive "^p")
(or arg (setq arg 1))
(goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))
This command assumes point is not in a string or comment.
If INTERACTIVE is non-nil, as it is interactively,
report errors as appropriate for this kind of usage."
(interactive "^p\nd")
(if interactive
(condition-case _
(forward-list arg nil)
(scan-error (user-error (if (> arg 0)
"No next group"
"No previous group"))))
(or arg (setq arg 1))
(goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))))
(defun backward-list (&optional arg)
(defun backward-list (&optional arg interactive)
"Move backward across one balanced group of parentheses.
This command will also work on other parentheses-like expressions
defined by the current language mode.
With ARG, do it that many times.
Negative arg -N means move forward across N groups of parentheses.
This command assumes point is not in a string or comment."
(interactive "^p")
This command assumes point is not in a string or comment.
If INTERACTIVE is non-nil, as it is interactively,
report errors as appropriate for this kind of usage."
(interactive "^p\nd")
(or arg (setq arg 1))
(forward-list (- arg)))
(forward-list (- arg) interactive))
(defun down-list (&optional arg)
(defun down-list (&optional arg interactive)
"Move forward down one level of parentheses.
This command will also work on other parentheses-like expressions
defined by the current language mode.
With ARG, do this that many times.
A negative argument means move backward but still go down a level.
This command assumes point is not in a string or comment."
(interactive "^p")
(or arg (setq arg 1))
(let ((inc (if (> arg 0) 1 -1)))
(while (/= arg 0)
(goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
(setq arg (- arg inc)))))
This command assumes point is not in a string or comment.
If INTERACTIVE is non-nil, as it is interactively,
report errors as appropriate for this kind of usage."
(interactive "^p\nd")
(if interactive
(condition-case _
(down-list arg nil)
(scan-error (user-error "At bottom level")))
(or arg (setq arg 1))
(let ((inc (if (> arg 0) 1 -1)))
(while (/= arg 0)
(goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
(setq arg (- arg inc))))))
(defun backward-up-list (&optional arg escape-strings no-syntax-crossing)
"Move backward out of one level of parentheses.
@ -229,26 +266,39 @@ point is unspecified."
(or (< inc 0)
(forward-comment 1))
(setf arg (+ arg inc)))
(signal (car err) (cdr err))))))
(if no-syntax-crossing
;; Assume called interactively; don't signal an error.
(user-error "At top level")
(signal (car err) (cdr err)))))))
(setq arg (- arg inc)))))
(defun kill-sexp (&optional arg)
(defun kill-sexp (&optional arg interactive)
"Kill the sexp (balanced expression) following point.
With ARG, kill that many sexps after point.
Negative arg -N means kill N sexps before point.
This command assumes point is not in a string or comment."
(interactive "p")
(let ((opoint (point)))
(forward-sexp (or arg 1))
(kill-region opoint (point))))
This command assumes point is not in a string or comment.
If INTERACTIVE is non-nil, as it is interactively,
report errors as appropriate for this kind of usage."
(interactive "p\nd")
(if interactive
(condition-case _
(kill-sexp arg nil)
(scan-error (user-error (if (> arg 0)
"No next sexp"
"No previous sexp"))))
(let ((opoint (point)))
(forward-sexp (or arg 1))
(kill-region opoint (point)))))
(defun backward-kill-sexp (&optional arg)
(defun backward-kill-sexp (&optional arg interactive)
"Kill the sexp (balanced expression) preceding point.
With ARG, kill that many sexps before point.
Negative arg -N means kill N sexps after point.
This command assumes point is not in a string or comment."
(interactive "p")
(kill-sexp (- (or arg 1))))
This command assumes point is not in a string or comment.
If INTERACTIVE is non-nil, as it is interactively,
report errors as appropriate for this kind of usage."
(interactive "p\nd")
(kill-sexp (- (or arg 1)) interactive))
;; After Zmacs:
(defun kill-backward-up-list (&optional arg)
@ -735,12 +785,37 @@ This command assumes point is not in a string or comment."
(insert-pair arg ?\( ?\)))
(defun delete-pair (&optional arg)
"Delete a pair of characters enclosing ARG sexps following point.
A negative ARG deletes a pair of characters around preceding ARG sexps."
(interactive "p")
(unless arg (setq arg 1))
(save-excursion (forward-sexp arg) (delete-char (if (> arg 0) -1 1)))
(delete-char (if (> arg 0) 1 -1)))
"Delete a pair of characters enclosing ARG sexps that follow point.
A negative ARG deletes a pair around the preceding ARG sexps instead."
(interactive "P")
(if arg
(setq arg (prefix-numeric-value arg))
(setq arg 1))
(if (< arg 0)
(save-excursion
(skip-chars-backward " \t")
(save-excursion
(let ((close-char (char-before)))
(forward-sexp arg)
(unless (member (list (char-after) close-char)
(mapcar (lambda (p)
(if (= (length p) 3) (cdr p) p))
insert-pair-alist))
(error "Not after matching pair"))
(delete-char 1)))
(delete-char -1))
(save-excursion
(skip-chars-forward " \t")
(save-excursion
(let ((open-char (char-after)))
(forward-sexp arg)
(unless (member (list open-char (char-before))
(mapcar (lambda (p)
(if (= (length p) 3) (cdr p) p))
insert-pair-alist))
(error "Not before matching pair"))
(delete-char -1)))
(delete-char 1))))
(defun raise-sexp (&optional arg)
"Raise ARG sexps higher up the tree."

3
lisp/erc/erc-status-sidebar.el
View file

@ -68,7 +68,8 @@
(defcustom erc-status-sidebar-header-line-format nil
"Header line format for the status sidebar."
:type 'string
:type '(choice (const :tag "No header line" nil)
string)
:group 'erc-status-sidebar)
(defcustom erc-status-sidebar-width 15

1
lisp/gnus/gnus-art.el
View file

@ -274,6 +274,7 @@ This can also be a list of the above values."
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
:type '(choice string
(const :tag "None" nil)
(function-item gnus-display-x-face-in-from)
function)
:version "27.1"

4
lisp/gnus/gnus-topic.el
View file

@ -897,9 +897,7 @@ articles in the topic and its subtopics."
(let ((inhibit-read-only t))
(unless gnus-topic-inhibit-change-level
(gnus-group-goto-group (or (car (nth 1 previous)) group))
(when (and gnus-topic-mode
gnus-topic-alist
(not gnus-topic-inhibit-change-level))
(when (and gnus-topic-mode gnus-topic-alist (gnus-current-topic))
;; Remove the group from the topics.
(if (and (< oldlevel gnus-level-zombie)
(>= level gnus-level-zombie))

2
lisp/gnus/gnus-util.el
View file

@ -1177,7 +1177,7 @@ ARG is passed to the first function."
(maphash
(lambda (group active)
(when active
(insert (format "%s %d %d y\n"
(insert (format "%S %d %d y\n"
(if full-names
group
(gnus-group-real-name group))

2
lisp/gnus/message.el
View file

@ -307,7 +307,7 @@ any confusion."
"Command to take a screenshot.
The command should insert a PNG in the current buffer."
:group 'message-various
:type '(list string)
:type '(repeat string)
:version "28.1")
;;; Start of variables adopted from `message-utils.el'.

228
lisp/gnus/nnselect.el
View file

@ -203,11 +203,22 @@ as `(keyfunc member)' and the corresponding element is just
(nnselect-categorize ,articles 'nnselect-article-group
'nnselect-article-id)))
(define-inline numbers-by-group (articles)
(define-inline numbers-by-group (articles &optional type)
(inline-quote
(nnselect-categorize
,articles 'nnselect-article-group 'nnselect-article-number)))
(cond
((eq ,type 'range)
(nnselect-categorize (gnus-uncompress-range ,articles)
'nnselect-article-group 'nnselect-article-number))
((eq ,type 'tuple)
(nnselect-categorize ,articles
#'(lambda (elem)
(nnselect-article-group (car elem)))
#'(lambda (elem)
(cons (nnselect-article-number
(car elem)) (cdr elem)))))
(t
(nnselect-categorize ,articles
'nnselect-article-group 'nnselect-article-number)))))
(defmacro nnselect-add-prefix (group)
"Ensures that the GROUP has an nnselect prefix."
@ -246,7 +257,8 @@ Returns either the retrieved header format 'nov or 'headers.
If this variable is nil, or if the provided function returns nil,
`gnus-retrieve-headers' will be called instead."
:version "28.1" :type '(function) :group 'nnselect)
:version "28.1"
:type '(repeat function))
;; Gnus backend interface functions.
@ -328,11 +340,13 @@ If this variable is nil, or if the provided function returns nil,
(nnheader-parse-nov))
(forward-line 1)))
('headers
(goto-char (point-min))
(while (not (eobp))
(nnselect-add-novitem
(nnheader-parse-head))
(forward-line 1)))
(gnus-run-hooks 'gnus-parse-headers-hook)
(let ((nnmail-extra-headers gnus-extra-headers))
(goto-char (point-min))
(while (not (eobp))
(nnselect-add-novitem
(nnheader-parse-head))
(forward-line 1))))
((pred listp)
(dolist (novitem gnus-headers-retrieved-by)
(nnselect-add-novitem novitem)))
@ -502,15 +516,15 @@ If this variable is nil, or if the provided function returns nil,
(list (car artgroup)
(gnus-compress-sequence (sort (cdr artgroup) '<))
action marks))
(numbers-by-group
(gnus-uncompress-range range)))))
(numbers-by-group range 'range))))
actions)
'car 'cdr)))
(deffoo nnselect-request-update-info (group info &optional _server)
(let* ((group (nnselect-add-prefix group))
(gnus-newsgroup-selection (or gnus-newsgroup-selection
(nnselect-get-artlist group))))
(let* ((group (nnselect-add-prefix group))
(gnus-newsgroup-selection
(or gnus-newsgroup-selection (nnselect-get-artlist group)))
newmarks)
(gnus-info-set-marks info nil)
(setf (gnus-info-read info) nil)
(pcase-dolist (`(,artgroup . ,nartids)
@ -518,30 +532,56 @@ If this variable is nil, or if the provided function returns nil,
(number-sequence 1 (nnselect-artlist-length
gnus-newsgroup-selection))))
(let* ((gnus-newsgroup-active nil)
(artids (cl-sort nartids '< :key 'car))
(artids (cl-sort nartids #'< :key 'car))
(group-info (gnus-get-info artgroup))
(marks (gnus-info-marks group-info))
(unread (gnus-uncompress-sequence
(gnus-range-difference (gnus-active artgroup)
(gnus-info-read group-info)))))
(gnus-atomic-progn
(setf (gnus-info-read info)
(gnus-add-to-range
(gnus-info-read info)
(delq nil
(mapcar
#'(lambda (art)
(unless (memq (cdr art) unread) (car art)))
artids))))
(pcase-dolist (`(,type . ,range) marks)
(setq range (gnus-uncompress-sequence range))
(gnus-add-marked-articles
group type
(delq nil
(mapcar
#'(lambda (art)
(when (memq (cdr art) range)
(car art))) artids)))))))
(setf (gnus-info-read info)
(gnus-add-to-range
(gnus-info-read info)
(delq nil (mapcar
#'(lambda (art)
(unless (memq (cdr art) unread) (car art)))
artids))))
(pcase-dolist (`(,type . ,mark-list) marks)
(let ((mark-type (gnus-article-mark-to-type type)) new)
(when
(setq new
(delq nil
(cond
((eq mark-type 'tuple)
(mapcar
#'(lambda (id)
(let (mark)
(when
(setq mark (assq (cdr id) mark-list))
(cons (car id) (cdr mark)))))
artids))
(t
(setq mark-list
(gnus-uncompress-range mark-list))
(mapcar
#'(lambda (id)
(when (memq (cdr id) mark-list)
(car id))) artids)))))
(let ((previous (alist-get type newmarks)))
(if previous
(nconc previous new)
(push (cons type new) newmarks))))))))
;; Clean up the marks: compress lists;
(pcase-dolist (`(,type . ,mark-list) newmarks)
(let ((mark-type (gnus-article-mark-to-type type)))
(unless (eq mark-type 'tuple)
(setf (alist-get type newmarks)
(gnus-compress-sequence mark-list)))))
;; and ensure an unexist key.
(unless (assq 'unexist newmarks)
(push (cons 'unexist nil) newmarks))
(gnus-info-set-marks info newmarks)
(gnus-set-active group (cons 1 (nnselect-artlist-length
gnus-newsgroup-selection)))))
@ -767,42 +807,61 @@ article came from is also searched."
"Copy mark-lists from GROUP to the originating groups."
(let ((select-unreads (numbers-by-group gnus-newsgroup-unreads))
(select-reads (numbers-by-group
(gnus-uncompress-range
(gnus-info-read (gnus-get-info group)))))
(gnus-info-read (gnus-get-info group)) 'range))
(select-unseen (numbers-by-group gnus-newsgroup-unseen))
(gnus-newsgroup-active nil)
mark-list type-list)
(gnus-newsgroup-active nil) mark-list)
;; collect the set of marked article lists categorized by
;; originating groups
(pcase-dolist (`(,mark . ,type) gnus-article-mark-lists)
(when (setq type-list
(symbol-value (intern (format "gnus-newsgroup-%s" mark))))
(push (cons type
(numbers-by-group
(gnus-uncompress-range type-list))) mark-list)))
(let (type-list)
(when (setq type-list
(symbol-value (intern (format "gnus-newsgroup-%s" mark))))
(push (cons
type
(numbers-by-group type-list (gnus-article-mark-to-type type)))
mark-list))))
;; now work on each originating group one at a time
(pcase-dolist (`(,artgroup . ,artlist)
(numbers-by-group gnus-newsgroup-articles))
(let* ((group-info (gnus-get-info artgroup))
(old-unread (gnus-list-of-unread-articles artgroup))
newmarked)
newmarked delta-marks)
(when group-info
;; iterate over mark lists for this group
(pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists)
(let ((select-type
(sort
(cdr (assoc artgroup (alist-get type mark-list)))
'<)) list)
(setq list
(gnus-uncompress-range
(gnus-add-to-range
(gnus-remove-from-range
(alist-get type (gnus-info-marks group-info))
artlist)
select-type)))
(let ((list (cdr (assoc artgroup (alist-get type mark-list))))
(mark-type (gnus-article-mark-to-type type)))
(when list
;; Get rid of the entries of the articles that have the
;; default score.
(when (and (eq type 'score)
gnus-save-score
list)
;; When the backend can store marks we collect any
;; changes. Unlike a normal group the mark lists only
;; include marks for articles we retrieved.
(when (and (gnus-check-backend-function
'request-set-mark artgroup)
(not (gnus-article-unpropagatable-p type)))
(let* ((old (gnus-list-range-intersection
artlist
(alist-get type (gnus-info-marks group-info))))
(del (gnus-remove-from-range (copy-tree old) list))
(add (gnus-remove-from-range (copy-tree list) old)))
(when add (push (list add 'add (list type)) delta-marks))
(when del
;; Don't delete marks from outside the active range.
;; This shouldn't happen, but is a sanity check.
(setq del (gnus-sorted-range-intersection
(gnus-active artgroup) del))
(push (list del 'del (list type)) delta-marks))))
;; Marked sets are of mark-type 'tuple, 'list, or
;; 'range. We merge the lists with what is already in
;; the original info to get full list of new marks. We
;; do this by removing all the articles we retrieved
;; from the full list, and then add back in the newly
;; marked ones.
(cond
((eq mark-type 'tuple)
;; Get rid of the entries that have the default
;; score.
(when (and list (eq type 'score) gnus-save-score)
(let* ((arts list)
(prev (cons nil list))
(all prev))
@ -812,30 +871,41 @@ article came from is also searched."
(setcdr prev (cdr arts))
(setq prev arts))
(setq arts (cdr arts)))
(setq list (cdr all)))))
(when (or (eq (gnus-article-mark-to-type type) 'list)
(eq (gnus-article-mark-to-type type) 'range))
(setq list (cdr all))))
;; now merge with the original list and sort just to
;; make sure
(setq list
(gnus-compress-sequence (sort list '<) t)))
(sort (map-merge
'list list
(alist-get type (gnus-info-marks group-info)))
(lambda (elt1 elt2)
(< (car elt1) (car elt2))))))
(t
(setq list
(gnus-compress-sequence
(gnus-sorted-union
(gnus-sorted-difference
(gnus-uncompress-sequence
(alist-get type (gnus-info-marks group-info)))
artlist)
(sort list #'<)) t)))
;; When exiting the group, everything that's previously been
;; unseen is now seen.
(when (eq type 'seen)
(setq list (gnus-range-add
list (cdr (assoc artgroup select-unseen)))))
;; When exiting the group, everything that's previously been
;; unseen is now seen.
(when (eq type 'seen)
(setq list (gnus-range-add
list (cdr (assoc artgroup select-unseen))))))
(when (or list (eq type 'unexist))
(push (cons type list) newmarked))))
(push (cons type list) newmarked)))) ;; end of mark-type loop
(when delta-marks
(unless (gnus-check-group artgroup)
(error "Can't open server for %s" artgroup))
(gnus-request-set-mark artgroup delta-marks))
(gnus-atomic-progn
;; Enter these new marks into the info of the group.
(if (nthcdr 3 group-info)
(setcar (nthcdr 3 group-info) newmarked)
;; Add the marks lists to the end of the info.
(when newmarked
(setcdr (nthcdr 2 group-info) (list newmarked))))
(gnus-info-set-marks group-info newmarked)
;; Cut off the end of the info if there's nothing else there.
(let ((i 5))
(while (and (> i 2)

2
lisp/help-fns.el
View file

@ -627,7 +627,7 @@ FILE is the file where FUNCTION was probably defined."
;; of the *packages* in which the function is defined.
(let* ((name (symbol-name symbol))
(re (concat "\\_<" (regexp-quote name) "\\_>"))
(news (directory-files data-directory t "\\`NEWS\\.[1-9]"))
(news (directory-files data-directory t "\\`NEWS\\($\\|\\.\\)"))
(place nil)
(first nil))
(with-temp-buffer

1
lisp/info.el
View file

@ -4053,6 +4053,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
(define-key map "^" 'Info-up)
(define-key map "," 'Info-index-next)
(define-key map "\177" 'Info-scroll-down)
(define-key map [remap goto-line] 'goto-line-relative)
(define-key map [mouse-2] 'Info-mouse-follow-nearest-node)
(define-key map [follow-link] 'mouse-face)
(define-key map [XF86Back] 'Info-history-back)

19
lisp/man.el
View file

@ -927,15 +927,18 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description"
;; run differently in Man-getpage-in-background, an error
;; here may not necessarily mean that we'll also get an
;; error later.
(ignore-errors
(call-process manual-program nil '(t nil) nil
"-k" (concat (when (or Man-man-k-use-anchor
(string-equal prefix ""))
"^")
prefix))))
(setq table (Man-parse-man-k)))
(when (eq 0
(ignore-errors
(call-process
manual-program nil '(t nil) nil
"-k" (concat (when (or Man-man-k-use-anchor
(string-equal prefix ""))
"^")
prefix))))
(setq table (Man-parse-man-k)))))
;; Cache the table for later reuse.
(setq Man-completion-cache (cons prefix table)))
(when table
(setq Man-completion-cache (cons prefix table))))
;; The table may contain false positives since the match is made
;; by "man -k" not just on the manpage's name.
(if section

4
lisp/misc.el
View file

@ -69,7 +69,9 @@ The characters copied are inserted in the buffer before point."
Case is ignored if `case-fold-search' is non-nil in the current buffer.
Goes backward if ARG is negative; error if CHAR not found.
Ignores CHAR at point."
(interactive "p\ncZap up to char: ")
(interactive (list (prefix-numeric-value current-prefix-arg)
(read-char-from-minibuffer "Zap up to char: "
nil 'read-char-history)))
(let ((direction (if (>= arg 0) 1 -1)))
(kill-region (point)
(progn

20
lisp/mwheel.el
View file

@ -85,7 +85,7 @@ set to the event sent when clicking on the mouse wheel button."
:type 'number)
(defcustom mouse-wheel-scroll-amount
'(5 ((shift) . 1) ((meta) . nil) ((control) . text-scale))
'(1 ((shift) . hscroll) ((meta) . nil) ((control) . text-scale))
"Amount to scroll windows by when spinning the mouse wheel.
This is an alist mapping the modifier key to the amount to scroll when
the wheel is moved with the modifier key depressed.
@ -97,6 +97,9 @@ screen. It can also be a floating point number, specifying the fraction of
a full screen to scroll. A near full screen is `next-screen-context-lines'
less than a full screen.
If AMOUNT is the symbol 'hscroll', this means that with MODIFIER,
the mouse wheel will scroll horizontally instead of vertically.
If AMOUNT is the symbol text-scale, this means that with
MODIFIER, the mouse wheel will change the face height instead of
scrolling."
@ -123,9 +126,10 @@ scrolling."
(const :tag "Scroll full screen" :value nil)
(integer :tag "Scroll specific # of lines")
(float :tag "Scroll fraction of window")
(const :tag "Scroll horizontally" :value hscroll)
(const :tag "Change face size" :value text-scale)))))
:set 'mouse-wheel-change-button
:version "27.1")
:version "28.1")
(defcustom mouse-wheel-progressive-speed t
"If non-nil, the faster the user moves the wheel, the faster the scrolling.
@ -270,7 +274,11 @@ non-Windows systems."
(condition-case nil
(unwind-protect
(let ((button (mwheel-event-button event)))
(cond ((eq button mouse-wheel-down-event)
(cond ((and (eq amt 'hscroll) (eq button mouse-wheel-down-event))
(funcall (if mouse-wheel-flip-direction
mwheel-scroll-left-function
mwheel-scroll-right-function) 1))
((eq button mouse-wheel-down-event)
(condition-case nil (funcall mwheel-scroll-down-function amt)
;; Make sure we do indeed scroll to the beginning of
;; the buffer.
@ -285,7 +293,11 @@ non-Windows systems."
;; for a reason that escapes me. This problem seems
;; to only affect scroll-down. --Stef
(set-window-start (selected-window) (point-min))))))
((eq button mouse-wheel-up-event)
((and (eq amt 'hscroll) (eq button mouse-wheel-up-event))
(funcall (if mouse-wheel-flip-direction
mwheel-scroll-right-function
mwheel-scroll-left-function) 1))
((eq button mouse-wheel-up-event)
(condition-case nil (funcall mwheel-scroll-up-function amt)
;; Make sure we do indeed scroll to the end of the buffer.
(end-of-buffer (while t (funcall mwheel-scroll-up-function)))))

295
lisp/net/dbus.el
View file

@ -144,6 +144,17 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
;; </signal>
;; </interface>
(defconst dbus-interface-monitoring (concat dbus-interface-dbus ".Monitoring")
"The monitoring interface.
See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#bus-messages-become-monitor'.")
;; <interface name="org.freedesktop.DBus.Monitoring">
;; <method name="BecomeMonitor">
;; <arg name="rule" type="as" direction="in"/>
;; <arg name="flags" type="u" direction="in"/> ;; Not used, must be 0.
;; </method>
;; </interface>
(defconst dbus-interface-local (concat dbus-interface-dbus ".Local")
"An interface whose methods can only be invoked by the local implementation.")
@ -336,7 +347,8 @@ object is returned instead of a list containing this single Lisp object.
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(or (memq bus '(:system :session :system-private :session-private))
(stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@ -440,7 +452,8 @@ Example:
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(or (memq bus '(:system :session :system-private :session-private))
(stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@ -490,7 +503,8 @@ Example:
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(or (memq bus '(:system :session :system-private :session-private))
(stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (null service) (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@ -510,7 +524,8 @@ This is an internal function, it shall not be used outside dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(or (memq bus '(:system :session :system-private :session-private))
(stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@ -527,7 +542,8 @@ This is an internal function, it shall not be used outside dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(or (memq bus '(:system :session :system-private :session-private))
(stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@ -545,7 +561,8 @@ This is an internal function, it shall not be used outside dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
(or (memq bus '(:system :session)) (stringp bus)
(or (memq bus '(:system :session :system-private :session-private))
(stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@ -1018,19 +1035,29 @@ STRING must have been encoded with `dbus-escape-as-identifier'."
"Check whether EVENT is a well formed D-Bus event.
EVENT is a list which starts with symbol `dbus-event':
(dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
(dbus-event BUS TYPE SERIAL SERVICE DESTINATION PATH
INTERFACE MEMBER HANDLER &rest ARGS)
BUS identifies the D-Bus the message is coming from. It is
either a Lisp symbol, `:system' or `:session', or a string
denoting the bus address. TYPE is the D-Bus message type which
has caused the event, SERIAL is the serial number of the received
D-Bus message. SERVICE and PATH are the unique name and the
object path of the D-Bus object emitting the message. INTERFACE
and MEMBER denote the message which has been sent. HANDLER is
the function which has been registered for this message. ARGS
are the typed arguments as returned from the message. They are
passed to HANDLER without type information, when it is called
during event handling in `dbus-handle-event'.
either a Lisp symbol, `:system', `:session', `:systemp-private'
or `:session-private', or a string denoting the bus address.
TYPE is the D-Bus message type which has caused the event, SERIAL
is the serial number of the received D-Bus message when TYPE is
equal `dbus-message-type-method-return' or `dbus-message-type-error'.
SERVICE and PATH are the unique name and the object path of the
D-Bus object emitting the message. DESTINATION is the D-Bus name
the message is dedicated to, or nil in case thje message is a
broadcast signal.
INTERFACE and MEMBER denote the message which has been sent.
When TYPE is `dbus-message-type-error', MEMBER is the error name.
HANDLER is the function which has been registered for this
message. ARGS are the typed arguments as returned from the
message. They are passed to HANDLER without type information,
when it is called during event handling in `dbus-handle-event'.
This function signals a `dbus-error' if the event is not well
formed."
@ -1038,7 +1065,7 @@ formed."
(unless (and (listp event)
(eq (car event) 'dbus-event)
;; Bus symbol.
(or (symbolp (nth 1 event))
(or (keywordp (nth 1 event))
(stringp (nth 1 event)))
;; Type.
(and (natnump (nth 2 event))
@ -1050,20 +1077,26 @@ formed."
(= dbus-message-type-error (nth 2 event))
(or (stringp (nth 4 event))
(null (nth 4 event))))
;; Destination.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
(or (stringp (nth 5 event))
(null (nth 5 event))))
;; Object path.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
(stringp (nth 5 event)))
(stringp (nth 6 event)))
;; Interface.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
(stringp (nth 6 event)))
(stringp (nth 7 event)))
;; Member.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
(stringp (nth 7 event)))
(stringp (nth 8 event)))
;; Handler.
(functionp (nth 8 event)))
(functionp (nth 9 event))
;; Arguments.
(listp (nthcdr 10 event)))
(signal 'dbus-error (list "Not a valid D-Bus event" event))))
(defun dbus-delete-types (&rest args)
@ -1103,28 +1136,36 @@ part of the event, is called with arguments ARGS (without type information).
If the HANDLER returns a `dbus-error', it is propagated as return message."
(interactive "e")
(condition-case err
(let (args result)
(let (monitor args result)
;; We ignore not well-formed events.
(dbus-check-event event)
;; Remove type information.
(setq args (mapcar #'dbus-delete-types (nthcdr 9 event)))
;; Error messages must be propagated.
(when (= dbus-message-type-error (nth 2 event))
(signal 'dbus-error args))
;; Apply the handler.
(setq result (apply (nth 8 event) args))
;; Return an (error) message when it is a message call.
(when (= dbus-message-type-method-call (nth 2 event))
(dbus-ignore-errors
(if (eq (car-safe result) :error)
(apply #'dbus-method-error-internal
(nth 1 event) (nth 4 event) (nth 3 event) (cdr result))
(if (eq result :ignore)
(dbus-method-return-internal
(nth 1 event) (nth 4 event) (nth 3 event))
(apply #'dbus-method-return-internal
(nth 1 event) (nth 4 event) (nth 3 event)
(if (consp result) result (list result))))))))
(setq args (mapcar #'dbus-delete-types (nthcdr 10 event)))
(setq monitor
(gethash
(list :monitor (nth 1 event)) dbus-registered-objects-table))
(if monitor
;; A monitor event shall not trigger other operations, and
;; it shall not trigger D-Bus errors.
(setq result (dbus-ignore-errors (apply (nth 9 event) args)))
;; Error messages must be propagated. The error name is in
;; the member slot.
(when (= dbus-message-type-error (nth 2 event))
(signal 'dbus-error (cons (nth 8 event) args)))
;; Apply the handler.
(setq result (apply (nth 9 event) args))
;; Return an (error) message when it is a message call.
(when (= dbus-message-type-method-call (nth 2 event))
(dbus-ignore-errors
(if (eq (car-safe result) :error)
(apply #'dbus-method-error-internal
(nth 1 event) (nth 4 event) (nth 3 event) (cdr result))
(if (eq result :ignore)
(dbus-method-return-internal
(nth 1 event) (nth 4 event) (nth 3 event))
(apply #'dbus-method-return-internal
(nth 1 event) (nth 4 event) (nth 3 event)
(if (consp result) result (list result)))))))))
;; Error handling.
(dbus-error
;; Return an error message when it is a message call.
@ -1172,13 +1213,21 @@ formed."
(dbus-check-event event)
(nth 4 event))
(defun dbus-event-destination-name (event)
"Return the name of the D-Bus object the event is dedicated to.
The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
This function signals a `dbus-error' if the event is not well
formed."
(dbus-check-event event)
(nth 5 event))
(defun dbus-event-path-name (event)
"Return the object path of the D-Bus object the event is coming from.
The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
This function signals a `dbus-error' if the event is not well
formed."
(dbus-check-event event)
(nth 5 event))
(nth 6 event))
(defun dbus-event-interface-name (event)
"Return the interface name of the D-Bus object the event is coming from.
@ -1186,15 +1235,32 @@ The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
This function signals a `dbus-error' if the event is not well
formed."
(dbus-check-event event)
(nth 6 event))
(nth 7 event))
(defun dbus-event-member-name (event)
"Return the member name the event is coming from.
It is either a signal name or a method name. The result is a
string. EVENT is a D-Bus event, see `dbus-check-event'. This
function signals a `dbus-error' if the event is not well formed."
It is either a signal name, a method name or an error name. The
result is a string. EVENT is a D-Bus event, see
`dbus-check-event'. This function signals a `dbus-error' if the
event is not well formed."
(dbus-check-event event)
(nth 7 event))
(nth 8 event))
(defun dbus-event-handler (event)
"Return the handler the event is applied with.
The result is a function. EVENT is a D-Bus event, see
`dbus-check-event'. This function signals a `dbus-error' if the
event is not well formed."
(dbus-check-event event)
(nth 9 event))
(defun dbus-event-arguments (event)
"Return the arguments the event is carrying on.
The result is a list of arguments. EVENT is a D-Bus event, see
`dbus-check-event'. This function signals a `dbus-error' if the
event is not well formed."
(dbus-check-event event)
(nthcdr 10 event))
;;; D-Bus registered names.
@ -1717,7 +1783,7 @@ It will be registered for all objects created by `dbus-register-property'."
;; "Set" needs the third typed argument from `last-input-event'.
((string-equal method "Set")
(let* ((value (dbus-flatten-types (nth 11 last-input-event)))
(let* ((value (dbus-flatten-types (nth 12 last-input-event)))
(entry (dbus-get-this-registered-property
bus service path interface property))
(object (car (last (car entry)))))
@ -1907,13 +1973,123 @@ It will be registered for all objects created by `dbus-register-service'."
result)
'(:signature "{oa{sa{sv}}}"))))))
(defun dbus-register-monitor
(bus &optional service path interface member handler &rest args)
"Register HANDLER for monitor events on the D-Bus BUS.
BUS is either a Lisp symbol, `:system' or `:session', or a string
denoting the bus address.
SERVICE is the D-Bus service name of the D-Bus. It must be a
known name (see discussion of DONT-REGISTER-SERVICE below).
PATH is the D-Bus object path SERVICE is registered at (see
discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
name of the interface used at PATH. MEMBER is either a method
name, a signal name, or an error name.
HANDLER is the function to be called when a monitor event
arrives. If nil, the default handler `dbus-monitor-handler' is
applied. It is called with ARGS as arguments."
(let ((bus-private (if (eq bus :system) :system-private
(if (eq bus :session) :session-private bus)))
keyword type rule1 rule2 key key1 value)
(unless handler (setq handler #'dbus-monitor-handler))
;; Read arguments.
(while args
(when (keywordp (setq keyword (pop args)))
(cond
((eq :type keyword)
;; Must be "signal", "method_call", "method_return", or "error".
(setq type (pop args))))))
;; Compose rules.
(setq rule1
(or
(string-join
(delq nil
(list (when service (format "sender='%s'" service))
(when path (format "path='%s'" path))
(when interface (format "interface='%s'" interface))
(when member (format "member='%s'" member))
(when type (format "type='%s'" type))))
",")
"")
rule2
(when service
(string-join
(delq nil
(list (format "destination='%s'" service)
(when path (format "path='%s'" path))
(when interface (format "interface='%s'" interface))
(when member (format "member='%s'" member))
(when type (format "type='%s'" type))))
",")))
(unless (ignore-errors (dbus-get-unique-name bus-private))
(dbus-init-bus bus 'private))
(dbus-call-method
bus-private dbus-service-dbus dbus-path-dbus dbus-interface-monitoring
"BecomeMonitor"
(append `(:array :string ,rule1) (when rule2 `(:string ,rule2)))
:uint32 0)
(when dbus-debug (message "Matching rule \"%s\" created" rule1))
;; Create a hash table entry.
(setq key (list :monitor bus-private)
key1 (list nil nil nil handler)
value (gethash key dbus-registered-objects-table))
(unless (member key1 value)
(puthash key (cons key1 value) dbus-registered-objects-table))
(when dbus-debug (message "%s" dbus-registered-objects-table))
;; Return the object.
(list key (list service path handler))))
(defun dbus-monitor-handler (&rest _args)
"Default handler for the \"org.freedesktop.DBus.Monitoring.BecomeMonitor\" interface.
It will be applied all objects created by `dbus-register-monitor'."
(with-current-buffer (get-buffer-create "*D-Bus Monitor*")
(special-mode)
(let* ((inhibit-read-only t)
(eobp (eobp))
(event last-input-event)
(type (dbus-event-message-type event))
(sender (dbus-event-service-name event))
(destination (dbus-event-destination-name event))
(serial (dbus-event-serial-number event))
(path (dbus-event-path-name event))
(interface (dbus-event-interface-name event))
(member (dbus-event-member-name event))
(arguments (dbus-event-arguments event)))
(save-excursion
(goto-char (point-max))
(insert
(format
(concat
"%s sender=%s -> destination=%s serial=%s "
"path=%s interface=%s member=%s\n")
(cond
((= type dbus-message-type-method-call) "method-call")
((= type dbus-message-type-method-return) "method-return")
((= type dbus-message-type-error) "error")
((= type dbus-message-type-signal) "signal"))
sender destination serial path interface member))
(dolist (arg arguments)
(pp (dbus-flatten-types arg) (current-buffer)))
(insert "\n"))
(when eobp
(goto-char (point-max))))))
(defun dbus-handle-bus-disconnect ()
"React to a bus disconnection.
BUS is the bus that disconnected. This routine unregisters all
handlers on the given bus and causes all synchronous calls
pending at the time of disconnect to fail."
(let ((bus (dbus-event-bus-name last-input-event))
(keys-to-remove))
keys-to-remove)
(maphash
(lambda (key value)
(when (and (eq (nth 0 key) :serial)
@ -1923,13 +2099,14 @@ pending at the time of disconnect to fail."
(list 'dbus-event
bus
dbus-message-type-error
(nth 2 key)
nil
nil
nil
nil
value)
(list 'dbus-error "Bus disconnected" bus))
(nth 2 key) ; serial
nil ; service
nil ; destination
nil ; path
nil ; interface
nil ; member
value) ; handler
(list 'dbus-error dbus-error-disconnected "Bus disconnected" bus))
(push key keys-to-remove)))
dbus-registered-objects-table)
(dolist (key keys-to-remove)
@ -1980,13 +2157,9 @@ this connection to those buses."
;;; TODO:
;; * Check property type in org.freedesktop.DBus.Properties.Set.
;;
;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
;;
;; * Implement org.freedesktop.DBus.Monitoring.BecomeMonitor.
;;
;; * Cache introspection data.
;;
;; * Run handlers in own threads.

10
lisp/net/shr.el
View file

@ -555,7 +555,10 @@ size, and full-buffer size."
;; If the element was empty, we don't have anything to put the
;; anchor on. So just insert a dummy character.
(when (= start (point))
(insert ? )
(if (not (bolp))
(insert ? )
(insert ? )
(shr-mark-fill start))
(put-text-property (1- (point)) (point) 'display ""))
(put-text-property start (1+ start) 'shr-target-id id))
;; If style is set, then this node has set the color.
@ -675,8 +678,11 @@ size, and full-buffer size."
(goto-char start)
(when (looking-at "[ \t\n\r]+")
(replace-match "" t t))
(while (re-search-forward "[ \t\n\r]+" nil t)
(while (re-search-forward "[\t\n\r]+" nil t)
(replace-match " " t t))
(goto-char start)
(while (re-search-forward " +" nil t)
(replace-match " " t t))
(shr--translate-insertion-chars)
(goto-char (point-max)))
;; We may have removed everything we inserted if it was just

1
lisp/net/soap-client.el
View file

@ -1716,6 +1716,7 @@ This is a specialization of `soap-encode-value' for
((and (not (eq indicator 'choice))
(= instance-count 0)
(not (soap-xs-element-optional? element))
(not (soap-xs-complex-type-optional? type))
(and (soap-xs-complex-type-p element-type)
(not (soap-xs-complex-type-optional-p
element-type))))

2
lisp/net/tramp-crypt.el
View file

@ -120,7 +120,7 @@ initializing a new crypted remote directory."
"Whether to keep the encfs configuration file in the crypted remote directory."
:group 'tramp
:version "28.1"
:type 'booleanp)
:type 'boolean)
;;;###tramp-autoload
(defvar tramp-crypt-directories nil

4
lisp/net/tramp-sh.el
View file

@ -118,7 +118,9 @@ detected as prompt when being sent on echoing hosts, therefore.")
;;;###tramp-autoload
(defcustom tramp-use-ssh-controlmaster-options t
"Whether to use `tramp-ssh-controlmaster-options'."
"Whether to use `tramp-ssh-controlmaster-options'.
Set it to nil, if you use Control* or Proxy* options in your ssh
configuration."
:group 'tramp
:version "24.4"
:type 'boolean)

2
lisp/play/gamegrid.el
View file

@ -635,6 +635,8 @@ FILE is created there."
(save-excursion
(setq file (expand-file-name file (or directory
temporary-file-directory)))
(unless (file-exists-p (file-name-directory file))
(make-directory (file-name-directory file) t))
(find-file-other-window file)
(setq buffer-read-only nil)
(goto-char (point-max))

5
lisp/progmodes/antlr-mode.el
View file

@ -720,9 +720,8 @@ imenu."
"Major mode menu."
`("Antlr"
,@(if (cond-emacs-xemacs
:EMACS (and antlr-options-use-submenus
(>= emacs-major-version 21))
:XEMACS antlr-options-use-submenus)
:EMACS antlr-options-use-submenus
:XEMACS antlr-options-use-submenus)
`(("Insert File Option"
:filter ,(lambda (x) (antlr-options-menu-filter 1 x)))
("Insert Grammar Option"

6
lisp/progmodes/compile.el
View file

@ -64,7 +64,8 @@ If nil, use Emacs default."
If the replacement is nil, the file will not be considered an
error after all. If not nil, it should be a regexp replacement
string."
:type '(repeat (list regexp string))
:type '(repeat (list regexp (choice (const :tag "No replacement" nil)
string)))
:version "27.1")
(defvar compilation-filter-hook nil
@ -449,6 +450,9 @@ during global destruction\\.$\\)" 1 2)
\\([0-9]+\\) of file://\\(.+\\)"
4 2 3 (1))
(shellcheck
"^In \\(.+\\) line \\([0-9]+\\):" 1 2)
(sparc-pascal-file
"^\\w\\w\\w \\w\\w\\w +[0-3]?[0-9] +[0-2][0-9]:[0-5][0-9]:[0-5][0-9]\
[12][09][0-9][0-9] +\\(.*\\):$"

5
lisp/progmodes/gdb-mi.el
View file

@ -643,13 +643,14 @@ and looks under `gdb-window-configuration-directory'.
Note that this variable only takes effect when variable
`gdb-many-windows' is t."
:type 'string
:type '(choice (const :tag "None" nil)
string)
:group 'gdb
:version "28.1")
(defcustom gdb-display-source-buffer-action '(nil . ((inhibit-same-window . t)))
"`display-buffer' action used when GDB displays a source buffer."
:type 'list
:type 'sexp
:group 'gdb
:version "28.1")

3
lisp/progmodes/idlwave.el
View file

@ -6727,8 +6727,7 @@ accumulate information on matching completions."
(not super-classes))) ; no possibilities for inheritance
;; In these cases, we do not have to do anything
list
(let* ((do-prop (and (>= show-classes 0)
(>= emacs-major-version 21)))
(let* ((do-prop (>= show-classes 0))
(do-buf (not (= show-classes 0)))
(do-dots t)
(inherit (if (and (not (eq type 'class-tag)) super-classes)

82
lisp/progmodes/prolog.el
View file

@ -776,12 +776,6 @@ This is really kludgy, and unneeded (i.e. obsolete) in Emacs>=24."
(modify-syntax-entry ?> "." table)
(modify-syntax-entry ?| "." table)
(modify-syntax-entry ?\' "\"" table)
;; Any better way to handle the 0'<char> construct?!?
(when (and prolog-char-quote-workaround
(not (fboundp 'syntax-propertize-rules)))
(modify-syntax-entry ?0 "\\" table))
(modify-syntax-entry ?% "<" table)
(modify-syntax-entry ?\n ">" table)
(modify-syntax-entry ?* ". 23b" table)
@ -1047,21 +1041,19 @@ VERSION is of the format (Major . Minor)"
alist)))
(defconst prolog-syntax-propertize-function
(when (fboundp 'syntax-propertize-rules)
(syntax-propertize-rules
;; GNU Prolog only accepts 0'\' rather than 0'', but the only
;; possible meaning of 0'' is rather clear.
("\\<0\\(''?\\)"
(1 (unless (save-excursion (nth 8 (syntax-ppss (match-beginning 0))))
(string-to-syntax "_"))))
;; We could check that we're not inside an atom, but I don't think
;; that 'foo 8'z could be a valid syntax anyway, so why bother?
("\\<[1-9][0-9]*\\('\\)[0-9a-zA-Z]" (1 "_"))
;; Supposedly, ISO-Prolog wants \NNN\ for octal and \xNNN\ for hexadecimal
;; escape sequences in atoms, so be careful not to let the terminating \
;; escape a subsequent quote.
("\\\\[x0-7][[:xdigit:]]*\\(\\\\\\)" (1 "_"))
)))
(syntax-propertize-rules
;; GNU Prolog only accepts 0'\' rather than 0'', but the only
;; possible meaning of 0'' is rather clear.
("\\<0\\(''?\\)"
(1 (unless (save-excursion (nth 8 (syntax-ppss (match-beginning 0))))
(string-to-syntax "_"))))
;; We could check that we're not inside an atom, but I don't think
;; that 'foo 8'z could be a valid syntax anyway, so why bother?
("\\<[1-9][0-9]*\\('\\)[0-9a-zA-Z]" (1 "_"))
;; Supposedly, ISO-Prolog wants \NNN\ for octal and \xNNN\ for hexadecimal
;; escape sequences in atoms, so be careful not to let the terminating \
;; escape a subsequent quote.
("\\\\[x0-7][[:xdigit:]]*\\(\\\\\\)" (1 "_"))))
(defun prolog-mode-variables ()
"Set some common variables to Prolog code specific values."
@ -1886,14 +1878,7 @@ Argument BOUND is a buffer position limiting searching."
bound t)))
point))
(defsubst prolog-face-name-p (facename)
;; Return t if FACENAME is the name of a face. This method is
;; necessary since facep in XEmacs only returns t for the actual
;; face objects (while it's only their names that are used just
;; about anywhere else) without providing a predicate that tests
;; face names. This function (including the above commentary) is
;; borrowed from cc-mode.
(memq facename (face-list)))
(define-obsolete-function-alias 'prolog-face-name-p 'facep "28.1")
;; Set everything up
(defun prolog-font-lock-keywords ()
@ -1928,6 +1913,8 @@ Argument BOUND is a buffer position limiting searching."
(t (:underline t)))
"Face name to use for compiler warnings."
:group 'prolog-faces)
(define-obsolete-face-alias 'prolog-warning-face
'font-lock-warning-face "28.1")
(defface prolog-builtin-face
'((((class color) (background light)) (:foreground "Purple"))
(((class color) (background dark)) (:foreground "Cyan"))
@ -1937,15 +1924,11 @@ Argument BOUND is a buffer position limiting searching."
(t (:bold t)))
"Face name to use for compiler warnings."
:group 'prolog-faces)
(defvar prolog-warning-face
(if (prolog-face-name-p 'font-lock-warning-face)
'font-lock-warning-face
'prolog-warning-face)
(define-obsolete-face-alias 'prolog-builtin-face
'font-lock-builtin-face "28.1")
(defvar prolog-warning-face 'font-lock-warning-face
"Face name to use for built in predicates.")
(defvar prolog-builtin-face
(if (prolog-face-name-p 'font-lock-builtin-face)
'font-lock-builtin-face
'prolog-builtin-face)
(defvar prolog-builtin-face 'font-lock-builtin-face
"Face name to use for built in predicates.")
(defvar prolog-redo-face 'prolog-redo-face
"Face name to use for redo trace lines.")
@ -2291,12 +2274,12 @@ between them)."
(progn
(goto-char cbeg)
(search-forward-regexp "%+[ \t]*" end t)
(prolog-replace-in-string (buffer-substring beg (point))
"[^ \t%]" " "))
(replace-regexp-in-string "[^ \t%]" " "
(buffer-substring beg (point))))
;(goto-char beg)
(if (search-forward-regexp "^[ \t]*\\(%+\\|\\*+\\|/\\*+\\)[ \t]*"
end t)
(prolog-replace-in-string (buffer-substring beg (point)) "/" " ")
(replace-regexp-in-string "/" " " (buffer-substring beg (point)))
(beginning-of-line)
(when (search-forward-regexp "^[ \t]+" end t)
(buffer-substring beg (point)))))))))
@ -2336,11 +2319,10 @@ In effect it sets the `fill-prefix' when inside comments and then calls
(do-auto-fill)
))
(defalias 'prolog-replace-in-string
(if (fboundp 'replace-in-string)
#'replace-in-string
(lambda (str regexp newtext &optional literal)
(replace-regexp-in-string regexp newtext str nil literal))))
(defun prolog-replace-in-string (str regexp newtext &optional literal)
(declare (obsolete replace-regexp-in-string "28.1"))
(replace-regexp-in-string regexp newtext str nil literal))
;;-------------------------------------------------------------------
;; Online help
@ -3083,12 +3065,8 @@ The module name should be written manually just before the semi-colon."
(insert "%%% -*- Module: ; -*-\n")
(backward-char 6))
(defalias 'prolog-uncomment-region
(if (fboundp 'uncomment-region) #'uncomment-region
(lambda (beg end)
"Uncomment the region between BEG and END."
(interactive "r")
(comment-region beg end -1))))
(define-obsolete-function-alias 'prolog-uncomment-region
'uncomment-region "28.1")
(defun prolog-indent-predicate ()
"Indent the current predicate."
@ -3374,7 +3352,7 @@ PREFIX is the prefix of the search regexp."
"Commands for Prolog code manipulation."
'("Prolog"
["Comment region" comment-region (use-region-p)]
["Uncomment region" prolog-uncomment-region (use-region-p)]
["Uncomment region" uncomment-region (use-region-p)]
["Add comment/move to comment" indent-for-comment t]
["Convert variables in region to '_'" prolog-variables-to-anonymous
:active (use-region-p) :included (not (eq prolog-system 'mercury))]

4
lisp/progmodes/python.el
View file

@ -3796,7 +3796,7 @@ was `continue'. This behavior slightly differentiates the `continue' command
from the `exit' command listed in `python-pdbtrack-exit-command'.
See `python-pdbtrack-activate' for pdbtracking session overview."
:type 'list
:type '(repeat string)
:version "27.1")
(defcustom python-pdbtrack-exit-command '("q" "quit" "exit")
@ -3805,7 +3805,7 @@ After one of this commands is sent to pdb, pdbtracking session is
considered over.
See `python-pdbtrack-activate' for pdbtracking session overview."
:type 'list
:type '(repeat string)
:version "27.1")
(defcustom python-pdbtrack-kill-buffers t

40
lisp/progmodes/ruby-mode.el
View file

@ -142,12 +142,11 @@ This should only be called after matching against `ruby-here-doc-beg-re'."
"Regexp to match symbols.")
(defvar ruby-use-smie t)
(make-obsolete-variable 'ruby-use-smie nil "28.1")
(defvar ruby-mode-map
(let ((map (make-sparse-keymap)))
(unless ruby-use-smie
(define-key map (kbd "M-C-b") 'ruby-backward-sexp)
(define-key map (kbd "M-C-f") 'ruby-forward-sexp)
(define-key map (kbd "M-C-q") 'ruby-indent-exp))
(when ruby-use-smie
(define-key map (kbd "M-C-d") 'smie-down-list))
@ -170,14 +169,8 @@ This should only be called after matching against `ruby-here-doc-beg-re'."
"--"
["Toggle String Quotes" ruby-toggle-string-quotes t]
"--"
["Backward Sexp" ruby-backward-sexp
:visible (not ruby-use-smie)]
["Backward Sexp" backward-sexp
:visible ruby-use-smie]
["Forward Sexp" ruby-forward-sexp
:visible (not ruby-use-smie)]
["Forward Sexp" forward-sexp
:visible ruby-use-smie]
["Backward Sexp" backward-sexp t]
["Forward Sexp" forward-sexp t]
["Indent Sexp" ruby-indent-exp
:visible (not ruby-use-smie)]
["Indent Sexp" prog-indent-sexp
@ -741,10 +734,10 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
(defun ruby-mode-variables ()
"Set up initial buffer-local variables for Ruby mode."
(setq indent-tabs-mode ruby-indent-tabs-mode)
(if ruby-use-smie
(smie-setup ruby-smie-grammar #'ruby-smie-rules
:forward-token #'ruby-smie--forward-token
:backward-token #'ruby-smie--backward-token)
(smie-setup ruby-smie-grammar #'ruby-smie-rules
:forward-token #'ruby-smie--forward-token
:backward-token #'ruby-smie--backward-token)
(unless ruby-use-smie
(setq-local indent-line-function #'ruby-indent-line))
(setq-local comment-start "# ")
(setq-local comment-end "")
@ -1378,7 +1371,8 @@ move forward."
The defun begins at or after the point. This function is called
by `end-of-defun'."
(interactive "p")
(ruby-forward-sexp)
(with-suppressed-warnings ((obsolete ruby-forward-sexp))
(ruby-forward-sexp))
(let (case-fold-search)
(when (looking-back (concat "^\\s *" ruby-block-end-re)
(line-beginning-position))
@ -1467,11 +1461,14 @@ With ARG, move out of multiple blocks."
(defun ruby-forward-sexp (&optional arg)
"Move forward across one balanced expression (sexp).
With ARG, do it many times. Negative ARG means move backward."
(declare (obsolete forward-sexp "28.1"))
;; TODO: Document body
(interactive "p")
(cond
(ruby-use-smie (forward-sexp arg))
((and (numberp arg) (< arg 0)) (ruby-backward-sexp (- arg)))
((and (numberp arg) (< arg 0))
(with-suppressed-warnings ((obsolete ruby-backward-sexp))
(ruby-backward-sexp (- arg))))
(t
(let ((i (or arg 1)))
(condition-case nil
@ -1515,11 +1512,14 @@ With ARG, do it many times. Negative ARG means move backward."
(defun ruby-backward-sexp (&optional arg)
"Move backward across one balanced expression (sexp).
With ARG, do it many times. Negative ARG means move forward."
(declare (obsolete backward-sexp "28.1"))
;; TODO: Document body
(interactive "p")
(cond
(ruby-use-smie (backward-sexp arg))
((and (numberp arg) (< arg 0)) (ruby-forward-sexp (- arg)))
((and (numberp arg) (< arg 0))
(with-suppressed-warnings ((obsolete ruby-forward-sexp))
(ruby-forward-sexp (- arg))))
(t
(let ((i (or arg 1)))
(condition-case nil
@ -1671,7 +1671,8 @@ See `add-log-current-defun-function'."
(defun ruby-block-contains-point (pt)
(save-excursion
(save-match-data
(ruby-forward-sexp)
(with-suppressed-warnings ((obsolete ruby-forward-sexp))
(ruby-forward-sexp))
(> (point) pt))))
(defun ruby-brace-to-do-end (orig end)
@ -1749,7 +1750,8 @@ If the result is do-end block, it will always be multiline."
(progn
(goto-char (or (match-beginning 1) (match-beginning 2)))
(setq beg (point))
(save-match-data (ruby-forward-sexp))
(with-suppressed-warnings ((obsolete ruby-forward-sexp))
(save-match-data (ruby-forward-sexp)))
(setq end (point))
(> end start)))
(if (match-beginning 1)

7
lisp/progmodes/sql.el
View file

@ -342,8 +342,7 @@ file. Since that is a plaintext file, this could be dangerous."
(const :format "" :completion)
(sexp :tag ":completion")
(const :format "" :must-match)
(restricted-sexp
:match-alternatives (listp stringp))))
(symbol :tag ":must-match")))
(const port)))
;; SQL Product support
@ -838,11 +837,11 @@ host key."
(setq w (locate-user-emacs-file (concat "sql-wallet" ext)
(concat ".sql-wallet" ext)))
(when (file-exists-p w)
(setq wallet w)))))
(setq wallet (list w))))))
"Identification of the password wallet.
See `sql-password-search-wallet-function' to understand how this value
is used to locate the password wallet."
:type `(plist-get (symbol-plist 'auth-sources) 'custom-type)
:type (plist-get (symbol-plist 'auth-sources) 'custom-type)
:version "27.1")
(defvar sql-password-search-wallet-function #'sql-auth-source-search-wallet

4
lisp/repeat.el
View file

@ -85,10 +85,6 @@
;; C-x { shrink-window-horizontally
;; C-x } enlarge-window-horizontally
;; This command was first called `vi-dot', because
;; it was inspired by the `.' command in the vi editor,
;; but it was renamed to make its name more meaningful.
;;; Code:
;;;;; ************************* USER OPTIONS ************************** ;;;;;

91
lisp/simple.el
View file

@ -1231,7 +1231,43 @@ that uses or sets the mark."
"History of values entered with `goto-line'.")
(make-variable-buffer-local 'goto-line-history)
(defun goto-line (line &optional buffer)
(defun goto-line-read-args (&optional relative)
"Read arguments for `goto-line' related commands."
(if (and current-prefix-arg (not (consp current-prefix-arg)))
(list (prefix-numeric-value current-prefix-arg))
;; Look for a default, a number in the buffer at point.
(let* ((default
(save-excursion
(skip-chars-backward "0-9")
(if (looking-at "[0-9]")
(string-to-number
(buffer-substring-no-properties
(point)
(progn (skip-chars-forward "0-9")
(point)))))))
;; Decide if we're switching buffers.
(buffer
(if (consp current-prefix-arg)
(other-buffer (current-buffer) t)))
(buffer-prompt
(if buffer
(concat " in " (buffer-name buffer))
"")))
;; Read the argument, offering that number (if any) as default.
(list (read-number (format "Goto%s line%s: "
(if (= (point-min) 1) ""
;; In a narrowed buffer.
(if relative " relative" " absolute"))
buffer-prompt)
(list default (if (or relative (= (point-min) 1))
(line-number-at-pos)
(save-restriction
(widen)
(line-number-at-pos))))
'goto-line-history)
buffer))))
(defun goto-line (line &optional buffer relative)
"Go to LINE, counting from line 1 at beginning of buffer.
If called interactively, a numeric prefix argument specifies
LINE; without a numeric prefix argument, read LINE from the
@ -1241,6 +1277,13 @@ If optional argument BUFFER is non-nil, switch to that buffer and
move to line LINE there. If called interactively with \\[universal-argument]
as argument, BUFFER is the most recently selected other buffer.
If optional argument RELATIVE is non-nil, counting starts at the beginning
of the accessible portion of the (potentially narrowed) buffer.
If the variable `widen-automatically' is non-nil, cancel narrowing and
leave all lines accessible. If `widen-automatically' is nil, just move
point to the edge of visible portion and don't change the buffer bounds.
Prior to moving point, this function sets the mark (without
activating it), unless Transient Mark mode is enabled and the
mark is already active.
@ -1252,32 +1295,7 @@ What you probably want instead is something like:
If at all possible, an even better solution is to use char counts
rather than line counts."
(declare (interactive-only forward-line))
(interactive
(if (and current-prefix-arg (not (consp current-prefix-arg)))
(list (prefix-numeric-value current-prefix-arg))
;; Look for a default, a number in the buffer at point.
(let* ((default
(save-excursion
(skip-chars-backward "0-9")
(if (looking-at "[0-9]")
(string-to-number
(buffer-substring-no-properties
(point)
(progn (skip-chars-forward "0-9")
(point)))))))
;; Decide if we're switching buffers.
(buffer
(if (consp current-prefix-arg)
(other-buffer (current-buffer) t)))
(buffer-prompt
(if buffer
(concat " in " (buffer-name buffer))
"")))
;; Read the argument, offering that number (if any) as default.
(list (read-number (format "Goto line%s: " buffer-prompt)
(list default (line-number-at-pos))
'goto-line-history)
buffer))))
(interactive (goto-line-read-args))
;; Switch to the desired buffer, one way or another.
(if buffer
(let ((window (get-buffer-window buffer)))
@ -1286,13 +1304,28 @@ rather than line counts."
;; Leave mark at previous position
(or (region-active-p) (push-mark))
;; Move to the specified line number in that buffer.
(save-restriction
(widen)
(if (and (not relative) (not widen-automatically))
(save-restriction
(widen)
(goto-char (point-min))
(if (eq selective-display t)
(re-search-forward "[\n\C-m]" nil 'end (1- line))
(forward-line (1- line))))
(unless relative (widen))
(goto-char (point-min))
(if (eq selective-display t)
(re-search-forward "[\n\C-m]" nil 'end (1- line))
(forward-line (1- line)))))
(defun goto-line-relative (line &optional buffer)
"Go to LINE, counting from line at (point-min).
The line number is relative to the accessible portion of the narrowed
buffer. The argument BUFFER is the same as in the function `goto-line'."
(declare (interactive-only forward-line))
(interactive (goto-line-read-args t))
(with-suppressed-warnings ((interactive-only goto-line))
(goto-line line buffer t)))
(defun count-words-region (start end &optional arg)
"Count the number of words in the region.
If called interactively, print a message reporting the number of

46
lisp/subr.el
View file

@ -4435,37 +4435,21 @@ Unless optional argument INPLACE is non-nil, return a new string."
newstr))
(defun replace-in-string (fromstring tostring instring)
"Replace FROMSTRING with TOSTRING in INSTRING each time it occurs.
This function returns a freshly created string."
(declare (side-effect-free t))
(let ((i 0)
(start 0)
(result nil))
(while (< i (length instring))
(if (eq (aref instring i)
(aref fromstring 0))
;; See if we're in a match.
(let ((ii i)
(if 0))
(while (and (< ii (length instring))
(< if (length fromstring))
(eq (aref instring ii)
(aref fromstring if)))
(setq ii (1+ ii)
if (1+ if)))
(if (not (= if (length fromstring)))
;; We didn't have a match after all.
(setq i (1+ i))
;; We had one, so gather the previous part and the
;; substitution.
(when (not (= start i))
(push (substring instring start i) result))
(push tostring result)
(setq i ii
start ii)))
(setq i (1+ i))))
(when (not (= start i))
(push (substring instring start i) result))
"Replace FROMSTRING with TOSTRING in INSTRING each time it occurs."
(declare (pure t))
(when (equal fromstring "")
(signal 'wrong-length-argument fromstring))
(let ((start 0)
(result nil)
pos)
(while (setq pos (string-search fromstring instring start))
(unless (= start pos)
(push (substring instring start pos) result))
(push tostring result)
(setq start (+ pos (length fromstring))))
;; Get any remaining bit.
(unless (= start (length instring))
(push (substring instring start) result))
(apply #'concat (nreverse result))))
(defun replace-regexp-in-string (regexp rep string &optional

22
lisp/term/ns-win.el
View file

@ -632,15 +632,21 @@ This function has been overloaded in Nextstep.")
(defvar ns-input-fontsize)
(defun ns-respond-to-change-font ()
"Respond to changeFont: event, expecting `ns-input-font' and\n\
`ns-input-fontsize' of new font."
"Set the font chosen in the font-picker panel.
Respond to changeFont: event, expecting ns-input-font and
ns-input-fontsize of new font."
(interactive)
(modify-frame-parameters (selected-frame)
(list (cons 'fontsize ns-input-fontsize)))
(modify-frame-parameters (selected-frame)
(list (cons 'font ns-input-font)))
(set-frame-font ns-input-font))
(let ((face 'default))
(set-face-attribute face t
:family ns-input-font
:height (* 10 ns-input-fontsize))
(set-face-attribute face (selected-frame)
:family ns-input-font
:height (* 10 ns-input-fontsize))
(let ((spec (list (list t (face-attr-construct 'default)))))
(put face 'customized-face spec)
(custom-push-theme 'theme-face face 'user 'set spec)
(put face 'face-modified nil))))
;; Default fontset for macOS. This is mainly here to show how a fontset
;; can be set up manually. Ordinarily, fontsets are auto-created whenever

24
lisp/textmodes/artist.el
View file

@ -1993,25 +1993,11 @@ The replacement is used to convert tabs and new-lines to spaces."
(defun artist-replace-chars (new-char count)
"Replace characters at point with NEW-CHAR. COUNT chars are replaced."
;; Check that the variable exists first. The doc says it was added in 19.23.
(if (and (and (boundp 'emacs-major-version) (= emacs-major-version 20))
(and (boundp 'emacs-minor-version) (<= emacs-minor-version 3)))
;; This is a bug workaround for Emacs 20, versions up to 20.3:
;; The self-insert-command doesn't care about the overwrite-mode,
;; so the insertion is done in the same way as in picture mode.
;; This seems to be a little bit slower.
(let* ((replaced-c (artist-get-replacement-char new-char))
(replaced-s (make-string count replaced-c)))
(artist-move-to-xy (+ (artist-current-column) count)
(artist-current-line))
(delete-char (- count))
(insert replaced-s))
;; In emacs-19, the self-insert-command works better
(let ((overwrite-mode 'overwrite-mode-textual)
(fill-column 32765) ; Large :-)
(blink-matching-paren nil))
(setq last-command-event (artist-get-replacement-char new-char))
(self-insert-command count))))
(let ((overwrite-mode 'overwrite-mode-textual)
(fill-column 32765) ; Large :-)
(blink-matching-paren nil))
(setq last-command-event (artist-get-replacement-char new-char))
(self-insert-command count)))
(defsubst artist-replace-string (string &optional see-thru)
"Replace contents at point with STRING.

8
lisp/whitespace.el
View file

@ -445,6 +445,8 @@ See also `whitespace-display-mappings' for documentation."
(const :tag "(Face) Lines" lines)
(const :tag "(Face) Lines, only overlong part" lines-tail)
(const :tag "(Face) NEWLINEs" newline)
(const :tag "(Face) Missing newlines at EOB"
missing-newline-at-eof)
(const :tag "(Face) Empty Lines At BOB And/Or EOB" empty)
(const :tag "(Face) Indentation SPACEs" indentation::tab)
(const :tag "(Face) Indentation TABs"
@ -726,7 +728,7 @@ and the cons cdr is used for TABs visualization.
Used when `whitespace-style' includes `indentation',
`indentation::tab' or `indentation::space'."
:type '(cons (regexp :tag "Indentation SPACEs")
:type '(cons (string :tag "Indentation SPACEs")
(regexp :tag "Indentation TABs"))
:group 'whitespace)
@ -757,8 +759,8 @@ and the cons cdr is used for TABs visualization.
Used when `whitespace-style' includes `space-after-tab',
`space-after-tab::tab' or `space-after-tab::space'."
:type '(cons (regexp :tag "SPACEs After TAB")
regexp)
:type '(cons (string :tag "SPACEs After TAB")
string)
:group 'whitespace)
(defcustom whitespace-big-indent-regexp

11
lisp/wid-edit.el
View file

@ -303,12 +303,15 @@ the :notify function can't know the new value.")
(or (not widget-field-add-space) (widget-get widget :size))))
(if (functionp help-echo)
(setq help-echo 'widget-mouse-help))
(when (= (char-before to) ?\n)
(when (and (or (> to (1+ from)) (null (widget-get widget :size)))
(= (char-before to) ?\n))
;; When the last character in the field is a newline, we want to
;; give it a `field' char-property of `boundary', which helps the
;; C-n/C-p act more naturally when entering/leaving the field. We
;; do this by making a small secondary overlay to contain just that
;; one character.
;; do this by making a small secondary overlay to contain just that
;; one character. BUT we only do this if there is more than one
;; character (so we don't do this for the character widget),
;; or if the size of the editable field isn't specified.
(let ((overlay (make-overlay (1- to) to nil t nil)))
(overlay-put overlay 'field 'boundary)
;; We need the real field for tabbing.
@ -3524,7 +3527,7 @@ To use this type, you must define :match or :match-alternatives."
:value 0
:size 1
:format "%{%t%}: %v\n"
:valid-regexp "\\`.\\'"
:valid-regexp "\\`\\(.\\|\n\\)\\'"
:error "This field should contain a single character"
:value-get (lambda (w) (widget-field-value-get w t))
:value-to-internal (lambda (_widget value)

139
src/dbusbind.c
View file

@ -44,7 +44,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* Alist of D-Bus buses we are polling for messages.
The key is the symbol or string of the bus, and the value is the
connection address. */
connection address. For every bus, just one connection is counted.
If there shall be a second connection to the same bus, a different
symbol or string for the bus must be chosen. On Lisp level, a bus
stands for the associated connection. */
static Lisp_Object xd_registered_buses;
/* Whether we are reading a D-Bus event. */
@ -279,10 +282,13 @@ XD_OBJECT_TO_STRING (Lisp_Object object)
else \
{ \
CHECK_SYMBOL (bus); \
if (!(EQ (bus, QCsystem) || EQ (bus, QCsession))) \
if (!(EQ (bus, QCsystem) || EQ (bus, QCsession) \
|| EQ (bus, QCsystem_private) \
|| EQ (bus, QCsession_private))) \
XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \
/* We do not want to have an autolaunch for the session bus. */ \
if (EQ (bus, QCsession) && session_bus_address == NULL) \
if ((EQ (bus, QCsession) || EQ (bus, QCsession_private)) \
&& session_bus_address == NULL) \
XD_SIGNAL2 (build_string ("No connection to bus"), bus); \
} \
} while (0)
@ -968,8 +974,9 @@ xd_lisp_dbus_to_dbus (Lisp_Object bus)
return xmint_pointer (bus);
}
/* Return D-Bus connection address. BUS is either a Lisp symbol,
:system or :session, or a string denoting the bus address. */
/* Return D-Bus connection address.
BUS is either a Lisp symbol, :system, :session, :system-private or
:session-private, or a string denoting the bus address. */
static DBusConnection *
xd_get_connection_address (Lisp_Object bus)
{
@ -1031,7 +1038,8 @@ xd_add_watch (DBusWatch *watch, void *data)
}
/* Stop monitoring WATCH for possible I/O.
DATA is the used bus, either a string or QCsystem or QCsession. */
DATA is the used bus, either a string or QCsystem, QCsession,
QCsystem_private or QCsession_private. */
static void
xd_remove_watch (DBusWatch *watch, void *data)
{
@ -1046,7 +1054,7 @@ xd_remove_watch (DBusWatch *watch, void *data)
/* Unset session environment. */
#if 0
/* This is buggy, since unsetenv is not thread-safe. */
if (XSYMBOL (QCsession) == data)
if (XSYMBOL (QCsession) == data) || (XSYMBOL (QCsession_private) == data)
{
XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
unsetenv ("DBUS_SESSION_BUS_ADDRESS");
@ -1120,6 +1128,11 @@ can be a string denoting the address of the corresponding bus. For
the system and session buses, this function is called when loading
`dbus.el', there is no need to call it again.
A special case is BUS being the symbol `:system-private' or
`:session-private'. These symbols still denote the system or session
bus, but using a private connection. They should not be used outside
dbus.el.
The function returns a number, which counts the connections this Emacs
session has established to the BUS under the same unique name (see
`dbus-get-unique-name'). It depends on the libraries Emacs is linked
@ -1142,6 +1155,10 @@ this connection to those buses. */)
ptrdiff_t refcount;
/* Check parameter. */
if (!NILP (private))
bus = EQ (bus, QCsystem)
? QCsystem_private
: EQ (bus, QCsession) ? QCsession_private : bus;
XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
/* Close bus if it is already open. */
@ -1169,8 +1186,9 @@ this connection to those buses. */)
else
{
DBusBusType bustype = (EQ (bus, QCsystem)
? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION);
DBusBusType bustype
= EQ (bus, QCsystem) || EQ (bus, QCsystem_private)
? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION;
if (NILP (private))
connection = dbus_bus_get (bustype, &derror);
else
@ -1184,9 +1202,9 @@ this connection to those buses. */)
XD_SIGNAL2 (build_string ("No connection to bus"), bus);
/* If it is not the system or session bus, we must register
ourselves. Otherwise, we have called dbus_bus_get, which has
configured us to exit if the connection closes - we undo this
setting. */
ourselves. Otherwise, we have called dbus_bus_get{_private},
which has configured us to exit if the connection closes - we
undo this setting. */
if (STRINGP (bus))
dbus_bus_register (connection, &derror);
else
@ -1215,6 +1233,9 @@ this connection to those buses. */)
dbus_error_free (&derror);
}
XD_DEBUG_MESSAGE ("Registered buses: %s",
XD_OBJECT_TO_STRING (xd_registered_buses));
/* Return reference counter. */
refcount = xd_get_connection_references (connection);
XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
@ -1533,8 +1554,8 @@ usage: (dbus-message-internal &rest REST) */)
}
/* Read one queued incoming message of the D-Bus BUS.
BUS is either a Lisp symbol, :system or :session, or a string denoting
the bus address. */
BUS is either a Lisp symbol, :system, :session, :system-private or
:session-private, or a string denoting the bus address. */
static void
xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
{
@ -1546,7 +1567,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
int mtype;
dbus_uint32_t serial;
unsigned int ui_serial;
const char *uname, *path, *interface, *member, *error_name;
const char *uname, *destination, *path, *interface, *member, *error_name;
dmessage = dbus_connection_pop_message (connection);
@ -1579,6 +1600,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
? dbus_message_get_reply_serial (dmessage)
: dbus_message_get_serial (dmessage);
uname = dbus_message_get_sender (dmessage);
destination = dbus_message_get_destination (dmessage);
path = dbus_message_get_path (dmessage);
interface = dbus_message_get_interface (dmessage);
member = dbus_message_get_member (dmessage);
@ -1586,7 +1608,8 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s %s",
XD_MESSAGE_TYPE_TO_STRING (mtype),
ui_serial, uname, path, interface, member, error_name,
ui_serial, uname, destination, path, interface,
mtype == DBUS_MESSAGE_TYPE_ERROR ? error_name : member,
XD_OBJECT_TO_STRING (args));
if (mtype == DBUS_MESSAGE_TYPE_INVALID)
@ -1601,7 +1624,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
/* There shall be exactly one entry. Construct an event. */
if (NILP (value))
goto cleanup;
goto monitor;
/* Remove the entry. */
Fremhash (key, Vdbus_registered_objects_table);
@ -1610,11 +1633,8 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
EVENT_INIT (event);
event.kind = DBUS_EVENT;
event.frame_or_window = Qnil;
event.arg =
Fcons (value,
(mtype == DBUS_MESSAGE_TYPE_ERROR)
? Fcons (list2 (QCstring, build_string (error_name)), args)
: args);
/* Handler. */
event.arg = Fcons (value, args);
}
else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */
@ -1622,7 +1642,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
/* Vdbus_registered_objects_table requires non-nil interface and
member. */
if ((interface == NULL) || (member == NULL))
goto cleanup;
goto monitor;
/* Search for a registered function of the message. */
key = list4 (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL ? QCmethod : QCsignal,
@ -1647,6 +1667,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
EVENT_INIT (event);
event.kind = DBUS_EVENT;
event.frame_or_window = Qnil;
/* Handler. */
event.arg
= Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))), args);
break;
@ -1655,16 +1676,22 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
}
if (NILP (value))
goto cleanup;
goto monitor;
}
/* Add type, serial, uname, path, interface and member to the event. */
event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
event.arg);
/* Add type, serial, uname, destination, path, interface and member
or error_name to the event. */
event.arg
= Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR
? error_name == NULL ? Qnil : build_string (error_name)
: member == NULL ? Qnil : build_string (member),
event.arg);
event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
event.arg);
event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
event.arg);
event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)),
event.arg);
event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
event.arg);
event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
@ -1678,14 +1705,58 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg));
/* Monitor. */
monitor:
/* Search for a registered function of the message. */
key = list2 (QCmonitor, bus);
value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
/* There shall be exactly one entry. Construct an event. */
if (NILP (value))
goto cleanup;
/* Construct an event. */
EVENT_INIT (event);
event.kind = DBUS_EVENT;
event.frame_or_window = Qnil;
/* Add type, serial, uname, destination, path, interface, member
or error_name and handler to the event. */
event.arg
= Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (CAR_SAFE (value))))),
args);
event.arg
= Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR
? error_name == NULL ? Qnil : build_string (error_name)
: member == NULL ? Qnil : build_string (member),
event.arg);
event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
event.arg);
event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
event.arg);
event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)),
event.arg);
event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
event.arg);
event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
event.arg = Fcons (make_fixnum (mtype), event.arg);
/* Add the bus symbol to the event. */
event.arg = Fcons (bus, event.arg);
/* Store it into the input event queue. */
kbd_buffer_store_event (&event);
XD_DEBUG_MESSAGE ("Monitor event stored: %s", XD_OBJECT_TO_STRING (event.arg));
/* Cleanup. */
cleanup:
dbus_message_unref (dmessage);
}
/* Read queued incoming messages of the D-Bus BUS.
BUS is either a Lisp symbol, :system or :session, or a string denoting
the bus address. */
BUS is either a Lisp symbol, :system, :session, :system-private or
:session-private, or a string denoting the bus address. */
static Lisp_Object
xd_read_message (Lisp_Object bus)
{
@ -1762,6 +1833,8 @@ syms_of_dbusbind (void)
/* Lisp symbols of the system and session buses. */
DEFSYM (QCsystem, ":system");
DEFSYM (QCsession, ":session");
DEFSYM (QCsystem_private, ":system-private");
DEFSYM (QCsession_private, ":session-private");
/* Lisp symbol for method call timeout. */
DEFSYM (QCtimeout, ":timeout");
@ -1788,10 +1861,11 @@ syms_of_dbusbind (void)
DEFSYM (QCdict_entry, ":dict-entry");
/* Lisp symbols of objects in `dbus-registered-objects-table'.
`:property', which does exist there as well, is not used here. */
`:property', which does exist there as well, is not declared here. */
DEFSYM (QCserial, ":serial");
DEFSYM (QCmethod, ":method");
DEFSYM (QCsignal, ":signal");
DEFSYM (QCmonitor, ":monitor");
DEFVAR_LISP ("dbus-compiled-version",
Vdbus_compiled_version,
@ -1867,8 +1941,9 @@ path of the sending object. All of them can be nil, which means a
wildcard then.
OBJECT is either the handler to be called when a D-Bus message, which
matches the key criteria, arrives (TYPE `:method' and `:signal'), or a
list (ACCESS EMITS-SIGNAL VALUE) for TYPE `:property'.
matches the key criteria, arrives (TYPE `:method', `:signal' and
`:monitor'), or a list (ACCESS EMITS-SIGNAL VALUE) for TYPE
`:property'.
For entries of type `:signal', there is also a fifth element RULE,
which keeps the match string the signal is registered with.

52
src/fns.c
View file

@ -5454,6 +5454,57 @@ It should not be used for anything security-related. See
return make_digest_string (digest, SHA1_DIGEST_SIZE);
}
DEFUN ("string-search", Fstring_search, Sstring_search, 2, 3, 0,
doc: /* Search for the string NEEDLE in the string HAYSTACK.
The return value is the position of the first occurrence of NEEDLE in
HAYSTACK, or nil if no match was found.
The optional START-POS argument says where to start searching in
HAYSTACK and defaults to zero (start at the beginning).
It must be between zero and the length of HAYSTACK, inclusive.
Case is always significant and text properties are ignored. */)
(register Lisp_Object needle, Lisp_Object haystack, Lisp_Object start_pos)
{
ptrdiff_t start_byte = 0, haybytes;
char *res, *haystart;
CHECK_STRING (needle);
CHECK_STRING (haystack);
if (!NILP (start_pos))
{
CHECK_FIXNUM (start_pos);
EMACS_INT start = XFIXNUM (start_pos);
if (start < 0 || start > SCHARS (haystack))
xsignal1 (Qargs_out_of_range, start_pos);
start_byte = string_char_to_byte (haystack, start);
}
haystart = SSDATA (haystack) + start_byte;
haybytes = SBYTES (haystack) - start_byte;
if (STRING_MULTIBYTE (haystack) == STRING_MULTIBYTE (needle))
res = memmem (haystart, haybytes,
SSDATA (needle), SBYTES (needle));
else if (STRING_MULTIBYTE (haystack)) /* unibyte needle */
{
Lisp_Object multi_needle = string_to_multibyte (needle);
res = memmem (haystart, haybytes,
SSDATA (multi_needle), SBYTES (multi_needle));
}
else /* unibyte haystack, multibyte needle */
{
Lisp_Object uni_needle = Fstring_as_unibyte (needle);
res = memmem (haystart, haybytes,
SSDATA (uni_needle), SBYTES (uni_needle));
}
if (! res)
return Qnil;
return make_int (string_byte_to_char (haystack, res - SSDATA (haystack)));
}
void
@ -5494,6 +5545,7 @@ syms_of_fns (void)
defsubr (&Sremhash);
defsubr (&Smaphash);
defsubr (&Sdefine_hash_table_test);
defsubr (&Sstring_search);
/* Crypto and hashing stuff. */
DEFSYM (Qiv_auto, "iv-auto");

240
src/nsfont.m
View file

@ -39,9 +39,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu)
#include "pdumper.h"
/* TODO: Drop once we can assume gnustep-gui 0.17.1. */
#ifdef NS_IMPL_GNUSTEP
#import <AppKit/NSFontDescriptor.h>
#endif
#define NSFONT_TRACE 0
#define LCD_SMOOTHING_MARGIN 2
@ -237,12 +235,6 @@ ns_char_width (NSFont *sfont, int c)
CGFloat w = -1.0;
NSString *cstr = [NSString stringWithFormat: @"%c", c];
#ifdef NS_IMPL_COCOA
NSGlyph glyph = [sfont glyphWithName: cstr];
if (glyph)
w = [sfont advancementForGlyph: glyph].width;
#endif
if (w < 0.0)
{
NSDictionary *attrsDictionary =
@ -273,12 +265,6 @@ ns_ascii_average_width (NSFont *sfont)
ascii_printable = [[NSString alloc] initWithFormat: @"%s", chars];
}
#ifdef NS_IMPL_COCOA
NSGlyph glyph = [sfont glyphWithName: ascii_printable];
if (glyph)
w = [sfont advancementForGlyph: glyph].width;
#endif
if (w < (CGFloat) 0.0)
{
NSDictionary *attrsDictionary =
@ -511,10 +497,6 @@ static NSSet
}
[charset release];
}
#ifdef NS_IMPL_COCOA
if ([families count] == 0)
[families addObject: @"LastResort"];
#endif
[scriptToFamilies setObject: families forKey: script];
}
@ -734,11 +716,6 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
traits: traits & ~NSItalicFontMask
weight: fixLeopardBug size: pixel_size];
}
#ifdef NS_IMPL_COCOA
/* LastResort not really a family */
if (nsfont == nil && [@"LastResort" isEqualToString: family])
nsfont = [NSFont fontWithName: @"LastResort" size: pixel_size];
#endif
if (nsfont == nil)
{
@ -765,12 +742,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
font_info->metrics = xzalloc (0x100 * sizeof *font_info->metrics);
/* for metrics */
#ifdef NS_IMPL_COCOA
sfont = [nsfont screenFontWithRenderingMode:
NSFontAntialiasedIntegerAdvancementsRenderingMode];
#else
sfont = [nsfont screenFont];
#endif
if (sfont == nil)
sfont = nsfont;
@ -797,11 +769,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
* intended. */
CGFloat adjusted_descender = [sfont descender] + 0.0001;
#ifdef NS_IMPL_GNUSTEP
font_info->nsfont = sfont;
#else
font_info->nsfont = nsfont;
#endif
[font_info->nsfont retain];
/* set up ns_font (defined in nsgui.h) */
@ -834,32 +802,6 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
font_info->max_bounds.rbearing =
lrint (brect.size.width - (CGFloat) font_info->width);
#ifdef NS_IMPL_COCOA
/* set up synthItal and the CG font */
font_info->synthItal = synthItal;
{
ATSFontRef atsFont = ATSFontFindFromPostScriptName
((CFStringRef)[nsfont fontName], kATSOptionFlagsDefault);
if (atsFont == kATSFontRefUnspecified)
{
/* see if we can get it by dropping italic (then synthesizing) */
atsFont = ATSFontFindFromPostScriptName ((CFStringRef)
[[fontMgr convertFont: nsfont toNotHaveTrait: NSItalicFontMask]
fontName], kATSOptionFlagsDefault);
if (atsFont != kATSFontRefUnspecified)
font_info->synthItal = YES;
else
{
/* last resort fallback */
atsFont = ATSFontFindFromPostScriptName
((CFStringRef)@"Monaco", kATSOptionFlagsDefault);
}
}
font_info->cgfont = CGFontCreateWithPlatformFont ((void *) &atsFont);
}
#endif
/* set up metrics portion of font struct */
font->ascent = lrint([sfont ascender]);
font->descent = -lrint(floor(adjusted_descender));
@ -901,9 +843,6 @@ nsfont_close (struct font *font)
xfree (font_info->glyphs);
xfree (font_info->metrics);
[font_info->nsfont release];
#ifdef NS_IMPL_COCOA
CGFontRelease (font_info->cgfont);
#endif
xfree (font_info->name);
font_info->name = NULL;
}
@ -994,17 +933,12 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
{
static unsigned char cbuf[1024];
unsigned char *c = cbuf;
#ifdef NS_IMPL_GNUSTEP
#if GNUSTEP_GUI_MAJOR_VERSION > 0 || GNUSTEP_GUI_MINOR_VERSION > 22
static CGFloat advances[1024];
CGFloat *adv = advances;
#else
static float advances[1024];
float *adv = advances;
#endif
#else
static CGSize advances[1024];
CGSize *adv = advances;
#endif
struct face *face;
NSRect r;
@ -1073,11 +1007,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
else
{
cwidth = LGLYPH_WADJUST (glyph);
#ifdef NS_IMPL_GNUSTEP
*(adv-1) += LGLYPH_XOFF (glyph);
#else
(*(adv-1)).width += LGLYPH_XOFF (glyph);
#endif
}
}
}
@ -1088,12 +1018,8 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
cwidth = font->metrics[hi][lo].width;
}
twidth += cwidth;
#ifdef NS_IMPL_GNUSTEP
*adv++ = cwidth;
c += CHAR_STRING (*t, c); /* This converts the char to UTF-8. */
#else
(*adv++).width = cwidth;
#endif
}
len = adv - advances;
r.size.width = twidth;
@ -1192,61 +1118,6 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
DPSgrestore (context);
}
#else /* NS_IMPL_COCOA */
{
CGContextRef gcontext =
[[NSGraphicsContext currentContext] graphicsPort];
static CGAffineTransform fliptf;
static BOOL firstTime = YES;
if (firstTime)
{
firstTime = NO;
fliptf = CGAffineTransformMakeScale (1.0, -1.0);
}
CGContextSaveGState (gcontext);
// Used to be Fix2X (kATSItalicQDSkew), but Fix2X is deprecated
// and kATSItalicQDSkew is 0.25.
fliptf.c = font->synthItal ? 0.25 : 0.0;
CGContextSetFont (gcontext, font->cgfont);
CGContextSetFontSize (gcontext, font->size);
if (NILP (ns_antialias_text) || font->size <= ns_antialias_threshold)
CGContextSetShouldAntialias (gcontext, 0);
else
CGContextSetShouldAntialias (gcontext, 1);
CGContextSetTextMatrix (gcontext, fliptf);
if (bgCol != nil)
{
/* foreground drawing; erase first to avoid overstrike */
[bgCol set];
CGContextSetTextDrawingMode (gcontext, kCGTextFillStroke);
CGContextSetTextPosition (gcontext, r.origin.x, r.origin.y);
CGContextShowGlyphsWithAdvances (gcontext, s->char2b, advances, len);
CGContextSetTextDrawingMode (gcontext, kCGTextFill);
}
[col set];
CGContextSetTextPosition (gcontext, r.origin.x, r.origin.y);
CGContextShowGlyphsWithAdvances (gcontext, s->char2b + from,
advances, len);
if (face->overstrike)
{
CGContextSetTextPosition (gcontext, r.origin.x+0.5, r.origin.y);
CGContextShowGlyphsWithAdvances (gcontext, s->char2b + from,
advances, len);
}
CGContextRestoreGState (gcontext);
}
#endif /* NS_IMPL_COCOA */
unblock_input ();
return to-from;
}
@ -1264,10 +1135,6 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y,
static void
ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
{
#ifdef NS_IMPL_COCOA
static EmacsGlyphStorage *glyphStorage;
static char firstTime = 1;
#endif
unichar *unichars = xmalloc (0x101 * sizeof (unichar));
unsigned int i, g, idx;
unsigned short *glyphs;
@ -1278,14 +1145,6 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
block_input ();
#ifdef NS_IMPL_COCOA
if (firstTime)
{
firstTime = 0;
glyphStorage = [[EmacsGlyphStorage alloc] initWithCapacity: 0x100];
}
#endif
font_info->glyphs[block] = xmalloc (0x100 * sizeof (unsigned short));
if (!unichars || !(font_info->glyphs[block]))
emacs_abort ();
@ -1299,38 +1158,16 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block)
unichars[0x100] = 0;
{
#ifdef NS_IMPL_COCOA
NSString *allChars = [[NSString alloc]
initWithCharactersNoCopy: unichars
length: 0x100
freeWhenDone: NO];
NSGlyphGenerator *glyphGenerator = [NSGlyphGenerator sharedGlyphGenerator];
/* NSCharacterSet *coveredChars = [nsfont coveredCharacterSet]; */
unsigned int numGlyphs = [font_info->nsfont numberOfGlyphs];
NSUInteger gInd = 0, cInd = 0;
[glyphStorage setString: allChars font: font_info->nsfont];
[glyphGenerator generateGlyphsForGlyphStorage: glyphStorage
desiredNumberOfCharacters: glyphStorage->maxChar
glyphIndex: &gInd characterIndex: &cInd];
#endif
glyphs = font_info->glyphs[block];
for (i = 0; i < 0x100; i++, glyphs++)
{
#ifdef NS_IMPL_GNUSTEP
g = unichars[i];
#else
g = glyphStorage->cglyphs[i];
/* TODO: is this a good check? Maybe need to use coveredChars. */
if (g > numGlyphs || g == NSNullGlyph)
g = INVALID_GLYPH; /* Hopefully unused... */
#endif
*glyphs = g;
}
#ifdef NS_IMPL_COCOA
[allChars release];
#endif
}
unblock_input ();
@ -1352,19 +1189,12 @@ ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block)
fprintf (stderr, "%p\tComputing metrics for glyphs in block %d\n",
font_info, block);
#ifdef NS_IMPL_GNUSTEP
/* not implemented yet (as of startup 0.18), so punt */
if (numGlyphs == 0)
numGlyphs = 0x10000;
#endif
block_input ();
#ifdef NS_IMPL_COCOA
sfont = [font_info->nsfont screenFontWithRenderingMode:
NSFontAntialiasedIntegerAdvancementsRenderingMode];
#else
sfont = [font_info->nsfont screenFont];
#endif
font_info->metrics[block] = xzalloc (0x100 * sizeof (struct font_metrics));
if (!(font_info->metrics[block]))
@ -1397,76 +1227,6 @@ ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block)
}
#ifdef NS_IMPL_COCOA
/* Helper for font glyph setup. */
@implementation EmacsGlyphStorage
- init
{
return [self initWithCapacity: 1024];
}
- initWithCapacity: (unsigned long) c
{
self = [super init];
maxChar = 0;
maxGlyph = 0;
dict = [NSMutableDictionary new];
cglyphs = xmalloc (c * sizeof (CGGlyph));
return self;
}
- (void) dealloc
{
if (attrStr != nil)
[attrStr release];
[dict release];
xfree (cglyphs);
[super dealloc];
}
- (void) setString: (NSString *)str font: (NSFont *)font
{
[dict setObject: font forKey: NSFontAttributeName];
if (attrStr != nil)
[attrStr release];
attrStr = [[NSAttributedString alloc] initWithString: str attributes: dict];
maxChar = [str length];
maxGlyph = 0;
}
/* NSGlyphStorage protocol */
- (NSUInteger)layoutOptions
{
return 0;
}
- (NSAttributedString *)attributedString
{
return attrStr;
}
- (void)insertGlyphs: (const NSGlyph *)glyphs length: (NSUInteger)length
forStartingGlyphAtIndex: (NSUInteger)glyphIndex
characterIndex: (NSUInteger)charIndex
{
len = glyphIndex+length;
for (i =glyphIndex; i<len; i++)
cglyphs[i] = glyphs[i-glyphIndex];
if (len > maxGlyph)
maxGlyph = len;
}
- (void)setIntAttribute: (NSInteger)attributeTag value: (NSInteger)val
forGlyphAtIndex: (NSUInteger)glyphIndex
{
return;
}
@end
#endif /* NS_IMPL_COCOA */
/* Debugging */
void
ns_dump_glyphstring (struct glyph_string *s)

12
src/nsimage.m
View file

@ -36,6 +36,14 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
#include "coding.h"
#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MAX_ALLOWED < 1070
# define COLORSPACE_NAME NSCalibratedRGBColorSpace
#else
# define COLORSPACE_NAME \
((ns_use_srgb_colorspace && NSAppKitVersionNumber >= NSAppKitVersionNumber10_7) \
? NSDeviceRGBColorSpace : NSCalibratedRGBColorSpace)
#endif
/* ==========================================================================
@ -295,7 +303,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
pixelsWide: w pixelsHigh: h
bitsPerSample: 8 samplesPerPixel: 4
hasAlpha: YES isPlanar: YES
colorSpaceName: NSCalibratedRGBColorSpace
colorSpaceName: COLORSPACE_NAME
bytesPerRow: w bitsPerPixel: 0];
[bmRep getBitmapDataPlanes: planes];
@ -415,7 +423,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a)
/* keep things simple for now */
bitsPerSample: 8 samplesPerPixel: 4 /*RGB+A*/
hasAlpha: YES isPlanar: YES
colorSpaceName: NSCalibratedRGBColorSpace
colorSpaceName: COLORSPACE_NAME
bytesPerRow: width bitsPerPixel: 0];
[bmRep getBitmapDataPlanes: pixmapData];

41
src/nsterm.h
View file

@ -718,22 +718,6 @@ typedef id instancetype;
========================================================================== */
#ifdef NS_IMPL_COCOA
/* rendering util */
@interface EmacsGlyphStorage : NSObject <NSGlyphStorage>
{
@public
NSAttributedString *attrStr;
NSMutableDictionary *dict;
CGGlyph *cglyphs;
unsigned long maxChar, maxGlyph;
long i, len;
}
- (instancetype)initWithCapacity: (unsigned long) c;
- (void) setString: (NSString *)str font: (NSFont *)font;
@end
#endif /* NS_IMPL_COCOA */
extern NSArray *ns_send_types, *ns_return_types;
extern NSString *ns_app_name;
extern EmacsMenu *svcsMenu;
@ -811,6 +795,7 @@ struct ns_color_table
#define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG(color) * 0x101)
#define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG(color) * 0x101)
#ifdef NS_IMPL_GNUSTEP
/* this extends font backend font */
struct nsfont_info
{
@ -827,14 +812,8 @@ struct nsfont_info
float size;
#ifdef __OBJC__
NSFont *nsfont;
#if defined (NS_IMPL_COCOA)
CGFontRef cgfont;
#else /* GNUstep */
void *cgfont;
#endif
#else /* ! OBJC */
void *nsfont;
void *cgfont;
#endif
char bold, ital; /* convenience flags */
char synthItal;
@ -844,7 +823,7 @@ struct nsfont_info
unsigned short **glyphs; /* map Unicode index to glyph */
struct font_metrics **metrics;
};
#endif
/* Initialized in ns_initialize_display_info (). */
struct ns_display_info
@ -1107,7 +1086,7 @@ extern void ns_term_shutdown (int sig);
#define NS_DUMPGLYPH_MOUSEFACE 3
#ifdef NS_IMPL_GNUSTEP
/* In nsfont, called from fontset.c */
extern void nsfont_make_fontset_for_font (Lisp_Object name,
Lisp_Object font_object);
@ -1115,6 +1094,7 @@ extern void nsfont_make_fontset_for_font (Lisp_Object name,
/* In nsfont, for debugging */
struct glyph_string;
void ns_dump_glyphstring (struct glyph_string *s) EXTERNALLY_VISIBLE;
#endif
/* Implemented in nsterm, published in or needed from nsfns. */
extern Lisp_Object ns_list_fonts (struct frame *f, Lisp_Object pattern,
@ -1274,6 +1254,19 @@ extern char gnustep_base_version[]; /* version tracking */
? (min) : (((x)>(max)) ? (max) : (x)))
#define SCREENMAXBOUND(x) (IN_BOUND (-SCREENMAX, x, SCREENMAX))
#ifdef NS_IMPL_COCOA
/* Add some required AppKit version numbers if they're not defined. */
#ifndef NSAppKitVersionNumber10_7
#define NSAppKitVersionNumber10_7 1138
#endif
#ifndef NSAppKitVersionNumber10_10
#define NSAppKitVersionNumber10_10 1343
#endif
#endif /* NS_IMPL_COCOA */
/* macOS 10.7 introduces some new constants. */
#if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_7)
#define NSFullScreenWindowMask (1 << 14)

105
src/nsterm.m
View file

@ -140,14 +140,9 @@ char const * nstrace_fullscreen_type_name (int fs_type)
+ (NSColor *)colorForEmacsRed:(CGFloat)red green:(CGFloat)green
blue:(CGFloat)blue alpha:(CGFloat)alpha
{
#if defined (NS_IMPL_COCOA) \
&& MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
if (ns_use_srgb_colorspace
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070
&& [NSColor respondsToSelector:
@selector(colorWithSRGBRed:green:blue:alpha:)]
#endif
)
&& NSAppKitVersionNumber >= NSAppKitVersionNumber10_7)
return [NSColor colorWithSRGBRed: red
green: green
blue: blue
@ -161,28 +156,12 @@ char const * nstrace_fullscreen_type_name (int fs_type)
- (NSColor *)colorUsingDefaultColorSpace
{
/* FIXME: We're checking for colorWithSRGBRed here so this will only
work in the same place as in the method above. It should really
be a check whether we're on macOS 10.7 or above. */
#if defined (NS_IMPL_COCOA) \
&& MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070
if ([NSColor respondsToSelector:
@selector(colorWithSRGBRed:green:blue:alpha:)])
#endif
{
if (ns_use_srgb_colorspace)
return [self colorUsingColorSpace: [NSColorSpace sRGBColorSpace]];
else
return [self colorUsingColorSpace: [NSColorSpace deviceRGBColorSpace]];
}
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070
else
#endif
#endif /* NS_IMPL_COCOA && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 */
#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 1070
return [self colorUsingColorSpaceName: NSCalibratedRGBColorSpace];
#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
if (ns_use_srgb_colorspace
&& NSAppKitVersionNumber >= NSAppKitVersionNumber10_7)
return [self colorUsingColorSpace: [NSColorSpace sRGBColorSpace]];
#endif
return [self colorUsingColorSpace: [NSColorSpace deviceRGBColorSpace]];
}
@end
@ -2209,10 +2188,6 @@ ns_set_appearance (struct frame *f, Lisp_Object new_value, Lisp_Object old_value
NSTRACE ("ns_set_appearance");
#ifndef NSAppKitVersionNumber10_10
#define NSAppKitVersionNumber10_10 1343
#endif
if (NSAppKitVersionNumber < NSAppKitVersionNumber10_10)
return;
@ -3052,6 +3027,40 @@ ns_scroll_run (struct window *w, struct run *run)
}
static void
ns_clear_under_internal_border (struct frame *f)
{
NSTRACE ("ns_clear_under_internal_border");
if (FRAME_INTERNAL_BORDER_WIDTH (f) > 0)
{
int border_width = FRAME_INTERNAL_BORDER_WIDTH (f);
NSView *view = FRAME_NS_VIEW (f);
NSRect edge_rect, frame_rect = [view bounds];
NSRectEdge edge[] = {NSMinXEdge, NSMinYEdge, NSMaxXEdge, NSMaxYEdge};
int face_id =
!NILP (Vface_remapping_alist)
? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
: INTERNAL_BORDER_FACE_ID;
struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
if (!face)
face = FRAME_DEFAULT_FACE (f);
ns_focus (f, &frame_rect, 1);
[ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set];
for (int i = 0; i < 4 ; i++)
{
NSDivideRect (frame_rect, &edge_rect, &frame_rect, border_width, edge[i]);
NSRectFill (edge_rect);
}
ns_unfocus (f);
}
}
static void
ns_after_update_window_line (struct window *w, struct glyph_row *desired_row)
/* --------------------------------------------------------------------------
@ -3080,12 +3089,32 @@ ns_after_update_window_line (struct window *w, struct glyph_row *desired_row)
height > 0))
{
int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y));
int face_id =
!NILP (Vface_remapping_alist)
? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
: INTERNAL_BORDER_FACE_ID;
struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
block_input ();
ns_clear_frame_area (f, 0, y, width, height);
ns_clear_frame_area (f,
FRAME_PIXEL_WIDTH (f) - width,
y, width, height);
if (face)
{
NSRect r = NSMakeRect (0, y, FRAME_PIXEL_WIDTH (f), height);
ns_focus (f, &r, 1);
[ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set];
NSRectFill (NSMakeRect (0, y, width, height));
NSRectFill (NSMakeRect (FRAME_PIXEL_WIDTH (f) - width,
y, width, height));
ns_unfocus (f);
}
else
{
ns_clear_frame_area (f, 0, y, width, height);
ns_clear_frame_area (f,
FRAME_PIXEL_WIDTH (f) - width,
y, width, height);
}
unblock_input ();
}
}
@ -3140,10 +3169,12 @@ ns_compute_glyph_string_overhangs (struct glyph_string *s)
else
{
s->left_overhang = 0;
#ifdef NS_IMPL_GNUSTEP
if (EQ (font->driver->type, Qns))
s->right_overhang = ((struct nsfont_info *)font)->ital ?
FONT_HEIGHT (font) * 0.2 : 0;
else
#endif
s->right_overhang = 0;
}
}
@ -5301,7 +5332,7 @@ static struct redisplay_interface ns_redisplay_interface =
ns_draw_glyph_string,
ns_define_frame_cursor,
ns_clear_frame_area,
0, /* clear_under_internal_border */
ns_clear_under_internal_border, /* clear_under_internal_border */
ns_draw_window_cursor,
ns_draw_vertical_window_border,
ns_draw_window_divider,

39
src/process.c
View file

@ -1205,6 +1205,16 @@ not the name of the pty that Emacs uses to talk with that terminal. */)
return XPROCESS (process)->tty_name;
}
static void
update_process_mark (struct Lisp_Process *p)
{
Lisp_Object buffer = p->buffer;
if (BUFFERP (buffer))
set_marker_both (p->mark, buffer,
BUF_ZV (XBUFFER (buffer)),
BUF_ZV_BYTE (XBUFFER (buffer)));
}
DEFUN ("set-process-buffer", Fset_process_buffer, Sset_process_buffer,
2, 2, 0,
doc: /* Set buffer associated with PROCESS to BUFFER (a buffer, or nil).
@ -1217,7 +1227,11 @@ Return BUFFER. */)
if (!NILP (buffer))
CHECK_BUFFER (buffer);
p = XPROCESS (process);
pset_buffer (p, buffer);
if (!EQ (p->buffer, buffer))
{
pset_buffer (p, buffer);
update_process_mark (p);
}
if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p))
pset_childp (p, Fplist_put (p->childp, QCbuffer, buffer));
setup_process_coding_systems (process);
@ -1637,6 +1651,7 @@ DEFUN ("process-list", Fprocess_list, Sprocess_list, 0, 0, 0,
return Fmapcar (Qcdr, Vprocess_alist);
}
/* Starting asynchronous inferior processes. */
DEFUN ("make-process", Fmake_process, Smake_process, 0, MANY, 0,
@ -1805,10 +1820,7 @@ usage: (make-process &rest ARGS) */)
: EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2);
/* Make the process marker point into the process buffer (if any). */
if (BUFFERP (buffer))
set_marker_both (XPROCESS (proc)->mark, buffer,
BUF_ZV (XBUFFER (buffer)),
BUF_ZV_BYTE (XBUFFER (buffer)));
update_process_mark (XPROCESS (proc));
USE_SAFE_ALLOCA;
@ -2453,10 +2465,7 @@ usage: (make-pipe-process &rest ARGS) */)
: EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2);
/* Make the process marker point into the process buffer (if any). */
if (BUFFERP (buffer))
set_marker_both (p->mark, buffer,
BUF_ZV (XBUFFER (buffer)),
BUF_ZV_BYTE (XBUFFER (buffer)));
update_process_mark (p);
{
/* Setup coding systems for communicating with the network stream. */
@ -3182,12 +3191,7 @@ usage: (make-serial-process &rest ARGS) */)
if (!EQ (p->command, Qt))
add_process_read_fd (fd);
if (BUFFERP (buffer))
{
set_marker_both (p->mark, buffer,
BUF_ZV (XBUFFER (buffer)),
BUF_ZV_BYTE (XBUFFER (buffer)));
}
update_process_mark (p);
tem = Fplist_get (contact, QCcoding);
@ -3664,10 +3668,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos,
pset_status (p, Qlisten);
/* Make the process marker point into the process buffer (if any). */
if (BUFFERP (p->buffer))
set_marker_both (p->mark, p->buffer,
BUF_ZV (XBUFFER (p->buffer)),
BUF_ZV_BYTE (XBUFFER (p->buffer)));
update_process_mark (p);
if (p->is_non_blocking_client)
{

7
src/syntax.c
View file

@ -2354,6 +2354,13 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
/* We have encountered a nested comment of the same style
as the comment sequence which began this comment section. */
nesting++;
if (comment_end_can_be_escaped
&& (code == Sescape || code == Scharquote))
{
inc_both (&from, &from_byte);
UPDATE_SYNTAX_TABLE_FORWARD (from);
if (from == stop) continue; /* Failure */
}
inc_both (&from, &from_byte);
UPDATE_SYNTAX_TABLE_FORWARD (from);

13
src/xdisp.c
View file

@ -11809,7 +11809,20 @@ resize_mini_window (struct window *w, bool exact_p)
height = (max_height / unit) * unit;
init_iterator (&it, w, ZV, ZV_BYTE, NULL, DEFAULT_FACE_ID);
move_it_vertically_backward (&it, height - unit);
/* The following move is usually a no-op when the stuff
displayed in the mini-window comes entirely from buffer
text, but it is needed when some of it comes from overlay
strings, especially when there's an after-string at ZV.
This happens with some completion packages, like
icomplete, ido-vertical, etc. With those packages, if we
don't force w->start to be at the beginning of a screen
line, important parts of the stuff in the mini-window,
such as user prompt, will be hidden from view. */
move_it_by_lines (&it, 0);
start = it.current.pos;
/* Prevent redisplay_window from recentering, and thus from
overriding the window-start point we computed here. */
w->start_at_line_beg = false;
}
else
SET_TEXT_POS (start, BEGV, BEGV_BYTE);

148
test/lisp/allout-tests.el Normal file
View file

@ -0,0 +1,148 @@
;;; allout-tests.el --- Tests for allout.el -*- lexical-binding: t -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(require 'allout)
(require 'cl-lib)
(defun allout-tests-obliterate-variable (name)
"Completely unbind variable with NAME."
(if (local-variable-p name (current-buffer)) (kill-local-variable name))
(while (boundp name) (makunbound name)))
(defvar allout-tests-globally-unbound nil
"Fodder for allout resumptions tests -- defvar just for byte compiler.")
(defvar allout-tests-globally-true nil
"Fodder for allout resumptions tests -- defvar just for byte compiler.")
(defvar allout-tests-locally-true nil
"Fodder for allout resumptions tests -- defvar just for byte compiler.")
;; For each resumption case, we also test that the right local/global
;; scopes are affected during resumption effects.
(ert-deftest allout-test-resumption-unbound-return-to-unbound ()
"Previously unbound variables return to the unbound state."
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-add-resumptions '(allout-tests-globally-unbound t))
(should (not (default-boundp 'allout-tests-globally-unbound)))
(should (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
(should (boundp 'allout-tests-globally-unbound))
(should (equal allout-tests-globally-unbound t))
(allout-do-resumptions)
(should (not (local-variable-p 'allout-tests-globally-unbound
(current-buffer))))
(should (not (boundp 'allout-tests-globally-unbound)))))
(ert-deftest allout-test-resumption-variable-resumed ()
"Ensure that variable with prior global value is resumed."
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-globally-true)
(setq allout-tests-globally-true t)
(allout-add-resumptions '(allout-tests-globally-true nil))
(should (equal (default-value 'allout-tests-globally-true) t))
(should (local-variable-p 'allout-tests-globally-true (current-buffer)))
(should (equal allout-tests-globally-true nil))
(allout-do-resumptions)
(should (not (local-variable-p 'allout-tests-globally-true
(current-buffer))))
(should (boundp 'allout-tests-globally-true))
(should (equal allout-tests-globally-true t))))
(ert-deftest allout-test-resumption-prior-value-resumed ()
"Ensure that prior local value is resumed."
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-locally-true)
(set (make-local-variable 'allout-tests-locally-true) t)
(cl-assert (not (default-boundp 'allout-tests-locally-true))
nil (concat "Test setup mistake -- variable supposed to"
" not have global binding, but it does."))
(cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer))
nil (concat "Test setup mistake -- variable supposed to have"
" local binding, but it lacks one."))
(allout-add-resumptions '(allout-tests-locally-true nil))
(should (not (default-boundp 'allout-tests-locally-true)))
(should (local-variable-p 'allout-tests-locally-true (current-buffer)))
(should (equal allout-tests-locally-true nil))
(allout-do-resumptions)
(should (boundp 'allout-tests-locally-true))
(should (local-variable-p 'allout-tests-locally-true (current-buffer)))
(should (equal allout-tests-locally-true t))
(should (not (default-boundp 'allout-tests-locally-true)))))
(ert-deftest allout-test-resumption-multiple-holds ()
"Ensure that last of multiple resumptions holds, for various scopes."
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-tests-obliterate-variable 'allout-tests-globally-true)
(setq allout-tests-globally-true t)
(allout-tests-obliterate-variable 'allout-tests-locally-true)
(set (make-local-variable 'allout-tests-locally-true) t)
(allout-add-resumptions '(allout-tests-globally-unbound t)
'(allout-tests-globally-true nil)
'(allout-tests-locally-true nil))
(allout-add-resumptions '(allout-tests-globally-unbound 2)
'(allout-tests-globally-true 3)
'(allout-tests-locally-true 4))
;; reestablish many of the basic conditions are maintained after re-add:
(should (not (default-boundp 'allout-tests-globally-unbound)))
(should (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
(should (equal allout-tests-globally-unbound 2))
(should (default-boundp 'allout-tests-globally-true))
(should (local-variable-p 'allout-tests-globally-true (current-buffer)))
(should (equal allout-tests-globally-true 3))
(should (not (default-boundp 'allout-tests-locally-true)))
(should (local-variable-p 'allout-tests-locally-true (current-buffer)))
(should (equal allout-tests-locally-true 4))
(allout-do-resumptions)
(should (not (local-variable-p 'allout-tests-globally-unbound
(current-buffer))))
(should (not (boundp 'allout-tests-globally-unbound)))
(should (not (local-variable-p 'allout-tests-globally-true
(current-buffer))))
(should (boundp 'allout-tests-globally-true))
(should (equal allout-tests-globally-true t))
(should (boundp 'allout-tests-locally-true))
(should (local-variable-p 'allout-tests-locally-true (current-buffer)))
(should (equal allout-tests-locally-true t))
(should (not (default-boundp 'allout-tests-locally-true)))))
(ert-deftest allout-test-resumption-unbinding ()
"Ensure that deliberately unbinding registered variables doesn't foul things."
(with-temp-buffer
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-tests-obliterate-variable 'allout-tests-globally-true)
(setq allout-tests-globally-true t)
(allout-tests-obliterate-variable 'allout-tests-locally-true)
(set (make-local-variable 'allout-tests-locally-true) t)
(allout-add-resumptions '(allout-tests-globally-unbound t)
'(allout-tests-globally-true nil)
'(allout-tests-locally-true nil))
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-tests-obliterate-variable 'allout-tests-globally-true)
(allout-tests-obliterate-variable 'allout-tests-locally-true)
(allout-do-resumptions)))
(provide 'allout-tests)
;;; allout-tests.el ends here

87
test/lisp/allout-widgets-tests.el Normal file
View file

@ -0,0 +1,87 @@
;;; allout-widgets-tests.el --- Tests for allout-widgets.el -*- lexical-binding: t -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(require 'allout-widgets)
(require 'cl-lib)
(ert-deftest allout-test-range-overlaps ()
"`allout-range-overlaps' unit tests."
(let* (ranges
got
(try (lambda (from to)
(setq got (allout-range-overlaps from to ranges))
(setq ranges (cadr got))
got)))
;; ;; biggie:
;; (setq ranges nil)
;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall
;; ;; ~ 13 seconds for doing repeated funcall
;; (message "time-trial: %s, resulting size %s"
;; (time-trial
;; '(let ((size 10000)
;; doing)
;; (dotimes (count size)
;; (setq doing (random size))
;; (funcall try doing (+ doing (random 5)))
;; ;;(list doing (+ doing (random 5)))
;; )))
;; (length ranges))
;; (sit-for 2)
;; fresh:
(setq ranges nil)
(should (equal (funcall try 3 5) '(nil ((3 5)))))
;; add range at end:
(should (equal (funcall try 10 12) '(nil ((3 5) (10 12)))))
;; add range at beginning:
(should (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12)))))
;; insert range somewhere in the middle:
(should (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12)))))
;; consolidate some:
(should (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12)))))
;; add more:
(should (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17)))))
;; add more:
(should (equal (funcall try 20 22)
'(nil ((1 2) (3 9) (10 12) (15 17) (20 22)))))
;; encompass more:
(should (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22)))))
;; encompass all:
(should (equal (funcall try 2 25) '(t ((1 25)))))
;; fresh slate:
(setq ranges nil)
(should (equal (funcall try 20 25) '(nil ((20 25)))))
(should (equal (funcall try 30 35) '(nil ((20 25) (30 35)))))
(should (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35)))))
(should (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35)))))
(should (equal (funcall try 10 30) '(t ((10 35)))))
(should (equal (funcall try 5 6) '(nil ((5 6) (10 35)))))
(should (equal (funcall try 2 100) '(t ((2 100)))))
(setq ranges nil)))
(provide 'allout-widgets-tests)
;;; allout-widgets-tests.el ends here

2
test/lisp/arc-mode-tests.el
View file

@ -32,7 +32,7 @@
(cons 1024 "------S---") ; Bug#28092
(cons 2048 "---S------"))))
(dolist (x alist)
(should (equal (cdr x) (archive-int-to-mode (car x)))))))
(should (equal (cdr x) (file-modes-number-to-symbolic (car x)))))))
(ert-deftest arc-mode-test-zip-extract-gz ()
(skip-unless (and archive-zip-extract (executable-find (car archive-zip-extract))))

170
test/lisp/completion-tests.el Normal file
View file

@ -0,0 +1,170 @@
;;; completion-tests.el --- Tests for completion.el -*- lexical-binding: t -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(require 'completion)
(ert-deftest completion-test-cmpl-string-case-type ()
(should (eq (cmpl-string-case-type "123ABCDEF456") :up))
(should (eq (cmpl-string-case-type "123abcdef456") :down))
(should (eq (cmpl-string-case-type "123aBcDeF456") :mixed))
(should (eq (cmpl-string-case-type "123456") :neither))
(should (eq (cmpl-string-case-type "Abcde123") :capitalized)))
(ert-deftest completion-test-cmpl-merge-string-cases ()
(should (equal (cmpl-merge-string-cases "AbCdEf456" "abc") "AbCdEf456"))
(should (equal (cmpl-merge-string-cases "abcdef456" "ABC") "ABCDEF456"))
(should (equal (cmpl-merge-string-cases "ABCDEF456" "Abc") "Abcdef456"))
(should (equal (cmpl-merge-string-cases "ABCDEF456" "abc") "abcdef456")))
(ert-deftest completion-test-add-find-delete-tail ()
(unwind-protect
(progn
;; - Add and Find -
(should (equal (add-completion-to-head "banana") '("banana" 0 nil 0)))
(should (equal (find-exact-completion "banana") '("banana" 0 nil 0)))
(should (equal (find-exact-completion "bana") nil))
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0))))
(should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0))))
(should (equal (add-completion-to-head "banish") '("banish" 0 nil 0)))
(should (equal (find-exact-completion "banish") '("banish" 0 nil 0)))
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0) ("banana" 0 nil 0))))
(should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0))))
(should (equal (add-completion-to-head "banana") '("banana" 0 nil 0)))
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0))))
(should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0))))
;; - Deleting -
(should (equal (add-completion-to-head "banner") '("banner" 0 nil 0)))
(delete-completion "banner")
(should-not (find-exact-completion "banner"))
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0))))
(should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0))))
(should (equal (add-completion-to-head "banner") '("banner" 0 nil 0)))
(delete-completion "banana")
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banner" 0 nil 0) ("banish" 0 nil 0))))
(should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0))))
(delete-completion "banner")
(delete-completion "banish")
(should-not (find-cmpl-prefix-entry "ban"))
(should-error (delete-completion "banner"))
;; - Tail -
(should (equal (add-completion-to-tail-if-new "banana") '("banana" 0 nil 0)))
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0))))
(should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0))))
(add-completion-to-tail-if-new "banish") '("banish" 0 nil 0)
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0))))
(should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0)))))
(ignore-errors (kill-completion "banana"))
(ignore-errors (kill-completion "banner"))
(ignore-errors (kill-completion "banish"))))
(ert-deftest completion-test-add-find-accept-delete ()
(unwind-protect
(progn
;; - Add and Find -
(add-completion "banana" 5 10)
(should (equal (find-exact-completion "banana") '("banana" 5 10 0)))
(add-completion "banana" 6)
(should (equal (find-exact-completion "banana") '("banana" 6 10 0)))
(add-completion "banish")
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0) ("banana" 6 10 0))))
;; - Accepting -
(setq completion-to-accept "banana")
(accept-completion)
(should (equal (find-exact-completion "banana") '("banana" 7 10 0)))
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 7 10 0) ("banish" 0 nil 0))))
(setq completion-to-accept "banish")
(add-completion "banner")
(should (equal (car (find-cmpl-prefix-entry "ban"))
'(("banner" 0 nil 0) ("banish" 1 nil 0) ("banana" 7 10 0))))
;; - Deleting -
(kill-completion "banish")
(should (equal (car (find-cmpl-prefix-entry "ban")) '(("banner" 0 nil 0) ("banana" 7 10 0)))))
(ignore-errors (kill-completion "banish"))
(ignore-errors (kill-completion "banana"))
(ignore-errors (kill-completion "banner"))))
(ert-deftest completion-test-search ()
(unwind-protect
(progn
;; - Add and Find -
(add-completion "banana")
(completion-search-reset "ban")
(should (equal (car (completion-search-next 0)) "banana"))
;; - Discrimination -
(add-completion "cumberland")
(add-completion "cumberbund")
;; cumbering
(completion-search-reset "cumb")
(should (equal (car (completion-search-peek t)) "cumberbund"))
(should (equal (car (completion-search-next 0)) "cumberbund"))
(should (equal (car (completion-search-peek t)) "cumberland"))
(should (equal (car (completion-search-next 1)) "cumberland"))
(should-not (completion-search-peek nil))
;; FIXME
;; (should (equal (completion-search-next 2) "cumbering")) ; {cdabbrev}
;;(completion-search-next 3) --> nil or "cumming" {depends on context}
(should (equal (car (completion-search-next 1)) "cumberland"))
;; FIXME
;; (should (equal (completion-search-peek t) "cumbering")) ; {cdabbrev}
;; - Accepting -
(should (equal (car (completion-search-next 1)) "cumberland"))
(setq completion-to-accept "cumberland")
(completion-search-reset "foo")
(completion-search-reset "cum")
(should (equal (car (completion-search-next 0)) "cumberland"))
;; - Deleting -
(kill-completion "cumberland")
(add-completion "cummings")
(completion-search-reset "cum")
(should (equal (car (completion-search-next 0)) "cummings"))
(should (equal (car (completion-search-next 1)) "cumberbund"))
;; - Ignoring Capitalization -
(completion-search-reset "CuMb")
(should (equal (car (completion-search-next 0)) "cumberbund")))
(ignore-errors (kill-completion "banana"))
(ignore-errors (kill-completion "cumberland"))
(ignore-errors (kill-completion "cumberbund"))
(ignore-errors (kill-completion "cummings"))))
(ert-deftest completion-test-lisp-def-regexp ()
(should (= (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) 8))
(should (= (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) 9))
(should (= (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) 10))
(should (= (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) 9)))
(provide 'completion-tests)
;;; completion-tests.el ends here

11
test/lisp/custom-tests.el
View file

@ -147,4 +147,15 @@
(widget-apply field :value-to-internal origvalue)
"bar"))))))
(defconst custom-test-admin-cus-test
(expand-file-name "admin/cus-test.el" source-directory))
(declare-function cus-test-opts custom-test-admin-cus-test)
(ert-deftest check-for-wrong-custom-types ()
:tags '(:expensive-test)
(skip-unless (file-readable-p custom-test-admin-cus-test))
(load custom-test-admin-cus-test)
(should (null (cus-test-opts t))))
;;; custom-tests.el ends here

21
test/lisp/emacs-lisp/ert-x-tests.el
View file

@ -187,18 +187,15 @@
"Tests `ert-describe-test'."
(save-window-excursion
(ert-with-buffer-renamed ("*Help*")
(if (< emacs-major-version 24)
(should (equal (should-error (ert-describe-test 'ert-describe-test))
'(error "Requires Emacs 24")))
(ert-describe-test 'ert-test-describe-test)
(with-current-buffer "*Help*"
(let ((case-fold-search nil))
(should (string-match (concat
"\\`ert-test-describe-test is a test"
" defined in"
" ['`‘]ert-x-tests.elc?['’]\\.\n\n"
"Tests ['`‘]ert-describe-test['’]\\.\n\\'")
(buffer-string)))))))))
(ert-describe-test 'ert-test-describe-test)
(with-current-buffer "*Help*"
(let ((case-fold-search nil))
(should (string-match (concat
"\\`ert-test-describe-test is a test"
" defined in"
" ['`‘]ert-x-tests.elc?['’]\\.\n\n"
"Tests ['`‘]ert-describe-test['’]\\.\n\\'")
(buffer-string))))))))
(ert-deftest ert-test-message-log-truncation ()
:tags '(:causes-redisplay)

5
test/lisp/emacs-lisp/lisp-tests.el
View file

@ -136,8 +136,7 @@
(text-mode)
(insert "\"foo\"")
(goto-char (point-min))
(delete-pair)
(should (string-equal "fo\"" (buffer-string)))))
(should-error (delete-pair))))
(ert-deftest lisp-delete-pair-quotes-text-mode-syntax-table ()
"Test \\[delete-pair] with modified Text Mode syntax for #15014."
@ -296,7 +295,7 @@
(lambda () (up-list 1 t t))
(or "(1 '2 ( 2' 1 '2 ) 2' 1)")
;; abcdefghijklmnopqrstuvwxy
i k x scan-error)
i k x user-error)
(define-lisp-up-list-test backward-up-list-basic
(lambda () (backward-up-list))

3
test/lisp/help-fns-tests.el
View file

@ -123,6 +123,9 @@ Return first line of the output of (describe-function-1 FUNC)."
(goto-char (point-min))
(should (looking-at "^font-lock-comment-face is "))))
(defvar foo-test-map)
(defvar help-fns-test--describe-keymap-foo)
;;; Tests for describe-keymap
(ert-deftest help-fns-test-find-keymap-name ()

37
test/lisp/net/dbus-tests.el
View file

@ -4,18 +4,20 @@
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see `https://www.gnu.org/licenses/'.
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
@ -63,6 +65,7 @@
(ert-deftest dbus-test01-type-conversion ()
"Check type conversion functions."
(skip-unless dbus--test-enabled-session-bus)
(let ((ustr "0123abc_xyz\x01\xff")
(mstr "Grüß Göttin"))
(should
@ -93,6 +96,7 @@
(ert-deftest dbus-test01-basic-types ()
"Check basic D-Bus type arguments."
(skip-unless dbus--test-enabled-session-bus)
;; Unknown keyword.
(should-error
(dbus-check-arguments :session dbus--test-service :keyword)
@ -265,12 +269,13 @@
(dbus-check-arguments :session dbus--test-service :double "string")
:type 'wrong-type-argument)
;; `:unix-fd'. Value range 0 .. 9.
;; `:unix-fd'. UNIX file descriptors are transfered out-of-band.
;; We do not support this, and so we cannot do much testing here for
;; `:unix-fd' being an argument (which is an index to the file
;; descriptor in the array of file descriptors that accompany the
;; D-Bus message). Mainly testing, that values out of `:uint32'
;; type range fail.
(should (dbus-check-arguments :session dbus--test-service :unix-fd 0))
(should (dbus-check-arguments :session dbus--test-service :unix-fd 9))
(should-error
(dbus-check-arguments :session dbus--test-service :unix-fd 10)
:type 'dbus-error)
(should-error
(dbus-check-arguments :session dbus--test-service :unix-fd -1)
:type 'args-out-of-range)

5
test/lisp/progmodes/compile-tests.el
View file

@ -324,6 +324,9 @@
1 8 71 "/home/reto/test/group.xml")
("Warning: Start tag for undeclared element geroup\nin unnamed entity at line 4 char 8 of file:///home/reto/test/group.xml"
1 8 4 "/home/reto/test/group.xml")
;; shellcheck
("In autogen.sh line 48:"
1 nil 48 "autogen.sh")
;; sparc-pascal-file sparc-pascal-line sparc-pascal-example
("Thu May 14 10:46:12 1992 mom3.p:"
1 nil nil "mom3.p")
@ -436,7 +439,7 @@ The test data is in `compile-tests--test-regexps-data'."
(compilation-num-warnings-found 0)
(compilation-num-infos-found 0))
(mapc #'compile--test-error-line compile-tests--test-regexps-data)
(should (eq compilation-num-errors-found 95))
(should (eq compilation-num-errors-found 96))
(should (eq compilation-num-warnings-found 35))
(should (eq compilation-num-infos-found 28)))))

2
test/lisp/progmodes/ps-mode-tests.el
View file

@ -54,7 +54,7 @@
< 23 > %hex string
<~a>a%a~> %base85 string
(%)s
(sf\(g>a)sdg)
(sf\\(g>a)sdg)
/foo {
<<

2
test/lisp/progmodes/ruby-mode-tests.el
View file

@ -848,8 +848,6 @@ VALUES-PLIST is a list with alternating index and value elements."
(ruby--insert-coding-comment "utf-8")
(should (string= "# encoding: utf-8\n\n" (buffer-string))))))
;; TODO: Convert these into unit proper tests instead of using an
;; external file.
(ert-deftest ruby--indent/converted-from-manual-test ()
:tags '(:expensive-test)
;; Converted from manual test.

12
test/lisp/subr-tests.el
View file

@ -456,7 +456,17 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350."
(should (equal (replace-in-string "azot" "bar" "zat")
"zat"))
(should (equal (replace-in-string "azot" "bar" "azot")
"bar")))
"bar"))
(should (equal (replace-in-string "azot" "bar" "foozotbar")
"foozotbar"))
(should (equal (replace-in-string "\377" "x" "a\377b")
"axb"))
(should (equal (replace-in-string "\377" "x" "a\377ø")
"axø"))
(should-error (replace-in-string "" "x" "abc")))
(provide 'subr-tests)
;;; subr-tests.el ends here

2
test/lisp/textmodes/css-mode-tests.el
View file

@ -417,8 +417,6 @@
(point))
"black")))))
;; TODO: Convert these into unit proper tests instead of using an
;; external file.
(ert-deftest css-mode-test-indent ()
(with-current-buffer
(find-file-noselect (expand-file-name "test-indent.css"

1
test/lisp/wdired-tests.el
View file

@ -106,7 +106,6 @@ only the name before the link arrow."
"Test editing a file name without saving the change.
Finding the new name should be possible while still in
wdired-mode."
:expected-result (if (< emacs-major-version 27) :failed :passed)
(let* ((test-dir (make-temp-file "test-dir-" t))
(test-file (concat (file-name-as-directory test-dir) "foo.c"))
(replace "bar")

16
test/lisp/wid-edit-tests.el
View file

@ -113,4 +113,20 @@
(should (eq (current-column)
(widget-get grandchild :indent)))))))
(ert-deftest widget-test-character-widget-value ()
"Check that we get the character widget's value correctly."
(with-temp-buffer
(let ((wid (widget-create '(character :value ?\n))))
(goto-char (widget-get wid :from))
(should (string= (widget-apply wid :value-get) "\n"))
(should (char-equal (widget-value wid) ?\n))
(should-not (widget-apply wid :validate)))))
(ert-deftest widget-test-editable-field-widget-value ()
"Test that we get the editable field widget's value correctly."
(with-temp-buffer
(let ((wid (widget-create '(editable-field :value ""))))
(widget-insert "And some non-widget text.")
(should (string= (widget-apply wid :value-get) "")))))
;;; wid-edit-tests.el ends here

21
test/lisp/xml-tests.el
View file

@ -174,6 +174,27 @@ Parser is called with and without 'symbol-qnames argument.")
:type 'xml-invalid-character)
'(xml-invalid-character #x3FFFFF 3)))))
(defvar xml-tests--data-with-comments
`(;; simple case
("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>"
. ((foo ((baz . "true")) "bar")))
;; toplevel comments -- first document child must not get lost
(,(concat "<?xml version=\"1.0\"?><foo>bar</foo><!--comment-1-->"
"<!--comment-2-->")
. ((foo nil "bar")))
(,(concat "<?xml version=\"1.0\"?><!--comment-a--><foo a=\"b\">"
"<bar>blub</bar></foo><!--comment-b--><!--comment-c-->")
. ((foo ((a . "b")) (bar nil "blub")))))
"Alist of XML strings and their expected parse trees for discarded comments.")
(ert-deftest xml-remove-comments ()
(dolist (test xml-tests--data-with-comments)
(erase-buffer)
(insert (car test))
(xml-remove-comments (point-min) (point-max))
(should (equal (cdr test)
(xml-parse-region (point-min) (point-max))))))
;; Local Variables:
;; no-byte-compile: t
;; End:

59
test/src/fns-tests.el
View file

@ -166,6 +166,8 @@
(should (equal (should-error (sort "cba" #'<) :type 'wrong-type-argument)
'(wrong-type-argument list-or-vector-p "cba"))))
(defvar w32-collate-ignore-punctuation)
(ert-deftest fns-tests-collate-sort ()
(skip-unless (fns-tests--collate-enabled-p))
@ -228,9 +230,9 @@
(should (equal (func-arity 'format) '(1 . many)))
(require 'info)
(should (equal (func-arity 'Info-goto-node) '(1 . 3)))
(should (equal (func-arity (lambda (&rest x))) '(0 . many)))
(should (equal (func-arity (eval '(lambda (x &optional y)) nil)) '(1 . 2)))
(should (equal (func-arity (eval '(lambda (x &optional y)) t)) '(1 . 2)))
(should (equal (func-arity (lambda (&rest _x))) '(0 . many)))
(should (equal (func-arity (eval '(lambda (_x &optional y)) nil)) '(1 . 2)))
(should (equal (func-arity (eval '(lambda (_x &optional y)) t)) '(1 . 2)))
(should (equal (func-arity 'let) '(1 . unevalled))))
(defun fns-tests--string-repeat (s o)
@ -901,3 +903,54 @@
(should (equal (delete t [nil t]) [nil]))
(should (equal (delete 1 v1) (vector)))
(should (equal (delete 2 v1) v1))))
(ert-deftest string-search ()
(should (equal (string-search "zot" "foobarzot") 6))
(should (equal (string-search "foo" "foobarzot") 0))
(should (not (string-search "fooz" "foobarzot")))
(should (not (string-search "zot" "foobarzo")))
(should (equal (string-search "ab" "ab") 0))
(should (equal (string-search "ab\0" "ab") nil))
(should (equal (string-search "ab" "abababab" 3) 4))
(should (equal (string-search "ab" "ababac" 3) nil))
(let ((case-fold-search t))
(should (equal (string-search "ab" "AB") nil)))
(should (equal
(string-search (make-string 2 130)
(concat "helló" (make-string 5 130 t) "bár"))
5))
(should (equal
(string-search (make-string 2 127)
(concat "helló" (make-string 5 127 t) "bár"))
5))
(should (equal (string-search "\377" "a\377ø") 1))
(should (equal (string-search "\377" "a\377a") 1))
(should (not (string-search (make-string 1 255) "a\377ø")))
(should (not (string-search (make-string 1 255) "a\377a")))
(should (equal (string-search "fóo" "zotfóo") 3))
(should (equal (string-search (string-to-multibyte "\377") "ab\377c") 2))
(should (equal (string-search "\303" "aøb") nil))
(should (equal (string-search "\270" "aøb") nil))
;; This test currently fails, but it shouldn't!
;;(should (equal (string-search "ø" "\303\270") nil))
(should-error (string-search "a" "abc" -1))
(should-error (string-search "a" "abc" 4))
(should-error (string-search "a" "abc" 100000000000))
(should (equal (string-search "a" "aaa" 3) nil))
(should (equal (string-search "\0" "") nil))
(should (equal (string-search "" "") 0))
(should-error (string-search "" "" 1))
(should (equal (string-search "" "abc") 0))
(should (equal (string-search "" "abc" 2) 2))
(should (equal (string-search "" "abc" 3) 3))
(should-error (string-search "" "abc" 4))
(should-error (string-search "" "abc" -1))
)

52
test/src/xdisp-tests.el Normal file
View file

@ -0,0 +1,52 @@
;;; xdisp-tests.el --- tests for xdisp.c functions -*- lexical-binding: t -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
(require 'ert)
(ert-deftest xdisp-tests--minibuffer-resizing () ;; bug#43519
;; FIXME: This test returns success when run in batch but
;; it's only a lucky accident: it also returned success
;; when bug#43519 was not fixed.
(should
(equal
t
(catch 'result
(minibuffer-with-setup-hook
(lambda ()
(insert "hello")
(let ((ol (make-overlay (point) (point)))
(max-mini-window-height 1)
(text "askdjfhaklsjdfhlkasjdfhklasdhflkasdhflkajsdhflkashdfkljahsdlfkjahsdlfkjhasldkfhalskdjfhalskdfhlaksdhfklasdhflkasdhflkasdhflkajsdhklajsdgh"))
;; (save-excursion (insert text))
;; (sit-for 2)
;; (delete-region (point) (point-max))
(put-text-property 0 1 'cursor t text)
(overlay-put ol 'after-string text)
(redisplay 'force)
(throw 'result
;; Make sure we do the see "hello" text.
(prog1 (equal (window-start) (point-min))
;; (list (window-start) (window-end) (window-width))
(delete-overlay ol)))))
(let ((executing-kbd-macro t)) ;Force real minibuffer in `read-string'.
(read-string "toto: ")))))))
;;; xdisp-tests.el ends here

21
test/src/xml-tests.el
View file

@ -42,20 +42,6 @@
(comment nil "comment-b") (comment nil "comment-c"))))
"Alist of XML strings and their expected parse trees for preserved comments.")
(defvar libxml-tests--data-comments-discarded
`(;; simple case
("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>"
. (foo ((baz . "true")) "bar"))
;; toplevel comments -- first document child must not get lost
(,(concat "<?xml version=\"1.0\"?><foo>bar</foo><!--comment-1-->"
"<!--comment-2-->")
. (foo nil "bar"))
(,(concat "<?xml version=\"1.0\"?><!--comment-a--><foo a=\"b\">"
"<bar>blub</bar></foo><!--comment-b--><!--comment-c-->")
. (foo ((a . "b")) (bar nil "blub"))))
"Alist of XML strings and their expected parse trees for discarded comments.")
(ert-deftest libxml-tests ()
"Test libxml."
(when (fboundp 'libxml-parse-xml-region)
@ -64,11 +50,6 @@
(erase-buffer)
(insert (car test))
(should (equal (cdr test)
(libxml-parse-xml-region (point-min) (point-max)))))
(dolist (test libxml-tests--data-comments-discarded)
(erase-buffer)
(insert (car test))
(should (equal (cdr test)
(libxml-parse-xml-region (point-min) (point-max) nil t)))))))
(libxml-parse-xml-region (point-min) (point-max))))))))
;;; libxml-tests.el ends here