procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Andrea Corallo 2020-09-06 08:07:30 +02:00
commit 8055633466
127 changed files with 5180 additions and 3546 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
.gitlab-ci.yml
View file

@ -41,6 +41,33 @@ stages:
# test-all:
# # This tests also file monitor libraries inotify and inotifywatch.
# stage: test
# only:
# changes:
# - "Makefile.in"
# - .gitlab-ci.yml
# - aclocal.m4
# - autogen.sh
# - configure.ac
# - lib/*.{h,c}
# - lisp/*.el
# - lisp/**/*.el
# - src/*.{h,c}
# - test/lisp/*.el
# - test/lisp/**/*.el
# - test/src/*.el
# except:
# changes:
# # gfilemonitor, kqueue
# - src/gfilenotify.c
# - src/kqueue.c
# # MS Windows
# - lisp/w32*.el
# - lisp/term/w32*.el
# - src/w32*.{h,c}
# # GNUstep
# - lisp/term/ns-win.el
# - src/ns*.{h,m}
# - src/macfont.{h,m}
# script:
# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools
# - ./autogen.sh autoconf
@ -108,18 +135,10 @@ test-gnustep:
changes:
- .gitlab-ci.yml
- configure.ac
- src/nsfns.m
- src/nsfont.m
- src/nsgui.h
- src/nsimage.m
- src/nsmenu.m
- src/nsselect.m
- src/nsterm.h
- src/nsterm.m
- src/nsxwidget.h
- src/nsxwidget.m
- src/macfont.h
- src/macfont.m
- src/ns*.{h,m}
- src/macfont.{h,m}
- lisp/term/ns-win.el
- nextstep/**/*
script:
- DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 gnustep-devel
- ./autogen.sh autoconf

15
admin/admin.el
View file

@ -928,13 +928,15 @@ changes (in a non-trivial way). This function does not check for that."
(defun reminder-for-release-blocking-bugs (version)
"Submit a reminder message for release-blocking bugs of Emacs VERSION."
(interactive
(list (completing-read
"Emacs release: "
(mapcar #'identity debbugs-gnu-emacs-blocking-reports)
nil t debbugs-gnu-emacs-current-release)))
(list (progn
(require 'debbugs-gnu)
(completing-read
"Emacs release: "
(mapcar #'identity debbugs-gnu-emacs-blocking-reports)
nil t debbugs-gnu-emacs-current-release))))
(require 'reporter)
(require 'debbugs-gnu)
(require 'reporter)
(when-let ((id (alist-get version debbugs-gnu-emacs-blocking-reports
nil nil #'string-equal))
@ -949,7 +951,8 @@ changes (in a non-trivial way). This function does not check for that."
(lambda () ; posthook
(goto-char (point-min))
(mail-position-on-field "subject")
(insert (format "Release-blocking bugs for Emacs %s" version))
(insert (format "Reminder: release-blocking bugs for Emacs %s (%s)"
version (format-time-string "%F" nil "UTC0")))
(mail-text)
(delete-region (point) (point-max))
(insert "

10
admin/notes/bug-triage
View file

@ -11,7 +11,11 @@ interface via org-mode.
The goal of this triage is to prune down the list of old bugs, closing
the ones that are not reproducible on the current release.
1. To start, enter debbugs mode (either debbugs-gnu, debbugs-org, or via the
0. To start, check the most relevant bugs blocking a release by
calling debbugs-gnu-emacs-release-blocking-reports. If you want
to check this for another Emacs version but the next-to-be-released-one,
use the "C-u" prefix.
1. After that, enter debbugs mode (either debbugs-gnu, debbugs-org, or via the
web browser), and accept the default list option of bugs that have severity
serious, important, or normal.
2. For each bug, we want to primarily make sure it is still
@ -20,7 +24,7 @@ the ones that are not reproducible on the current release.
suggested checklist to follow for handling these bugs, along with
example replies. Closing, tagging, etc., are done
with debbugs control messages, which in debbugs-gnu is initiated
with a "C".
with a "C" or "E".
[ ] Read the mail thread for the bug. Find out if anyone has
been able to reproduce this on the current release. If
someone has been able to, then your work is finished for this
@ -87,7 +91,7 @@ necessary information for others to act on.
For each new bug, ask the following questions:
1. Is the bug report written in a way to be easy to reproduce (starts from
emacs -Q, etc.)? If not, ask the reporter to try and reproduce it on an
"emacs -Q", etc.)? If not, ask the reporter to try and reproduce it on an
emacs without customization.
2. Is the bug report written against the latest emacs? If not, try to
reproduce on the latest version, and if it can't be reproduced, ask the

13
admin/notes/bugtracker
View file

@ -33,7 +33,7 @@ By mailing commands to control@debbugs.gnu.org. Place commands at the
start of the message body, one per line.
severity 123 serious|important|normal|minor|wishlist
tags 123 moreinfo|unreproducible|wontfix|patch
tags 123 moreinfo|unreproducible|wontfix|patch|notabug
* More detailed information
@ -185,7 +185,7 @@ Basically, reply only to the numbered bug address (and any individual
people's addresses). Do not send mail direct to bug-gnu-emacs or
emacs-pretest-bug unless you are reporting a new bug.
** To close bug #123 (for example), send mail
** To close bug#123 (for example), send mail
To: 123-done@debbugs.gnu.org
@ -260,7 +260,7 @@ reopen 123
*** Bugs can be tagged in various ways (eg wontfix, patch, etc).
The available tags are:
patch wontfix moreinfo unreproducible fixed notabug security confirmed
patch wontfix moreinfo unreproducible fixed notabug help security confirmed easy
See https://debbugs.gnu.org/Developer#tags
The list of tags can be prefixed with +, - or =, meaning to add (the
default), remove, or reset the tags. E.g.:
@ -290,10 +290,9 @@ limited, predefined set of normal tags are available (see above).
2) A usertag is associated with a specific user. This is normally
an email address (with an "@" sign and least 4 characters after the "@"),
but on debbugs.gnu.org, the definition is less strict - anything with
5 or more alphanumeric characters will work. For personal tags,
but on debbugs.gnu.org, it can also be a package name. For personal tags,
using an email address is still recommended. Please only use the
"emacs" user, or other short users, for "official" tags.
"emacs" user for "official" tags.
You set usertags in the same way as tags, by talking to the control server.
One difference is that you can also specify the associated user.
@ -307,7 +306,7 @@ a) In a control message:
user emacs # or email@example.com
usertags 1234 any-tag-you-like
This will add a usertag "any-tag-you-like" to bug 1234. The tag will
This will add a usertag "any-tag-you-like" to bug#1234. The tag will
be associated with the user "emacs". If you omit the first line,
the tag will be associated with your email address.

20
admin/release-process
View file

@ -41,17 +41,17 @@ released in the next release cycle. From time to time, the master
branches merges bugfix commits from the "emacs-NN" branch.
See admin/gitmerge.el.
* RELEASE-CRITICAL BUGS
* RELEASE-BLOCKING BUGS
Emacs uses the "blocking" feature of Debbugs for bugs that need to be
addressed in the next release.
Currently, bug#39200 is the tracking bug for release of 27.1 and
Currently, bug#43018 is the tracking bug for release of 27.2 and
bug#39202 is the tracking bug for release 28.1. Say bug#123 needs
to be fixed for Emacs 27.1. Send a message to control@debbugs.gnu.org
to be fixed for Emacs 27.2. Send a message to control@debbugs.gnu.org
that says:
block 39200 by 123
block 43018 by 123
Change "block" to "unblock" to remove a bug from the list. Closed
bugs are not listed as blockers, so you do not need to explicitly
@ -59,9 +59,17 @@ unblock one that has been closed. You may need to force an update of
the tracking bug with ctrl-f5/shift-reload to see the latest version.
If you use the debbugs package from GNU ELPA, you can apply the
following form to see all bugs which block a given release:
following command to see all bugs which block a given release:
(debbugs-gnu-emacs-release-blocking-reports "27.1")
(debbugs-gnu-emacs-release-blocking-reports "27.2")
The following command from admin/admin.el sends a reminder message
about release-blocking bugs to the <emacs-devel@gnu.org> mailing list:
(reminder-for-release-blocking-bugs "27.2")
It is recommended to send this reminder message once a month. Once the
pretest has started, a reminder message once a week is appropriate.
* TO BE DONE SHORTLY BEFORE RELEASE

19
configure.ac
View file

@ -1901,8 +1901,7 @@ tmp_CPPFLAGS="$CPPFLAGS"
tmp_CFLAGS="$CFLAGS"
CPPFLAGS="$CPPFLAGS -x objective-c"
CFLAGS="$CFLAGS -x objective-c"
# Recent versions of GCC don't use C99 to compile Obj-C.
GNU_OBJC_CFLAGS="-std=c99"
GNU_OBJC_CFLAGS=""
LIBS_GNUSTEP=
if test "${with_ns}" != no; then
# macfont.o requires macuvs.h which is absent after 'make extraclean',
@ -1918,7 +1917,7 @@ if test "${with_ns}" != no; then
elif flags=$( (gnustep-config --objc-flags) 2>/dev/null); then
NS_IMPL_GNUSTEP=yes
NS_GNUSTEP_CONFIG=yes
GNU_OBJC_CFLAGS="$GNU_OBJC_CFLAGS $flags"
GNU_OBJC_CFLAGS="$flags"
LIBS_GNUSTEP=$(gnustep-config --gui-libs) || exit
elif test -f $GNUSTEP_CONFIG_FILE; then
NS_IMPL_GNUSTEP=yes
@ -2068,6 +2067,20 @@ if test "${HAVE_NS}" = yes; then
AC_DEFINE(NATIVE_OBJC_INSTANCETYPE, 1,
[Define if ObjC compiler supports instancetype natively.])
fi
AC_CACHE_CHECK(
[if the Objective C compiler defaults to C99],
[emacs_cv_objc_c99],
[AC_LANG_PUSH([Objective C])
AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM([], [[for (int i = 0;;);]])],
emacs_cv_objc_c99=yes,
emacs_cv_objc_c99=no)
AC_LANG_POP([Objective C])])
if test x$emacs_cv_objc_c99 = xno ; then
GNU_OBJC_CFLAGS="$GNU_OBJC_CFLAGS -std=c99"
fi
fi
HAVE_W32=no

2
doc/lispintro/emacs-lisp-intro.texi
View file

@ -3997,7 +3997,7 @@ looks like this:
@smallexample
@group
(if (equal characteristic "fierce")
(message "It is a tiger!")))
(message "It is a tiger!"))
@end group
@end smallexample

15
doc/lispref/customize.texi
View file

@ -358,6 +358,10 @@ This is meaningful only for certain types, currently including
@code{hook}, @code{plist} and @code{alist}. See the definition of the
individual types for a description of how to use @code{:options}.
Re-evaluating a @code{defcustom} form with a different @code{:options}
value does not clear the values added by previous evaluations, or
added by calls to @code{custom-add-frequent-value} (see below).
@item :set @var{setfunction}
@kindex set@r{, @code{defcustom} keyword}
Specify @var{setfunction} as the way to change the value of this
@ -485,6 +489,10 @@ list of reasonable values.
The precise effect of adding a value depends on the customization type
of @var{symbol}.
Since evaluating a @code{defcustom} form does not clear values added
previously, Lisp programs can use this function to add values for user
options not yet defined.
@end defun
Internally, @code{defcustom} uses the symbol property
@ -1189,6 +1197,13 @@ current value is valid for the widget. Otherwise, it should return
the widget containing the invalid data, and set that widget's
@code{:error} property to a string explaining the error.
@item :type-error @var{string}
@kindex type-error@r{, customization keyword}
@var{string} should be a string that describes why a value doesn't
match the type, as determined by the @code{:match} function. When the
@code{:match} function returns @code{nil}, the widget's @code{:error}
property will be set to @var{string}.
@ignore
@item :indent @var{columns}
Indent this item by @var{columns} columns. The indentation is used for

16
doc/lispref/files.texi
View file

@ -2438,26 +2438,14 @@ This is for the sake of filesystems that have the concept of a
superroot above the root directory @file{/}. On other filesystems,
@file{/../} is interpreted exactly the same as @file{/}.
If a filename must be that of a directory, its expansion must be too.
For example, if a filename ends in @samp{/} or @samp{/.} or @samp{/..}
then its expansion ends in @samp{/} so that it cannot be
misinterpreted as the name of a symbolic link:
@example
@group
(expand-file-name "/a///b//.")
@result{} "/a/b/"
@end group
@end example
Expanding @file{.} or the empty string returns the default directory:
@example
@group
(expand-file-name "." "/usr/spool/")
@result{} "/usr/spool/"
@result{} "/usr/spool"
(expand-file-name "" "/usr/spool/")
@result{} "/usr/spool/"
@result{} "/usr/spool"
@end group
@end example

3
doc/lispref/minibuf.texi
View file

@ -437,6 +437,9 @@ passed to @code{format} (@pxref{Formatting Strings}).
@code{minibuffer-default-prompt-format} can be @samp{""}, in which
case no default values are displayed.
If @var{default} is @code{nil}, there is no default value, and
therefore no ``default value'' string is included in the result value.
@end defun
@node Object from Minibuffer

23
doc/lispref/modes.texi
View file

@ -2039,7 +2039,7 @@ be useful for Shell mode (in reality, Shell mode does not set
"%n"
")%]--"
@group
'(which-func-mode ("" which-func-format "--"))
'(which-function-mode ("" which-func-format "--"))
'(line-number-mode "L%l--")
'(column-number-mode "C%c--")
'(-3 "%p")))
@ -2047,8 +2047,8 @@ be useful for Shell mode (in reality, Shell mode does not set
@end example
@noindent
(The variables @code{line-number-mode}, @code{column-number-mode}
and @code{which-func-mode} enable particular minor modes; as usual,
(The variables @code{line-number-mode}, @code{column-number-mode} and
@code{which-function-mode} enable particular minor modes; as usual,
these variable names are also the minor mode command names.)
@node Mode Line Variables
@ -2190,7 +2190,7 @@ enabled separately in each buffer.
@defvar global-mode-string
This variable holds a mode line construct that, by default, appears in
the mode line just after the @code{which-func-mode} minor mode if set,
the mode line just after the @code{which-function-mode} minor mode if set,
else after @code{mode-line-modes}. The command @code{display-time} sets
@code{global-mode-string} to refer to the variable
@code{display-time-string}, which holds a string containing the time and
@ -2219,7 +2219,7 @@ specifies addition of text properties.
" "
@group
mode-line-modes
(which-func-mode ("" which-func-format "--"))
(which-function-mode ("" which-func-format "--"))
(global-mode-string ("--" global-mode-string))
"-%-")
@end group
@ -2327,6 +2327,10 @@ read-only buffer. @xref{Buffer Modification}.
@item %&
@samp{*} if the buffer is modified, and @samp{-} otherwise.
@item %@@
@samp{@@} if the buffer's @code{default-directory} (@pxref{File Name
Expansion}) is on a remote machine, and @samp{-} otherwise.
@item %[
An indication of the depth of recursive editing levels (not counting
minibuffer levels): one @samp{[} for each editing level.
@ -2344,16 +2348,13 @@ The character @samp{%}---this is how to include a literal @samp{%} in a
string in which @code{%}-constructs are allowed.
@end table
The following two @code{%}-constructs are still supported, but they are
obsolete, since you can get the same results with the variables
@code{mode-name} and @code{global-mode-string}.
The following @code{%}-construct is still supported, but it is
obsolete, since you can get the same result using the variable
@code{mode-name}.
@table @code
@item %m
The value of @code{mode-name}.
@item %M
The value of @code{global-mode-string}.
@end table
@node Properties in Mode

5
doc/lispref/text.texi
View file

@ -5154,6 +5154,11 @@ Utility functions:
@item dom-pp @var{dom} &optional @var{remove-empty}
Pretty-print @var{dom} at point. If @var{remove-empty}, don't print
textual nodes that just contain white-space.
@item dom-print @var{dom} &optional @var{pretty} @var{xml}
Print @var{dom} at point. If @var{xml} is non-@code{nil}, print as
@acronym{XML}; otherwise, print as @acronym{HTML}. If @var{pretty} is
non-@code{nil}, indent the @acronym{HTML}/@acronym{XML} logically.
@end table

5
doc/misc/auth.texi
View file

@ -227,6 +227,11 @@ machine YOURMACHINE login YOU password SMTPPASSWORD port 433
machine YOURMACHINE login YOU password GENERALPASSWORD
@end example
If you wish to specify a particular SMTP authentication method to use
with a machine, you can use the @code{smtp-auth} keyword.
@xref{Authentication,, Authentication, smtpmail, Emacs SMTP Library},
for available methods.
For url-auth authentication (HTTP/HTTPS), you need to put this in your
netrc file:

52
doc/misc/dbus.texi
View file

@ -1462,7 +1462,15 @@ cons cell, @var{handler} can return this object directly, instead of
returning a list containing the object.
If @var{handler} returns a reply message with an empty argument list,
@var{handler} must return the symbol @code{:ignore}.
@var{handler} must return the symbol @code{:ignore} in order
to distinguish it from @code{nil} (the boolean false).
If @var{handler} detects an error, it shall return the list
@code{(:error @var{ERROR-NAME} @var{ERROR-MESSAGE)}}.
@var{ERROR-NAME} is a namespaced string which characterizes the error
type, and @var{ERROR-MESSAGE} is a free text string. Alternatively,
any Emacs signal @code{dbus-error} in @var{handler} raises a D-Bus
error message with the error name @samp{org.freedesktop.DBus.Error.Failed}.
When @var{dont-register-service} is non-@code{nil}, the known name
@var{service} is not registered. This means that other D-Bus clients
@ -1512,17 +1520,20 @@ could use the command line tool @code{dbus-send} in a shell:
boolean true
@end example
You can indicate an error by raising the Emacs signal
@code{dbus-error}. The handler above could be changed like this:
You can indicate an error by returning an @code{:error} list reply, or
by raising the Emacs signal @code{dbus-error}. The handler above
could be changed like this:
@lisp
(defun my-dbus-method-handler (&rest args)
(unless (and (= (length args) 1) (stringp (car args)))
(signal 'dbus-error (list (format "Wrong argument list: %S" args))))
(condition-case err
(find-file (car args))
(error (signal 'dbus-error (cdr err))))
t)
(if (not (and (= (length args) 1) (stringp (car args))))
(list :error
"org.freedesktop.TextEditor.Error.InvalidArgs"
(format "Wrong argument list: %S" args))
(condition-case err
(find-file (car args))
(error (signal 'dbus-error (cdr err))))
t))
@end lisp
The test then runs
@ -1534,9 +1545,20 @@ The test then runs
"org.freedesktop.TextEditor.OpenFile" \
string:"/etc/hosts" string:"/etc/passwd"
@print{} Error org.freedesktop.DBus.Error.Failed:
@print{} Error org.freedesktop.TextEditor.Error.InvalidArgs:
Wrong argument list: ("/etc/hosts" "/etc/passwd")
@end example
@example
# dbus-send --session --print-reply \
--dest="org.freedesktop.TextEditor" \
"/org/freedesktop/TextEditor" \
"org.freedesktop.TextEditor.OpenFile" \
string:"/etc/crypttab"
@print{} Error org.freedesktop.DBus.Error.Failed:
D-Bus error: "File is not readable", "/etc/crypttab"
@end example
@end defun
@defun dbus-register-property bus service path interface property access value &optional emits-signal dont-register-service
@ -1556,14 +1578,16 @@ discussion of @var{dont-register-service} below).
@var{property} is the name of the property of @var{interface}.
@var{access} indicates, whether the property can be changed by other
services via D-Bus. It must be either the symbol @code{:read} or
@code{:readwrite}. @var{value} is the initial value of the property,
it can be of any valid type (@xref{dbus-call-method}, for details).
services via D-Bus. It must be either the symbol @code{:read},
@code{:write} or @code{:readwrite}. @var{value} is the initial value
of the property, it can be of any valid type (@xref{dbus-call-method},
for details).
If @var{property} already exists on @var{path}, it will be
overwritten. For properties with access type @code{:read} this is the
only way to change their values. Properties with access type
@code{:readwrite} can be changed by @code{dbus-set-property}.
@code{:write} or @code{:readwrite} can be changed by
@code{dbus-set-property}.
The interface @samp{org.freedesktop.DBus.Properties} is added to
@var{path}, including a default handler for the @samp{Get},

14
doc/misc/eudc.texi
View file

@ -166,15 +166,11 @@ your own local BBDB (@pxref{Creating BBDB Records})
@node macOS Contacts
@section macOS Contacts
macOS Contacts is the rolodex-like application that ships with the
macOS operating system@footnote{Apple have changed the names of their
operating system and some applications over time. macOS used to be
called Mac OS X in the past, and the Contacts application was
previously called Address Book.}.
EUDC considers macOS Contacts as a directory server back end just like
LDAP, though the macOS Contacts application always resides locally on
your machine.
This EUDC back end considers macOS Contacts as a directory server just
like LDAP, though the macOS Contacts application always runs locally
on your machine. The Contacts application was previously called
Address Book; the EUDC macOS Contacts back end also works on those
older versions.
@node Installation

266
doc/misc/gnus.texi
View file

@ -641,7 +641,7 @@ Select Methods
* Getting Mail:: Reading your personal mail with Gnus.
* Browsing the Web:: Getting messages from a plethora of Web sources.
* Other Sources:: Reading directories, files.
* Combined Groups:: Combining groups into one group.
* Virtual Groups:: Combining articles from multiple sources.
* Email Based Diary:: Using mails to manage diary events in Gnus.
* Gnus Unplugged:: Reading news and mail offline.
@ -716,9 +716,10 @@ Document Groups
* Document Server Internals:: How to add your own document types.
Combined Groups
Virtual Groups
* Virtual Groups:: Combining articles from many groups.
* Selection Groups:: Articles selected from many places.
* Combined Groups:: Combining multiple groups.
Email Based Diary
@ -4967,6 +4968,15 @@ The address (from the @code{From} header). This works the same way as
the @code{a} spec.
@item L
Number of lines in the article.
@item Z
Retrieval Score Value (RSV) of the article; nil if not in an nnselect
group.
@item G
Originating group name of the article; nil if not in an nnselect
group.
@item g
Short form of the originating group name of the article; nil if not in
an nnselect group.
@item c
Number of characters in the article. This specifier is not supported
in some methods (like nnfolder).
@ -10407,12 +10417,20 @@ article (@code{gnus-summary-refer-references}).
@findex gnus-summary-refer-thread
@kindex A T @r{(Summary)}
Display the full thread where the current article appears
(@code{gnus-summary-refer-thread}). This command has to fetch all the
headers in the current group to work, so it usually takes a while. If
you do it often, you may consider setting @code{gnus-fetch-old-headers}
to @code{invisible} (@pxref{Filling In Threads}). This won't have any
visible effects normally, but it'll make this command work a whole lot
faster. Of course, it'll make group entry somewhat slow.
(@code{gnus-summary-refer-thread}). By default this command looks for
articles only in the current group. Some backends (currently only
'nnimap) know how to find articles in the thread directly. In other
cases each header in the current group must be fetched and examined,
so it usually takes a while. If you do it often, you may consider
setting @code{gnus-fetch-old-headers} to @code{invisible}
(@pxref{Filling In Threads}). This won't have any visible effects
normally, but it'll make this command work a whole lot faster. Of
course, it'll make group entry somewhat slow.
@vindex gnus-refer-thread-use-search
If @code{gnus-refer-thread-use-search} is non-nil then those backends
that know how to find threads directly will search not just in the
current group but all groups on the same server.
@vindex gnus-refer-thread-limit
The @code{gnus-refer-thread-limit} variable says how many old (i.e.,
@ -10421,6 +10439,15 @@ fetch when doing this command. The default is 200. If @code{t}, all
the available headers will be fetched. This variable can be overridden
by giving the @kbd{A T} command a numerical prefix.
@vindex gnus-refer-thread-limit-to-thread
In most cases @code{gnus-refer-thread} adds any articles it finds to
the current summary buffer. (When @code{gnus-refer-thread-use-search}
is true and the initial referral starts from a summary buffer for a
non-virtual group this may not be possible. In this case a new summary
buffer is created holding a virtual group with the result of the thread
search). If @code{gnus-refer-thread-limit-to-thread} is non-nil then
the summary buffer will be limited to articles in the thread.
@item M-^ (Summary)
@findex gnus-summary-refer-article
@kindex M-^ @r{(Summary)}
@ -13262,7 +13289,7 @@ The different methods all have their peculiarities, of course.
* Getting Mail:: Reading your personal mail with Gnus.
* Browsing the Web:: Getting messages from a plethora of Web sources.
* Other Sources:: Reading directories, files.
* Combined Groups:: Combining groups into one group.
* Virtual Groups:: Combining articles and groups together.
* Email Based Diary:: Using mails to manage diary events in Gnus.
* Gnus Unplugged:: Reading news and mail offline.
@end menu
@ -17834,19 +17861,133 @@ methods, but want to only use secondary ones:
@end lisp
@node Combined Groups
@section Combined Groups
@node Virtual Groups
@section Virtual Groups
Gnus allows combining a mixture of all the other group types into bigger
groups.
Gnus allows combining articles from many sources, and combinations of
whole groups together into virtual groups.
@menu
* Virtual Groups:: Combining articles from many groups.
* Selection Groups:: Combining articles from many groups.
* Combined Groups:: Combining multiple groups.
@end menu
@node Virtual Groups
@subsection Virtual Groups
@node Selection Groups
@subsection Select Groups
@cindex nnselect
@cindex select groups
@cindex selecting articles
Gnus provides the @dfn{nnselect} method for creating virtual groups
composed of collections of messages, even when these messages come
from groups that span multiple servers and backends. For the most part
these virtual groups behave like any other group: messages may be
threaded, marked, moved, deleted, copied, etc.; groups may be
ephemeral or persistent; groups may be created via
@code{gnus-group-make-group} or browsed as foreign via
@code{gnus-group-browse-foreign-server}.
The key to using an nnselect group is specifying the messages to
include. Each nnselect group has a group parameter
@code{nnselect-specs} which is an alist with two elements: a function
@code{nnselect-function}; and arguments @code{nnselect-args} to be
passed to the function, if any.
The function @code{nnselect-function} must return a vector. Each
element of this vector is in turn a 3-element vector corresponding to
one message. The 3 elements are: the fully-qualified group name; the
message number; and a "score" that can be used for additional
sorting. The values for the score are arbitrary, and are not used
directly by the nnselect method---they may, for example, all be set to
100.
Here is an example:
@lisp
(nnselect-specs
(nnselect-function . identity)
(nnselect-args .
[["nnimap+work:mail" 595 100]
["nnimap+home:sent" 223 100]
["nntp+news.gmane.org:gmane.emacs.gnus.general" 23666 100]]))
@end lisp
The function is the identity and the argument is just the list of
messages to include in the virtual group.
Or we may wish to create a group from the results of a search query:
@lisp
(nnselect-specs
(nnselect-function . nnir-run-query)
(nnselect-args
(nnir-query-spec
(query . "FLAGGED")
(criteria . ""))
(nnir-group-spec
("nnimap:home")
("nnimap:work"))))
@end lisp
This creates a group including all flagged messages from all groups on
two imap servers, "home" and "work".
And one last example. Here is a function that runs a search query to
find all message that have been received recently from certain groups:
@lisp
(defun my-recent-email (args)
(let ((query-spec
(list
(cons 'query
(format-time-string "SENTSINCE %d-%b-%Y"
(time-subtract (current-time)
(days-to-time (car args)))))
(cons 'criteria "")))
(group-spec (cadr args)))
(nnir-run-query (cons 'nnir-specs
(list (cons 'nnir-query-spec query-spec)
(cons 'nnir-group-spec group-spec))))))
@end lisp
Then an nnselect-specs
@lisp
(nnselect-specs
(nnselect-function . my-recent-email)
(nnselect-args . (7 (("nnimap:home") ("nnimap:work")))))
@end lisp
will provide a group composed of all messages on the home and work
servers received in the last 7 days.
Refreshing the selection of an nnselect group by running the
@code{nnselect-function} may take a long time to
complete. Consequently nnselect groups are not refreshed by default
when @code{gnus-group-get-new-news} is invoked. In those cases where
running the function is not too time-consuming, a non-nil group
parameter of @code{nnselect-rescan} will allow automatic refreshing. A
refresh can always be invoked manually through
@code{gnus-group-get-new-news-this-group}.
The nnir interface (@pxref{nnir}) includes engines for searching a
variety of backends. While the details of each search engine vary, the
result of an nnir search is always a vector of the sort used by the
nnselect method, and the results of nnir queries are usually viewed
using an nnselect group. Indeed the standard search function
@code{gnus-group-read-ephemeral-search-group} just creates an
ephemeral nnselect group with the appropriate nnir query as the
@code{nnselect-specs}. nnir originally included both the search
engines and the glue to connect search results to gnus. Over time this
glue evolved into the nnselect method. The two had
a mostly amicable parting so that nnselect could pursue its dream of
becoming a fully functioning backend, but occasional conflicts may
still linger.
@node Combined Groups
@subsection Combined Groups
@cindex nnvirtual
@cindex virtual groups
@cindex merging groups
@ -21238,14 +21379,26 @@ four days, Gnus will decay the scores four times, for instance.
@chapter Searching
@cindex searching
FIXME: Add a brief overview of Gnus search capabilities. A brief
comparison of nnir, nnmairix, contrib/gnus-namazu would be nice
as well.
FIXME: A brief comparison of nnir, nnmairix, contrib/gnus-namazu would
be nice.
This chapter describes tools for searching groups and servers for
articles matching a query and then retrieving those articles. Gnus
provides a simpler mechanism for searching through articles in a summary buffer
to find those matching a pattern. @xref{Searching for Articles}.
Gnus has various ways of finding articles that match certain criteria
(from a particular author, on a certain subject, etc). The simplest
method is to enter a group and then either "limit" the summary buffer
to the desired articles using the limiting commands (@xref{Limiting}),
or searching through messages in the summary buffer (@xref{Searching
for Articles}).
Limiting commands and summary buffer searching work on subsets of the
articles already fetched from the servers, and these commands won’t
query the server for additional articles. While simple, these methods
are therefore inadequate if the desired articles span multiple groups,
or if the group is so large that fetching all articles is
impractical. Many backends (such as imap, notmuch, namazu, etc.)
provide their own facilities to search for articles directly on the
server and gnus can take advantage of these methods. This chapter
describes tools for searching groups and servers for articles matching
a query.
@menu
* nnir:: Searching with various engines.
@ -21275,7 +21428,7 @@ through mail and news repositories. Different backends (like
interface.
The @code{nnimap} search engine should work with no configuration.
Other engines require a local index that needs to be created and
Other engines may require a local index that needs to be created and
maintained outside of Gnus.
@ -21283,23 +21436,19 @@ maintained outside of Gnus.
@subsection Basic Usage
In the group buffer typing @kbd{G G} will search the group on the
current line by calling @code{gnus-group-make-nnir-group}. This prompts
for a query string, creates an ephemeral @code{nnir} group containing
current line by calling @code{gnus-group-make-search-group}. This prompts
for a query string, creates an ephemeral @code{nnselect} group containing
the articles that match this query, and takes you to a summary buffer
showing these articles. Articles may then be read, moved and deleted
using the usual commands.
The @code{nnir} group made in this way is an @code{ephemeral} group,
and some changes are not permanent: aside from reading, moving, and
deleting, you can't act on the original article. But there is an
alternative: you can @emph{warp} (i.e., jump) to the original group
for the article on the current line with @kbd{A W}, aka
@code{gnus-warp-to-article}. Even better, the function
@code{gnus-summary-refer-thread}, bound by default in summary buffers
to @kbd{A T}, will first warp to the original group before it works
its magic and includes all the articles in the thread. From here you
can read, move and delete articles, but also copy them, alter article
marks, whatever. Go nuts.
The @code{nnselect} group made in this way is an @code{ephemeral}
group, and will disappear upon exit from the group. However changes
made in the group are permanently reflected in the real groups from
which the articles are drawn. It is occasionally convenient to view
articles found through searching in their original group. You can
@emph{warp} (i.e., jump) to the original group for the article on the
current line with @kbd{A W}, aka @code{gnus-warp-to-article}.
You say you want to search more than just the group on the current line?
No problem: just process-mark the groups you want to search. You want
@ -21307,14 +21456,14 @@ even more? Calling for an nnir search with the cursor on a topic heading
will search all the groups under that heading.
Still not enough? OK, in the server buffer
@code{gnus-group-make-nnir-group} (now bound to @kbd{G}) will search all
groups from the server on the current line. Too much? Want to ignore
certain groups when searching, like spam groups? Just customize
@code{nnir-ignored-newsgroups}.
@code{gnus-group-make-search-group} (now bound to @kbd{G}) will search
all groups from the server on the current line. Too much? Want to
ignore certain groups when searching, like spam groups? Just
customize @code{nnir-ignored-newsgroups}.
One more thing: individual search engines may have special search
features. You can access these special features by giving a prefix-arg
to @code{gnus-group-make-nnir-group}. If you are searching multiple
to @code{gnus-group-make-search-group}. If you are searching multiple
groups with different search engines you will be prompted for the
special search features for each engine separately.
@ -21371,8 +21520,7 @@ variable is set to use the @code{imap} engine for all servers using the
your servers with an @code{nnimap} backend you could change this to
@lisp
'((nnimap . namazu)
(nntp . gmane))
'((nnimap . namazu))
@end lisp
@node The imap Engine
@ -21575,7 +21723,7 @@ This engine is obsolete.
@item nnir-method-default-engines
Alist of pairs of server backends and search engines. The default
associations are
association is
@example
(nnimap . imap)
@end example
@ -21584,32 +21732,6 @@ associations are
A regexp to match newsgroups in the active file that should be skipped
when searching all groups on a server.
@item nnir-summary-line-format
The format specification to be used for lines in an nnir summary buffer.
All the items from @code{gnus-summary-line-format} are available, along with
three items unique to nnir summary buffers:
@example
%Z Search retrieval score value (integer)
%G Article original full group name (string)
%g Article original short group name (string)
@end example
If @code{nil} (the default) this will use @code{gnus-summary-line-format}.
@item nnir-retrieve-headers-override-function
If non-@code{nil}, a function that retrieves article headers rather than using
the gnus built-in function. This function takes an article list and
group as arguments and populates the @code{nntp-server-buffer} with the
retrieved headers. It should then return either 'nov or 'headers
indicating the retrieved header format. Failure to retrieve headers
should return @code{nil}.
If this variable is @code{nil}, or if the provided function returns
@code{nil} for a search result, @code{gnus-retrieve-headers} will be
called instead."
@end table

7
doc/misc/message.texi
View file

@ -2296,8 +2296,11 @@ String to mark the end of some inserted text.
String to be inserted at the end of the message buffer. If @code{t}
(which is the default), the @code{message-signature-file} file will be
inserted instead. If a function, the result from the function will be
used instead. If a form, the result from the form will be used instead.
If this variable is @code{nil}, no signature will be inserted at all.
used instead. If a form, the result from the form will be used
instead. If this variable is @code{nil}, no signature will be
inserted at all, but you can still insert your
@code{message-signature-file} by hand when desired, using the
@kbd{C-c C-w} (@code{message-insert-signature}) command.
@item message-signature-file
@vindex message-signature-file

10
doc/misc/smtpmail.texi
View file

@ -267,10 +267,12 @@ file, @pxref{Top,,auth-source, auth, Emacs auth-source Library}.
The process by which the SMTP library authenticates you to the server
is known as ``Simple Authentication and Security Layer'' (SASL).
There are various SASL mechanisms, and this library supports three of
them: CRAM-MD5, PLAIN, and LOGIN@. It tries each of them, in that order,
until one succeeds. The first uses a form of encryption to obscure
your password, while the other two do not.
them: CRAM-MD5, PLAIN, and LOGIN, where the first uses a form of
encryption to obscure your password, while the other two do not. It
tries each of them, in that order, until one succeeds. You can
override this by assigning a specific authentication mechanism to a
server by including a key @code{smtp-auth} with the value of your
preferred mechanism in the appropriate @file{~/.authinfo} entry.
@node Encryption
@chapter Encryption

87
etc/NEWS
View file

@ -43,7 +43,7 @@ still a valid backend.
---
** Building without double buffering support.
configure --with-xdbe=no can now be used to disable double buffering
'configure --with-xdbe=no' can now be used to disable double buffering
at build time.
---
@ -99,14 +99,14 @@ box if the point is on an image larger than 'SIZE' pixels in any
dimension.
+++
** New custom option 'word-wrap-by-category'.
** New user option 'word-wrap-by-category'.
When word-wrap is enabled, and this option is non-nil, that allows
Emacs to break lines after more characters than just whitespace
characters. In particular, this significantly improves word-wrapping
for CJK text mixed with Latin text.
---
*** Improved language transliteration in Malayalam input methods.
** Improved language transliteration in Malayalam input methods.
Added a new Mozhi scheme. The inapplicable ITRANS scheme is now
deprecated. Errors in the Inscript method were corrected.
@ -167,6 +167,19 @@ same for a button.
* Changes in Specialized Modes and Packages in Emacs 28.1
---
** Specific warnings can now be disabled from the warning buffer.
When a warning is displayed to the user, the resulting buffer now has
buttons which allow making permanent changes to the treatment of that
warning. Automatic showing of the warning can be disabled (although
it is still logged to the *Messages* buffer), or the warning can be
disabled entirely.
** mspool.el
---
*** Autoload the main entry point 'mspool-show'.
** Windows
*** The key prefix 'C-x 4 1' displays next command buffer in the same window.
@ -296,7 +309,7 @@ invoke 'C-u C-x v s' ('vc-create-tag').
*** 'vc-hg' now uses 'hg summary' to populate extra 'vc-dir' headers.
---
*** New variable 'vc-git-revision-complete-only-branches'.
*** New user option 'vc-git-revision-complete-only-branches'.
If non-nil, only branches and remotes are considered when doing
completion over Git branch names. The default is nil, which causes
tags to be considered as well.
@ -304,7 +317,24 @@ tags to be considered as well.
** Gnus
+++
*** New option 'gnus-dbus-close-on-sleep'
*** New backend 'nnselect'.
The newly added 'nnselect' backend allows creating groups from an
arbitrary list of articles that may come from multiple groups and
servers. These groups generally behave like any other group: they may
be ephemeral or persistent, and allow article marking, moving,
deletion, etc. 'nnselect' groups may be created like any other group,
but there is also a convenience function for the common case of
obtaining the list of articles as a result of a search:
'gnus-group-make-search-group' ('G g') that will prompt for an 'nnir'
search query and create a dedicated group for that search. As part of
this addition, the user option 'nnir-summary-line-format' has been
removed; it's functionality is now available directly in the
'gnus-summary-line-format' '%G' and '%g' specs. The user option
'gnus-refer-thread-use-nnir' has been renamed to
'gnus-refer-thread-use-search'.
+++
*** New user option 'gnus-dbus-close-on-sleep'.
On systems with D-Bus support, it is now possible to register a signal
to close all Gnus servers before the system sleeps.
@ -379,6 +409,13 @@ In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot')
command has been added. It depends on using an external program to
take the actual screenshot, and defaults to "ImageMagick import".
** Smtpmail
+++
*** Allow direct selection of smtp authentication mechanism.
A server entry retrieved by auth-source can request a desired smtp
authentication mechanism by setting a value for the key 'smtp-auth'.
** Help
+++
@ -899,17 +936,16 @@ based on the current window size. In previous versions of Emacs, this
was always done (and that could lead to odd displays when resizing the
window after starting). This variable defaults to nil.
** Miscellaneous
+++
*** The user can now customize how \"default\" values are prompted for.
*** The user can now customize how "default" values are prompted for.
The new utility function 'format-prompt' has been added which uses the
new 'minibuffer-default-prompt-format' variable to format \"default\"
new 'minibuffer-default-prompt-format' user option to format "default"
prompts. This means that prompts that look like "Enter a number
(default 10)" can be customized to look like, for instance, "Enter a
number [10]", or not have the default displayed at all, like "Enter a
number". (This requires that all callers are altered to user
number". (This requires that all callers are altered to use
'format-prompt', though.)
---
@ -917,7 +953,7 @@ number". (This requires that all callers are altered to user
This face is used for error messages from diff.
+++
*** New global mode 'global-goto-address-mode'
*** New global mode 'global-goto-address-mode'.
This will enable 'goto-address-mode' in all buffers.
---
@ -968,7 +1004,6 @@ never be narrower than 19 characters.
When the bookmark.el library is loaded, a customize choice is added
to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list.
** xwidget-webkit mode
*** New xwidget functions.
@ -1026,6 +1061,14 @@ The following user options have been renamed:
The old names are now obsolete.
** D-Bus
+++
*** Registered properties can have the new access type ':write'.
+++
*** In case of problems, handlers can emit proper D-Bus error messages now.
* New Modes and Packages in Emacs 28.1
@ -1115,12 +1158,12 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el.
'allout-init', 'bookmark-jump-noselect',
'bookmark-read-annotation-text-func', 'buffer-menu-mode-hook',
'c-forward-into-nomenclature', 'char-coding-system-table',
'char-valid-p', 'charset-bytes', 'charset-id', 'charset-list'
(function), 'choose-completion-delete-max-match', 'complete-in-turn',
'char-valid-p', 'charset-bytes', 'charset-id', 'charset-list',
'choose-completion-delete-max-match', 'complete-in-turn',
'completion-base-size', 'completion-common-substring',
'crm-minibuffer-complete', 'crm-minibuffer-complete-and-exit',
'crm-minibuffer-completion-help', 'custom-mode', 'custom-mode-hook',
'detect-coding-with-priority', 'dirtrack-debug' (function),
'detect-coding-with-priority', 'dirtrack-debug',
'dirtrack-debug-toggle', 'dynamic-completion-table',
'easy-menu-precalculate-equivalent-keybindings',
'epa-display-verify-result', 'epg-passphrase-callback-function',
@ -1140,10 +1183,9 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el.
'nonascii-translation-table', 'password-read-and-add',
'pre-abbrev-expand-hook', 'princ-list', 'print-help-return-message',
'process-filter-multibyte-p', 'read-file-name-predicate',
'remember-buffer' (function), 'rmail-highlight-face',
'rmail-message-filter', 'set-coding-priority',
'set-process-filter-multibyte', 'shadows-compare-text-p',
'shell-dirtrack-toggle', 't-mouse-mode',
'remember-buffer', 'rmail-highlight-face', 'rmail-message-filter',
'set-coding-priority', 'set-process-filter-multibyte',
'shadows-compare-text-p', 'shell-dirtrack-toggle', 't-mouse-mode',
'term-dynamic-simple-complete', 'tooltip-hook', 'tpu-have-ispell',
'url-generate-unique-filename', 'url-temporary-directory',
'vc-arch-command', 'vc-default-working-revision' (variable),
@ -1173,12 +1215,6 @@ region's (or buffer's) end.
This function can be used by modes to add elements to the
'choice' customization type of a variable.
+++
** 'expand-file-name' no longer omits a trailing slash if the omission
changes the filename's meaning. E.g., (expand-file-name "/a/b/.") now
returns "/a/b/" not "/a/b", which might be misinterpreted as the name
of a symbolic link rather than of the directory it points to.
+++
** New function 'file-modes-number-to-symbolic' to convert a numeric
file mode specification into symbolic form.
@ -1215,6 +1251,9 @@ equivalent period in seconds.
+++
** The new function 'dom-remove-attribute' has been added.
+++
** The new function 'dom-print' has been added.
---
** 'make-network-process', 'make-serial-process' ':coding' behavior change.
Previously, passing ':coding nil' to either of these functions would

6
lib/gnulib.mk.in
View file

@ -442,6 +442,7 @@ GNULIB_STRCASESTR = @GNULIB_STRCASESTR@
GNULIB_STRCHRNUL = @GNULIB_STRCHRNUL@
GNULIB_STRDUP = @GNULIB_STRDUP@
GNULIB_STRERROR = @GNULIB_STRERROR@
GNULIB_STRERRORNAME_NP = @GNULIB_STRERRORNAME_NP@
GNULIB_STRERROR_R = @GNULIB_STRERROR_R@
GNULIB_STRFTIME = @GNULIB_STRFTIME@
GNULIB_STRNCAT = @GNULIB_STRNCAT@
@ -662,6 +663,7 @@ HAVE_STPCPY = @HAVE_STPCPY@
HAVE_STPNCPY = @HAVE_STPNCPY@
HAVE_STRCASESTR = @HAVE_STRCASESTR@
HAVE_STRCHRNUL = @HAVE_STRCHRNUL@
HAVE_STRERRORNAME_NP = @HAVE_STRERRORNAME_NP@
HAVE_STRPBRK = @HAVE_STRPBRK@
HAVE_STRPTIME = @HAVE_STRPTIME@
HAVE_STRSEP = @HAVE_STRSEP@
@ -965,6 +967,7 @@ REPLACE_STRCASESTR = @REPLACE_STRCASESTR@
REPLACE_STRCHRNUL = @REPLACE_STRCHRNUL@
REPLACE_STRDUP = @REPLACE_STRDUP@
REPLACE_STRERROR = @REPLACE_STRERROR@
REPLACE_STRERRORNAME_NP = @REPLACE_STRERRORNAME_NP@
REPLACE_STRERROR_R = @REPLACE_STRERROR_R@
REPLACE_STRFTIME = @REPLACE_STRFTIME@
REPLACE_STRNCAT = @REPLACE_STRNCAT@
@ -2859,6 +2862,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's/@''GNULIB_STRTOK_R''@/$(GNULIB_STRTOK_R)/g' \
-e 's/@''GNULIB_STRERROR''@/$(GNULIB_STRERROR)/g' \
-e 's/@''GNULIB_STRERROR_R''@/$(GNULIB_STRERROR_R)/g' \
-e 's/@''GNULIB_STRERRORNAME_NP''@/$(GNULIB_STRERRORNAME_NP)/g' \
-e 's/@''GNULIB_SIGABBREV_NP''@/$(GNULIB_SIGABBREV_NP)/g' \
-e 's/@''GNULIB_SIGDESCR_NP''@/$(GNULIB_SIGDESCR_NP)/g' \
-e 's/@''GNULIB_STRSIGNAL''@/$(GNULIB_STRSIGNAL)/g' \
@ -2883,6 +2887,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''HAVE_STRCASESTR''@|$(HAVE_STRCASESTR)|g' \
-e 's|@''HAVE_DECL_STRTOK_R''@|$(HAVE_DECL_STRTOK_R)|g' \
-e 's|@''HAVE_DECL_STRERROR_R''@|$(HAVE_DECL_STRERROR_R)|g' \
-e 's|@''HAVE_STRERRORNAME_NP''@|$(HAVE_STRERRORNAME_NP)|g' \
-e 's|@''HAVE_SIGABBREV_NP''@|$(HAVE_SIGABBREV_NP)|g' \
-e 's|@''HAVE_SIGDESCR_NP''@|$(HAVE_SIGDESCR_NP)|g' \
-e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \
@ -2900,6 +2905,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''REPLACE_STRTOK_R''@|$(REPLACE_STRTOK_R)|g' \
-e 's|@''REPLACE_STRERROR''@|$(REPLACE_STRERROR)|g' \
-e 's|@''REPLACE_STRERROR_R''@|$(REPLACE_STRERROR_R)|g' \
-e 's|@''REPLACE_STRERRORNAME_NP''@|$(REPLACE_STRERRORNAME_NP)|g' \
-e 's|@''REPLACE_STRSIGNAL''@|$(REPLACE_STRSIGNAL)|g' \
-e 's|@''UNDEFINE_STRTOK_R''@|$(UNDEFINE_STRTOK_R)|g' \
-e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \

24
lib/string.in.h
View file

@ -1045,6 +1045,30 @@ _GL_WARN_ON_USE (strerror_r, "strerror_r is unportable - "
# endif
#endif
/* Return the name of the system error code ERRNUM. */
#if @GNULIB_STRERRORNAME_NP@
# if @REPLACE_STRERRORNAME_NP@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# undef strerrorname_np
# define strerrorname_np rpl_strerrorname_np
# endif
_GL_FUNCDECL_RPL (strerrorname_np, const char *, (int errnum));
_GL_CXXALIAS_RPL (strerrorname_np, const char *, (int errnum));
# else
# if !@HAVE_STRERRORNAME_NP@
_GL_FUNCDECL_SYS (strerrorname_np, const char *, (int errnum));
# endif
_GL_CXXALIAS_SYS (strerrorname_np, const char *, (int errnum));
# endif
_GL_CXXALIASWARN (strerrorname_np);
#elif defined GNULIB_POSIXCHECK
# undef strerrorname_np
# if HAVE_RAW_DECL_STRERRORNAME_NP
_GL_WARN_ON_USE (strerrorname_np, "strerrorname_np is unportable - "
"use gnulib module strerrorname_np for portability");
# endif
#endif
/* Return an abbreviation string for the signal number SIG. */
#if @GNULIB_SIGABBREV_NP@
# if ! @HAVE_SIGABBREV_NP@

43
lib/verify.h
View file

@ -246,13 +246,6 @@ template <int w>
/* @assert.h omit start@ */
#if defined __has_builtin
/* <https://clang.llvm.org/docs/LanguageExtensions.html#builtin-functions> */
# define _GL_HAS_BUILTIN_ASSUME __has_builtin (__builtin_assume)
#else
# define _GL_HAS_BUILTIN_ASSUME 0
#endif
#if 3 < __GNUC__ + (3 < __GNUC_MINOR__ + (4 <= __GNUC_PATCHLEVEL__))
# define _GL_HAS_BUILTIN_TRAP 1
#elif defined __has_builtin
@ -312,36 +305,14 @@ template <int w>
Although assuming R can help a compiler generate better code or
diagnostics, performance can suffer if R uses hard-to-optimize
features such as function calls not inlined by the compiler. */
features such as function calls not inlined by the compiler.
/* Use __builtin_assume in preference to __builtin_unreachable, because
in clang versions 8.0.x and older, the definition based on
__builtin_assume has an effect on optimizations, whereas the definition
based on __builtin_unreachable does not. (GCC so far has only
__builtin_unreachable.) */
#if _GL_HAS_BUILTIN_ASSUME
/* Use __builtin_constant_p to help clang's data-flow analysis for the case
assume (0).
Use a temporary variable, to avoid a clang warning
"the argument to '__builtin_assume' has side effects that will be discarded"
if R contains invocations of functions not marked as 'const'.
The type of the temporary variable can't be __typeof__ (R), because that
does not work on bit field expressions. Use '_Bool' or 'bool' as type
instead. */
# if defined __cplusplus
# define assume(R) \
(__builtin_constant_p (R) && !(R) \
? (void) __builtin_unreachable () \
: (void) ({ bool _gl_verify_temp = (R); \
__builtin_assume (_gl_verify_temp); }))
# else
# define assume(R) \
(__builtin_constant_p (R) && !(R) \
? (void) __builtin_unreachable () \
: (void) ({ _Bool _gl_verify_temp = (R); \
__builtin_assume (_gl_verify_temp); }))
# endif
#elif _GL_HAS_BUILTIN_UNREACHABLE
Avoid Clang's __builtin_assume, as it breaks GNU Emacs master
as of 2020-08-23T21:09:49Z!eggert@cs.ucla.edu; see
<https://bugs.gnu.org/43152#71>. It's not known whether this breakage
is a Clang bug or an Emacs bug; play it safe for now. */
#if _GL_HAS_BUILTIN_UNREACHABLE
# define assume(R) ((R) ? (void) 0 : __builtin_unreachable ())
#elif 1200 <= _MSC_VER
# define assume(R) __assume (R)

56
lisp/calendar/icalendar.el
View file

@ -515,9 +515,10 @@ The strings are suitable for assembling into a TZ variable."
(let* ((offsetto (car (cddr (assq 'TZOFFSETTO alist))))
(offsetfrom (car (cddr (assq 'TZOFFSETFROM alist))))
(rrule-value (car (cddr (assq 'RRULE alist))))
(rdate-p (and (assq 'RDATE alist) t))
(dtstart (car (cddr (assq 'DTSTART alist))))
(no-dst (equal offsetto offsetfrom)))
;; FIXME: for now we only handle RRULE and not RDATE here.
(no-dst (or rdate-p (equal offsetto offsetfrom))))
;; FIXME: the presence of an RDATE is assumed to denote the first day of the year
(when (and offsetto dtstart (or rrule-value no-dst))
(let* ((rrule (icalendar--split-value rrule-value))
(freq (cadr (assq 'FREQ rrule)))
@ -561,12 +562,13 @@ The strings are suitable for assembling into a TZ variable."
(defun icalendar--parse-vtimezone (alist)
"Turn a VTIMEZONE ALIST into a cons (ID . TZ-STRING).
Consider only the most recent date specification.
Return nil if timezone cannot be parsed."
(let* ((tz-id (icalendar--convert-string-for-import
(icalendar--get-event-property alist 'TZID)))
(daylight (cadr (cdar (icalendar--get-children alist 'DAYLIGHT))))
(daylight (cadr (cdar (icalendar--get-most-recent-observance alist 'DAYLIGHT))))
(day (and daylight (icalendar--convert-tz-offset daylight t)))
(standard (cadr (cdar (icalendar--get-children alist 'STANDARD))))
(standard (cadr (cdar (icalendar--get-most-recent-observance alist 'STANDARD))))
(std (and standard (icalendar--convert-tz-offset standard nil))))
(if (and tz-id std)
(cons tz-id
@ -575,6 +577,28 @@ Return nil if timezone cannot be parsed."
"," (cdr day) "," (cdr std))
(car std))))))
(defun icalendar--get-most-recent-observance (alist sub-comp)
"Return the latest observance for SUB-COMP DAYLIGHT or STANDARD.
ALIST is a VTIMEZONE potentially containing historical records."
;FIXME?: "most recent" should be relative to a given date
(let ((components (icalendar--get-children alist sub-comp)))
(list
(car
(sort components
#'(lambda (a b)
(let* ((get-recent (lambda (n)
(car
(sort
(delq nil
(mapcar (lambda (p)
(and (memq (car p) '(DTSTART RDATE))
(car (cddr p))))
n))
'string-greaterp))))
(a-recent (funcall get-recent (car (cddr a))))
(b-recent (funcall get-recent (car (cddr b)))))
(string-greaterp a-recent b-recent))))))))
(defun icalendar--convert-all-timezones (icalendar)
"Convert all timezones in the ICALENDAR into an alist.
Each element of the alist is a cons (ID . TZ-STRING),
@ -594,15 +618,18 @@ ZONE-MAP is a timezone alist as returned by `icalendar--convert-all-timezones'."
(cdr (assoc id zone-map)))))
(defun icalendar--decode-isodatetime (isodatetimestring &optional day-shift
zone)
source-zone
result-zone)
"Return ISODATETIMESTRING in format like `decode-time'.
Converts from ISO-8601 to Emacs representation. If
ISODATETIMESTRING specifies UTC time (trailing letter Z) the
decoded time is given in the local time zone! If optional
parameter DAY-SHIFT is non-nil the result is shifted by DAY-SHIFT
days.
ZONE, if provided, is the timezone, in any format understood by `encode-time'.
SOURCE-ZONE, if provided, is the timezone for decoding the time,
in any format understood by `encode-time'.
RESULT-ZONE, if provided, is the timezone for encoding the result
in any format understood by `decode-time'.
FIXME: multiple comma-separated values should be allowed!"
(icalendar--dmsg isodatetimestring)
(if isodatetimestring
@ -624,7 +651,10 @@ FIXME: multiple comma-separated values should be allowed!"
(when (and (> (length isodatetimestring) 15)
;; UTC specifier present
(char-equal ?Z (aref isodatetimestring 15)))
(setq zone t))
(setq source-zone t
;; decode to local time unless result-zone is explicitly given,
;; i.e. do not decode to UTC, i.e. do not (setq result-zone t)
))
;; shift if necessary
(if day-shift
(let ((mdy (calendar-gregorian-from-absolute
@ -637,9 +667,9 @@ FIXME: multiple comma-separated values should be allowed!"
;; create the decoded date-time
;; FIXME!?!
(let ((decoded-time (list second minute hour day month year
nil -1 zone)))
nil -1 source-zone)))
(condition-case nil
(decode-time (encode-time decoded-time))
(decode-time (encode-time decoded-time) result-zone)
(error
(message "Cannot decode \"%s\"" isodatetimestring)
;; Hope for the best....
@ -685,9 +715,9 @@ FIXME: multiple comma-separated values should be allowed!"
(setq days (1- days))))
((match-beginning 4) ;days and time
(if (match-beginning 5)
(setq days (* 7 (read (substring isodurationstring
(match-beginning 6)
(match-end 6))))))
(setq days (read (substring isodurationstring
(match-beginning 6)
(match-end 6)))))
(if (match-beginning 7)
(setq hours (read (substring isodurationstring
(match-beginning 8)

6
lisp/comint.el
View file

@ -2423,11 +2423,13 @@ Security bug: your string can still be temporarily recovered with
(defun comint-watch-for-password-prompt (string)
"Prompt in the minibuffer for password and send without echoing.
Looks for a match to `comint-password-prompt-regexp' in order
to detect the need to (prompt and) send a password.
to detect the need to (prompt and) send a password. Ignores any
carriage returns (\\r) in STRING.
This function could be in the list `comint-output-filter-functions'."
(when (let ((case-fold-search t))
(string-match comint-password-prompt-regexp string))
(string-match comint-password-prompt-regexp
(replace-regexp-in-string "\r" "" string)))
(when (string-match "^[ \n\r\t\v\f\b\a]+" string)
(setq string (replace-match "" t t string)))
(let ((comint--prompt-recursion-depth (1+ comint--prompt-recursion-depth)))

2
lisp/cus-edit.el
View file

@ -2685,7 +2685,7 @@ try matching its doc string against `custom-guess-doc-alist'."
:sample-face (if obsolete
'custom-variable-obsolete
'custom-variable-tag)
tag)
:tag tag)
buttons)
(push (widget-create-child-and-convert
widget type

17
lisp/cus-theme.el
View file

@ -419,14 +419,13 @@ It includes all variables in list VARS."
(widget-value child)
;; Child is null if the widget is closed (hidden).
(car (widget-get widget :shown-value)))))
(when (boundp symbol)
(unless (bolp)
(princ "\n"))
(princ " '(")
(prin1 symbol)
(princ " ")
(prin1 (custom-quote value))
(princ ")")))))
(unless (bolp)
(princ "\n"))
(princ " '(")
(prin1 symbol)
(princ " ")
(prin1 (custom-quote value))
(princ ")"))))
(if (bolp)
(princ " "))
(princ ")")
@ -454,7 +453,7 @@ It includes all faces in list FACES."
;; Child is null if the widget is closed (hidden).
((widget-get widget :shown-value))
(t (custom-face-get-current-spec symbol)))))
(when (and (facep symbol) value)
(when value
(princ (if (bolp) " '(" "\n '("))
(prin1 symbol)
(princ " ")

21
lisp/custom.el
View file

@ -907,7 +907,15 @@ See `custom-known-themes' for a list of known themes."
(boundp symbol))
(let ((sv (get symbol 'standard-value))
(val (symbol-value symbol)))
(unless (and sv (equal (eval (car sv)) val))
(unless (or
;; We only do this trick if the current value
;; is different from the standard value.
(and sv (equal (eval (car sv)) val))
;; And we don't do it if we would end up recording
;; the same value for the user theme. This way we avoid
;; having ((user VALUE) (changed VALUE)). That would be
;; useless, because we don't disable the user theme.
(and (eq theme 'user) (equal (custom-quote val) value)))
(setq old `((changed ,(custom-quote val))))))))
(put symbol prop (cons (list theme value) old)))
(put theme 'theme-settings
@ -1368,13 +1376,14 @@ function runs. To disable other themes, use `disable-theme'."
obarray (lambda (sym) (get sym 'theme-settings)) t))))
(unless (custom-theme-p theme)
(error "Undefined Custom theme %s" theme))
(let ((settings (get theme 'theme-settings)))
(let ((settings (get theme 'theme-settings)) ; '(prop symbol theme value)
;; We are enabling the theme, so don't inhibit enabling it. (Bug#34027)
(custom--inhibit-theme-enable nil))
;; Loop through theme settings, recalculating vars/faces.
(dolist (s settings)
(let* ((prop (car s))
(symbol (cadr s))
(spec-list (get symbol prop)))
(put symbol prop (cons (cddr s) (assq-delete-all theme spec-list)))
(symbol (cadr s)))
(custom-push-theme prop symbol theme 'set (nth 3 s))
(cond
((eq prop 'theme-face)
(custom-theme-recalc-face symbol))
@ -1443,7 +1452,7 @@ See `custom-enabled-themes' for a list of enabled themes."
(let* ((prop (car s))
(symbol (cadr s))
(val (assq-delete-all theme (get symbol prop))))
(put symbol prop val)
(custom-push-theme prop symbol theme 'reset)
(cond
((eq prop 'theme-value)
(custom-theme-recalc-variable symbol))

16
lisp/dired-aux.el
View file

@ -1549,17 +1549,13 @@ files matching `dired-omit-regexp'."
;;;###autoload
(defun dired-remove-file (file)
"Remove entry FILE on each dired buffer.
Note this doesn't delete FILE in the file system.
See `dired-delete-file' in case you wish that."
(dired-fun-in-all-buffers
(file-name-directory file) (file-name-nondirectory file)
#'dired-remove-entry file))
(defun dired-remove-entry (file)
(save-excursion
(and (dired-goto-file file)
(let (buffer-read-only)
(delete-region (progn (beginning-of-line) (point))
(line-beginning-position 2))))))
;;;###autoload
(defun dired-relist-file (file)
"Create or update the line for FILE in all Dired buffers it would belong in."
@ -1676,6 +1672,9 @@ rename them using `vc-rename-file'."
;;;###autoload
(defun dired-rename-file (file newname ok-if-already-exists)
"Rename FILE to NEWNAME.
Signal a `file-already-exists' error if a file NEWNAME already exists
unless OK-IF-ALREADY-EXISTS is non-nil."
(dired-handle-overwrite newname)
(dired-maybe-create-dirs (file-name-directory newname))
(if (and dired-vc-rename-file
@ -1690,7 +1689,8 @@ rename them using `vc-rename-file'."
(set-visited-file-name newname nil t)))
(dired-remove-file file)
;; See if it's an inserted subdir, and rename that, too.
(dired-rename-subdir file newname))
(when (file-directory-p file)
(dired-rename-subdir file newname)))
(defun dired-rename-subdir (from-dir to-dir)
(setq from-dir (file-name-as-directory from-dir)

1
lisp/dired-x.el
View file

@ -137,6 +137,7 @@ folding to be used on case-insensitive filesystems only."
(file-name-case-insensitive-p dir)
dired-omit-case-fold))
;;;###autoload
(define-minor-mode dired-omit-mode
"Toggle omission of uninteresting files in Dired (Dired-Omit mode).

30
lisp/dired.el
View file

@ -2908,12 +2908,12 @@ You can then feed the file name(s) to other commands with \\[yank]."
;; Keeping Dired buffers in sync with the filesystem and with each other
(defun dired-buffers-for-dir (dir &optional file)
;; Return a list of buffers for DIR (top level or in-situ subdir).
;; If FILE is non-nil, include only those whose wildcard pattern (if any)
;; matches FILE.
;; The list is in reverse order of buffer creation, most recent last.
;; As a side effect, killed dired buffers for DIR are removed from
;; dired-buffers.
"Return a list of buffers for DIR (top level or in-situ subdir).
If FILE is non-nil, include only those whose wildcard pattern (if any)
matches FILE.
The list is in reverse order of buffer creation, most recent last.
As a side effect, killed dired buffers for DIR are removed from
dired-buffers."
(setq dir (file-name-as-directory dir))
(let (result buf)
(dolist (elt dired-buffers)
@ -3462,18 +3462,28 @@ Return list of buffers where FUN succeeded (i.e., returned non-nil)."
(let (success-list)
(dolist (buf (dired-buffers-for-dir (expand-file-name directory) file))
(with-current-buffer buf
(if (apply fun args)
(push buf success-list))))
(when (apply fun args)
(push (buffer-name buf) success-list))))
;; FIXME: AFAICT, this return value is not used by any of the callers!
success-list))
;; Delete the entry for FILE from
(defun dired-delete-entry (file)
(defun dired-remove-entry (file)
"Remove entry FILE in the current dired buffer.
Note this doesn't delete FILE in the file system.
See `dired-delete-file' in case you wish that."
(save-excursion
(and (dired-goto-file file)
(let ((inhibit-read-only t))
(delete-region (progn (beginning-of-line) (point))
(save-excursion (forward-line 1) (point))))))
(line-beginning-position 2))))))
(defun dired-delete-entry (file)
"Remove entry FILE in the current dired buffer.
Like `dired-remove-entry' followed by `dired-clean-up-after-deletion'.
Note this doesn't delete FILE in the file system.
See `dired-delete-file' in case you wish that."
(dired-remove-entry file)
(dired-clean-up-after-deletion file))
(defvar dired-clean-up-buffers-too)

44
lisp/dom.el
View file

@ -269,6 +269,50 @@ white-space."
(insert ")")
(insert "\n" (make-string (1+ column) ? ))))))))
(defun dom-print (dom &optional pretty xml)
"Print DOM at point as HTML/XML.
If PRETTY, indent the HTML/XML logically.
If XML, generate XML instead of HTML."
(let ((column (current-column)))
(insert (format "<%s" (dom-tag dom)))
(let ((attr (dom-attributes dom)))
(dolist (elem attr)
;; In HTML, these are boolean attributes that should not have
;; an = value.
(if (and (memq (car elem)
'(async autofocus autoplay checked
contenteditable controls default
defer disabled formNoValidate frameborder
hidden ismap itemscope loop
multiple muted nomodule novalidate open
readonly required reversed
scoped selected typemustmatch))
(cdr elem)
(not xml))
(insert (format " %s" (car elem)))
(insert (format " %s=%S" (car elem) (cdr elem))))))
(let* ((children (dom-children dom))
(non-text nil))
(if (null children)
(insert " />")
(insert ">")
(dolist (child children)
(if (stringp child)
(insert child)
(setq non-text t)
(when pretty
(insert "\n" (make-string (+ column 2) ? )))
(dom-print child pretty xml)))
;; If we inserted non-text child nodes, or a text node that
;; ends with a newline, then we indent the end tag.
(when (and pretty
(or (bolp)
non-text))
(unless (bolp)
(insert "\n"))
(insert (make-string column ? )))
(insert (format "</%s>" (dom-tag dom)))))))
(provide 'dom)
;;; dom.el ends here

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

@ -5,7 +5,7 @@
;; Author: Noah Friedman <friedman@splode.com>
;; Keywords: extensions
;; Created: 1995-10-06
;; Version: 1.8.0
;; Version: 1.10.0
;; Package-Requires: ((emacs "26.3"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@ -573,7 +573,8 @@ Meant as a value for `eldoc-documentation-strategy'."
(let* ((callback (eldoc--make-callback :enthusiast))
(str (funcall f callback)))
(if (stringp str) (funcall callback str))
nil))))
nil)))
t)
;; JT@2020-07-10: ElDoc is pre-loaded, so in Emacs < 28 we can't
;; make the "old" `eldoc-documentation-function' point to the new
@ -739,14 +740,14 @@ should endeavour to display the docstrings eventually produced."
(when (and string (cl-loop for (p) in docs-registered
never (< p pos)))
(setq docs-registered '())
(register-doc pos string plist)
(when (and (timerp eldoc--enthusiasm-curbing-timer)
(memq eldoc--enthusiasm-curbing-timer
timer-list))
(cancel-timer eldoc--enthusiasm-curbing-timer))
(setq eldoc--enthusiasm-curbing-timer
(run-at-time (unless (zerop pos) 0.3)
nil #'display-doc)))
(register-doc pos string plist))
(when (and (timerp eldoc--enthusiasm-curbing-timer)
(memq eldoc--enthusiasm-curbing-timer
timer-list))
(cancel-timer eldoc--enthusiasm-curbing-timer))
(setq eldoc--enthusiasm-curbing-timer
(run-at-time (unless (zerop pos) 0.3)
nil #'display-doc))
t))
(:patient
(cl-incf want)

30
lisp/emacs-lisp/warnings.el
View file

@ -200,6 +200,21 @@ SUPPRESS-LIST is the list of kinds of warnings to suppress."
;; we return t.
some-match))
(define-button-type 'warning-suppress-warning
'action #'warning-suppress-action
'help-echo "mouse-2, RET: Don't display this warning automatically")
(defun warning-suppress-action (button)
(customize-save-variable 'warning-suppress-types
(cons (list (button-get button 'warning-type))
warning-suppress-types)))
(define-button-type 'warning-suppress-log-warning
'action #'warning-suppress-log-action
'help-echo "mouse-2, RET: Don't log this warning")
(defun warning-suppress-log-action (button)
(customize-save-variable 'warning-suppress-log-types
(cons (list (button-get button 'warning-type))
warning-suppress-types)))
;;;###autoload
(defun display-warning (type message &optional level buffer-name)
"Display a warning message, MESSAGE.
@ -227,7 +242,12 @@ See the `warnings' custom group for user customization features.
See also `warning-series', `warning-prefix-function',
`warning-fill-prefix', and `warning-fill-column' for additional
programming features."
programming features.
This will also display buttons allowing the user to permanently
disable automatic display of the warning or disable the warning
entirely by setting `warning-suppress-types' or
`warning-suppress-log-types' on their behalf."
(if (not (or after-init-time noninteractive (daemonp)))
;; Ensure warnings that happen early in the startup sequence
;; are visible when startup completes (bug#20792).
@ -272,6 +292,14 @@ programming features."
(insert (format (nth 1 level-info)
(format warning-type-format typename))
message)
(insert " ")
(insert-button "Disable showing"
'type 'warning-suppress-warning
'warning-type type)
(insert " ")
(insert-button "Disable logging"
'type 'warning-suppress-log-warning
'warning-type type)
(funcall newline)
(when (and warning-fill-prefix (not (string-match "\n" message)))
(let ((fill-prefix warning-fill-prefix)

76
lisp/eshell/esh-mode.el
View file

@ -72,51 +72,43 @@
(defcustom eshell-mode-unload-hook nil
"A hook that gets run when `eshell-mode' is unloaded."
:type 'hook
:group 'eshell-mode)
:type 'hook)
(defcustom eshell-mode-hook nil
"A hook that gets run when `eshell-mode' is entered."
:type 'hook
:group 'eshell-mode)
:type 'hook)
(defcustom eshell-first-time-mode-hook nil
"A hook that gets run the first time `eshell-mode' is entered.
That is to say, the first time during an Emacs session."
:type 'hook
:group 'eshell-mode)
:type 'hook)
(defcustom eshell-exit-hook nil
"A hook that is run whenever `eshell' is exited.
This hook is only run if exiting actually kills the buffer."
:version "24.1" ; removed eshell-query-kill-processes
:type 'hook
:group 'eshell-mode)
:type 'hook)
(defcustom eshell-kill-on-exit t
"If non-nil, kill the Eshell buffer on the `exit' command.
Otherwise, the buffer will simply be buried."
:type 'boolean
:group 'eshell-mode)
:type 'boolean)
(defcustom eshell-input-filter-functions nil
"Functions to call before input is processed.
The input is contained in the region from `eshell-last-input-start' to
`eshell-last-input-end'."
:type 'hook
:group 'eshell-mode)
:type 'hook)
(defcustom eshell-send-direct-to-subprocesses nil
"If t, send any input immediately to a subprocess."
:type 'boolean
:group 'eshell-mode)
:type 'boolean)
(defcustom eshell-expand-input-functions nil
"Functions to call before input is parsed.
Each function is passed two arguments, which bounds the region of the
current input text."
:type 'hook
:group 'eshell-mode)
:type 'hook)
(defcustom eshell-scroll-to-bottom-on-input nil
"Controls whether input to interpreter causes window to scroll.
@ -126,8 +118,7 @@ buffer. If `this', scroll only the selected window.
See `eshell-preinput-scroll-to-bottom'."
:type '(radio (const :tag "Do not scroll Eshell windows" nil)
(const :tag "Scroll all windows showing the buffer" all)
(const :tag "Scroll only the selected window" this))
:group 'eshell-mode)
(const :tag "Scroll only the selected window" this)))
(defcustom eshell-scroll-to-bottom-on-output nil
"Controls whether interpreter output causes window to scroll.
@ -140,8 +131,7 @@ See variable `eshell-scroll-show-maximum-output' and function
:type '(radio (const :tag "Do not scroll Eshell windows" nil)
(const :tag "Scroll all windows showing the buffer" all)
(const :tag "Scroll only the selected window" this)
(const :tag "Scroll all windows other than selected" others))
:group 'eshell-mode)
(const :tag "Scroll all windows other than selected" others)))
(defcustom eshell-scroll-show-maximum-output t
"Controls how interpreter output causes window to scroll.
@ -149,16 +139,14 @@ If non-nil, then show the maximum output when the window is scrolled.
See variable `eshell-scroll-to-bottom-on-output' and function
`eshell-postoutput-scroll-to-bottom'."
:type 'boolean
:group 'eshell-mode)
:type 'boolean)
(defcustom eshell-buffer-maximum-lines 1024
"The maximum size in lines for eshell buffers.
Eshell buffers are truncated from the top to be no greater than this
number, if the function `eshell-truncate-buffer' is on
`eshell-output-filter-functions'."
:type 'integer
:group 'eshell-mode)
:type 'integer)
(defcustom eshell-output-filter-functions
'(eshell-postoutput-scroll-to-bottom
@ -168,36 +156,31 @@ number, if the function `eshell-truncate-buffer' is on
"Functions to call before output is displayed.
These functions are only called for output that is displayed
interactively, and not for output which is redirected."
:type 'hook
:group 'eshell-mode)
:type 'hook)
(defcustom eshell-preoutput-filter-functions nil
"Functions to call before output is inserted into the buffer.
These functions get one argument, a string containing the text to be
inserted. They return the string as it should be inserted."
:type 'hook
:group 'eshell-mode)
:type 'hook)
(defcustom eshell-password-prompt-regexp
(format "\\(%s\\)[^:：៖]*[:：៖]\\s *\\'" (regexp-opt password-word-equivalents))
"Regexp matching prompts for passwords in the inferior process.
This is used by `eshell-watch-for-password-prompt'."
:type 'regexp
:version "27.1"
:group 'eshell-mode)
:version "27.1")
(defcustom eshell-skip-prompt-function nil
"A function called from beginning of line to skip the prompt."
:type '(choice (const nil) function)
:group 'eshell-mode)
:type '(choice (const nil) function))
(define-obsolete-variable-alias 'eshell-status-in-modeline
'eshell-status-in-mode-line "24.3")
(defcustom eshell-status-in-mode-line t
"If non-nil, let the user know a command is running in the mode line."
:type 'boolean
:group 'eshell-mode)
:type 'boolean)
(defcustom eshell-directory-name
(locate-user-emacs-file "eshell/" ".eshell/")
@ -329,6 +312,8 @@ and the hook `eshell-exit-hook'."
(if mode-line-elt
(setcar mode-line-elt 'eshell-command-running-string))))
(set (make-local-variable 'bookmark-make-record-function)
'eshell-bookmark-make-record)
(setq local-abbrev-table eshell-mode-abbrev-table)
(set (make-local-variable 'list-buffers-directory)
@ -1015,5 +1000,28 @@ This function could be in the list `eshell-output-filter-functions'."
(custom-add-option 'eshell-output-filter-functions
'eshell-handle-ansi-color)
;;; Bookmark support:
(declare-function bookmark-make-record-default
"bookmark" (&optional no-file no-context posn))
(declare-function bookmark-prop-get "bookmark" (bookmark prop))
(defun eshell-bookmark-name ()
(format "eshell-%s"
(file-name-nondirectory
(directory-file-name
(file-name-directory default-directory)))))
(defun eshell-bookmark-make-record ()
"Create a bookmark for the current Eshell buffer."
`(,(eshell-bookmark-name)
(location . ,default-directory)
(handler . eshell-bookmark-jump)))
(defun eshell-bookmark-jump (bookmark)
"Default bookmark handler for Eshell buffers."
(let ((default-directory (bookmark-prop-get bookmark 'location)))
(eshell)))
(provide 'esh-mode)
;;; esh-mode.el ends here

2
lisp/files.el
View file

@ -5577,7 +5577,7 @@ change the additional actions you can take on files."
(concat "\\<"
(regexp-quote
(file-name-nondirectory
buffer-file-name))
(buffer-file-name buffer)))
"<[^>]*>\\'")
(buffer-name buffer)))
;; The buffer name is similar to the

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

@ -3934,7 +3934,7 @@ If REREAD is not nil, downloaded articles are marked as unread."
(mm-with-unibyte-buffer
(nnheader-insert-file-contents file)
(nnheader-remove-body)
(setq header (nnheader-parse-naked-head)))
(setq header (nnheader-parse-head t)))
(setf (mail-header-number header) (car downloaded))
(if nov-arts
(let ((key (concat "^" (int-to-string (car nov-arts))

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

@ -186,7 +186,7 @@ it's not cached."
(gnus-cache-update-file-total-fetched-for group file))
(setq lines-chars (nnheader-get-lines-and-char))
(nnheader-remove-body)
(setq headers (nnheader-parse-naked-head))
(setq headers (nnheader-parse-head t))
(setf (mail-header-number headers) number)
(setf (mail-header-lines headers) (car lines-chars))
(setf (mail-header-chars headers) (cadr lines-chars))

10
lisp/gnus/gnus-cloud.el
View file

@ -391,6 +391,8 @@ When FULL is t, upload everything, not just a difference from the last full."
(gnus-group-refresh-group group))
(gnus-error 2 "Failed to upload Gnus Cloud data to %s" group)))))
(defvar gnus-alter-header-function)
(defun gnus-cloud-add-timestamps (elems)
(dolist (elem elems)
(let* ((file-name (plist-get elem :file-name))
@ -409,9 +411,11 @@ When FULL is t, upload everything, not just a difference from the last full."
(when (gnus-retrieve-headers (gnus-uncompress-range active) group)
(with-current-buffer nntp-server-buffer
(goto-char (point-min))
(while (and (not (eobp))
(setq head (nnheader-parse-head)))
(push head headers))))
(while (setq head (nnheader-parse-head))
(when gnus-alter-header-function
(funcall gnus-alter-header-function head))
(push head headers))
))
(sort (nreverse headers)
(lambda (h1 h2)
(> (gnus-cloud-chunk-sequence (mail-header-subject h1))

57
lisp/gnus/gnus-group.el
View file

@ -49,8 +49,6 @@
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
(autoload 'gnus-group-make-nnir-group "nnir")
(autoload 'gnus-cloud-upload-all-data "gnus-cloud")
(autoload 'gnus-cloud-download-all-data "gnus-cloud")
@ -663,7 +661,8 @@ simple manner."
"D" gnus-group-enter-directory
"f" gnus-group-make-doc-group
"w" gnus-group-make-web-group
"G" gnus-group-make-nnir-group
"G" gnus-group-read-ephemeral-search-group
"g" gnus-group-make-search-group
"M" gnus-group-read-ephemeral-group
"r" gnus-group-rename-group
"R" gnus-group-make-rss-group
@ -909,7 +908,8 @@ simple manner."
["Add the help group" gnus-group-make-help-group t]
["Make a doc group..." gnus-group-make-doc-group t]
["Make a web group..." gnus-group-make-web-group t]
["Make a search group..." gnus-group-make-nnir-group t]
["Read a search group..." gnus-group-read-ephemeral-search-group t]
["Make a search group..." gnus-group-make-search-group t]
["Make a virtual group..." gnus-group-make-empty-virtual t]
["Add a group to a virtual..." gnus-group-add-to-virtual t]
["Make an ephemeral group..." gnus-group-read-ephemeral-group t]
@ -2411,7 +2411,8 @@ the bug number, and browsing the URL must return mbox output."
(require 'bug-reference)
(let ((def (cond ((thing-at-point-looking-at bug-reference-bug-regexp 500)
(match-string 2))
((number-at-point)))))
((and (number-at-point)
(abs (number-at-point)))))))
;; Pass DEF as the value of COLLECTION instead of DEF because:
;; a) null input should not cause DEF to be returned and
;; b) TAB and M-n still work this way.
@ -3165,6 +3166,52 @@ mail messages or news articles in files that have numeric names."
(gnus-group-real-name group)
(list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir)))))
(autoload 'nnir-make-specs "nnir")
(autoload 'gnus-group-topic-name "gnus-topic")
;; Temporary to make group creation easier
(defun gnus-group-make-search-group (nnir-extra-parms &optional specs)
(interactive "P")
(let ((name (gnus-read-group "Group name: ")))
(with-current-buffer gnus-group-buffer
(gnus-group-make-group
name
(list 'nnselect "nnselect")
nil
(list
(cons 'nnselect-specs
(list
(cons 'nnselect-function 'nnir-run-query)
(cons 'nnselect-args
(nnir-make-specs nnir-extra-parms specs)))))))))
(defun gnus-group-read-ephemeral-search-group (nnir-extra-parms &optional specs)
"Create an nnselect group based on a search. Prompt for a
search query and determine the groups to search as follows: if
called from the *Server* buffer search all groups belonging to
the server on the current line; if called from the *Group* buffer
search any marked groups, or the group on the current line, or
all the groups under the current topic. Calling with a prefix-arg
prompts for additional search-engine specific constraints. A
non-nil `specs' arg must be an alist with `nnir-query-spec' and
`nnir-group-spec' keys, and skips all prompting."
(interactive "P")
(gnus-group-read-ephemeral-group
(concat "nnselect-" (message-unique-id))
(list 'nnselect "nnselect")
nil
(cons (current-buffer) gnus-current-window-configuration)
; nil
nil nil
(list
(cons 'nnselect-specs
(list
(cons 'nnselect-function 'nnir-run-query)
(cons 'nnselect-args
(nnir-make-specs nnir-extra-parms specs))))
(cons 'nnselect-artlist nil))))
(defun gnus-group-add-to-virtual (n vgroup)
"Add the current group to a virtual group."
(interactive

120
lisp/gnus/gnus-msg.el
View file

@ -393,10 +393,9 @@ only affect the Gcc copy, but not the original message."
(gnus-inews-make-draft-meta-information
,gnus-newsgroup-name ',articles)))
(autoload 'nnir-article-number "nnir" nil nil 'macro)
(autoload 'nnir-article-group "nnir" nil nil 'macro)
(autoload 'gnus-nnir-group-p "nnir")
(autoload 'nnselect-article-number "nnselect" nil nil 'macro)
(autoload 'nnselect-article-group "nnselect" nil nil 'macro)
(autoload 'gnus-nnselect-group-p "nnselect")
(defvar gnus-article-reply nil)
(defmacro gnus-setup-message (config &rest forms)
@ -404,22 +403,24 @@ only affect the Gcc copy, but not the original message."
(winconf-name (make-symbol "gnus-setup-message-winconf-name"))
(buffer (make-symbol "gnus-setup-message-buffer"))
(article (make-symbol "gnus-setup-message-article"))
(oarticle (make-symbol "gnus-setup-message-oarticle"))
(yanked (make-symbol "gnus-setup-yanked-articles"))
(group (make-symbol "gnus-setup-message-group")))
`(let ((,winconf (current-window-configuration))
(,winconf-name gnus-current-window-configuration)
(,buffer (buffer-name (current-buffer)))
(,article (if (and (gnus-nnir-group-p gnus-newsgroup-name)
gnus-article-reply)
(nnir-article-number (or (car-safe gnus-article-reply)
gnus-article-reply))
gnus-article-reply))
(,article (when gnus-article-reply
(or (nnselect-article-number
(or (car-safe gnus-article-reply)
gnus-article-reply))
gnus-article-reply)))
(,oarticle gnus-article-reply)
(,yanked gnus-article-yanked-articles)
(,group (if (and (gnus-nnir-group-p gnus-newsgroup-name)
gnus-article-reply)
(nnir-article-group (or (car-safe gnus-article-reply)
gnus-article-reply))
gnus-newsgroup-name))
(,group (when gnus-article-reply
(or (nnselect-article-group
(or (car-safe gnus-article-reply)
gnus-article-reply))
gnus-newsgroup-name)))
(message-header-setup-hook
(copy-sequence message-header-setup-hook))
(mbl mml-buffer-list)
@ -460,24 +461,23 @@ only affect the Gcc copy, but not the original message."
(unwind-protect
(progn
,@forms)
(gnus-inews-add-send-actions ,winconf ,buffer ,article ,config
(gnus-inews-add-send-actions ,winconf ,buffer ,oarticle ,config
,yanked ,winconf-name)
(setq gnus-message-buffer (current-buffer))
(set (make-local-variable 'gnus-message-group-art)
(cons ,group ,article))
(set (make-local-variable 'gnus-newsgroup-name) ,group)
;; Enable highlighting of different citation levels
(when gnus-message-highlight-citation
(gnus-message-citation-mode 1))
(gnus-run-hooks 'gnus-message-setup-hook)
(if (eq major-mode 'message-mode)
(let ((mbl1 mml-buffer-list))
(setq mml-buffer-list mbl) ;; Global value
(set (make-local-variable 'mml-buffer-list) mbl1);; Local value
(add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)
(add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
(mml-destroy-buffers)
(setq mml-buffer-list mbl)))
;; Enable highlighting of different citation levels
(when gnus-message-highlight-citation
(gnus-message-citation-mode 1))
(gnus-run-hooks 'gnus-message-setup-hook)
(if (eq major-mode 'message-mode)
(let ((mbl1 mml-buffer-list))
(setq mml-buffer-list mbl) ;; Global value
(set (make-local-variable 'mml-buffer-list) mbl1);; Local value
(add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)
(add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
(mml-destroy-buffers)
(setq mml-buffer-list mbl)))
(message-hide-headers)
(gnus-add-buffer)
(gnus-configure-windows ,config t)
@ -521,12 +521,10 @@ instead."
mail-buf)
(unwind-protect
(progn
(setq gnus-newsgroup-name "")
(let ((gnus-newsgroup-name ""))
(gnus-setup-message 'message
(message-mail to subject other-headers continue
nil yank-action send-actions return-action)))
(with-current-buffer buf
(setq gnus-newsgroup-name group-name)))
nil yank-action send-actions return-action)))))
(when switch-action
(setq mail-buf (current-buffer))
(switch-to-buffer buf)
@ -617,18 +615,15 @@ If ARG is 1, prompt for a group name to find the posting style."
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read
"Use posting style of group"
nil (gnus-read-active-file-p))
(gnus-group-group-name))
""))
;; #### see comment in gnus-setup-message -- drv
(gnus-setup-message 'message (message-mail)))
(with-current-buffer buffer
(setq gnus-newsgroup-name group)))))
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read
"Use posting style of group"
nil (gnus-read-active-file-p))
(gnus-group-group-name))
"")))
(gnus-setup-message 'message (message-mail)))))))
(defun gnus-group-news (&optional arg)
"Start composing a news.
@ -647,19 +642,16 @@ network. The corresponding back end must have a `request-post' method."
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read "Use group"
nil
(gnus-read-active-file-p))
(gnus-group-group-name))
""))
;; #### see comment in gnus-setup-message -- drv
"")))
(gnus-setup-message 'message
(message-news (gnus-group-real-name gnus-newsgroup-name))))
(with-current-buffer buffer
(setq gnus-newsgroup-name group)))))
(message-news (gnus-group-real-name gnus-newsgroup-name))))))))
(defun gnus-group-post-news (&optional arg)
"Start composing a message (a news by default).
@ -694,18 +686,15 @@ posting style."
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read "Use group"
nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
;; #### see comment in gnus-setup-message -- drv
(gnus-setup-message 'message (message-mail)))
(with-current-buffer buffer
(setq gnus-newsgroup-name group)))))
gnus-newsgroup-name)))
(gnus-setup-message 'message (message-mail)))))))
(defun gnus-summary-news-other-window (&optional arg)
"Start composing a news in another window.
@ -724,24 +713,21 @@ network. The corresponding back end must have a `request-post' method."
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read "Use group"
nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
;; #### see comment in gnus-setup-message -- drv
gnus-newsgroup-name)))
(gnus-setup-message 'message
(progn
(message-news (gnus-group-real-name gnus-newsgroup-name))
(set (make-local-variable 'gnus-discouraged-post-methods)
(remove
(car (gnus-find-method-for-group gnus-newsgroup-name))
gnus-discouraged-post-methods)))))
(with-current-buffer buffer
(setq gnus-newsgroup-name group)))))
gnus-discouraged-post-methods)))))))))
(defun gnus-summary-post-news (&optional arg)
"Start composing a message. Post to the current group by default.
@ -823,7 +809,7 @@ active, the entire article will be yanked."
(with-current-buffer gnus-article-copy
(save-restriction
(nnheader-narrow-to-headers)
(nnheader-parse-naked-head)))))
(nnheader-parse-head t)))))
(message-yank-original)
(message-exchange-point-and-mark)
(setq beg (or beg (mark t))))
@ -1993,10 +1979,10 @@ process-mark several articles, they will all be attached."
(gnus-summary-iterate n
(gnus-summary-select-article)
(with-current-buffer destination
;; Attach at the end of the buffer.
(save-excursion
(goto-char (point-max))
(message-forward-make-body-mime gnus-original-article-buffer))))
;; Attach at the end of the buffer.
(save-excursion
(goto-char (point-max))
(message-forward-make-body-mime gnus-original-article-buffer))))
(gnus-configure-windows 'message t)))
(provide 'gnus-msg)

13
lisp/gnus/gnus-registry.el
View file

@ -427,6 +427,8 @@ This is not required after changing `gnus-registry-cache-file'."
(gnus-message 4 "Removed %d ignored entries from the Gnus registry"
(- old-size (registry-size db)))))
(declare-function gnus-nnselect-group-p "nnselect" (group))
(declare-function nnselect-article-group "nnselect" (article))
;; article move/copy/spool/delete actions
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
@ -437,7 +439,10 @@ This is not required after changing `gnus-registry-cache-file'."
(or (cdr-safe (assq 'To extra)) "")))
(sender (nth 0 (gnus-registry-extract-addresses
(mail-header-from data-header))))
(from (gnus-group-guess-full-name-from-command-method from))
(from (gnus-group-guess-full-name-from-command-method
(if (gnus-nnselect-group-p from)
(nnselect-article-group (mail-header-number data-header))
from)))
(to (if to (gnus-group-guess-full-name-from-command-method to) nil)))
(gnus-message 7 "Gnus registry: article %s %s from %s to %s"
id (if method "respooling" "going") from to)
@ -788,7 +793,7 @@ Consults `gnus-registry-unfollowed-groups' and
Consults `gnus-registry-ignored-groups' and
`nnmail-split-fancy-with-parent-ignore-groups'."
(and group
(or (gnus-grep-in-list
(or (gnus-virtual-group-p group) (gnus-grep-in-list
group
(delq nil (mapcar (lambda (g)
(cond
@ -1218,7 +1223,7 @@ is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it."
(gnus-registry-initialize)))
gnus-registry-enabled)
;; largely based on nnir-warp-to-article
;; largely based on nnselect-warp-to-article
(defun gnus-try-warping-via-registry ()
"Try to warp via the registry.
This will be done via the current article's source group based on
@ -1242,7 +1247,7 @@ data stored in the registry."
(gnus-ephemeral-group-p group) ;; any ephemeral group
(memq (car (gnus-find-method-for-group group))
;; Specific methods; this list may need to expand.
'(nnir)))
'(nnselect)))
;; remember that we've seen this group already
(push group seen-groups)

5
lisp/gnus/gnus-srvr.el
View file

@ -34,7 +34,8 @@
(require 'gnus-range)
(require 'gnus-cloud)
(autoload 'gnus-group-make-nnir-group "nnir")
(autoload 'gnus-group-read-ephemeral-search-group "nnselect")
;;(autoload 'gnus-group-make-permanent-search-group "nnselect")
(defcustom gnus-server-exit-hook nil
"Hook run when exiting the server buffer."
@ -176,7 +177,7 @@ If nil, a faster, but more primitive, buffer is used instead."
"g" gnus-server-regenerate-server
"G" gnus-group-make-nnir-group
"G" gnus-group-read-ephemeral-search-group
"z" gnus-server-compact-server

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

@ -1802,7 +1802,7 @@ backend check whether the group actually exists."
;; by one.
(t
(dolist (info infos)
(gnus-activate-group (gnus-info-group info) nil nil method t))))))
(gnus-activate-group (gnus-info-group info) t nil method t))))))
(defun gnus-make-hashtable-from-newsrc-alist ()
"Create a hash table from `gnus-newsrc-alist'.

295
lisp/gnus/gnus-sum.el
View file

@ -85,8 +85,8 @@
(autoload 'gnus-article-outlook-unwrap-lines "deuglify" nil t)
(autoload 'gnus-article-outlook-repair-attribution "deuglify" nil t)
(autoload 'gnus-article-outlook-rearrange-citation "deuglify" nil t)
(autoload 'nnir-article-rsv "nnir" nil nil 'macro)
(autoload 'nnir-article-group "nnir" nil nil 'macro)
(autoload 'nnselect-article-rsv "nnselect" nil nil)
(autoload 'nnselect-article-group "nnselect" nil nil)
(defcustom gnus-kill-summary-on-exit t
"If non-nil, kill the summary buffer when you exit from it.
@ -144,9 +144,9 @@ If t, fetch all the available old headers."
:type '(choice number
(sexp :menu-tag "other" t)))
(defcustom gnus-refer-thread-use-nnir nil
"Use nnir to search an entire server when referring threads.
A nil value will only search for thread-related articles in the
(defcustom gnus-refer-thread-use-search nil
"Search an entire server when referring threads. A
nil value will only search for thread-related articles in the
current group."
:version "24.1"
:group 'gnus-thread
@ -884,6 +884,7 @@ controls how articles are sorted."
(function-item gnus-article-sort-by-subject)
(function-item gnus-article-sort-by-date)
(function-item gnus-article-sort-by-score)
(function-item gnus-article-sort-by-rsv)
(function-item gnus-article-sort-by-random)
(function :tag "other"))
(boolean :tag "Reverse order"))))
@ -927,6 +928,7 @@ subthreads, customize `gnus-subthread-sort-functions'."
(function-item gnus-thread-sort-by-subject)
(function-item gnus-thread-sort-by-date)
(function-item gnus-thread-sort-by-score)
(function-item gnus-thread-sort-by-rsv)
(function-item gnus-thread-sort-by-most-recent-number)
(function-item gnus-thread-sort-by-most-recent-date)
(function-item gnus-thread-sort-by-random)
@ -1433,16 +1435,13 @@ the normal Gnus MIME machinery."
(?c (or (mail-header-chars gnus-tmp-header) 0) ?d)
(?k (gnus-summary-line-message-size gnus-tmp-header) ?s)
(?L gnus-tmp-lines ?s)
(?Z (or (nnir-article-rsv (mail-header-number gnus-tmp-header))
0)
?d)
(?G (or (nnir-article-group (mail-header-number gnus-tmp-header))
"")
?s)
(?Z (or (nnselect-article-rsv (mail-header-number gnus-tmp-header))
0) ?d)
(?G (or (nnselect-article-group (mail-header-number gnus-tmp-header))
"") ?s)
(?g (or (gnus-group-short-name
(nnir-article-group (mail-header-number gnus-tmp-header)))
"")
?s)
(nnselect-article-group (mail-header-number gnus-tmp-header)))
"") ?s)
(?O gnus-tmp-downloaded ?c)
(?I gnus-tmp-indentation ?s)
(?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s)
@ -1619,6 +1618,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
(defvar gnus-newsgroup-sparse nil)
(defvar gnus-newsgroup-selection nil)
(defvar gnus-current-article nil)
(defvar gnus-article-current nil)
(defvar gnus-current-headers nil)
@ -1653,6 +1654,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
gnus-newsgroup-undownloaded
gnus-newsgroup-unsendable
gnus-newsgroup-selection
gnus-newsgroup-begin gnus-newsgroup-end
gnus-newsgroup-last-rmail gnus-newsgroup-last-mail
gnus-newsgroup-last-folder gnus-newsgroup-last-file
@ -4532,48 +4535,14 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
;; This function has to be called with point after the article number
;; on the beginning of the line.
(defsubst gnus-nov-parse-line (number dependencies &optional force-new)
(let ((eol (point-at-eol))
header references in-reply-to)
(let (header)
;; overview: [num subject from date id refs chars lines misc]
(unwind-protect
(let (x)
(narrow-to-region (point) eol)
(unless (eobp)
(forward-char))
(setq header
(make-full-mail-header
number ; number
(condition-case () ; subject
(gnus-remove-odd-characters
(funcall gnus-decode-encoded-word-function
(setq x (nnheader-nov-field))))
(error x))
(condition-case () ; from
(gnus-remove-odd-characters
(funcall gnus-decode-encoded-address-function
(setq x (nnheader-nov-field))))
(error x))
(nnheader-nov-field) ; date
(nnheader-nov-read-message-id number) ; id
(setq references (nnheader-nov-field)) ; refs
(nnheader-nov-read-integer) ; chars
(nnheader-nov-read-integer) ; lines
(unless (eobp)
(if (looking-at "Xref: ")
(goto-char (match-end 0)))
(nnheader-nov-field)) ; Xref
(nnheader-nov-parse-extra)))) ; extra
(narrow-to-region (point) (point-at-eol))
(unless (eobp)
(forward-char))
(setq header (nnheader-parse-nov number))
(widen))
(when (and (string= references "")
(setq in-reply-to (mail-header-extra header))
(setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to))))
(setf (mail-header-references header)
(gnus-extract-message-id-from-in-reply-to in-reply-to)))
(when gnus-alter-header-function
(funcall gnus-alter-header-function header))
(gnus-dependencies-add-header header dependencies force-new)))
@ -5104,6 +5073,17 @@ using some other form will lead to serious barfage."
(gnus-article-sort-by-date
(gnus-thread-header h1) (gnus-thread-header h2)))
(defsubst gnus-article-sort-by-rsv (h1 h2)
"Sort articles by rsv."
(when gnus-newsgroup-selection
(< (nnselect-article-rsv (mail-header-number h1))
(nnselect-article-rsv (mail-header-number h2)))))
(defun gnus-thread-sort-by-rsv (h1 h2)
"Sort threads by root article rsv."
(gnus-article-sort-by-rsv
(gnus-thread-header h1) (gnus-thread-header h2)))
(defsubst gnus-article-sort-by-score (h1 h2)
"Sort articles by root article score.
Unscored articles will be counted as having a score of zero."
@ -5634,22 +5614,32 @@ or a straight list of headers."
"Fetch headers of ARTICLES."
(gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name)
(prog1
(if (eq 'nov
(setq gnus-headers-retrieved-by
(gnus-retrieve-headers
articles gnus-newsgroup-name
(or limit
;; We might want to fetch old headers, but
;; not if there is only 1 article.
(and (or (and
(not (eq gnus-fetch-old-headers 'some))
(not (numberp gnus-fetch-old-headers)))
(> (length articles) 1))
gnus-fetch-old-headers)))))
(gnus-get-newsgroup-headers-xover
articles force-new dependencies gnus-newsgroup-name t)
(gnus-get-newsgroup-headers dependencies force-new))
(gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name)))
(pcase (setq gnus-headers-retrieved-by
(gnus-retrieve-headers
articles gnus-newsgroup-name
(or limit
;; We might want to fetch old headers, but
;; not if there is only 1 article.
(and (or (and
(not (eq gnus-fetch-old-headers 'some))
(not (numberp gnus-fetch-old-headers)))
(> (length articles) 1))
gnus-fetch-old-headers))))
('nov
(gnus-get-newsgroup-headers-xover
articles force-new dependencies gnus-newsgroup-name t))
('headers
(gnus-get-newsgroup-headers dependencies force-new))
((pred listp)
(let ((dependencies
(or dependencies
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-dependencies))))
(delq nil (mapcar #'(lambda (header)
(gnus-dependencies-add-header
header dependencies force-new))
gnus-headers-retrieved-by)))))
(gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name)))
(defun gnus-select-newsgroup (group &optional read-all select-articles)
"Select newsgroup GROUP.
@ -6405,12 +6395,11 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(gnus-group-update-group group t))))))
(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
(let ((cur nntp-server-buffer)
(dependencies
(let ((dependencies
(or dependencies
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-dependencies)))
headers id end ref number
headers
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
(save-current-buffer (condition-case nil
@ -6418,146 +6407,15 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(error))
gnus-newsgroup-ignored-charsets)))
(with-current-buffer nntp-server-buffer
;; Translate all TAB characters into SPACE characters.
(subst-char-in-region (point-min) (point-max) ?\t ? t)
(subst-char-in-region (point-min) (point-max) ?\r ? t)
(ietf-drums-unfold-fws)
(gnus-run-hooks 'gnus-parse-headers-hook)
(let ((case-fold-search t)
in-reply-to header p lines chars)
(let ((nnmail-extra-headers gnus-extra-headers)
header)
(goto-char (point-min))
;; Search to the beginning of the next header. Error messages
;; do not begin with 2 or 3.
(while (re-search-forward "^[23][0-9]+ " nil t)
(setq id nil
ref nil)
;; This implementation of this function, with nine
;; search-forwards instead of the one re-search-forward and
;; a case (which basically was the old function) is actually
;; about twice as fast, even though it looks messier. You
;; can't have everything, I guess. Speed and elegance
;; doesn't always go hand in hand.
(setq
header
(make-full-mail-header
;; Number.
(prog1
(setq number (read cur))
(end-of-line)
(setq p (point))
(narrow-to-region (point)
(or (and (search-forward "\n.\n" nil t)
(- (point) 2))
(point))))
;; Subject.
(progn
(goto-char p)
(if (search-forward "\nsubject:" nil t)
(funcall gnus-decode-encoded-word-function
(nnheader-header-value))
"(none)"))
;; From.
(progn
(goto-char p)
(if (search-forward "\nfrom:" nil t)
(funcall gnus-decode-encoded-address-function
(nnheader-header-value))
"(nobody)"))
;; Date.
(progn
(goto-char p)
(if (search-forward "\ndate:" nil t)
(nnheader-header-value) ""))
;; Message-ID.
(progn
(goto-char p)
(setq id (if (re-search-forward
"^message-id: *\\(<[^\n\t> ]+>\\)" nil t)
;; We do it this way to make sure the Message-ID
;; is (somewhat) syntactically valid.
(buffer-substring (match-beginning 1)
(match-end 1))
;; If there was no message-id, we just fake one
;; to make subsequent routines simpler.
(nnheader-generate-fake-message-id number))))
;; References.
(progn
(goto-char p)
(if (search-forward "\nreferences:" nil t)
(progn
(setq end (point))
(prog1
(nnheader-header-value)
(setq ref
(buffer-substring
(progn
(end-of-line)
(search-backward ">" end t)
(1+ (point)))
(progn
(search-backward "<" end t)
(point))))))
;; Get the references from the in-reply-to header if there
;; were no references and the in-reply-to header looks
;; promising.
(if (and (search-forward "\nin-reply-to:" nil t)
(setq in-reply-to (nnheader-header-value))
(string-match "<[^>]+>" in-reply-to))
(let (ref2)
(setq ref (substring in-reply-to (match-beginning 0)
(match-end 0)))
(while (string-match "<[^>]+>" in-reply-to (match-end 0))
(setq ref2 (substring in-reply-to (match-beginning 0)
(match-end 0)))
(when (> (length ref2) (length ref))
(setq ref ref2)))
ref)
(setq ref nil))))
;; Chars.
(progn
(goto-char p)
(if (search-forward "\nchars: " nil t)
(if (numberp (setq chars (ignore-errors (read cur))))
chars -1)
-1))
;; Lines.
(progn
(goto-char p)
(if (search-forward "\nlines: " nil t)
(if (numberp (setq lines (ignore-errors (read cur))))
lines -1)
-1))
;; Xref.
(progn
(goto-char p)
(and (search-forward "\nxref:" nil t)
(nnheader-header-value)))
;; Extra.
(when gnus-extra-headers
(let ((extra gnus-extra-headers)
out)
(while extra
(goto-char p)
(when (search-forward
(concat "\n" (symbol-name (car extra)) ":") nil t)
(push (cons (car extra) (nnheader-header-value))
out))
(pop extra))
out))))
(when (equal id ref)
(setq ref nil))
(when gnus-alter-header-function
(funcall gnus-alter-header-function header)
(setq id (mail-header-id header)
ref (gnus-parent-id (mail-header-references header))))
(while (setq header (nnheader-parse-head))
(when (setq header
(gnus-dependencies-add-header
header dependencies force-new))
(push header headers))
(goto-char (point-max))
(widen))
(push header headers)))
(nreverse headers)))))
;; Goes through the xover lines and returns a list of vectors
@ -8702,7 +8560,8 @@ SCORE."
When called interactively, ID is the Message-ID of the current
article. If thread-only is non-nil limit the summary buffer to
these articles."
(interactive (list (mail-header-id (gnus-summary-article-header))))
(interactive (list (mail-header-id (gnus-summary-article-header))
current-prefix-arg))
(let ((articles (gnus-articles-in-thread
(gnus-id-to-thread (gnus-root-id id))))
;;we REALLY want the whole thread---this prevents cut-threads
@ -9125,13 +8984,13 @@ Return the number of articles fetched."
result))
(defun gnus-summary-refer-thread (&optional limit)
"Fetch all articles in the current thread. For backends
that know how to search for threads (currently only 'nnimap)
a non-numeric prefix arg will use nnir to search the entire
"Fetch all articles in the current thread. For backends that
know how to search for threads (currently only 'nnimap) a
non-numeric prefix arg will search the entire
server; without a prefix arg only the current group is
searched. If the variable `gnus-refer-thread-use-nnir' is
non-nil the prefix arg has the reverse meaning. If no
backend-specific `request-thread' function is available fetch
searched. If the variable `gnus-refer-thread-use-search' is
non-nil the prefix arg has the reverse meaning. If no
backend-specific 'request-thread function is available fetch
LIMIT (the numerical prefix) old headers. If LIMIT is
non-numeric or nil fetch the number specified by the
`gnus-refer-thread-limit' variable."
@ -9141,9 +9000,9 @@ non-numeric or nil fetch the number specified by the
(gnus-inhibit-demon t)
(gnus-summary-ignore-duplicates t)
(gnus-read-all-available-headers t)
(gnus-refer-thread-use-nnir
(gnus-refer-thread-use-search
(if (and (not (null limit)) (listp limit))
(not gnus-refer-thread-use-nnir) gnus-refer-thread-use-nnir))
(not gnus-refer-thread-use-search) gnus-refer-thread-use-search))
(new-headers
(if (gnus-check-backend-function
'request-thread gnus-newsgroup-name)
@ -9284,9 +9143,9 @@ non-numeric or nil fetch the number specified by the
(dolist (method gnus-refer-article-method)
(push (if (eq 'current method)
gnus-current-select-method
(if (eq 'nnir (car method))
(if (eq 'nnselect (car method))
(list
'nnir
'nnselect
(or (cadr method)
(gnus-method-to-server gnus-current-select-method)))
method))

18
lisp/gnus/gnus.el
View file

@ -853,12 +853,6 @@ be used directly.")
(cons (car list) (list :type type :data data)))
list)))
(let ((command (format "%s" this-command)))
(when (string-match "gnus" command)
(if (eq 'gnus-other-frame this-command)
(gnus-get-buffer-create gnus-group-buffer)
(gnus-splash))))
;;; Do the rest.
(require 'gnus-util)
@ -1613,7 +1607,7 @@ total number of articles in the group.")
:variable-default (mapcar
(lambda (g) (list g t))
'("delayed$" "drafts$" "queue$" "INBOX$"
"^nnmairix:" "^nnir:" "archive"))
"^nnmairix:" "^nnselect:" "archive"))
:variable-document
"Groups in which the registry should be turned off."
:variable-group gnus-registry
@ -2711,6 +2705,11 @@ with some simple extensions.
%k Pretty-printed version of the above (string)
For example, \"1.2k\" or \"0.4M\".
%L Number of lines in the article (integer)
%Z RSV of the article; nil if not in an nnselect group (integer)
%G Originating group name for the article; nil if not
in an nnselect group (string)
%g Short from of the originating group name for the article;
nil if not in an nnselect group (string)
%I Indentation based on thread level (a string of
spaces)
%B A complex trn-style thread tree (string)
@ -3159,7 +3158,10 @@ that that variable is buffer-local to the summary buffers."
(defun gnus-kill-ephemeral-group (group)
"Remove ephemeral GROUP from relevant structures."
(remhash group gnus-newsrc-hashtb))
(remhash group gnus-newsrc-hashtb)
(setq gnus-newsrc-alist
(delq (assoc group gnus-newsrc-alist)
gnus-newsrc-alist)))
(defun gnus-simplify-mode-line ()
"Make mode lines a bit simpler."

2
lisp/gnus/nndiary.el
View file

@ -992,7 +992,7 @@ all. This may very well take some time.")
(narrow-to-region
(goto-char (point-min))
(if (search-forward "\n\n" nil t) (1- (point)) (point-max))))
(let ((headers (nnheader-parse-naked-head)))
(let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
headers))))

2
lisp/gnus/nnfolder.el
View file

@ -1160,7 +1160,7 @@ This command does not work if you use short group names."
(if (search-forward "\n\n" e t) (setq e (1- (point)))))
(with-temp-buffer
(insert-buffer-substring buf b e)
(let ((headers (nnheader-parse-naked-head)))
(let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
headers)))))

346
lisp/gnus/nnheader.el
View file

@ -28,6 +28,10 @@
(eval-when-compile (require 'cl-lib))
(defvar gnus-decode-encoded-word-function)
(defvar gnus-decode-encoded-address-function)
(defvar gnus-alter-header-function)
(defvar nnmail-extra-headers)
(defvar gnus-newsgroup-name)
(defvar jka-compr-compression-info-list)
@ -39,6 +43,7 @@
(require 'mail-utils)
(require 'mm-util)
(require 'gnus-util)
(autoload 'gnus-remove-odd-characters "gnus-sum")
(autoload 'gnus-range-add "gnus-range")
(autoload 'gnus-remove-from-range "gnus-range")
;; FIXME none of these are used explicitly in this file.
@ -188,124 +193,167 @@ on your system, you could say something like:
(autoload 'ietf-drums-unfold-fws "ietf-drums")
(defun nnheader-parse-naked-head (&optional number)
;; This function unfolds continuation lines in this buffer
;; destructively. When this side effect is unwanted, use
;; `nnheader-parse-head' instead of this function.
(let ((case-fold-search t)
(buffer-read-only nil)
(cur (current-buffer))
(p (point-min))
in-reply-to lines ref)
(nnheader-remove-cr-followed-by-lf)
(ietf-drums-unfold-fws)
(subst-char-in-region (point-min) (point-max) ?\t ? )
(goto-char p)
(insert "\n")
(prog1
;; This implementation of this function, with nine
;; search-forwards instead of the one re-search-forward and a
;; case (which basically was the old function) is actually
;; about twice as fast, even though it looks messier. You
;; can't have everything, I guess. Speed and elegance don't
;; always go hand in hand.
(make-full-mail-header
;; Number.
(or number 0)
;; Subject.
(progn
(goto-char p)
(if (search-forward "\nsubject:" nil t)
(nnheader-header-value) "(none)"))
;; From.
(progn
(goto-char p)
(if (search-forward "\nfrom:" nil t)
(nnheader-header-value) "(nobody)"))
;; Date.
(progn
(goto-char p)
(if (search-forward "\ndate:" nil t)
(nnheader-header-value) ""))
;; Message-ID.
(progn
(goto-char p)
(if (search-forward "\nmessage-id:" nil t)
(buffer-substring
(1- (or (search-forward "<" (point-at-eol) t)
(point)))
(or (search-forward ">" (point-at-eol) t) (point)))
;; If there was no message-id, we just fake one to make
;; subsequent routines simpler.
(nnheader-generate-fake-message-id number)))
;; References.
(progn
(goto-char p)
(if (search-forward "\nreferences:" nil t)
(nnheader-header-value)
;; Get the references from the in-reply-to header if
;; there were no references and the in-reply-to header
;; looks promising.
(if (and (search-forward "\nin-reply-to:" nil t)
(setq in-reply-to (nnheader-header-value))
(string-match "<[^\n>]+>" in-reply-to))
(let (ref2)
(setq ref (substring in-reply-to (match-beginning 0)
(match-end 0)))
(while (string-match "<[^\n>]+>"
in-reply-to (match-end 0))
(setq ref2 (substring in-reply-to (match-beginning 0)
(match-end 0)))
(when (> (length ref2) (length ref))
(setq ref ref2)))
ref)
nil)))
;; Chars.
0
;; Lines.
(progn
(goto-char p)
(if (search-forward "\nlines: " nil t)
(if (numberp (setq lines (read cur)))
lines 0)
0))
;; Xref.
(progn
(goto-char p)
(and (search-forward "\nxref:" nil t)
(nnheader-header-value)))
;; Extra.
(when nnmail-extra-headers
(let ((extra nnmail-extra-headers)
out)
(while extra
(goto-char p)
(when (search-forward
(concat "\n" (symbol-name (car extra)) ":") nil t)
(push (cons (car extra) (nnheader-header-value))
out))
(pop extra))
out)))
(goto-char p)
(delete-char 1))))
(defun nnheader-parse-head (&optional naked)
(let ((cur (current-buffer)) num beg end)
(when (if naked
(setq num 0
beg (point-min)
end (point-max))
;; Search to the beginning of the next header. Error
;; messages do not begin with 2 or 3.
(when (re-search-forward "^[23][0-9]+ " nil t)
(setq num (read cur)
beg (point)
end (if (search-forward "\n.\n" nil t)
(goto-char (- (point) 2))
(point)))))
(with-temp-buffer
(insert-buffer-substring cur beg end)
(nnheader-parse-naked-head num)))))
(defsubst nnheader-head-make-header (number)
"Using data of type 'head in the current buffer
return a full mail header with article NUMBER."
(let ((p (point-min))
(cur (current-buffer))
in-reply-to chars lines end ref)
;; This implementation of this function, with nine
;; search-forwards instead of the one re-search-forward and a
;; case (which basically was the old function) is actually
;; about twice as fast, even though it looks messier. You
;; can't have everything, I guess. Speed and elegance don't
;; always go hand in hand.
(make-full-mail-header
;; Number.
number
;; Subject.
(progn
(goto-char p)
(if (search-forward "\nsubject:" nil t)
(funcall gnus-decode-encoded-word-function
(nnheader-header-value))
"(none)"))
;; From.
(progn
(goto-char p)
(if (search-forward "\nfrom:" nil t)
(funcall gnus-decode-encoded-address-function
(nnheader-header-value))
"(nobody)"))
;; Date.
(progn
(goto-char p)
(if (search-forward "\ndate:" nil t)
(nnheader-header-value) ""))
;; Message-ID.
(progn
(goto-char p)
(if (re-search-forward
"^message-id: *\\(<[^\n\t> ]+>\\)" nil t)
;; We do it this way to make sure the Message-ID
;; is (somewhat) syntactically valid.
(buffer-substring (match-beginning 1)
(match-end 1))
;; If there was no message-id, we just fake one to make
;; subsequent routines simpler.
(nnheader-generate-fake-message-id number)))
;; References.
(progn
(goto-char p)
(if (search-forward "\nreferences:" nil t)
(progn
(setq end (point))
(prog1
(nnheader-header-value)
(setq ref
(buffer-substring
(progn
(end-of-line)
(search-backward ">" end t)
(1+ (point)))
(progn
(search-backward "<" end t)
(point))))))
;; Get the references from the in-reply-to header if there
;; were no references and the in-reply-to header looks
;; promising.
(if (and (search-forward "\nin-reply-to:" nil t)
(setq in-reply-to (nnheader-header-value))
(string-match "<[^>]+>" in-reply-to))
(let (ref2)
(setq ref (substring in-reply-to (match-beginning 0)
(match-end 0)))
(while (string-match "<[^>]+>" in-reply-to (match-end 0))
(setq ref2 (substring in-reply-to (match-beginning 0)
(match-end 0)))
(when (> (length ref2) (length ref))
(setq ref ref2)))
ref)
nil)))
;; Chars.
(progn
(goto-char p)
(if (search-forward "\nchars: " nil t)
(if (numberp (setq chars (ignore-errors (read cur))))
chars -1)
-1))
;; Lines.
(progn
(goto-char p)
(if (search-forward "\nlines: " nil t)
(if (numberp (setq lines (ignore-errors (read cur))))
lines -1)
-1))
;; Xref.
(progn
(goto-char p)
(and (search-forward "\nxref:" nil t)
(nnheader-header-value)))
;; Extra.
(when nnmail-extra-headers
(let ((extra nnmail-extra-headers)
out)
(while extra
(goto-char p)
(when (search-forward
(concat "\n" (symbol-name (car extra)) ":") nil t)
(push (cons (car extra) (nnheader-header-value))
out))
(pop extra))
out)))))
(defun nnheader-parse-head (&optional naked temp)
"Parse data of type 'header in the current buffer and return a
mail header, modifying the buffer contents in the process. The
buffer is assumed to begin each header with an \"Article
retrieved\" line with an article number; If NAKED is non-nil
this line is assumed absent, and the buffer should contain a
single header's worth of data. If TEMP is non-nil the data is
first copied to a temporary buffer leaving the original buffer
untouched."
(let ((cur (current-buffer))
(num 0)
(beg (point-min))
(end (point-max))
buf)
(when (or naked
;; Search to the beginning of the next header. Error
;; messages do not begin with 2 or 3.
(when (re-search-forward "^[23][0-9]+ " nil t)
(setq num (read cur)
beg (point)
end (if (search-forward "\n.\n" nil t)
(goto-char (- (point) 2))
(point)))))
;; When TEMP copy the data to a temporary buffer
(if temp
(progn
(set-buffer (setq buf (generate-new-buffer " *nnheader-temp*")))
(insert-buffer-substring cur beg end))
;; Otherwise just narrow to the data
(narrow-to-region beg end))
(let ((case-fold-search t)
(buffer-read-only nil)
header)
(nnheader-remove-cr-followed-by-lf)
(ietf-drums-unfold-fws)
(subst-char-in-region (point-min) (point-max) ?\t ? t)
(subst-char-in-region (point-min) (point-max) ?\r ? t)
(goto-char (point-min))
(insert "\n")
(setq header (nnheader-head-make-header num))
(goto-char (point-min))
(delete-char 1)
(if temp
(kill-buffer buf)
(goto-char (point-max))
(widen))
(when gnus-alter-header-function
(funcall gnus-alter-header-function header))
header))))
(defmacro nnheader-nov-skip-field ()
'(search-forward "\t" eol 'move))
@ -347,24 +395,43 @@ on your system, you could say something like:
'id)
(nnheader-generate-fake-message-id ,number))))
(defun nnheader-parse-nov ()
(defalias 'nnheader-nov-make-header 'nnheader-parse-nov)
(autoload 'gnus-extract-message-id-from-in-reply-to "gnus-sum")
(defun nnheader-parse-nov (&optional number)
(let ((eol (point-at-eol))
(number (nnheader-nov-read-integer)))
(vector
number ; number
(nnheader-nov-field) ; subject
(nnheader-nov-field) ; from
(nnheader-nov-field) ; date
(nnheader-nov-read-message-id number) ; id
(nnheader-nov-field) ; refs
(nnheader-nov-read-integer) ; chars
(nnheader-nov-read-integer) ; lines
(if (eq (char-after) ?\n)
nil
(if (looking-at "Xref: ")
(goto-char (match-end 0)))
(nnheader-nov-field)) ; Xref
(nnheader-nov-parse-extra)))) ; extra
references in-reply-to x header)
(setq header
(make-full-mail-header
(or number (nnheader-nov-read-integer)) ; number
(condition-case () ; subject
(gnus-remove-odd-characters
(funcall gnus-decode-encoded-word-function
(setq x (nnheader-nov-field))))
(error x))
(condition-case () ; from
(gnus-remove-odd-characters
(funcall gnus-decode-encoded-address-function
(setq x (nnheader-nov-field))))
(error x))
(nnheader-nov-field) ; date
(nnheader-nov-read-message-id number) ; id
(setq references (nnheader-nov-field)) ; refs
(nnheader-nov-read-integer) ; chars
(nnheader-nov-read-integer) ; lines
(unless (eobp)
(if (looking-at "Xref: ")
(goto-char (match-end 0)))
(nnheader-nov-field)) ; Xref
(nnheader-nov-parse-extra))) ; extra
(when (and (string= references "")
(setq in-reply-to (mail-header-extra header))
(setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to))))
(setf (mail-header-references header)
(gnus-extract-message-id-from-in-reply-to in-reply-to)))
header))
(defun nnheader-insert-nov (header)
(princ (mail-header-number header) (current-buffer))
@ -399,17 +466,6 @@ on your system, you could say something like:
(delete-char 1))
(forward-line 1)))
(defun nnheader-parse-overview-file (file)
"Parse FILE and return a list of headers."
(mm-with-unibyte-buffer
(nnheader-insert-file-contents file)
(goto-char (point-min))
(let (headers)
(while (not (eobp))
(push (nnheader-parse-nov) headers)
(forward-line 1))
(nreverse headers))))
(defun nnheader-write-overview-file (file headers)
"Write HEADERS to FILE."
(with-temp-file file

15
lisp/gnus/nnimap.el
View file

@ -986,7 +986,10 @@ textual parts.")
(when (and (car result) (not can-move))
(nnimap-delete-article article))
(cons internal-move-group
(or (nnimap-find-uid-response "COPYUID" (caddr result))
(or (nnimap-find-uid-response
"COPYUID"
;; Server gives different responses for MOVE and COPY.
(if can-move (caddr result) (cadr result)))
(nnimap-find-article-by-message-id
internal-move-group server message-id
nnimap-request-articles-find-limit)))))
@ -1683,7 +1686,7 @@ If LIMIT, first try to limit the search to the N last articles."
(gnus-add-to-range
(gnus-add-to-range
(gnus-range-add (gnus-info-read info)
vanished)
vanished)
(cdr (assq '%Flagged flags)))
(cdr (assq '%Seen flags))))
(let ((marks (gnus-info-marks info)))
@ -1848,15 +1851,15 @@ If LIMIT, first try to limit the search to the N last articles."
(setq nnimap-status-string "Read-only server")
nil)
(defvar gnus-refer-thread-use-nnir) ;; gnus-sum.el
(defvar gnus-refer-thread-use-search) ;; gnus-sum.el
(declare-function gnus-fetch-headers "gnus-sum"
(articles &optional limit force-new dependencies))
(autoload 'nnir-search-thread "nnir")
(autoload 'nnselect-search-thread "nnselect")
(deffoo nnimap-request-thread (header &optional group server)
(if gnus-refer-thread-use-nnir
(nnir-search-thread header)
(if gnus-refer-thread-use-search
(nnselect-search-thread header)
(when (nnimap-change-group group server)
(let* ((cmd (nnimap-make-thread-query header))
(result (with-current-buffer (nnimap-buffer)

855
lisp/gnus/nnir.el
View file

File diff suppressed because it is too large Load diff

2
lisp/gnus/nnmaildir.el
View file

@ -492,7 +492,7 @@ This variable is set by `nnmaildir-request-article'.")
(setq nov-mid 0))
(goto-char (point-min))
(delete-char 1)
(setq nov (nnheader-parse-naked-head)
(setq nov (nnheader-parse-head t)
field (or (mail-header-lines nov) 0)))
(unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
(setq nov-mid field))

2
lisp/gnus/nnml.el
View file

@ -766,7 +766,7 @@ article number. This function is called narrowed to an article."
(if (re-search-forward "\n\r?\n" nil t)
(1- (point))
(point-max))))
(let ((headers (nnheader-parse-naked-head)))
(let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
headers))))

864
lisp/gnus/nnselect.el Normal file
View file

@ -0,0 +1,864 @@
;;; nnselect.el --- a virtual group backend -*- lexical-binding:t -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; Author: Andrew Cohen <cohen@andy.bu.edu>
;; Keywords: news mail
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This is a "virtual" backend that allows an aribtrary list of
;; articles to be treated as a gnus group. An nnselect group uses an
;; nnselect-spec group parameter to specify this list of
;; articles. nnselect-spec is an alist with two keys:
;; nnselect-function, whose value should be a function that returns
;; the list of articles, and nnselect-args. The function will be
;; applied to the arguments to generate the list of articles. The
;; return value should be a vector, each element of which should in
;; turn be a vector of three elements: a real prefixed group name, an
;; article number in that group, and an integer score. The score is
;; not used by nnselect but may be used by other code to help in
;; sorting. Most functions will just chose a fixed number, such as
;; 100, for this score.
;; For example the search function `nnir-run-query' applied to
;; arguments specifying a search query (see "nnir.el") can be used to
;; return a list of articles from a search. Or the function can be the
;; identity and the args a vector of articles.
;;; Code:
;;; Setup:
(require 'gnus-art)
(require 'nnir)
(eval-when-compile (require 'cl-lib))
;; Set up the backend
(nnoo-declare nnselect)
(nnoo-define-basics nnselect)
(gnus-declare-backend "nnselect" 'post-mail 'virtual)
;;; Internal Variables:
(defvar gnus-inhibit-demon)
(defvar gnus-message-group-art)
;; For future use
(defvoo nnselect-directory gnus-directory
"Directory for the nnselect backend.")
(defvoo nnselect-active-file
(expand-file-name "nnselect-active" nnselect-directory)
"nnselect active file.")
(defvoo nnselect-groups-file
(expand-file-name "nnselect-newsgroups" nnselect-directory)
"nnselect groups description file.")
;;; Helper routines.
(defun nnselect-compress-artlist (artlist)
"Compress ARTLIST."
(let (selection)
(pcase-dolist (`(,artgroup . ,arts)
(nnselect-categorize artlist 'nnselect-artitem-group))
(let (list)
(pcase-dolist (`(,rsv . ,articles)
(nnselect-categorize
arts 'nnselect-artitem-rsv 'nnselect-artitem-number))
(push (cons rsv (gnus-compress-sequence (sort articles '<)))
list))
(push (cons artgroup list) selection)))
selection))
(defun nnselect-uncompress-artlist (artlist)
"Uncompress ARTLIST."
(if (vectorp artlist)
artlist
(let (selection)
(pcase-dolist (`(,artgroup (,artrsv . ,artseq)) artlist)
(setq selection
(vconcat
(cl-map 'vector
#'(lambda (art)
(vector artgroup art artrsv))
(gnus-uncompress-sequence artseq)) selection)))
selection)))
(defun nnselect-group-server (group)
"Return the server for GROUP."
(gnus-group-server group))
;; Data type article list.
(define-inline nnselect-artlist-length (artlist)
(inline-quote (length ,artlist)))
(define-inline nnselect-artlist-article (artlist n)
"Return from ARTLIST the Nth artitem (counting starting at 1)."
(inline-quote (when (> ,n 0)
(elt ,artlist (1- ,n)))))
(define-inline nnselect-artitem-group (artitem)
"Return the group from the ARTITEM."
(inline-quote (elt ,artitem 0)))
(define-inline nnselect-artitem-number (artitem)
"Return the number from the ARTITEM."
(inline-quote (elt ,artitem 1)))
(define-inline nnselect-artitem-rsv (artitem)
"Return the Retrieval Status Value (RSV, score) from the ARTITEM."
(inline-quote (elt ,artitem 2)))
(define-inline nnselect-article-group (article)
"Return the group for ARTICLE."
(inline-quote
(nnselect-artitem-group (nnselect-artlist-article
gnus-newsgroup-selection ,article))))
(define-inline nnselect-article-number (article)
"Return the number for ARTICLE."
(inline-quote (nnselect-artitem-number
(nnselect-artlist-article
gnus-newsgroup-selection ,article))))
(define-inline nnselect-article-rsv (article)
"Return the rsv for ARTICLE."
(inline-quote (nnselect-artitem-rsv
(nnselect-artlist-article
gnus-newsgroup-selection ,article))))
(define-inline nnselect-article-id (article)
"Return the pair `(nnselect id . real id)' of ARTICLE."
(inline-quote (cons ,article (nnselect-article-number ,article))))
(define-inline nnselect-categorize (sequence keyfunc &optional valuefunc)
"Sorts a sequence into categories.
Returns a list of the form
`((key1 (element11 element12)) (key2 (element21 element22))'.
The category key for a member of the sequence is obtained
as `(keyfunc member)' and the corresponding element is just
`member' (or `(valuefunc member)' if `valuefunc' is non-nil)."
(inline-letevals (sequence keyfunc valuefunc)
(inline-quote (let ((valuefunc (or ,valuefunc 'identity))
result)
(unless (null ,sequence)
(mapc
(lambda (member)
(let* ((key (funcall ,keyfunc member))
(value (funcall valuefunc member))
(kr (assoc key result)))
(if kr
(push value (cdr kr))
(push (list key value) result))))
(reverse ,sequence))
result)))))
;; Unclear whether a macro or an inline function is best.
;; (defmacro nnselect-categorize (sequence keyfunc &optional valuefunc)
;; "Sorts a sequence into categories and returns a list of the form
;; `((key1 (element11 element12)) (key2 (element21 element22))'.
;; The category key for a member of the sequence is obtained
;; as `(keyfunc member)' and the corresponding element is just
;; `member' (or `(valuefunc member)' if `valuefunc' is non-nil)."
;; (let ((key (make-symbol "key"))
;; (value (make-symbol "value"))
;; (result (make-symbol "result"))
;; (valuefunc (or valuefunc 'identity)))
;; `(unless (null ,sequence)
;; (let (,result)
;; (mapc
;; (lambda (member)
;; (let* ((,key (,keyfunc member))
;; (,value (,valuefunc member))
;; (kr (assoc ,key ,result)))
;; (if kr
;; (push ,value (cdr kr))
;; (push (list ,key ,value) ,result))))
;; (reverse ,sequence))
;; ,result))))
(define-inline ids-by-group (articles)
(inline-quote
(nnselect-categorize ,articles 'nnselect-article-group
'nnselect-article-id)))
(define-inline numbers-by-group (articles)
(inline-quote
(nnselect-categorize
,articles 'nnselect-article-group 'nnselect-article-number)))
(defmacro nnselect-add-prefix (group)
"Ensures that the GROUP has an nnselect prefix."
`(gnus-group-prefixed-name
(gnus-group-short-name ,group) '(nnselect "nnselect")))
(defmacro nnselect-get-artlist (group)
"Retrieve the list of articles for GROUP."
`(when (gnus-nnselect-group-p ,group)
(nnselect-uncompress-artlist
(gnus-group-get-parameter ,group 'nnselect-artlist t))))
(defmacro nnselect-add-novitem (novitem)
"Add NOVITEM to the list of headers."
`(let* ((novitem ,novitem)
(artno (and novitem
(mail-header-number novitem)))
(art (car-safe (rassq artno artids))))
(when art
(setf (mail-header-number novitem) art)
(push novitem headers))))
;;; User Customizable Variables:
(defgroup nnselect nil
"Virtual groups in Gnus with arbitrary selection methods."
:group 'gnus)
(defcustom nnselect-retrieve-headers-override-function nil
"A function that retrieves article headers for ARTICLES from GROUP.
The retrieved headers should populate the `nntp-server-buffer'.
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 "24.1" :type '(function) :group 'nnselect)
;; Gnus backend interface functions.
(deffoo nnselect-open-server (server &optional definitions)
;; Just set the server variables appropriately.
(let ((backend (or (car (gnus-server-to-method server)) 'nnselect)))
(nnoo-change-server backend server definitions)))
;; (deffoo nnselect-server-opened (&optional server)
;; "Is SERVER the current virtual server?"
;; (if (string-empty-p server)
;; t
;; (let ((backend (car (gnus-server-to-method server))))
;; (nnoo-current-server-p (or backend 'nnselect) server))))
(deffoo nnselect-server-opened (&optional _server)
t)
(deffoo nnselect-request-group (group &optional _server _dont-check info)
(let* ((group (nnselect-add-prefix group))
(nnselect-artlist (nnselect-get-artlist group))
length)
;; Check for cached select result or run the selection and cache
;; the result.
(unless nnselect-artlist
(gnus-group-set-parameter
group 'nnselect-artlist
(nnselect-compress-artlist (setq nnselect-artlist
(nnselect-run
(gnus-group-get-parameter group 'nnselect-specs t)))))
(nnselect-request-update-info
group (or info (gnus-get-info group))))
(if (zerop (setq length (nnselect-artlist-length nnselect-artlist)))
(progn
(nnheader-report 'nnselect "Selection produced empty results.")
(nnheader-insert ""))
(with-current-buffer nntp-server-buffer
(nnheader-insert "211 %d %d %d %s\n"
length ; total #
1 ; first #
length ; last #
group))) ; group name
nnselect-artlist))
(deffoo nnselect-retrieve-headers (articles group &optional _server fetch-old)
(let ((group (nnselect-add-prefix group)))
(with-current-buffer (gnus-summary-buffer-name group)
(setq gnus-newsgroup-selection (or gnus-newsgroup-selection
(nnselect-get-artlist group)))
(let ((gnus-inhibit-demon t)
(gartids (ids-by-group articles))
headers)
(with-current-buffer nntp-server-buffer
(pcase-dolist (`(,artgroup . ,artids) gartids)
(let ((artlist (sort (mapcar 'cdr artids) '<))
(gnus-override-method (gnus-find-method-for-group artgroup))
(fetch-old
(or
(car-safe
(gnus-group-find-parameter artgroup
'gnus-fetch-old-headers t))
fetch-old)))
(erase-buffer)
(pcase (setq gnus-headers-retrieved-by
(or
(and
nnselect-retrieve-headers-override-function
(funcall
nnselect-retrieve-headers-override-function
artlist artgroup))
(gnus-retrieve-headers
artlist artgroup fetch-old)))
('nov
(goto-char (point-min))
(while (not (eobp))
(nnselect-add-novitem
(nnheader-parse-nov))
(forward-line 1)))
('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)))
(_ (error "Unknown header type %s while requesting articles \
of group %s" gnus-headers-retrieved-by artgroup)))))
(setq headers
(sort
headers
(lambda (x y)
(< (mail-header-number x) (mail-header-number y))))))))))
(deffoo nnselect-request-article (article &optional _group server to-buffer)
(let* ((gnus-override-method nil)
servers group-art artlist)
(if (numberp article)
(with-current-buffer gnus-summary-buffer
(unless (zerop (nnselect-artlist-length
gnus-newsgroup-selection))
(setq group-art (cons (nnselect-article-group article)
(nnselect-article-number article)))))
;; message-id: either coming from a referral or a pseudo-article
;; find the servers for a pseudo-article
(if (eq 'nnselect (car (gnus-server-to-method server)))
(with-current-buffer gnus-summary-buffer
(let ((thread (gnus-id-to-thread article)))
(when thread
(mapc
#'(lambda (x)
(when (and x (> x 0))
(cl-pushnew
(list
(gnus-method-to-server
(gnus-find-method-for-group
(nnselect-article-group x)))) servers :test 'equal)))
(gnus-articles-in-thread thread)))))
(setq servers (list (list server))))
(setq artlist
(nnir-run-query
(list
(cons 'nnir-query-spec
(list (cons 'query (format "HEADER Message-ID %s" article))
(cons 'criteria "") (cons 'shortcut t)))
(cons 'nnir-group-spec servers))))
(unless (zerop (nnselect-artlist-length artlist))
(setq
group-art
(cons
(nnselect-artitem-group (nnselect-artlist-article artlist 1))
(nnselect-artitem-number (nnselect-artlist-article artlist 1))))))
(when (numberp (cdr group-art))
(message "Requesting article %d from group %s"
(cdr group-art) (car group-art))
(if to-buffer
(with-current-buffer to-buffer
(let ((gnus-article-decode-hook nil))
(gnus-request-article-this-buffer
(cdr group-art) (car group-art))))
(gnus-request-article (cdr group-art) (car group-art)))
group-art)))
(deffoo nnselect-request-move-article
(article _group _server accept-form &optional last _internal-move-group)
(let* ((artgroup (nnselect-article-group article))
(artnumber (nnselect-article-number article))
(to-newsgroup (nth 1 accept-form))
(to-method (gnus-find-method-for-group to-newsgroup))
(from-method (gnus-find-method-for-group artgroup))
(move-is-internal (gnus-server-equal from-method to-method)))
(unless (gnus-check-backend-function
'request-move-article artgroup)
(error "The group %s does not support article moving" artgroup))
(gnus-request-move-article
artnumber
artgroup
(nth 1 from-method)
accept-form
last
(and move-is-internal
to-newsgroup ; Not respooling
(gnus-group-real-name to-newsgroup)))))
(deffoo nnselect-request-expire-articles
(articles _group &optional _server force)
(if force
(let (not-expired)
(pcase-dolist (`(,artgroup . ,artids) (ids-by-group articles))
(let ((artlist (sort (mapcar 'cdr artids) '<)))
(unless (gnus-check-backend-function 'request-expire-articles
artgroup)
(error "Group %s does not support article expiration" artgroup))
(unless (gnus-check-server (gnus-find-method-for-group artgroup))
(error "Couldn't open server for group %s" artgroup))
(push (mapcar #'(lambda (art)
(car (rassq art artids)))
(let ((nnimap-expunge 'immediately))
(gnus-request-expire-articles
artlist artgroup force)))
not-expired)))
(sort (delq nil not-expired) '<))
articles))
(deffoo nnselect-warp-to-article ()
(let* ((cur (if (> (gnus-summary-article-number) 0)
(gnus-summary-article-number)
(error "Can't warp to a pseudo-article")))
(artgroup (nnselect-article-group cur))
(artnumber (nnselect-article-number cur))
(_quit-config (gnus-ephemeral-group-p gnus-newsgroup-name)))
;; what should we do here? we could leave all the buffers around
;; and assume that we have to exit from them one by one. or we can
;; try to clean up directly
;;first exit from the nnselect summary buffer.
;;(gnus-summary-exit)
;; and if the nnselect summary buffer in turn came from another
;; summary buffer we have to clean that summary up too.
;;(when (not (eq (cdr quit-config) 'group))
;; (gnus-summary-exit))
(gnus-summary-read-group-1 artgroup t t nil
nil (list artnumber))))
;; we pass this through to the real group in case it wants to adjust
;; the mark. We also use this to mark an article expirable iff it is
;; expirable in the real group.
(deffoo nnselect-request-update-mark (_group article mark)
(let* ((artgroup (nnselect-article-group article))
(artnumber (nnselect-article-number article))
(gmark (gnus-request-update-mark artgroup artnumber mark)))
(when (and artnumber
(memq mark gnus-auto-expirable-marks)
(= mark gmark)
(gnus-group-auto-expirable-p artgroup))
(setq gmark gnus-expirable-mark))
gmark))
(deffoo nnselect-request-set-mark (_group actions &optional _server)
(mapc
(lambda (request) (gnus-request-set-mark (car request) (cdr request)))
(nnselect-categorize
(cl-mapcan
(lambda (act)
(cl-destructuring-bind (range action marks) act
(mapcar
(lambda (artgroup)
(list (car artgroup)
(gnus-compress-sequence (sort (cdr artgroup) '<))
action marks))
(numbers-by-group
(gnus-uncompress-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))))
(gnus-info-set-marks info nil)
(setf (gnus-info-read info) nil)
(pcase-dolist (`(,artgroup . ,nartids)
(ids-by-group
(number-sequence 1 (nnselect-artlist-length
gnus-newsgroup-selection))))
(let* ((gnus-newsgroup-active nil)
(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)))))))
(gnus-set-active group (cons 1 (nnselect-artlist-length
gnus-newsgroup-selection)))))
(deffoo nnselect-request-thread (header &optional group server)
(with-current-buffer gnus-summary-buffer
(let ((group (nnselect-add-prefix group))
;; find the best group for the originating article. if its a
;; pseudo-article look for real articles in the same thread
;; and see where they come from.
(artgroup (nnselect-article-group
(if (> (mail-header-number header) 0)
(mail-header-number header)
(if (> (gnus-summary-article-number) 0)
(gnus-summary-article-number)
(let ((thread
(gnus-id-to-thread (mail-header-id header))))
(when thread
(cl-some #'(lambda (x)
(when (and x (> x 0)) x))
(gnus-articles-in-thread thread)))))))))
;; Check if we are dealing with an imap backend.
(if (eq 'nnimap
(car (gnus-find-method-for-group artgroup)))
;; If so we perform the query, massage the result, and return
;; the new headers back to the caller to incorporate into the
;; current summary buffer.
(let* ((group-spec
(list (delq nil (list
(or server (gnus-group-server artgroup))
(unless gnus-refer-thread-use-search
artgroup)))))
(query-spec
(list (cons 'query (nnimap-make-thread-query header))
(cons 'criteria "")))
(last (nnselect-artlist-length gnus-newsgroup-selection))
(first (1+ last))
(new-nnselect-artlist
(nnir-run-query
(list (cons 'nnir-query-spec query-spec)
(cons 'nnir-group-spec group-spec))))
old-arts seq
headers)
(mapc
#'(lambda (article)
(if
(setq seq
(cl-position article
gnus-newsgroup-selection :test 'equal))
(push (1+ seq) old-arts)
(setq gnus-newsgroup-selection
(vconcat gnus-newsgroup-selection (vector article)))
(cl-incf last)))
new-nnselect-artlist)
(setq headers
(gnus-fetch-headers
(append (sort old-arts '<)
(number-sequence first last)) nil t))
(gnus-group-set-parameter
group
'nnselect-artlist
(nnselect-compress-artlist gnus-newsgroup-selection))
(when (>= last first)
(let (new-marks)
(pcase-dolist (`(,artgroup . ,artids)
(ids-by-group (number-sequence first last)))
(pcase-dolist (`(,type . ,marked)
(gnus-info-marks (gnus-get-info artgroup)))
(setq marked (gnus-uncompress-sequence marked))
(when (setq new-marks
(delq nil
(mapcar
#'(lambda (art)
(when (memq (cdr art) marked)
(car art)))
artids)))
(nconc
(symbol-value
(intern
(format "gnus-newsgroup-%s"
(car (rassq type gnus-article-mark-lists)))))
new-marks)))))
(setq gnus-newsgroup-active
(cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))
(gnus-set-active
group
(cons 1 (nnselect-artlist-length gnus-newsgroup-selection))))
headers)
;; If not an imap backend just warp to the original article
;; group and punt back to gnus-summary-refer-thread.
(and (gnus-warp-to-article) (gnus-summary-refer-thread))))))
(deffoo nnselect-close-group (group &optional _server)
(let ((group (nnselect-add-prefix group)))
(unless gnus-group-is-exiting-without-update-p
(nnselect-push-info group))
(setq gnus-newsgroup-selection nil)
(when (gnus-ephemeral-group-p group)
(gnus-kill-ephemeral-group group)
(setq gnus-ephemeral-servers
(assq-delete-all 'nnselect gnus-ephemeral-servers)))))
(deffoo nnselect-request-create-group (group &optional _server args)
(message "Creating nnselect group %s" group)
(let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect")))
(specs (assq 'nnselect-specs args))
(function-spec
(or (alist-get 'nnselect-function specs)
(intern (completing-read "Function: " obarray #'functionp))))
(args-spec
(or (alist-get 'nnselect-args specs)
(read-from-minibuffer "Args: " nil nil t nil "nil")))
(nnselect-specs (list (cons 'nnselect-function function-spec)
(cons 'nnselect-args args-spec))))
(gnus-group-set-parameter group 'nnselect-specs nnselect-specs)
(gnus-group-set-parameter
group 'nnselect-artlist
(nnselect-compress-artlist (or (alist-get 'nnselect-artlist args)
(nnselect-run nnselect-specs))))
(nnselect-request-update-info group (gnus-get-info group)))
t)
(deffoo nnselect-request-type (_group &optional article)
(if (and (numberp article) (> article 0))
(gnus-request-type
(nnselect-article-group article) (nnselect-article-number article))
'unknown))
(deffoo nnselect-request-post (&optional _server)
(if (not gnus-message-group-art)
(nnheader-report 'nnselect "Can't post to an nnselect group")
(gnus-request-post
(gnus-find-method-for-group
(nnselect-article-group (cdr gnus-message-group-art))))))
(deffoo nnselect-request-rename-group (_group _new-name &optional _server)
t)
(deffoo nnselect-request-scan (group _method)
(when (and group
(gnus-group-get-parameter (nnselect-add-prefix group)
'nnselect-rescan t))
(nnselect-request-group-scan group)))
(deffoo nnselect-request-group-scan (group &optional _server _info)
(let* ((group (nnselect-add-prefix group))
(artlist (nnselect-run
(gnus-group-get-parameter group 'nnselect-specs t))))
(gnus-set-active group (cons 1 (nnselect-artlist-length
artlist)))
(gnus-group-set-parameter
group 'nnselect-artlist
(nnselect-compress-artlist artlist))))
;; Add any undefined required backend functions
;; (nnoo-define-skeleton nnselect)
;;; Util Code:
(defun gnus-nnselect-group-p (group)
"Say whether GROUP is nnselect or not."
(or (and (gnus-group-prefixed-p group)
(eq 'nnselect (car (gnus-find-method-for-group group))))
(eq 'nnselect (car gnus-command-method))))
(defun nnselect-run (specs)
"Apply nnselect-function to nnselect-args from SPECS.
Return an article list."
(let ((func (alist-get 'nnselect-function specs))
(args (alist-get 'nnselect-args specs)))
(funcall func args)))
(defun nnselect-search-thread (header)
"Make an nnselect group containing the thread with article HEADER.
The current server will be searched. If the registry is
installed, the server that the registry reports the current
article came from is also searched."
(let* ((query
(list (cons 'query (nnimap-make-thread-query header))
(cons 'criteria "")))
(server
(list (list (gnus-method-to-server
(gnus-find-method-for-group gnus-newsgroup-name)))))
(registry-group (and
(bound-and-true-p gnus-registry-enabled)
(car (gnus-registry-get-id-key
(mail-header-id header) 'group))))
(registry-server
(and registry-group
(gnus-method-to-server
(gnus-find-method-for-group registry-group)))))
(when registry-server (cl-pushnew (list registry-server) server
:test 'equal))
(gnus-group-read-ephemeral-group
(concat "nnselect-" (message-unique-id))
(list 'nnselect "nnselect")
nil
(cons (current-buffer) gnus-current-window-configuration)
; nil
nil nil
(list
(cons 'nnselect-specs
(list
(cons 'nnselect-function 'nnir-run-query)
(cons 'nnselect-args
(list (cons 'nnir-query-spec query)
(cons 'nnir-group-spec server)))))
(cons 'nnselect-artlist nil)))
(gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header)))))
(defun nnselect-push-info (group)
"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)))))
(select-unseen (numbers-by-group gnus-newsgroup-unseen))
(gnus-newsgroup-active nil)
mark-list type-list)
(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)))
(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)
(when group-info
(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)))
(when list
;; Get rid of the entries of the articles that have the
;; default score.
(when (and (eq type 'score)
gnus-save-score
list)
(let* ((arts list)
(prev (cons nil list))
(all prev))
(while arts
(if (or (not (consp (car arts)))
(= (cdar arts) gnus-summary-default-score))
(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
(gnus-compress-sequence (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 (or list (eq type 'unexist))
(push (cons type list) newmarked))))
(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))))
;; Cut off the end of the info if there's nothing else there.
(let ((i 5))
(while (and (> i 2)
(not (nth i group-info)))
(when (nthcdr (cl-decf i) group-info)
(setcdr (nthcdr i group-info) nil))))
;; update read and unread
(gnus-update-read-articles
artgroup
(gnus-uncompress-range
(gnus-add-to-range
(gnus-remove-from-range
old-unread
(cdr (assoc artgroup select-reads)))
(sort (cdr (assoc artgroup select-unreads)) '<))))
(gnus-get-unread-articles-in-group
group-info (gnus-active artgroup) t)
(gnus-group-update-group artgroup t t)))))))
(declare-function gnus-registry-get-id-key "gnus-registry" (id key))
(defun gnus-summary-make-search-group (nnir-extra-parms)
"Search a group from the summary buffer.
Pass NNIR-EXTRA-PARMS on to the search engine."
(interactive "P")
(gnus-warp-to-article)
(let ((spec
(list
(cons 'nnir-group-spec
(list (list
(gnus-group-server gnus-newsgroup-name)
gnus-newsgroup-name))))))
(gnus-group-make-search-group nnir-extra-parms spec)))
;; The end.
(provide 'nnselect)
;;; nnselect.el ends here

2
lisp/gnus/nnspool.el
View file

@ -422,7 +422,7 @@ there.")
(nnspool-article-pathname nnspool-current-group article))
(nnheader-insert-article-line article)
(goto-char (point-min))
(let ((headers (nnheader-parse-head)))
(let ((headers (nnheader-parse-head nil t)))
(set-buffer cur)
(goto-char (point-max))
(nnheader-insert-nov headers)))

4
lisp/help-fns.el
View file

@ -151,9 +151,7 @@ When called from lisp, FUNCTION may also be a function object."
(let* ((fn (function-called-at-point))
(enable-recursive-minibuffers t)
(val (completing-read
(if fn
(format-prompt "Describe function" fn)
"Describe function: ")
(format-prompt "Describe function" fn)
#'help--symbol-completion-table
(lambda (f) (or (fboundp f) (get f 'function-documentation)))
t nil nil

2
lisp/icomplete.el
View file

@ -715,7 +715,7 @@ matches exist."
(setq prospects (nreverse prospects))
;; Return the first match if the user hits enter.
(when icomplete-show-matches-on-no-input
(setq completion-content-when-empty (car prospects)))
(setq-local completion-content-when-empty (car prospects)))
;; Decorate first of the prospects.
(when prospects
(let ((first (copy-sequence (pop prospects))))

11
lisp/indent.el
View file

@ -53,7 +53,16 @@ If `complete', TAB first tries to indent the current line, and if the line
was already indented, then try to complete the thing at point.
Some programming language modes have their own variable to control this,
e.g., `c-tab-always-indent', and do not respect this variable."
e.g., `c-tab-always-indent', and do not respect this variable.
If you want the TAB key to always insert a literal TAB character,
this can't be controlled by setting this variable. Instead you
could say something like:
\(setq overriding-terminal-local-map
(let ((map (make-sparse-keymap)))
(define-key map [?\t] 'self-insert-command)
map))"
:group 'indent
:type '(choice
(const :tag "Always indent" t)

9
lisp/international/mule-cmds.el
View file

@ -3010,6 +3010,15 @@ on encoding."
;; higher code, so it gets pushed later!
(if new-name (puthash new-name c names))
(if old-name (puthash old-name c names))
;; Unicode uses the spelling "lamda" in character
;; names, instead of "lambda", due to "preferences
;; expressed by the Greek National Body" (Bug#30513).
;; Some characters have an old-name with the "lambda"
;; spelling, but others don't. Add the traditional
;; spelling for more convenient completion.
(when (and (not old-name) new-name
(string-match "\\<LAMDA\\>" new-name))
(puthash (replace-match "LAMBDA" t t new-name) c names))
(setq c (1+ c))))))
;; Special case for "BELL" which is apparently the only char which
;; doesn't have a new name and whose old-name is shadowed by a newer

7
lisp/language/cyrillic.el
View file

@ -169,13 +169,6 @@ Support for Russian using koi8-r and the russian-computer input method.")
:charset-list '(ibm866)
:mime-charset 'cp866)
(define-coding-system 'koi8-u
"KOI8-U 8-bit encoding for Cyrillic (MIME: KOI8-U)"
:coding-type 'charset
:mnemonic ?U
:charset-list '(koi8-u)
:mime-charset 'koi8-u)
(define-coding-system 'koi8-t
"KOI8-T 8-bit encoding for Cyrillic"
:coding-type 'charset

3086
lisp/ldefs-boot.el
View file

File diff suppressed because it is too large Load diff

108
lisp/mail/mspools.el
View file

@ -1,4 +1,4 @@
;;; mspools.el --- show mail spools waiting to be read
;;; mspools.el --- show mail spools waiting to be read -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2020 Free Software Foundation, Inc.
@ -125,18 +125,15 @@
(defcustom mspools-update nil
"Non-nil means update *spools* buffer after visiting any folder."
:type 'boolean
:group 'mspools)
:type 'boolean)
(defcustom mspools-suffix "spool"
"Extension used for spool files (not including full stop)."
:type 'string
:group 'mspools)
:type 'string)
(defcustom mspools-using-vm (fboundp 'vm)
"Non-nil if VM is used as mail reader, otherwise RMAIL is used."
:type 'boolean
:group 'mspools)
:type 'boolean)
(defcustom mspools-folder-directory
(if (boundp 'vm-folder-directory)
@ -144,8 +141,7 @@
"~/MAIL/")
"Directory where mail folders are kept. Ensure it has a trailing /.
Defaults to `vm-folder-directory' if bound else to ~/MAIL/."
:type 'directory
:group 'mspools)
:type 'directory)
(defcustom mspools-vm-system-mail (or (getenv "MAIL")
(concat rmail-spool-directory
@ -156,8 +152,7 @@ without it. By default this will be set to the environment variable
$MAIL. Otherwise it will use `rmail-spool-directory' to guess where
your primary spool is. If this fails, set it to something like
/usr/spool/mail/login-name."
:type 'file
:group 'mspools)
:type 'file)
;;; Internal Variables
@ -175,11 +170,8 @@ your primary spool is. If this fails, set it to something like
(define-key map "\C-c\C-c" 'mspools-visit-spool)
(define-key map "\C-m" 'mspools-visit-spool)
(define-key map " " 'mspools-visit-spool)
(define-key map "?" 'mspools-help)
(define-key map "q" 'mspools-quit)
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
(define-key map "g" 'revert-buffer)
map)
"Keymap for the *spools* buffer.")
@ -221,14 +213,15 @@ your primary spool is. If this fails, set it to something like
(concat mspools-folder-directory s "." mspools-suffix)
(concat mspools-folder-directory s ".crash")))
;; So I create a vm-spool-files entry for each of those mail drops
(mapcar 'file-name-sans-extension
(mapcar #'file-name-sans-extension
(directory-files mspools-folder-directory nil
(format "\\`[^.]+\\.%s" mspools-suffix)))
))
))
;;; MSPOOLS-SHOW -- the main function
(defun mspools-show ( &optional noshow)
;;;###autoload
(defun mspools-show (&optional noshow)
"Show the list of non-empty spool files in the *spools* buffer.
Buffer is not displayed if SHOW is non-nil."
(interactive)
@ -237,7 +230,7 @@ Buffer is not displayed if SHOW is non-nil."
(progn
(set-buffer mspools-buffer)
(setq buffer-read-only nil)
(delete-region (point-min) (point-max)))
(erase-buffer))
;; else buffer doesn't exist so create it
(get-buffer-create mspools-buffer))
@ -260,8 +253,8 @@ Buffer is not displayed if SHOW is non-nil."
(defun mspools-visit-spool ()
"Visit the folder on the current line of the *spools* buffer."
(interactive)
(let ( spool-name folder-name)
(setq spool-name (mspools-get-spool-name))
(let ((spool-name (mspools-get-spool-name))
folder-name)
(if (null spool-name)
(message "No spool on current line")
@ -270,19 +263,20 @@ Buffer is not displayed if SHOW is non-nil."
;; put in a little "*" to indicate spool file has been read.
(if (not mspools-update)
(save-excursion
(setq buffer-read-only nil)
(beginning-of-line)
(insert "*")
(delete-char 1)
(setq buffer-read-only t)
))
(let ((inhibit-read-only t))
(insert "*")
(delete-char 1))))
(message "folder %s spool %s" folder-name spool-name)
(if (eq (count-lines (point-min) (point-at-eol))
mspools-files-len)
(forward-line (- 1 mspools-files-len)) ;back to top of list
;; else just on to next line
(forward-line 1))
(forward-line (if (eq (count-lines (point-min) (point-at-eol))
mspools-files-len)
;; FIXME: Why use `mspools-files-len' instead
;; of looking if we're on the last line and
;; jumping to the first one if so?
(- 1 mspools-files-len) ;back to top of list
;; else just on to next line
1))
;; Choose whether to use VM or RMAIL for reading folder.
(if mspools-using-vm
@ -296,8 +290,8 @@ Buffer is not displayed if SHOW is non-nil."
(if mspools-update
;; generate new list of spools.
(save-excursion
(mspools-show-again 'noshow))))))
(save-excursion ;;FIXME: Why?
(mspools-revert-buffer))))))
(defun mspools-get-folder-from-spool (name)
"Return folder name corresponding to the spool file NAME."
@ -319,27 +313,31 @@ Buffer is not displayed if SHOW is non-nil."
(defun mspools-get-spool-name ()
"Return the name of the spool on the current line."
(let ((line-num (1- (count-lines (point-min) (point-at-eol)))))
;; FIXME: Why not extract the name directly from the current line's text?
(car (nth line-num mspools-files))))
;;; Spools mode functions
(defun mspools-revert-buffer (ignore noconfirm)
"Re-run mspools-show to revert the *spools* buffer."
(defun mspools-revert-buffer (&optional _ignore _noconfirm)
"Re-run `mspools-show' to revert the *spools* buffer."
(mspools-show 'noshow))
(defun mspools-show-again (&optional noshow)
"Update the *spools* buffer. This is useful if mspools-update is
nil."
"Update the *spools* buffer.
This is useful if `mspools-update' is nil."
(declare (obsolete revert-buffer "28.1"))
(interactive)
(mspools-show noshow))
(defun mspools-help ()
"Show help for `mspools-mode'."
(declare (obsolete describe-mode "28.1"))
(interactive)
(describe-function 'mspools-mode))
(defun mspools-quit ()
"Quit the *spools* buffer."
(declare (obsolete quit-window "28.1"))
(interactive)
(kill-buffer mspools-buffer))
@ -353,32 +351,26 @@ nil."
(defun mspools-get-spool-files ()
"Find the list of spool files and display them in *spools* buffer."
(let (folders head spool len beg end any)
(if (null mspools-folder-directory)
(error "Set `mspools-folder-directory' to where the spool files are"))
(setq folders (directory-files mspools-folder-directory nil
(if (null mspools-folder-directory)
(error "Set `mspools-folder-directory' to where the spool files are"))
(let* ((folders (directory-files mspools-folder-directory nil
(format "\\`[^.]+\\.%s\\'" mspools-suffix)))
(setq folders (mapcar 'mspools-size-folder folders))
(setq folders (delq nil folders))
(folders (delq nil (mapcar #'mspools-size-folder folders)))
;; beg end
)
(setq mspools-files folders)
(setq mspools-files-len (length mspools-files))
(set-buffer mspools-buffer)
(while folders
(setq any t)
(setq head (car folders))
(setq spool (car head))
(setq len (cdr head))
(setq folders (cdr folders))
(setq beg (point))
(insert (format " %10d %s" len spool))
(setq end (point))
(insert "\n")
;;(put-text-property beg end 'mouse-face 'highlight)
)
(if any
(delete-char -1)) ;delete last RET
(goto-char (point-min))
))
(with-current-buffer mspools-buffer
(pcase-dolist (`(,spool . ,len) folders)
;; (setq beg (point))
(insert (format " %10d %s" len spool))
;; (setq end (point))
(insert "\n")
;;(put-text-property beg end 'mouse-face 'highlight)
)
(if (not (bolp))
(delete-char -1)) ;delete last RET
(goto-char (point-min)))))
(defun mspools-size-folder (spool)
"Return (SPOOL . SIZE ), if SIZE of spool file is non-zero."

4
lisp/mail/qp.el
View file

@ -125,7 +125,7 @@ encode lines starting with \"From\"."
(not (eobp)))
(insert
(prog1
(format "=%02X" (char-after))
(format "=%02X" (get-byte))
(delete-char 1))))
;; Encode white space at the end of lines.
(goto-char (point-min))
@ -134,7 +134,7 @@ encode lines starting with \"From\"."
(while (not (eolp))
(insert
(prog1
(format "=%02X" (char-after))
(format "=%02X" (get-byte))
(delete-char 1)))))
(let ((ultra
(and (boundp 'mm-use-ultra-safe-encoding)

8
lisp/minibuffer.el
View file

@ -3863,12 +3863,16 @@ the minibuffer was activated, and execute the forms."
If FORMAT-ARGS is nil, PROMPT is used as a plain string. If
FORMAT-ARGS is non-nil, PROMPT is used as a format control
string, and FORMAT-ARGS are the arguments to be substituted into
it. See `format' for details."
it. See `format' for details.
If DEFAULT is nil, no \"default value\" string is included in the
return value."
(concat
(if (null format-args)
prompt
(apply #'format prompt format-args))
(format minibuffer-default-prompt-format default)
(and default
(format minibuffer-default-prompt-format default))
": "))
(provide 'minibuffer)

58
lisp/mwheel.el
View file

@ -1,4 +1,4 @@
;;; mwheel.el --- Wheel mouse support
;;; mwheel.el --- Mouse wheel support -*- lexical-binding:t -*-
;; Copyright (C) 1998, 2000-2020 Free Software Foundation, Inc.
;; Keywords: mouse
@ -344,16 +344,24 @@ non-Windows systems."
(text-scale-decrease 1)))
(select-window selected-window))))
(defvar mwheel-installed-bindings nil)
(defvar mwheel-installed-text-scale-bindings nil)
(defvar mouse-wheel--installed-bindings-alist nil
"Alist of all installed mouse wheel key bindings.")
(defun mouse-wheel--remove-bindings (bindings funs)
"Remove key BINDINGS if they're bound to any function in FUNS.
BINDINGS is a list of key bindings, FUNS is a list of functions.
(defun mouse-wheel--add-binding (key fun)
"Bind mouse wheel button KEY to function FUN.
Save it for later removal by `mouse-wheel--remove-bindings'."
(global-set-key key fun)
(push (cons key fun) mouse-wheel--installed-bindings-alist))
(defun mouse-wheel--remove-bindings ()
"Remove all mouse wheel key bindings.
This is a helper function for `mouse-wheel-mode'."
(dolist (key bindings)
(when (memq (lookup-key (current-global-map) key) funs)
(global-unset-key key))))
(dolist (binding mouse-wheel--installed-bindings-alist)
(let ((key (car binding))
(fun (cdr binding)))
(when (eq (lookup-key (current-global-map) key) fun)
(global-unset-key key))))
(setq mouse-wheel--installed-bindings-alist nil))
(defun mouse-wheel--create-scroll-keys (binding event)
"Return list of key vectors for BINDING and EVENT.
@ -363,8 +371,11 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
'left-fringe 'right-fringe
'vertical-scroll-bar 'horizontal-scroll-bar
'mode-line 'header-line)))
(cons (vector event) ; default case: no prefix.
(when (not (consp binding))
(if (consp binding)
;; With modifiers, bind only the buffer area (no prefix).
(list `[(,@(car binding) ,event)])
;; No modifier: bind also some non-buffer areas of the screen.
(cons (vector event)
(mapcar (lambda (prefix) (vector prefix event)) prefixes)))))
(define-minor-mode mouse-wheel-mode
@ -378,12 +389,7 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
:global t
:group 'mouse
;; Remove previous bindings, if any.
(mouse-wheel--remove-bindings mwheel-installed-bindings
'(mwheel-scroll))
(mouse-wheel--remove-bindings mwheel-installed-text-scale-bindings
'(mouse-wheel-text-scale))
(setq mwheel-installed-bindings nil)
(setq mwheel-installed-text-scale-bindings nil)
(mouse-wheel--remove-bindings)
;; Setup bindings as needed.
(when mouse-wheel-mode
(dolist (binding mouse-wheel-scroll-amount)
@ -391,18 +397,16 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
;; Bindings for changing font size.
((and (consp binding) (eq (cdr binding) 'text-scale))
(dolist (event (list mouse-wheel-down-event mouse-wheel-up-event))
;; Add binding.
(let ((key `[,(list (caar binding) event)]))
(global-set-key key 'mouse-wheel-text-scale)
(push key mwheel-installed-text-scale-bindings))))
(mouse-wheel--add-binding `[,(list (caar binding) event)]
'mouse-wheel-text-scale)))
;; Bindings for scrolling.
(t
(dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
mouse-wheel-left-event mouse-wheel-right-event))
(dolist (key (mouse-wheel--create-scroll-keys binding event))
;; Add binding.
(global-set-key key 'mwheel-scroll)
(push key mwheel-installed-bindings))))))))
(mouse-wheel--add-binding key 'mwheel-scroll))))))))
;;; Obsolete.
;;; Compatibility entry point
;; preloaded ;;;###autoload
@ -411,6 +415,12 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
(declare (obsolete mouse-wheel-mode "27.1"))
(mouse-wheel-mode (if uninstall -1 1)))
(defvar mwheel-installed-bindings nil)
(make-obsolete-variable 'mwheel-installed-bindings nil "28.1")
(defvar mwheel-installed-text-scale-bindings nil)
(make-obsolete-variable 'mwheel-installed-text-scale-bindings nil "28.1")
(provide 'mwheel)
;;; mwheel.el ends here

214
lisp/net/dbus.el
View file

@ -53,6 +53,8 @@
(require 'xml)
;;; D-Bus constants.
(defconst dbus-service-dbus "org.freedesktop.DBus"
"The bus name used to talk to the bus itself.")
@ -62,7 +64,8 @@
(defconst dbus-path-local (concat dbus-path-dbus "/Local")
"The object path used in local/in-process-generated messages.")
;; Default D-Bus interfaces.
;;; Default D-Bus interfaces.
(defconst dbus-interface-dbus "org.freedesktop.DBus"
"The interface exported by the service `dbus-service-dbus'.")
@ -145,7 +148,28 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
;; </signal>
;; </interface>
;; Emacs defaults.
;;; Default D-Bus errors.
(defconst dbus-error-dbus "org.freedesktop.DBus.Error"
"The namespace for default error names.
See /usr/include/dbus-1.0/dbus/dbus-protocol.h.")
(defconst dbus-error-failed (concat dbus-error-dbus ".Failed")
"A generic error; \"something went wrong\" - see the error message for more.")
(defconst dbus-error-access-denied (concat dbus-error-dbus ".AccessDenied")
"Security restrictions don't allow doing what you're trying to do.")
(defconst dbus-error-invalid-args (concat dbus-error-dbus ".InvalidArgs")
"Invalid arguments passed to a method call.")
(defconst dbus-error-property-read-only
(concat dbus-error-dbus ".PropertyReadOnly")
"Property you tried to set is read-only.")
;;; Emacs defaults.
(defconst dbus-service-emacs "org.gnu.Emacs"
"The well known service name of Emacs.")
@ -157,7 +181,8 @@ shall be subdirectories of this path.")
(defconst dbus-interface-emacs "org.gnu.Emacs"
"The interface namespace used by Emacs.")
;; D-Bus constants.
;;; Basic D-Bus message functions.
(defmacro dbus-ignore-errors (&rest body)
"Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
@ -172,9 +197,6 @@ Otherwise, return result of last form in BODY, or all other errors."
Every function must accept two arguments, the event and the error variable
caught in `condition-case' by `dbus-error'.")
;;; Basic D-Bus message functions.
(defvar dbus-return-values-table (make-hash-table :test #'equal)
"Hash table for temporarily storing arguments of reply messages.
A key in this hash table is a list (:serial BUS SERIAL), like in
@ -463,8 +485,9 @@ This is an internal function, it shall not be used outside dbus.el."
(apply #'dbus-message-internal dbus-message-type-method-return
bus service serial args))
(defun dbus-method-error-internal (bus service serial &rest args)
(defun dbus-method-error-internal (bus service serial error-name &rest args)
"Return error message for message SERIAL on the D-Bus BUS.
ERROR-NAME must belong to the \"org.freedesktop.DBus.Error\" namespace.
This is an internal function, it shall not be used outside dbus.el."
(or (featurep 'dbusbind)
@ -477,7 +500,7 @@ This is an internal function, it shall not be used outside dbus.el."
(signal 'wrong-type-argument (list 'natnump serial)))
(apply #'dbus-message-internal dbus-message-type-error
bus service serial args))
bus service serial error-name args))
;;; Hash table of registered functions.
@ -587,7 +610,7 @@ queue of this service."
(maphash
(lambda (key value)
(unless (equal :serial (car key))
(unless (eq :serial (car key))
(dolist (elt value)
(ignore-errors
(when (and (equal bus (cadr key)) (string-equal service (cadr elt)))
@ -775,10 +798,18 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
interface offered by SERVICE. It must provide METHOD.
HANDLER is a Lisp function to be called when a method call is
received. It must accept the input arguments of METHOD. The return
value of HANDLER is used for composing the returning D-Bus message.
If HANDLER returns a reply message with an empty argument list,
HANDLER must return the symbol `:ignore'.
received. It must accept the input arguments of METHOD. The
return value of HANDLER is used for composing the returning D-Bus
message. If HANDLER returns a reply message with an empty
argument list, HANDLER must return the symbol `:ignore' in order
to distinguish it from `nil' (the boolean false).
If HANDLER detects an error, it shall return the list `(:error
ERROR-NAME ERROR-MESSAGE)'. ERROR-NAME is a namespaced string
which characterizes the error type, and ERROR-MESSAGE is a free
text string. Alternatively, any Emacs signal `dbus-error' in
HANDLER raises a D-Bus error message with the error name
\"org.freedesktop.DBus.Error.Failed\".
When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not
registered. This means that other D-Bus clients have no way of
@ -996,22 +1027,26 @@ If the HANDLER returns a `dbus-error', it is propagated as return message."
(signal 'dbus-error (nthcdr 9 event)))
;; Apply the handler.
(setq result (apply (nth 8 event) (nthcdr 9 event)))
;; Return a message when it is a message call.
;; Return an (error) message when it is a message call.
(when (= dbus-message-type-method-call (nth 2 event))
(dbus-ignore-errors
(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)))))))
(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.
(when (= dbus-message-type-method-call (nth 2 event))
(dbus-ignore-errors
(dbus-method-error-internal
(nth 1 event) (nth 4 event) (nth 3 event) (cadr err))))
(nth 1 event) (nth 4 event) (nth 3 event) dbus-error-failed
(error-message-string err))))
;; Propagate D-Bus error messages.
(run-hook-with-args 'dbus-event-error-functions event err)
(when dbus-debug
@ -1420,6 +1455,26 @@ nil is returned."
(dbus-call-method bus service path dbus-interface-properties
"GetAll" :timeout 500 interface))))
(defun dbus-get-this-registered-property (bus _service path interface property)
"Return PROPERTY entry of `dbus-registered-objects-table'.
Filter out not matching PATH."
;; Remove entries not belonging to this case.
(seq-remove
(lambda (item)
(not (string-equal path (nth 2 item))))
(gethash (list :property bus interface property)
dbus-registered-objects-table)))
(defun dbus-get-other-registered-property (bus _service path interface property)
"Return PROPERTY entry of `dbus-registered-objects-table'.
Filter out matching PATH."
;; Remove matching entries.
(seq-remove
(lambda (item)
(string-equal path (nth 2 item)))
(gethash (list :property bus interface property)
dbus-registered-objects-table)))
(defun dbus-register-property
(bus service path interface property access value
&optional emits-signal dont-register-service)
@ -1436,14 +1491,14 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
name of the interface used at PATH, PROPERTY is the name of the
property of INTERFACE. ACCESS indicates, whether the property
can be changed by other services via D-Bus. It must be either
the symbol `:read' or `:readwrite'. VALUE is the initial value
of the property, it can be of any valid type (see
the symbol `:read', `:write' or `:readwrite'. VALUE is the
initial value of the property, it can be of any valid type (see
`dbus-call-method' for details).
If PROPERTY already exists on PATH, it will be overwritten. For
properties with access type `:read' this is the only way to
change their values. Properties with access type `:readwrite'
can be changed by `dbus-set-property'.
change their values. Properties with access type `:write' or
`:readwrite' can be changed by `dbus-set-property'.
The interface \"org.freedesktop.DBus.Properties\" is added to
PATH, including a default handler for the \"Get\", \"GetAll\" and
@ -1457,7 +1512,7 @@ of noticing the newly registered property. When interfaces are
constructed incrementally by adding single methods or properties
at a time, DONT-REGISTER-SERVICE can be used to prevent other
clients from discovering the still incomplete interface."
(unless (member access '(:read :readwrite))
(unless (member access '(:read :write :readwrite))
(signal 'wrong-type-argument (list "Access type invalid" access)))
;; Add handlers for the three property-related methods.
@ -1479,19 +1534,25 @@ clients from discovering the still incomplete interface."
(when emits-signal
(dbus-send-signal
bus service path dbus-interface-properties "PropertiesChanged"
`((:dict-entry ,property (:variant ,value)))
'(:array)))
(if (member access '(:read :readwrite))
`(:array (:dict-entry ,property (:variant ,value)))
'(:array: :signature "{sv}"))
(if (eq access :write)
`(:array ,property)
'(:array))))
;; Create a hash table entry. We use nil for the unique name,
;; because the property might be accessed from anybody.
(let ((key (list :property bus interface property))
(val
(list
(cons
(list
nil service path
(cons
(if emits-signal (list access :emits-signal) (list access))
value)))))
value))
(dbus-get-other-registered-property
bus service path interface property))))
(puthash key val dbus-registered-objects-table)
;; Return the object.
@ -1509,55 +1570,70 @@ It will be registered for all objects created by `dbus-register-property'."
(cond
;; "Get" returns a variant.
((string-equal method "Get")
(let ((entry (gethash (list :property bus interface property)
dbus-registered-objects-table)))
(when (string-equal path (nth 2 (car entry)))
`((:variant ,(cdar (last (car entry))))))))
(let* ((entry (dbus-get-this-registered-property
bus service path interface property))
(object (car (last (car entry)))))
(cond
((not (consp object))
`(:error ,dbus-error-invalid-args
,(format-message
"No such property \"%s\" at path \"%s\"" property path)))
((eq (car object) :write)
`(:error ,dbus-error-access-denied
,(format-message
"Property \"%s\" at path \"%s\" is not readable" property path)))
;; Return the result.
(t `((:variant ,(cdar (last (car entry)))))))))
;; "Set" expects a variant.
((string-equal method "Set")
(let* ((value (caar (cddr args)))
(entry (gethash (list :property bus interface property)
dbus-registered-objects-table))
;; The value of the hash table is a list; in case of
;; properties it contains just one element (UNAME SERVICE
;; PATH OBJECT). OBJECT is a cons cell of a list, which
;; contains a list of annotations (like :read,
;; :read-write, :emits-signal), and the value of the
;; property.
(entry (dbus-get-this-registered-property
bus service path interface property))
(object (car (last (car entry)))))
(unless (consp object)
(signal 'dbus-error
(list "Property not registered at path" property path)))
(unless (member :readwrite (car object))
(signal 'dbus-error
(list "Property not writable at path" property path)))
(puthash (list :property bus interface property)
(list (append (butlast (car entry))
(list (cons (car object) value))))
dbus-registered-objects-table)
;; Send the "PropertiesChanged" signal.
(when (member :emits-signal (car object))
(dbus-send-signal
bus service path dbus-interface-properties "PropertiesChanged"
`((:dict-entry ,property (:variant ,value)))
'(:array)))
;; Return empty reply.
:ignore))
(cond
((not (consp object))
`(:error ,dbus-error-invalid-args
,(format-message
"No such property \"%s\" at path \"%s\"" property path)))
((eq (car object) :read)
`(:error ,dbus-error-property-read-only
,(format-message
"Property \"%s\" at path \"%s\" is not writable" property path)))
(t (puthash (list :property bus interface property)
(cons (append (butlast (car entry))
(list (cons (car object) value)))
(dbus-get-other-registered-property
bus service path interface property))
dbus-registered-objects-table)
;; Send the "PropertiesChanged" signal.
(when (member :emits-signal (car object))
(dbus-send-signal
bus service path dbus-interface-properties "PropertiesChanged"
(if (or (member :read (car object))
(member :readwrite (car object)))
`(:array (:dict-entry ,property (:variant ,value)))
'(:array: :signature "{sv}"))
(if (eq (car object) :write)
`(:array ,property)
'(:array))))
;; Return empty reply.
:ignore))))
;; "GetAll" returns "a{sv}".
((string-equal method "GetAll")
(let (result)
(maphash
(lambda (key val)
(when (and (equal (butlast key) (list :property bus interface))
(string-equal path (nth 2 (car val)))
(not (functionp (car (last (car val))))))
(push
(list :dict-entry
(car (last key))
(list :variant (cdar (last (car val)))))
result)))
(dolist (item val)
(when (and (equal (butlast key) (list :property bus interface))
(string-equal path (nth 2 item))
(not (functionp (car (last item)))))
(push
(list :dict-entry
(car (last key))
(list :variant (cdar (last item))))
result))))
dbus-registered-objects-table)
;; Return the result, or an empty array.
(list :array (or result '(:signature "{sv}"))))))))
@ -1765,5 +1841,7 @@ this connection to those buses."
;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
;;
;; * Run handlers in own threads.
;;; dbus.el ends here

3
lisp/net/eudcb-macos-contacts.el
View file

@ -96,7 +96,8 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
(name (nth 0 args))
(email (nth 1 args)))
(setq result (cons `((name . ,name)
(email . ,email)) result))))
(email . ,email))
result))))
(forward-line))
result)))

30
lisp/net/eww.el
View file

@ -1402,16 +1402,15 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(options nil)
(start (point))
(max 0))
(dolist (elem (dom-non-text-children dom))
(when (eq (dom-tag elem) 'option)
(when (dom-attr elem 'selected)
(nconc menu (list :value (dom-attr elem 'value))))
(let ((display (dom-text elem)))
(setq max (max max (length display)))
(push (list 'item
:value (dom-attr elem 'value)
:display display)
options))))
(dolist (elem (dom-by-tag dom 'option))
(when (dom-attr elem 'selected)
(nconc menu (list :value (dom-attr elem 'value))))
(let ((display (dom-text elem)))
(setq max (max max (length display)))
(push (list 'item
:value (dom-attr elem 'value)
:display display)
options)))
(when options
(setq options (nreverse options))
;; If we have no selected values, default to the first value.
@ -1451,12 +1450,13 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(cons (plist-get (cdr elem) :display)
(plist-get (cdr elem) :value))))
input)))
(display
(completing-read "Change value: " options nil 'require-match))
(display (completing-read "Change value: " options nil 'require-match))
(inhibit-read-only t))
(plist-put input :value (cdr (assoc-string display options t)))
(goto-char
(eww-update-field display))))
;; If the user doesn't enter anything, don't change anything.
(when (> (length display) 0)
(plist-put input :value (cdr (assoc-string display options t)))
(goto-char
(eww-update-field display)))))
(defun eww-update-field (string &optional offset)
(unless offset

6
lisp/net/shr.el
View file

@ -751,10 +751,10 @@ size, and full-buffer size."
(face (get-text-property (point) 'face)))
;; Extend the background to the end of the line.
(insert ?\n)
(when face
(put-text-property (1- (point)) (point)
'face (shr-face-background face)))
(shr-indent)
(when face
(put-text-property gap-start (point)
'face (shr-face-background face)))
(when (and (> (1- gap-start) (point-min))
(get-text-property (point) 'shr-url)
;; The link on both sides of the newline are the

19
lisp/net/tramp-cmds.el
View file

@ -482,9 +482,7 @@ For details, see `tramp-rename-files'."
(defun tramp-bug ()
"Submit a bug report to the Tramp developers."
(interactive)
(let ((reporter-prompt-for-summary-p t)
;; In rare cases, it could contain the password. So we make it nil.
tramp-password-save-function)
(let ((reporter-prompt-for-summary-p t))
(reporter-submit-bug-report
tramp-bug-report-address ; to-address
(format "tramp (%s %s/%s)" ; package name and version
@ -492,10 +490,11 @@ For details, see `tramp-rename-files'."
(sort
(delq nil (mapcar
(lambda (x)
(and x (boundp x) (cons x 'tramp-reporter-dump-variable)))
(and x (boundp x) (not (get x 'tramp-suppress-trace))
(cons x 'tramp-reporter-dump-variable)))
(append
(mapcar #'intern (all-completions "tramp-" obarray #'boundp))
;; Non-tramp variables of interest.
;; Non-Tramp variables of interest.
'(shell-prompt-pattern
backup-by-copying
backup-by-copying-when-linked
@ -552,11 +551,11 @@ buffer in your bug report.
(string-match-p
(concat "[^" (bound-and-true-p mm-7bit-chars) "]") val))
(with-current-buffer reporter-eval-buffer
(set
varsym
(format
"(decode-coding-string (base64-decode-string \"%s\") 'raw-text)"
(base64-encode-string (encode-coding-string val 'raw-text)))))))
(set varsym
`(decode-coding-string
(base64-decode-string
,(base64-encode-string (encode-coding-string val 'raw-text)))
'raw-text)))))
;; Dump variable.
(reporter-dump-variable varsym mailbuf)

2
lisp/net/tramp.el
View file

@ -80,6 +80,7 @@
(eval-and-compile ;; So it's also available in tramp-loaddefs.el!
(defvar tramp--startup-hook nil
"Forms to be executed at the end of tramp.el.")
(put 'tramp--startup-hook 'tramp-suppress-trace t)
(defmacro tramp--with-startup (&rest body)
"Schedule BODY to be executed at the end of tramp.el."
@ -1241,6 +1242,7 @@ the (optional) timestamp of last activity on this connection.")
"Password save function.
Will be called once the password has been verified by successful
authentication.")
(put 'tramp-password-save-function 'tramp-suppress-trace t)
(defconst tramp-completion-file-name-handler-alist
'((file-name-all-completions

12
lisp/pcmpl-linux.el
View file

@ -1,4 +1,4 @@
;;; pcmpl-linux.el --- functions for dealing with GNU/Linux completions
;;; pcmpl-linux.el --- functions for dealing with GNU/Linux completions -*- lexical-binding: t -*-
;; Copyright (C) 1999-2020 Free Software Foundation, Inc.
@ -65,18 +65,22 @@
(pcomplete-opt "hVanfFrsvwt(pcmpl-linux-fs-types)o?L?U?")
(while (pcomplete-here (pcomplete-entries) nil 'identity)))
(defconst pcmpl-linux-fs-modules-path-format "/lib/modules/%s/kernel/fs/")
(defun pcmpl-linux-fs-types ()
"Return a list of available fs modules on GNU/Linux systems."
(let ((kernel-ver (pcomplete-process-result "uname" "-r")))
(directory-files
(concat "/lib/modules/" kernel-ver "/kernel/fs/"))))
(format pcmpl-linux-fs-modules-path-format kernel-ver))))
(defconst pcmpl-linux-mtab-file "/etc/mtab")
(defun pcmpl-linux-mounted-directories ()
"Return a list of mounted directory names."
(let (points)
(when (file-readable-p "/etc/mtab")
(when (file-readable-p pcmpl-linux-mtab-file)
(with-temp-buffer
(insert-file-contents-literally "/etc/mtab")
(insert-file-contents-literally pcmpl-linux-mtab-file)
(while (not (eobp))
(let* ((line (buffer-substring (point) (line-end-position)))
(args (split-string line " ")))

16
lisp/pcmpl-unix.el
View file

@ -1,4 +1,4 @@
;;; pcmpl-unix.el --- standard UNIX completions
;;; pcmpl-unix.el --- standard UNIX completions -*- lexical-binding:t -*-
;; Copyright (C) 1999-2020 Free Software Foundation, Inc.
@ -155,12 +155,14 @@ documentation), this function returns nil."
(let ((host-re "\\(?:\\([-.[:alnum:]]+\\)\\|\\[\\([-.[:alnum:]]+\\)\\]:[0-9]+\\)[, ]")
ssh-hosts-list)
(while (re-search-forward (concat "^ *" host-re) nil t)
(add-to-list 'ssh-hosts-list (concat (match-string 1)
(match-string 2)))
(push (concat (match-string 1)
(match-string 2))
ssh-hosts-list)
(while (and (eq (char-before) ?,)
(re-search-forward host-re (line-end-position) t))
(add-to-list 'ssh-hosts-list (concat (match-string 1)
(match-string 2)))))
(push (concat (match-string 1)
(match-string 2))
ssh-hosts-list)))
ssh-hosts-list))))
(defun pcmpl-ssh-config-hosts ()
@ -173,7 +175,7 @@ documentation), this function returns nil."
(case-fold-search t))
(while (re-search-forward "^ *host\\(name\\)? +\\([-.[:alnum:]]+\\)"
nil t)
(add-to-list 'ssh-hosts-list (match-string 2)))
(push (match-string 2) ssh-hosts-list))
ssh-hosts-list))))
(defun pcmpl-ssh-hosts ()
@ -181,7 +183,7 @@ documentation), this function returns nil."
Uses both `pcmpl-ssh-config-file' and `pcmpl-ssh-known-hosts-file'."
(let ((hosts (pcmpl-ssh-known-hosts)))
(dolist (h (pcmpl-ssh-config-hosts))
(add-to-list 'hosts h))
(push h hosts))
hosts))
;;;###autoload

7
lisp/play/gamegrid.el
View file

@ -265,12 +265,7 @@ format."
(set-face-foreground face color)
(set-face-background face color)
(gamegrid-set-font face)
(condition-case nil
(set-face-background-pixmap face [nothing]);; XEmacs
(error nil))
(condition-case nil
(set-face-background-pixmap face nil);; Emacs
(error nil)))
(set-face-background-pixmap face nil))
(defun gamegrid-make-mono-tty-face ()
(let ((face (make-face 'gamegrid-mono-tty-face)))

88
lisp/play/life.el
View file

@ -1,4 +1,4 @@
;;; life.el --- John Horton Conway's `Life' game for GNU Emacs
;;; life.el --- John Horton Conway's Game of Life -*- lexical-binding:t -*-
;; Copyright (C) 1988, 2001-2020 Free Software Foundation, Inc.
@ -29,6 +29,15 @@
;;; Code:
(defgroup life nil
"Conway's Game of Life."
:group 'games)
(defcustom life-step-time 0.5
"Time to sleep between steps (generations)."
:type 'number
:version "28.1")
(defvar life-patterns
[("@@@" " @@" "@@@")
("@@@ @@@" "@@ @@ " "@@@ @@@")
@ -54,6 +63,7 @@
" @@")
("@@@@@@@@@" "@ @ @" "@ @@@@@ @" "@ @ @ @" "@@@ @@@"
"@ @ @ @" "@ @@@@@ @" "@ @ @" "@@@@@@@@@")
;; Glider Gun (infinite, Bill Gosper, 1970)
(" @ "
" @ @ "
" @@ @@ @@"
@ -74,7 +84,26 @@
" @@"
" @@ @"
"@ @ @")
("@@@@@@@@ @@@@@ @@@ @@@@@@@ @@@@@")]
("@@@@@@@@ @@@@@ @@@ @@@@@@@ @@@@@")
;; Pentadecathlon (period 15, John Conway, 1970)
(" @ @ "
"@@ @@@@ @@"
" @ @ ")
;; Queen Bee Shuttle (period 30, Bill Gosper, 1970)
(" @ "
" @ @ "
" @ @ "
"@@ @ @ @@"
"@@ @ @ @@"
" @ @ "
" @ ")
;; 2x Figure eight (period 8, Simon Norton, 1970)
("@@@ @@@ "
"@@@ @@@ "
"@@@ @@@ "
" @@@ @@@"
" @@@ @@@"
" @@@ @@@")]
"Vector of rectangles containing some Life startup patterns.")
;; Macros are used macros for manifest constants instead of variables
@ -106,28 +135,45 @@
;; (scroll-up) and (scroll-down) when trying to center the display.
(defvar life-window-start nil)
(defvar life--max-width nil
"If non-nil, restrict width to this positive integer. ")
(defvar life--max-height nil
"If non-nil, restrict height to this positive integer. ")
;; For mode line
(defvar life-current-generation nil)
;; Sadly, mode-line-format won't display numbers.
(defvar life-generation-string nil)
(defun life--tick ()
"Game tick for `life'."
(let ((inhibit-quit t)
(inhibit-read-only t))
(life-grim-reaper)
(life-expand-plane-if-needed)
(life-increment-generation)))
;;;###autoload
(defun life (&optional sleeptime)
(defun life (&optional step-time)
"Run Conway's Life simulation.
The starting pattern is randomly selected. Prefix arg (optional first
arg non-nil from a program) is the number of seconds to sleep between
generations (this defaults to 1)."
(interactive "p")
(or sleeptime (setq sleeptime 1))
The starting pattern is randomly selected from `life-patterns'.
Prefix arg is the number of tenths of a second to sleep between
generations (the default is `life-step-time').
When called from Lisp, optional argument STEP-TIME is the time to
sleep in seconds."
(interactive "P")
(setq step-time (or (and step-time (/ (if (consp step-time)
(car step-time)
step-time) 10.0))
life-step-time))
(life-setup)
(catch 'life-exit
(while t
(let ((inhibit-quit t)
(inhibit-read-only t))
(life-display-generation sleeptime)
(life-grim-reaper)
(life-expand-plane-if-needed)
(life-increment-generation)))))
(life-display-generation step-time)
(life--tick))))
(define-derived-mode life-mode special-mode "Life"
"Major mode for the buffer of `life'."
@ -138,16 +184,17 @@ generations (this defaults to 1)."
(setq-local life-generation-string "0")
(setq-local mode-line-buffer-identification '("Life: generation "
life-generation-string))
(setq-local fill-column (1- (window-width)))
(setq-local fill-column (min (or life--max-width most-positive-fixnum)
(1- (window-width))))
(setq-local life-window-start 1)
(buffer-disable-undo))
(defun life-setup ()
(switch-to-buffer (get-buffer-create "*Life*") t)
(erase-buffer)
(life-mode)
;; stuff in the random pattern
(let ((inhibit-read-only t))
(erase-buffer)
(life-mode)
(life-insert-random-pattern)
;; make sure (life-life-char) is used throughout
(goto-char (point-min))
@ -160,7 +207,8 @@ generations (this defaults to 1)."
(indent-to n)
(forward-line)))
;; center the pattern vertically
(let ((n (/ (- (1- (window-height))
(let ((n (/ (- (min (or life--max-height most-positive-fixnum)
(1- (window-height)))
(count-lines (point-min) (point-max)))
2)))
(goto-char (point-min))
@ -276,12 +324,12 @@ generations (this defaults to 1)."
(insert ?\n)
(setq life-window-start (+ life-window-start fill-column 1)))))
(defun life-display-generation (sleeptime)
(defun life-display-generation (step-time)
(goto-char life-window-start)
(recenter 0)
;; Redisplay; if the user has hit a key, exit the loop.
(or (and (sit-for sleeptime) (< 0 sleeptime))
(or (and (sit-for step-time) (< 0 step-time))
(not (input-pending-p))
(throw 'life-exit nil)))

20
lisp/play/pong.el
View file

@ -1,4 +1,4 @@
;;; pong.el --- classical implementation of pong
;;; pong.el --- classical implementation of pong -*- lexical-binding:t -*-
;; Copyright (C) 1999-2020 Free Software Foundation, Inc.
@ -33,88 +33,72 @@
;;; Customization
(defgroup pong nil
"Emacs-Lisp implementation of the classical game pong."
"Emacs Lisp implementation of the classical game pong."
:tag "Pong"
:group 'games)
(defcustom pong-buffer-name "*Pong*"
"Name of the buffer used to play."
:group 'pong
:type '(string))
(defcustom pong-width 50
"Width of the playfield."
:group 'pong
:type '(integer))
(defcustom pong-height (min 30 (- (frame-height) 6))
"Height of the playfield."
:group 'pong
:type '(integer))
(defcustom pong-bat-width 3
"Width of the bats for pong."
:group 'pong
:type '(integer))
(defcustom pong-blank-color "black"
"Color used for background."
:group 'pong
:type 'color)
(defcustom pong-bat-color "yellow"
"Color used for bats."
:group 'pong
:type 'color)
(defcustom pong-ball-color "red"
"Color used for the ball."
:group 'pong
:type 'color)
(defcustom pong-border-color "white"
"Color used for pong borders."
:group 'pong
:type 'color)
(defcustom pong-left-key "4"
"Alternate key to press for bat 1 to go up (primary one is [left])."
:group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-right-key "6"
"Alternate key to press for bat 1 to go down (primary one is [right])."
:group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-up-key "8"
"Alternate key to press for bat 2 to go up (primary one is [up])."
:group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-down-key "2"
"Alternate key to press for bat 2 to go down (primary one is [down])."
:group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-quit-key "q"
"Key to press to quit pong."
:group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-pause-key "p"
"Key to press to pause pong."
:group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-resume-key "p"
"Key to press to resume pong."
:group 'pong
:type '(restricted-sexp :match-alternatives (stringp vectorp)))
(defcustom pong-timer-delay 0.1
"Time to wait between every cycle."
:group 'pong
:type 'number)

4
lisp/play/snake.el
View file

@ -1,4 +1,4 @@
;;; snake.el --- implementation of Snake for Emacs
;;; snake.el --- implementation of Snake for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1997, 2001-2020 Free Software Foundation, Inc.
@ -279,7 +279,7 @@ and then start moving it leftwards.")
snake-velocity-queue nil)
(let ((x snake-initial-x)
(y snake-initial-y))
(dotimes (i snake-length)
(dotimes (_ snake-length)
(gamegrid-set-cell x y snake-snake)
(setq snake-positions (cons (vector x y) snake-positions))
(cl-incf x snake-velocity-x)

2
lisp/play/tetris.el
View file

@ -1,4 +1,4 @@
;;; tetris.el --- implementation of Tetris for Emacs
;;; tetris.el --- implementation of Tetris for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1997, 2001-2020 Free Software Foundation, Inc.

6
lisp/progmodes/cc-mode.el
View file

@ -1204,7 +1204,7 @@ Note that the style variables are always made local to the buffer."
(while (progn
(parse-partial-sexp (point) end nil nil st-s 'syntax-table)
(unless (bobp)
(c-clear-char-property (1- (point)) 'syntax-table))
(c-clear-syn-tab (1- (point))))
(setq st-pos (point))
(and (< (point) end)
(not (eq (char-before) ?\")))))
@ -1237,7 +1237,7 @@ Note that the style variables are always made local to the buffer."
t)
(t
;; At a significant "
(c-clear-char-property (1- (point)) 'syntax-table)
(c-clear-syn-tab (1- (point)))
(setq pos-ll (c-literal-limits)
pos-lt (c-literal-type pos-ll))
nil)))
@ -1245,7 +1245,7 @@ Note that the style variables are always made local to the buffer."
(cond
((bobp))
((eq pos-lt 'string)
(c-put-char-property (1- (point)) 'syntax-table '(15)))
(c-put-syn-tab (1- (point)) '(15)))
(t nil)))))
(defun c-put-syn-tab (pos value)

15
lisp/progmodes/compile.el
View file

@ -1148,12 +1148,13 @@ POS and RES.")
(setcdr l1 (cons (list ,key) l2)))))))
(defun compilation-auto-jump (buffer pos)
(with-current-buffer buffer
(goto-char pos)
(let ((win (get-buffer-window buffer 0)))
(if win (set-window-point win pos)))
(if compilation-auto-jump-to-first-error
(compile-goto-error))))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(goto-char pos)
(let ((win (get-buffer-window buffer 0)))
(if win (set-window-point win pos)))
(if compilation-auto-jump-to-first-error
(compile-goto-error)))))
;; This function is the central driver, called when font-locking to gather
;; all information needed to later jump to corresponding source code.
@ -2064,6 +2065,8 @@ Returns the compilation buffer created."
(define-key map "\M-p" 'compilation-previous-error)
(define-key map "\M-{" 'compilation-previous-file)
(define-key map "\M-}" 'compilation-next-file)
(define-key map "n" 'next-error-no-select)
(define-key map "p" 'previous-error-no-select)
(define-key map "\t" 'compilation-next-error)
(define-key map [backtab] 'compilation-previous-error)
(define-key map "g" 'recompile) ; revert

20
lisp/progmodes/cperl-mode.el
View file

@ -3241,8 +3241,8 @@ Return the error message (if any). Does not work if delimiter is `)'.
Works before syntax recognition is done."
;; Works *before* syntax recognition is done
(or st-l (setq st-l (list nil))) ; Avoid overwriting '()
(let (st b reset-st)
(condition-case b
(let (st result reset-st)
(condition-case err
(progn
(setq st (cperl-cached-syntax-table st-l))
(modify-syntax-entry ?\( "()" st)
@ -3250,8 +3250,7 @@ Works before syntax recognition is done."
(setq reset-st (syntax-table))
(set-syntax-table st)
(forward-sexp 1))
(error (message
"cperl-forward-group-in-re: error %s" b)))
(error (setq result err)))
;; now restore the initial state
(if st
(progn
@ -3259,7 +3258,7 @@ Works before syntax recognition is done."
(modify-syntax-entry ?\) "." st)))
(if reset-st
(set-syntax-table reset-st))
b))
result))
(defvar font-lock-string-face)
@ -4820,9 +4819,10 @@ conditional/loop constructs."
(while (< (point) tmp-end)
(parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol
(or (eolp) (forward-sexp 1)))
(if (> (point) tmp-end) ; Yes, there an unfinished block
(if (> (point) tmp-end) ; Check for an unfinished block
nil
(if (eq ?\) (preceding-char))
;; closing parens can be preceded by up to three sexps
(progn ;; Plan B: find by REGEXP block followup this line
(setq top (point))
(condition-case nil
@ -4843,7 +4843,9 @@ conditional/loop constructs."
(progn
(goto-char top)
(forward-sexp 1)
(setq top (point)))))
(setq top (point)))
;; no block to be processed: expression ends here
(setq done t)))
(error (setq done t)))
(goto-char top))
(if (looking-at ; Try Plan C: continuation block
@ -5774,8 +5776,8 @@ indentation and initial hashes. Behaves usually outside of comment."
t-font-lock-keywords)
cperl-font-lock-keywords cperl-font-lock-keywords-1
cperl-font-lock-keywords-2 (append
cperl-font-lock-keywords-1
t-font-lock-keywords-1)))
t-font-lock-keywords-1
cperl-font-lock-keywords-1)))
(if (fboundp 'ps-print-buffer) (cperl-ps-print-init))
(if (or (featurep 'choose-color) (featurep 'font-lock-extra))
(eval ; Avoid a warning

2
lisp/progmodes/elisp-mode.el
View file

@ -1421,7 +1421,7 @@ Intended for `eldoc-documentation-functions' (which see)."
"Document variable at point.
Intended for `eldoc-documentation-functions' (which see)."
(let* ((sym (elisp--current-symbol))
(docstring (and sym (elisp-get-var-docstring sym))))
(docstring (and sym (elisp-get-var-docstring sym))))
(when docstring
(funcall callback docstring
:thing sym

2
lisp/progmodes/flymake.el
View file

@ -1002,7 +1002,7 @@ special *Flymake log* buffer." :group 'flymake :lighter
(add-hook 'after-change-functions 'flymake-after-change-function nil t)
(add-hook 'after-save-hook 'flymake-after-save-hook nil t)
(add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t)
(add-hook 'eldoc-documentation-functions 'flymake-eldoc-function nil t)
(add-hook 'eldoc-documentation-functions 'flymake-eldoc-function t t)
;; If Flymake happened to be alrady already ON, we must cleanup
;; existing diagnostic overlays, lest we forget them by blindly

6
lisp/progmodes/project.el
View file

@ -1,7 +1,7 @@
;;; project.el --- Operations on the current project -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
;; Version: 0.5.1
;; Version: 0.5.2
;; Package-Requires: ((emacs "26.3") (xref "1.0.2"))
;; This is a GNU ELPA :core package. Avoid using functionality that
@ -667,7 +667,9 @@ The following commands are available:
(interactive)
(project--other-place-command '((display-buffer-in-new-tab))))
;;;###autoload (define-key tab-prefix-map "p" #'project-other-tab-command)
;;;###autoload
(when (bound-and-true-p tab-prefix-map)
(define-key tab-prefix-map "p" #'project-other-tab-command))
(declare-function grep-read-files "grep")
(declare-function xref--show-xrefs "xref")

2
lisp/svg.el
View file

@ -5,7 +5,7 @@
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Felix E. Klee <felix.klee@inka.de>
;; Keywords: image
;; Version: 1.0
;; Version: 1.1
;; Package-Requires: ((emacs "25"))
;; This file is part of GNU Emacs.

2
lisp/textmodes/flyspell.el
View file

@ -1904,7 +1904,7 @@ before point that's highlighted as misspelled."
(while (and (setq pos (previous-overlay-change pos))
(not (= pos pos1)))
(setq pos1 pos)
(if (> pos (point-min))
(if (>= pos (point-min))
(progn
(setq ovs (overlays-at pos))
(while (consp ovs)

3
lisp/textmodes/sgml-mode.el
View file

@ -46,7 +46,8 @@
(defcustom sgml-basic-offset 2
"Specifies the basic indentation level for `sgml-indent-line'."
:type 'integer)
:type 'integer
:safe #'integerp)
(defcustom sgml-attribute-offset 0
"Specifies a delta for attribute indentation in `sgml-indent-line'.

29
lisp/time.el
View file

@ -29,6 +29,8 @@
;;; Code:
(eval-when-compile (require 'subr-x))
(defgroup display-time nil
"Display time and load in mode line of Emacs."
:group 'mode-line
@ -559,26 +561,31 @@ See `world-clock'."
The variable `world-clock-list' specifies which time zones to use.
To turn off the world time display, go to the window and type `\\[quit-window]'."
(interactive)
(when (and world-clock-timer-enable
(not (get-buffer world-clock-buffer-name)))
(run-at-time t world-clock-timer-second #'world-clock-update))
(pop-to-buffer world-clock-buffer-name)
(if-let ((buffer (get-buffer world-clock-buffer-name)))
(pop-to-buffer buffer)
(pop-to-buffer world-clock-buffer-name)
(when world-clock-timer-enable
(run-at-time t world-clock-timer-second #'world-clock-update)
(add-hook 'kill-buffer-hook #'world-clock-cancel-timer nil t)))
(world-clock-display (time--display-world-list))
(world-clock-mode)
(fit-window-to-buffer))
(defun world-clock-cancel-timer ()
"Cancel the world clock timer."
(let ((list timer-list))
(while list
(let ((elt (pop list)))
(when (equal (symbol-name (timer--function elt))
"world-clock-update")
(cancel-timer elt))))))
(defun world-clock-update (&optional _arg _noconfirm)
"Update the `world-clock' buffer."
(if (get-buffer world-clock-buffer-name)
(with-current-buffer (get-buffer world-clock-buffer-name)
(world-clock-display (time--display-world-list)))
;; cancel timer
(let ((list timer-list))
(while list
(let ((elt (pop list)))
(when (equal (symbol-name (timer--function elt))
"world-clock-update")
(cancel-timer elt)))))))
(world-clock-cancel-timer)))
;;;###autoload
(defun emacs-uptime (&optional format)

6
lisp/vc/vc-dir.el
View file

@ -451,7 +451,11 @@ If NOINSERT, ignore elements on ENTRIES which are not in the ewoc."
(setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry))
(setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry))
(setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil)
(ewoc-invalidate vc-ewoc node))
;; `ewoc-invalidate' will kill line and insert new text,
;; let's keep point column.
(let ((p (point)))
(ewoc-invalidate vc-ewoc node)
(goto-char p)))
;; If the state is nil, the file does not exist
;; anymore, so remember the entry so we can remove
;; it after we are done inserting all ENTRIES.

3
lisp/vc/vc-dispatcher.el
View file

@ -691,7 +691,6 @@ BACKEND, if non-nil, specifies a VC backend for the Log Edit buffer."
(message "%s Type C-c C-c when done" msg)
(vc-finish-logentry (eq comment t)))))
(declare-function vc-dir-move-to-goal-column "vc-dir" ())
;; vc-finish-logentry is typically called from a log-edit buffer (see
;; vc-start-logentry).
(defun vc-finish-logentry (&optional nocomment)
@ -740,8 +739,6 @@ the buffer contents as a comment."
(mapc
(lambda (file) (vc-resynch-buffer file t t))
log-fileset))
(when (vc-dispatcher-browsing)
(vc-dir-move-to-goal-column))
(run-hooks after-hook 'vc-finish-logentry-hook)))
(defun vc-dispatcher-browsing ()

4
lisp/vc/vc.el
View file

@ -1346,8 +1346,6 @@ For old-style locking-based version control systems, like RCS:
nil t)))))
(vc-call-backend backend 'create-repo))
(declare-function vc-dir-move-to-goal-column "vc-dir" ())
;;;###autoload
(defun vc-register (&optional vc-fileset comment)
"Register into a version control system.
@ -1398,8 +1396,6 @@ first backend that could register the file is used."
(vc-resynch-buffer file t t))
files)
(when (derived-mode-p 'vc-dir-mode)
(vc-dir-move-to-goal-column))
(message "Registering %s... done" files)))
(defun vc-register-with (backend)

12
lisp/wdired.el
View file

@ -461,10 +461,12 @@ non-nil means return old filename."
(defun wdired-do-renames (renames)
"Perform RENAMES in parallel."
(let ((residue ())
(progress nil)
(errors 0)
(overwrite (or (not wdired-confirm-overwrite) 1)))
(let* ((residue ())
(progress nil)
(errors 0)
(total (1- (length renames)))
(prep (make-progress-reporter "Renaming" 0 total))
(overwrite (or (not wdired-confirm-overwrite) 1)))
(while (or renames
;; We've done one round through the renames, we have found
;; some residue, but we also made some progress, so maybe
@ -472,6 +474,7 @@ non-nil means return old filename."
(prog1 (setq renames residue)
(setq progress nil)
(setq residue nil)))
(progress-reporter-update prep (- total (length renames)))
(let* ((rename (pop renames))
(file-new (cdr rename)))
(cond
@ -519,6 +522,7 @@ non-nil means return old filename."
(dired-log "Rename `%s' to `%s' failed:\n%s\n"
file-ori file-new
err)))))))))
(progress-reporter-done prep)
errors))
(defun wdired-create-parentdirs (file-new)

9
lisp/wid-edit.el
View file

@ -3161,6 +3161,15 @@ It reads a file name from an editable text field."
:completions (completion-table-case-fold
#'completion-file-name-table
(not read-file-name-completion-ignore-case))
:match (lambda (widget value)
(or (not (widget-get widget :must-match))
(file-exists-p value)))
:validate (lambda (widget)
(let ((value (widget-value widget)))
(unless (widget-apply widget :match value)
(widget-put widget
:error (format "File %s does not exist" value))
widget)))
:prompt-value 'widget-file-prompt-value
:format "%{%t%}: %v"
;; Doesn't work well with terminating newline.

18
m4/include_next.m4
View file

@ -1,4 +1,4 @@
# include_next.m4 serial 25
# include_next.m4 serial 26
dnl Copyright (C) 2006-2020 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@ -106,19 +106,21 @@ dnl We intentionally avoid using AC_LANG_SOURCE here.
AC_SUBST([INCLUDE_NEXT])
AC_SUBST([INCLUDE_NEXT_AS_FIRST_DIRECTIVE])
AC_SUBST([PRAGMA_SYSTEM_HEADER])
AC_CACHE_CHECK([whether system header files limit the line length],
[gl_cv_pragma_columns],
[dnl HP NonStop systems, which define __TANDEM, have this misfeature.
AC_EGREP_CPP([choke me],
dnl HP NonStop systems, which define __TANDEM, limit the line length
dnl after including some system header files.
AC_CACHE_CHECK([whether source code line length is unlimited],
[gl_cv_source_line_length_unlimited],
[AC_EGREP_CPP([choke me],
[
#ifdef __TANDEM
choke me
#endif
],
[gl_cv_pragma_columns=yes],
[gl_cv_pragma_columns=no])
[gl_cv_source_line_length_unlimited=no],
[gl_cv_source_line_length_unlimited=yes])
])
if test $gl_cv_pragma_columns = yes; then
if test $gl_cv_source_line_length_unlimited = no; then
PRAGMA_COLUMNS="#pragma COLUMNS 10000"
else
PRAGMA_COLUMNS=

18
m4/stdint.m4
View file

@ -1,4 +1,4 @@
# stdint.m4 serial 55
# stdint.m4 serial 56
dnl Copyright (C) 2001-2020 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@ -302,9 +302,10 @@ static const char *macro_values[] =
HAVE_C99_STDINT_H=1
dnl Now see whether the system <stdint.h> works without
dnl __STDC_CONSTANT_MACROS/__STDC_LIMIT_MACROS defined.
AC_CACHE_CHECK([whether stdint.h predates C++11],
[gl_cv_header_stdint_predates_cxx11_h],
[gl_cv_header_stdint_predates_cxx11_h=yes
dnl If not, there would be problems when stdint.h is included from C++.
AC_CACHE_CHECK([whether stdint.h works without ISO C predefines],
[gl_cv_header_stdint_without_STDC_macros],
[gl_cv_header_stdint_without_STDC_macros=no
AC_COMPILE_IFELSE([
AC_LANG_PROGRAM([[
#define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */
@ -315,13 +316,14 @@ gl_STDINT_INCLUDES
intmax_t im = INTMAX_MAX;
int32_t i32 = INT32_C (0x7fffffff);
]])],
[gl_cv_header_stdint_predates_cxx11_h=no])])
[gl_cv_header_stdint_without_STDC_macros=yes])
])
if test "$gl_cv_header_stdint_predates_cxx11_h" = yes; then
if test $gl_cv_header_stdint_without_STDC_macros = no; then
AC_DEFINE([__STDC_CONSTANT_MACROS], [1],
[Define to 1 if the system <stdint.h> predates C++11.])
[Define to 1 if the system <stdint.h> predates C++11.])
AC_DEFINE([__STDC_LIMIT_MACROS], [1],
[Define to 1 if the system <stdint.h> predates C++11.])
[Define to 1 if the system <stdint.h> predates C++11.])
fi
AC_CACHE_CHECK([whether stdint.h has UINTMAX_WIDTH etc.],
[gl_cv_header_stdint_width],

89
m4/string_h.m4
View file

@ -5,7 +5,7 @@
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
# serial 26
# serial 27
# Written by Paul Eggert.
@ -28,7 +28,7 @@ AC_DEFUN([gl_HEADER_STRING_H_BODY],
]],
[ffsl ffsll memmem mempcpy memrchr rawmemchr stpcpy stpncpy strchrnul
strdup strncat strndup strnlen strpbrk strsep strcasestr strtok_r
strerror_r sigabbrev_np sigdescr_np strsignal strverscmp])
strerror_r strerrorname_np sigabbrev_np sigdescr_np strsignal strverscmp])
AC_REQUIRE([AC_C_RESTRICT])
])
@ -44,47 +44,48 @@ AC_DEFUN([gl_STRING_MODULE_INDICATOR],
AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS],
[
GNULIB_EXPLICIT_BZERO=0; AC_SUBST([GNULIB_EXPLICIT_BZERO])
GNULIB_FFSL=0; AC_SUBST([GNULIB_FFSL])
GNULIB_FFSLL=0; AC_SUBST([GNULIB_FFSLL])
GNULIB_MEMCHR=0; AC_SUBST([GNULIB_MEMCHR])
GNULIB_MEMMEM=0; AC_SUBST([GNULIB_MEMMEM])
GNULIB_MEMPCPY=0; AC_SUBST([GNULIB_MEMPCPY])
GNULIB_MEMRCHR=0; AC_SUBST([GNULIB_MEMRCHR])
GNULIB_RAWMEMCHR=0; AC_SUBST([GNULIB_RAWMEMCHR])
GNULIB_STPCPY=0; AC_SUBST([GNULIB_STPCPY])
GNULIB_STPNCPY=0; AC_SUBST([GNULIB_STPNCPY])
GNULIB_STRCHRNUL=0; AC_SUBST([GNULIB_STRCHRNUL])
GNULIB_STRDUP=0; AC_SUBST([GNULIB_STRDUP])
GNULIB_STRNCAT=0; AC_SUBST([GNULIB_STRNCAT])
GNULIB_STRNDUP=0; AC_SUBST([GNULIB_STRNDUP])
GNULIB_STRNLEN=0; AC_SUBST([GNULIB_STRNLEN])
GNULIB_STRPBRK=0; AC_SUBST([GNULIB_STRPBRK])
GNULIB_STRSEP=0; AC_SUBST([GNULIB_STRSEP])
GNULIB_STRSTR=0; AC_SUBST([GNULIB_STRSTR])
GNULIB_STRCASESTR=0; AC_SUBST([GNULIB_STRCASESTR])
GNULIB_STRTOK_R=0; AC_SUBST([GNULIB_STRTOK_R])
GNULIB_MBSLEN=0; AC_SUBST([GNULIB_MBSLEN])
GNULIB_MBSNLEN=0; AC_SUBST([GNULIB_MBSNLEN])
GNULIB_MBSCHR=0; AC_SUBST([GNULIB_MBSCHR])
GNULIB_MBSRCHR=0; AC_SUBST([GNULIB_MBSRCHR])
GNULIB_MBSSTR=0; AC_SUBST([GNULIB_MBSSTR])
GNULIB_MBSCASECMP=0; AC_SUBST([GNULIB_MBSCASECMP])
GNULIB_MBSNCASECMP=0; AC_SUBST([GNULIB_MBSNCASECMP])
GNULIB_MBSPCASECMP=0; AC_SUBST([GNULIB_MBSPCASECMP])
GNULIB_MBSCASESTR=0; AC_SUBST([GNULIB_MBSCASESTR])
GNULIB_MBSCSPN=0; AC_SUBST([GNULIB_MBSCSPN])
GNULIB_MBSPBRK=0; AC_SUBST([GNULIB_MBSPBRK])
GNULIB_MBSSPN=0; AC_SUBST([GNULIB_MBSSPN])
GNULIB_MBSSEP=0; AC_SUBST([GNULIB_MBSSEP])
GNULIB_MBSTOK_R=0; AC_SUBST([GNULIB_MBSTOK_R])
GNULIB_STRERROR=0; AC_SUBST([GNULIB_STRERROR])
GNULIB_STRERROR_R=0; AC_SUBST([GNULIB_STRERROR_R])
GNULIB_SIGABBREV_NP=0;AC_SUBST([GNULIB_SIGABBREV_NP])
GNULIB_SIGDESCR_NP=0; AC_SUBST([GNULIB_SIGDESCR_NP])
GNULIB_STRSIGNAL=0; AC_SUBST([GNULIB_STRSIGNAL])
GNULIB_STRVERSCMP=0; AC_SUBST([GNULIB_STRVERSCMP])
HAVE_MBSLEN=0; AC_SUBST([HAVE_MBSLEN])
GNULIB_EXPLICIT_BZERO=0; AC_SUBST([GNULIB_EXPLICIT_BZERO])
GNULIB_FFSL=0; AC_SUBST([GNULIB_FFSL])
GNULIB_FFSLL=0; AC_SUBST([GNULIB_FFSLL])
GNULIB_MEMCHR=0; AC_SUBST([GNULIB_MEMCHR])
GNULIB_MEMMEM=0; AC_SUBST([GNULIB_MEMMEM])
GNULIB_MEMPCPY=0; AC_SUBST([GNULIB_MEMPCPY])
GNULIB_MEMRCHR=0; AC_SUBST([GNULIB_MEMRCHR])
GNULIB_RAWMEMCHR=0; AC_SUBST([GNULIB_RAWMEMCHR])
GNULIB_STPCPY=0; AC_SUBST([GNULIB_STPCPY])
GNULIB_STPNCPY=0; AC_SUBST([GNULIB_STPNCPY])
GNULIB_STRCHRNUL=0; AC_SUBST([GNULIB_STRCHRNUL])
GNULIB_STRDUP=0; AC_SUBST([GNULIB_STRDUP])
GNULIB_STRNCAT=0; AC_SUBST([GNULIB_STRNCAT])
GNULIB_STRNDUP=0; AC_SUBST([GNULIB_STRNDUP])
GNULIB_STRNLEN=0; AC_SUBST([GNULIB_STRNLEN])
GNULIB_STRPBRK=0; AC_SUBST([GNULIB_STRPBRK])
GNULIB_STRSEP=0; AC_SUBST([GNULIB_STRSEP])
GNULIB_STRSTR=0; AC_SUBST([GNULIB_STRSTR])
GNULIB_STRCASESTR=0; AC_SUBST([GNULIB_STRCASESTR])
GNULIB_STRTOK_R=0; AC_SUBST([GNULIB_STRTOK_R])
GNULIB_MBSLEN=0; AC_SUBST([GNULIB_MBSLEN])
GNULIB_MBSNLEN=0; AC_SUBST([GNULIB_MBSNLEN])
GNULIB_MBSCHR=0; AC_SUBST([GNULIB_MBSCHR])
GNULIB_MBSRCHR=0; AC_SUBST([GNULIB_MBSRCHR])
GNULIB_MBSSTR=0; AC_SUBST([GNULIB_MBSSTR])
GNULIB_MBSCASECMP=0; AC_SUBST([GNULIB_MBSCASECMP])
GNULIB_MBSNCASECMP=0; AC_SUBST([GNULIB_MBSNCASECMP])
GNULIB_MBSPCASECMP=0; AC_SUBST([GNULIB_MBSPCASECMP])
GNULIB_MBSCASESTR=0; AC_SUBST([GNULIB_MBSCASESTR])
GNULIB_MBSCSPN=0; AC_SUBST([GNULIB_MBSCSPN])
GNULIB_MBSPBRK=0; AC_SUBST([GNULIB_MBSPBRK])
GNULIB_MBSSPN=0; AC_SUBST([GNULIB_MBSSPN])
GNULIB_MBSSEP=0; AC_SUBST([GNULIB_MBSSEP])
GNULIB_MBSTOK_R=0; AC_SUBST([GNULIB_MBSTOK_R])
GNULIB_STRERROR=0; AC_SUBST([GNULIB_STRERROR])
GNULIB_STRERROR_R=0; AC_SUBST([GNULIB_STRERROR_R])
GNULIB_STRERRORNAME_NP=0; AC_SUBST([GNULIB_STRERRORNAME_NP])
GNULIB_SIGABBREV_NP=0; AC_SUBST([GNULIB_SIGABBREV_NP])
GNULIB_SIGDESCR_NP=0; AC_SUBST([GNULIB_SIGDESCR_NP])
GNULIB_STRSIGNAL=0; AC_SUBST([GNULIB_STRSIGNAL])
GNULIB_STRVERSCMP=0; AC_SUBST([GNULIB_STRVERSCMP])
HAVE_MBSLEN=0; AC_SUBST([HAVE_MBSLEN])
dnl Assume proper GNU behavior unless another module says otherwise.
HAVE_EXPLICIT_BZERO=1; AC_SUBST([HAVE_EXPLICIT_BZERO])
HAVE_FFSL=1; AC_SUBST([HAVE_FFSL])
@ -104,6 +105,7 @@ AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS],
HAVE_STRCASESTR=1; AC_SUBST([HAVE_STRCASESTR])
HAVE_DECL_STRTOK_R=1; AC_SUBST([HAVE_DECL_STRTOK_R])
HAVE_DECL_STRERROR_R=1; AC_SUBST([HAVE_DECL_STRERROR_R])
HAVE_STRERRORNAME_NP=1; AC_SUBST([HAVE_STRERRORNAME_NP])
HAVE_SIGABBREV_NP=1; AC_SUBST([HAVE_SIGABBREV_NP])
HAVE_SIGDESCR_NP=1; AC_SUBST([HAVE_SIGDESCR_NP])
HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL])
@ -121,6 +123,7 @@ AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS],
REPLACE_STRTOK_R=0; AC_SUBST([REPLACE_STRTOK_R])
REPLACE_STRERROR=0; AC_SUBST([REPLACE_STRERROR])
REPLACE_STRERROR_R=0; AC_SUBST([REPLACE_STRERROR_R])
REPLACE_STRERRORNAME_NP=0; AC_SUBST([REPLACE_STRERRORNAME_NP])
REPLACE_STRSIGNAL=0; AC_SUBST([REPLACE_STRSIGNAL])
UNDEFINE_STRTOK_R=0; AC_SUBST([UNDEFINE_STRTOK_R])
])

14
m4/time_rz.m4
View file

@ -13,12 +13,12 @@ AC_DEFUN([gl_TIME_RZ],
AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS])
AC_REQUIRE([AC_STRUCT_TIMEZONE])
# Mac OS X 10.6 loops forever with some time_t values.
# On Mac OS X 10.6, localtime loops forever with some time_t values.
# See Bug#27706, Bug#27736, and
# https://lists.gnu.org/r/bug-gnulib/2017-07/msg00142.html
AC_CACHE_CHECK([whether localtime loops forever near extrema],
[gl_cv_func_localtime_infloop_bug],
[gl_cv_func_localtime_infloop_bug=no
AC_CACHE_CHECK([whether localtime works even near extrema],
[gl_cv_func_localtime_works],
[gl_cv_func_localtime_works=yes
AC_RUN_IFELSE(
[AC_LANG_PROGRAM(
[[#include <stdlib.h>
@ -37,10 +37,10 @@ AC_DEFUN([gl_TIME_RZ],
return tm && tm->tm_isdst;
]])],
[(TZ=QQQ0 ./conftest$EXEEXT) >/dev/null 2>&1 ||
gl_cv_func_localtime_infloop_bug=yes],
gl_cv_func_localtime_works=no],
[],
[gl_cv_func_localtime_infloop_bug="guessing no"])])
if test "$gl_cv_func_localtime_infloop_bug" = yes; then
[gl_cv_func_localtime_works="guessing yes"])])
if test "$gl_cv_func_localtime_works" = no; then
AC_DEFINE([HAVE_LOCALTIME_INFLOOP_BUG], 1,
[Define if localtime-like functions can loop forever on
extreme arguments.])

249
src/alloc.c
View file

@ -4477,9 +4477,17 @@ live_string_holding (struct mem_node *m, void *p)
must not be on the free-list. */
if (0 <= offset && offset < sizeof b->strings)
{
struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0];
if (s->u.s.data)
return s;
ptrdiff_t off = offset % sizeof b->strings[0];
if (off == Lisp_String
|| off == 0
|| off == offsetof (struct Lisp_String, u.s.size_byte)
|| off == offsetof (struct Lisp_String, u.s.intervals)
|| off == offsetof (struct Lisp_String, u.s.data))
{
struct Lisp_String *s = p = cp -= off;
if (s->u.s.data)
return s;
}
}
return NULL;
}
@ -4509,9 +4517,15 @@ live_cons_holding (struct mem_node *m, void *p)
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index))
{
struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0];
if (!deadp (s->u.s.car))
return s;
ptrdiff_t off = offset % sizeof b->conses[0];
if (off == Lisp_Cons
|| off == 0
|| off == offsetof (struct Lisp_Cons, u.s.u.cdr))
{
struct Lisp_Cons *s = p = cp -= off;
if (!deadp (s->u.s.car))
return s;
}
}
return NULL;
}
@ -4542,9 +4556,23 @@ live_symbol_holding (struct mem_node *m, void *p)
&& (b != symbol_block
|| offset / sizeof b->symbols[0] < symbol_block_index))
{
struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0];
if (!deadp (s->u.s.function))
return s;
ptrdiff_t off = offset % sizeof b->symbols[0];
if (off == Lisp_Symbol
/* Plain '|| off == 0' would run afoul of GCC 10.2
-Wlogical-op, as Lisp_Symbol happens to be zero. */
|| (Lisp_Symbol != 0 && off == 0)
|| off == offsetof (struct Lisp_Symbol, u.s.name)
|| off == offsetof (struct Lisp_Symbol, u.s.val)
|| off == offsetof (struct Lisp_Symbol, u.s.function)
|| off == offsetof (struct Lisp_Symbol, u.s.plist)
|| off == offsetof (struct Lisp_Symbol, u.s.next))
{
struct Lisp_Symbol *s = p = cp -= off;
if (!deadp (s->u.s.function))
return s;
}
}
return NULL;
}
@ -4556,23 +4584,70 @@ live_symbol_p (struct mem_node *m, void *p)
}
/* Return true if P is a pointer to a live Lisp float on
the heap. M is a pointer to the mem_block for P. */
/* If P is a (possibly-tagged) pointer to a live Lisp_Float on the
heap, return the address of the Lisp_Float. Otherwise, return NULL.
M is a pointer to the mem_block for P. */
static bool
live_float_p (struct mem_node *m, void *p)
static struct Lisp_Float *
live_float_holding (struct mem_node *m, void *p)
{
eassert (m->type == MEM_TYPE_FLOAT);
struct float_block *b = m->start;
char *cp = p;
ptrdiff_t offset = cp - (char *) &b->floats[0];
/* P must point to the start of a Lisp_Float and not be
one of the unused cells in the current float block. */
return (0 <= offset && offset < sizeof b->floats
&& offset % sizeof b->floats[0] == 0
/* P must point to (or be a tagged pointer to) the start of a
Lisp_Float and not be one of the unused cells in the current
float block. */
if (0 <= offset && offset < sizeof b->floats)
{
int off = offset % sizeof b->floats[0];
if ((off == Lisp_Float || off == 0)
&& (b != float_block
|| offset / sizeof b->floats[0] < float_block_index));
|| offset / sizeof b->floats[0] < float_block_index))
{
p = cp - off;
return p;
}
}
return NULL;
}
static bool
live_float_p (struct mem_node *m, void *p)
{
return live_float_holding (m, p) == p;
}
/* Return VECTOR if P points within it, NULL otherwise. */
static struct Lisp_Vector *
live_vector_pointer (struct Lisp_Vector *vector, void *p)
{
void *vvector = vector;
char *cvector = vvector;
char *cp = p;
ptrdiff_t offset = cp - cvector;
return ((offset == Lisp_Vectorlike
|| offset == 0
|| (sizeof vector->header <= offset
&& offset < vector_nbytes (vector)
&& (! (vector->header.size & PSEUDOVECTOR_FLAG)
? (offsetof (struct Lisp_Vector, contents) <= offset
&& (((offset - offsetof (struct Lisp_Vector, contents))
% word_size)
== 0))
/* For non-bool-vector pseudovectors, treat any pointer
past the header as valid since it's too much of a pain
to write special-case code for every pseudovector. */
: (! PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR)
|| offset == offsetof (struct Lisp_Bool_Vector, size)
|| (offsetof (struct Lisp_Bool_Vector, data) <= offset
&& (((offset
- offsetof (struct Lisp_Bool_Vector, data))
% sizeof (bits_word))
== 0))))))
? vector : NULL);
}
/* If P is a pointer to a live, large vector-like object, return the object.
@ -4583,10 +4658,7 @@ static struct Lisp_Vector *
live_large_vector_holding (struct mem_node *m, void *p)
{
eassert (m->type == MEM_TYPE_VECTORLIKE);
struct Lisp_Vector *vp = p;
struct Lisp_Vector *vector = large_vector_vec (m->start);
struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
return vector <= vp && vp < next ? vector : NULL;
return live_vector_pointer (large_vector_vec (m->start), p);
}
static bool
@ -4616,7 +4688,7 @@ live_small_vector_holding (struct mem_node *m, void *p)
{
struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
return vector;
return live_vector_pointer (vector, vp);
vector = next;
}
return NULL;
@ -4628,97 +4700,6 @@ live_small_vector_p (struct mem_node *m, void *p)
return live_small_vector_holding (m, p) == p;
}
/* Mark OBJ if we can prove it's a Lisp_Object. */
static void
mark_maybe_object (Lisp_Object obj)
{
#if USE_VALGRIND
VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj));
#endif
int type_tag = XTYPE (obj);
intptr_t pointer_word_tag = LISP_WORD_TAG (type_tag), offset, ipo;
switch (type_tag)
{
case_Lisp_Int: case Lisp_Type_Unused0:
return;
case Lisp_Symbol:
offset = (intptr_t) lispsym;
break;
default:
offset = 0;
break;
}
INT_ADD_WRAPV ((intptr_t) XLP (obj), offset - pointer_word_tag, &ipo);
void *po = (void *) ipo;
/* If the pointer is in the dump image and the dump has a record
of the object starting at the place where the pointer points, we
definitely have an object. If the pointer is in the dump image
and the dump has no idea what the pointer is pointing at, we
definitely _don't_ have an object. */
if (pdumper_object_p (po))
{
/* Don't use pdumper_object_p_precise here! It doesn't check the
tag bits. OBJ here might be complete garbage, so we need to
verify both the pointer and the tag. */
if (pdumper_find_object_type (po) == type_tag)
mark_object (obj);
return;
}
struct mem_node *m = mem_find (po);
if (m != MEM_NIL)
{
bool mark_p = false;
switch (type_tag)
{
case Lisp_String:
mark_p = m->type == MEM_TYPE_STRING && live_string_p (m, po);
break;
case Lisp_Cons:
mark_p = m->type == MEM_TYPE_CONS && live_cons_p (m, po);
break;
case Lisp_Symbol:
mark_p = m->type == MEM_TYPE_SYMBOL && live_symbol_p (m, po);
break;
case Lisp_Float:
mark_p = m->type == MEM_TYPE_FLOAT && live_float_p (m, po);
break;
case Lisp_Vectorlike:
mark_p = (m->type == MEM_TYPE_VECTOR_BLOCK
? live_small_vector_p (m, po)
: (m->type == MEM_TYPE_VECTORLIKE
&& live_large_vector_p (m, po)));
break;
default:
eassume (false);
}
if (mark_p)
mark_object (obj);
}
}
void
mark_maybe_objects (Lisp_Object const *array, ptrdiff_t nelts)
{
for (Lisp_Object const *lim = array + nelts; array < lim; array++)
mark_maybe_object (*array);
}
/* If P points to Lisp data, mark that as live if it isn't already
marked. */
@ -4731,14 +4712,21 @@ mark_maybe_pointer (void *p)
VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
#endif
/* If the pointer is in the dump image and the dump has a record
of the object starting at the place where the pointer points, we
definitely have an object. If the pointer is in the dump image
and the dump has no idea what the pointer is pointing at, we
definitely _don't_ have an object. */
if (pdumper_object_p (p))
{
/* Don't use pdumper_object_p_precise here! It doesn't check the
tag bits. OBJ here might be complete garbage, so we need to
verify both the pointer and the tag. */
int type = pdumper_find_object_type (p);
if (pdumper_valid_object_type_p (type))
mark_object (type == Lisp_Symbol
? make_lisp_symbol (p)
: make_lisp_ptr (p, type));
/* See mark_maybe_object for why we can confidently return. */
return;
}
@ -4782,9 +4770,12 @@ mark_maybe_pointer (void *p)
break;
case MEM_TYPE_FLOAT:
if (! live_float_p (m, p))
return;
obj = make_lisp_ptr (p, Lisp_Float);
{
struct Lisp_Float *h = live_float_holding (m, p);
if (!h)
return;
obj = make_lisp_ptr (h, Lisp_Float);
}
break;
case MEM_TYPE_VECTORLIKE:
@ -4869,11 +4860,6 @@ mark_memory (void const *start, void const *end)
intptr_t ip;
INT_ADD_WRAPV ((intptr_t) p, (intptr_t) lispsym, &ip);
mark_maybe_pointer ((void *) ip);
verify (alignof (Lisp_Object) % GC_POINTER_ALIGNMENT == 0);
if (alignof (Lisp_Object) == GC_POINTER_ALIGNMENT
|| (uintptr_t) pp % alignof (Lisp_Object) == 0)
mark_maybe_object (*(Lisp_Object const *) pp);
}
}
@ -6281,7 +6267,6 @@ mark_vectorlike (union vectorlike_header *header)
{
struct Lisp_Vector *ptr = (struct Lisp_Vector *) header;
ptrdiff_t size = ptr->header.size;
ptrdiff_t i;
eassert (!vector_marked_p (ptr));
@ -6296,8 +6281,7 @@ mark_vectorlike (union vectorlike_header *header)
the number of Lisp_Object fields that we should trace.
The distinction is used e.g. by Lisp_Process which places extra
non-Lisp_Object fields at the end of the structure... */
for (i = 0; i < size; i++) /* ...and then mark its elements. */
mark_object (ptr->contents[i]);
mark_objects (ptr->contents, size);
}
/* Like mark_vectorlike but optimized for char-tables (and
@ -6396,8 +6380,7 @@ mark_face_cache (struct face_cache *c)
{
if (c)
{
int i, j;
for (i = 0; i < c->used; ++i)
for (int i = 0; i < c->used; i++)
{
struct face *face = FACE_FROM_ID_OR_NULL (c->f, i);
@ -6406,8 +6389,7 @@ mark_face_cache (struct face_cache *c)
if (face->font && !vectorlike_marked_p (&face->font->header))
mark_vectorlike (&face->font->header);
for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
mark_object (face->lface[j]);
mark_objects (face->lface, LFACE_VECTOR_SIZE);
}
}
}
@ -6520,6 +6502,13 @@ mark_hash_table (struct Lisp_Vector *ptr)
}
}
void
mark_objects (Lisp_Object *obj, ptrdiff_t n)
{
for (ptrdiff_t i = 0; i < n; i++)
mark_object (obj[i]);
}
/* Determine type of generic Lisp_Object and mark it accordingly.
This function implements a straightforward depth-first marking

18
src/dbusbind.c
View file

@ -1261,6 +1261,7 @@ usage: (dbus-message-internal &rest REST) */)
Lisp_Object path = Qnil;
Lisp_Object interface = Qnil;
Lisp_Object member = Qnil;
Lisp_Object error_name = Qnil;
Lisp_Object result;
DBusConnection *connection;
DBusMessage *dmessage;
@ -1298,7 +1299,9 @@ usage: (dbus-message-internal &rest REST) */)
else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
{
serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
count = 4;
if (mtype == DBUS_MESSAGE_TYPE_ERROR)
error_name = args[4];
count = (mtype == DBUS_MESSAGE_TYPE_ERROR) ? 5 : 4;
}
/* Check parameters. */
@ -1341,13 +1344,22 @@ usage: (dbus-message-internal &rest REST) */)
XD_OBJECT_TO_STRING (interface),
XD_OBJECT_TO_STRING (member));
break;
default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
case DBUS_MESSAGE_TYPE_METHOD_RETURN:
ui_serial = serial;
XD_DEBUG_MESSAGE ("%s %s %s %u",
XD_MESSAGE_TYPE_TO_STRING (mtype),
XD_OBJECT_TO_STRING (bus),
XD_OBJECT_TO_STRING (service),
ui_serial);
break;
default: /* DBUS_MESSAGE_TYPE_ERROR */
ui_serial = serial;
XD_DEBUG_MESSAGE ("%s %s %s %u %s",
XD_MESSAGE_TYPE_TO_STRING (mtype),
XD_OBJECT_TO_STRING (bus),
XD_OBJECT_TO_STRING (service),
ui_serial,
XD_OBJECT_TO_STRING (error_name));
}
/* Retrieve bus address. */
@ -1406,7 +1418,7 @@ usage: (dbus-message-internal &rest REST) */)
XD_SIGNAL1 (build_string ("Unable to create a return message"));
if ((mtype == DBUS_MESSAGE_TYPE_ERROR)
&& (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED)))
&& (!dbus_message_set_error_name (dmessage, SSDATA (error_name))))
XD_SIGNAL1 (build_string ("Unable to create an error message"));
}

5
src/eval.c
View file

@ -4040,7 +4040,7 @@ mark_specpdl (union specbinding *first, union specbinding *ptr)
break;
case SPECPDL_UNWIND_ARRAY:
mark_maybe_objects (pdl->unwind_array.array, pdl->unwind_array.nelts);
mark_objects (pdl->unwind_array.array, pdl->unwind_array.nelts);
break;
case SPECPDL_UNWIND_EXCURSION:
@ -4054,8 +4054,7 @@ mark_specpdl (union specbinding *first, union specbinding *ptr)
mark_object (backtrace_function (pdl));
if (nargs == UNEVALLED)
nargs = 1;
while (nargs--)
mark_object (backtrace_args (pdl)[nargs]);
mark_objects (backtrace_args (pdl), nargs);
}
break;

86
src/fileio.c
View file

@ -827,9 +827,9 @@ the root directory. */)
ptrdiff_t tlen;
#ifdef DOS_NT
int drive = 0;
bool collapse_newdir = true;
bool is_escaped = 0;
#endif /* DOS_NT */
bool collapse_newdir = true;
ptrdiff_t length, nbytes;
Lisp_Object handler, result, handled_name;
bool multibyte;
@ -947,6 +947,22 @@ the root directory. */)
)
{
default_directory = Fexpand_file_name (default_directory, Qnil);
/* The above expansion might have produced a remote file name,
so give the handlers one last chance to DTRT. This can
happen when both NAME and DEFAULT-DIRECTORY arguments are
relative file names, and the buffer's default-directory is
remote. */
handler = Ffind_file_name_handler (default_directory,
Qexpand_file_name);
if (!NILP (handler))
{
handled_name = call3 (handler, Qexpand_file_name,
name, default_directory);
if (STRINGP (handled_name))
return handled_name;
error ("Invalid handler in `file-name-handler-alist'");
}
}
}
multibyte = STRING_MULTIBYTE (name);
@ -1065,7 +1081,7 @@ the root directory. */)
#endif /* WINDOWSNT */
#endif /* DOS_NT */
/* If nm is absolute, look for "/./" or "/../" or "//" sequences; if
/* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
none are found, we can probably return right away. We will avoid
allocating a new string if name is already fully expanded. */
if (
@ -1183,7 +1199,9 @@ the root directory. */)
newdir = SSDATA (hdir);
newdirlim = newdir + SBYTES (hdir);
}
#ifdef DOS_NT
collapse_newdir = false;
#endif
}
else /* ~user/filename */
{
@ -1203,7 +1221,9 @@ the root directory. */)
while (*++nm && !IS_DIRECTORY_SEP (*nm))
continue;
#ifdef DOS_NT
collapse_newdir = false;
#endif
}
/* If we don't find a user of that name, leave the name
@ -1370,15 +1390,12 @@ the root directory. */)
}
#endif /* DOS_NT */
length = newdirlim - newdir;
#ifdef DOS_NT
/* Ignore any slash at the end of newdir, unless newdir is
just "/" or "//". */
length = newdirlim - newdir;
while (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
&& ! (length == 2 && IS_DIRECTORY_SEP (newdir[0])))
length--;
#endif
/* Now concatenate the directory and name to new space in the stack frame. */
tlen = length + file_name_as_directory_slop + (nmlim - nm) + 1;
@ -1392,16 +1409,12 @@ the root directory. */)
#else /* not DOS_NT */
target = SAFE_ALLOCA (tlen);
#endif /* not DOS_NT */
*target = 0;
nbytes = 0;
if (newdir)
{
#ifndef DOS_NT
bool treat_as_absolute = !collapse_newdir;
#else
bool treat_as_absolute = !nm[0] || IS_DIRECTORY_SEP (nm[0]);
#endif
if (treat_as_absolute)
if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0]))
{
#ifdef DOS_NT
/* If newdir is effectively "C:/", then the drive letter will have
@ -1413,23 +1426,13 @@ the root directory. */)
&& newdir[1] == '\0'))
#endif
{
/* With ~ or ~user, leave NEWDIR as-is to avoid transforming
it from a symlink (or a regular file!) into a directory. */
memcpy (target, newdir, length);
target[length] = 0;
nbytes = length;
}
}
else
nbytes = file_name_as_directory (target, newdir, length, multibyte);
#ifndef DOS_NT
/* If TARGET ends in a directory separator, omit leading
directory separators from NM so that concatenating a TARGET "/"
to an NM "/foo" does not result in the incorrect "//foo". */
if (nbytes && IS_DIRECTORY_SEP (target[nbytes - 1]))
while (IS_DIRECTORY_SEP (nm[0]))
nm++;
#endif
}
memcpy (target + nbytes, nm, nmlim - nm + 1);
@ -1446,20 +1449,6 @@ the root directory. */)
{
*o++ = *p++;
}
#ifndef DOS_NT
else if (p[1] == '.' && IS_DIRECTORY_SEP (p[2]))
{
/* Replace "/./" with "/". */
p += 2;
}
else if (p[1] == '.' && !p[2])
{
/* At the end of the file name, replace "/." with "/".
The trailing "/" is for symlinks. */
*o++ = *p;
p += 2;
}
#else
else if (p[1] == '.'
&& (IS_DIRECTORY_SEP (p[2])
|| p[2] == 0))
@ -1470,7 +1459,6 @@ the root directory. */)
*o++ = *p;
p += 2;
}
#endif
else if (p[1] == '.' && p[2] == '.'
/* `/../' is the "superroot" on certain file systems.
Turned off on DOS_NT systems because they have no
@ -1484,35 +1472,21 @@ the root directory. */)
#endif
&& (IS_DIRECTORY_SEP (p[3]) || p[3] == 0))
{
#ifndef DOS_NT
while (o != target)
{
o--;
if (IS_DIRECTORY_SEP (*o))
{
/* Keep "/" at the end of the name, for symlinks. */
o += p[3] == 0;
break;
}
}
#else
# ifdef WINDOWSNT
#ifdef WINDOWSNT
char *prev_o = o;
# endif
#endif
while (o != target && (--o, !IS_DIRECTORY_SEP (*o)))
continue;
# ifdef WINDOWSNT
#ifdef WINDOWSNT
/* Don't go below server level in UNC filenames. */
if (o == target + 1 && IS_DIRECTORY_SEP (*o)
&& IS_DIRECTORY_SEP (*target))
o = prev_o;
else
# endif
#endif
/* Keep initial / only if this is the whole name. */
if (o == target && IS_ANY_SEP (*o) && p[3] == 0)
++o;
#endif
p += 3;
}
else if (IS_DIRECTORY_SEP (p[1])

Some files were not shown because too many files have changed in this diff Show more