[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/etags-regen 1daad17 2/8: Merge branch 'master' into scratch/etag
|
From: |
Dmitry Gutov |
|
Subject: |
scratch/etags-regen 1daad17 2/8: Merge branch 'master' into scratch/etags-regen |
|
Date: |
Sun, 7 Feb 2021 21:11:59 -0500 (EST) |
branch: scratch/etags-regen
commit 1daad1784f991d268515b1fa62b7787fe12bb89f
Merge: 8d00e2f 4ca808e
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: Dmitry Gutov <dgutov@yandex.ru>
Merge branch 'master' into scratch/etags-regen
---
doc/lispref/processes.texi | 27 ++-
etc/HELLO | 12 +-
etc/NEWS | 4 +
lisp/cedet/ede/base.el | 5 +-
lisp/cedet/ede/proj.el | 2 +-
lisp/epa.el | 4 +-
lisp/gnus/gnus-agent.el | 383 +++++++++++++-----------------------------
lisp/gnus/gnus-async.el | 9 +-
lisp/gnus/gnus-cache.el | 126 ++++----------
lisp/gnus/gnus-cloud.el | 16 +-
lisp/gnus/gnus-sum.el | 65 ++++---
lisp/gnus/gnus.el | 9 +-
lisp/gnus/nnvirtual.el | 172 +++++--------------
lisp/ibuf-ext.el | 16 +-
lisp/ibuffer.el | 9 +-
lisp/international/fontset.el | 1 +
lisp/language/cham.el | 3 +-
lisp/leim/quail/cham.el | 116 +++++++++++++
lisp/obsolete/nnir.el | 1 -
lisp/progmodes/xref.el | 11 +-
lisp/replace.el | 11 +-
src/nsselect.m | 15 +-
src/nsterm.h | 9 +
src/nsterm.m | 21 ++-
src/process.c | 9 +
test/Makefile.in | 20 ++-
test/README | 9 +-
test/infra/gitlab-ci.yml | 77 ++++-----
test/lisp/time-stamp-tests.el | 127 ++++++++------
test/src/process-tests.el | 115 +++++++++++++
test/src/xdisp-tests.el | 33 ++--
31 files changed, 749 insertions(+), 688 deletions(-)
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 535cebe..6dedaa3 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -729,7 +729,9 @@ coding systems (@pxref{Default Coding Systems}). On the
other hand,
it will use @var{query-flag} as its query-on-exit flag (@pxref{Query
Before Exit}). It will be associated with the @var{stderr} buffer
(@pxref{Process Buffers}) and send its output (which is the standard
-error of the main process) there.
+error of the main process) there. To get the process object for the
+standard error process, pass the @var{stderr} buffer to
+@code{get-buffer-process}.
If @var{stderr} is a pipe process, Emacs will use it as standard error
process for the new process.
@@ -1942,6 +1944,29 @@ code:
(while (accept-process-output stderr-process))
@end example
+If you passed a buffer to the @var{stderr} argument of
+@code{make-process}, you still have to wait for the standard error
+process, like so:
+
+@example
+(let* ((stdout (generate-new-buffer "stdout"))
+ (stderr (generate-new-buffer "stderr"))
+ (process (make-process :name "test"
+ :command '("my-program")
+ :buffer stdout
+ :stderr stderr))
+ (stderr-process (get-buffer-process stderr)))
+ (unless (and process stderr-process)
+ (error "Process unexpectedly nil"))
+ (while (accept-process-output process))
+ (while (accept-process-output stderr-process)))
+@end example
+
+@noindent
+Only when both @code{accept-process-output} forms return @code{nil},
+you can be sure that the process has exited and Emacs has read all its
+output.
+
Reading pending standard error from a process running on a remote host
is not possible this way.
diff --git a/etc/HELLO b/etc/HELLO
index 9a1f5d3..0cebb2b 100644
--- a/etc/HELLO
+++ b/etc/HELLO
@@ -30,22 +30,16 @@ Bengali (বাংলা) নমস্কার
Braille ⠓⠑⠇⠇⠕
Burmese (မြန်မာ) မင်္ဂလာပါ
C printf ("Hello, world!\n");
-Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨰꨁ
-
+Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨁꨰ
Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ
Comanche /kəˈmæntʃiː/ Haa marʉ́awe
-
Cree (ᓀᐦᐃᔭᐍᐏᐣ) ᑕᓂᓯ / ᐙᒋᔮ
-
Czech (čeština) Dobrý den
Danish (dansk) Hej / Goddag / Halløj
Dutch (Nederlands) Hallo / Dag
Efik /ˈɛfɪk/ Mɔkɔm
-
Egyptian Hieroglyphs (𓂋𓏤𓈖𓆎𓅓𓏏𓊖) 𓅓𓊵𓏏𓊪, 𓇍𓇋𓂻𓍘𓇋
-
Emacs emacs --no-splash -f view-hello-file
-
Emoji 👋
English /ˈɪŋɡlɪʃ/ Hello
Esperanto Saluton (Eĥoŝanĝo ĉiuĵaŭde)
@@ -61,7 +55,6 @@ Hebrew (עִבְרִית) שָׁלוֹם
Hungarian (magyar) Szép jó napot!
Hindi (हिंदी) नमस्ते / नमस्कार ।
Inuktitut (ᐃᓄᒃᑎᑐᑦ) ᐊᐃ
-
Italian (italiano) Ciao / Buon giorno
Javanese (ꦧꦱꦗꦮꦶ) console.log("ꦲꦭꦺꦴ");
Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ
@@ -69,7 +62,6 @@ Khmer (ភាសាខ្មែរ) ជំរាបសួរ
Lao (ພາສາລາວ) ສະບາຍດີ / ຂໍໃຫ້ໂຊກດີ
Malayalam (മലയാളം) നമസ്കാരം
Maldivian (ދިވެހި) އައްސަލާމު ޢަލައިކުމް / ކިހިނެހް؟
-
Maltese (il-Malti) Bonġu / Saħħa
Mathematics ∀ p ∈ world • hello p □
Mongolian (монгол хэл) Сайн байна уу?
@@ -85,7 +77,6 @@ Swedish (svenska) Hej / Goddag / Hallå
Tamil (தமிழ்) வணக்கம்
Telugu (తెలుగు) నమస్కారం
TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ
-
Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ
Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎
Tigrigna (ትግርኛ) ሰላማት
@@ -99,7 +90,6 @@ Vietnamese (tiếng Việt) Chào bạn
</x-charset><x-charset><param>chinese-gb2312</param>Chinese (中文,普通话,汉语)
你好
</x-charset><x-charset><param>chinese-big5-1</param>Cantonese (粵語,廣東話) 早晨, 你好
</x-charset><x-charset><param>korean-ksc5601</param>Korean (한글) 안녕하세요 /
안녕하십니까
-
</x-charset>
diff --git a/etc/NEWS b/etc/NEWS
index 359d308..d632283 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -827,6 +827,10 @@ so e.g. like 'C-x 8 [' inserts a left single quotation
mark,
Added a new Mozhi scheme. The inapplicable ITRANS scheme is now
deprecated. Errors in the Inscript method were corrected.
+---
+*** New input method 'cham'.
+There's also a Cham greeting in 'etc/HELLO'.
+
** Ispell
+++
diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el
index 7799746..810d6ef 100644
--- a/lisp/cedet/ede/base.el
+++ b/lisp/cedet/ede/base.el
@@ -160,16 +160,13 @@ and querying them will cause the actual project to get
loaded.")
;; Projects can also affect how EDE works, by changing what appears in
;; the EDE menu, or how some keys are bound.
;;
-(unless (fboundp 'ede-target-list-p)
- (cl-deftype ede-target-list () '(list-of ede-target)))
-
(defclass ede-project (ede-project-placeholder)
((subproj :initform nil
:type list
:documentation "Sub projects controlled by this project.
For Automake based projects, each directory is treated as a project.")
(targets :initarg :targets
- :type ede-target-list
+ :type (list-of ede-target)
:custom (repeat (object :objectcreatefcn ede-new-target-custom))
:label "Local Targets"
:group (targets)
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el
index 59628eb..4af8b41 100644
--- a/lisp/cedet/ede/proj.el
+++ b/lisp/cedet/ede/proj.el
@@ -184,7 +184,7 @@ Target variables are always renamed such as foo_CFLAGS,
then included into
commands where the variable would usually appear.")
(rules :initarg :rules
:initform nil
- :type list
+ :type (list-of ede-makefile-rule)
:custom (repeat (object :objecttype ede-makefile-rule))
:label "Additional Rules"
:group (make)
diff --git a/lisp/epa.el b/lisp/epa.el
index db2b127..197cd92 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -359,8 +359,8 @@ DOC is documentation text to insert at the start."
;; Find the end of the documentation text at the start.
;; Set POINT to where it ends, or nil if ends at eob.
- (unless (get-text-property point 'epa-list-keys)
- (setq point (next-single-property-change point 'epa-list-keys)))
+ (unless (get-text-property point 'epa-key)
+ (setq point (next-single-property-change point 'epa-key)))
;; If caller specified documentation text for that, replace the old
;; documentation text (if any) with what was specified.
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index 56640ea..6866230 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -1789,6 +1789,7 @@ variables. Returns the first non-nil value found."
. gnus-agent-enable-expiration)
(agent-predicate . gnus-agent-predicate)))))))
+;; FIXME: This looks an awful lot like `gnus-agent-retrieve-headers'.
(defun gnus-agent-fetch-headers (group)
"Fetch interesting headers into the agent. The group's overview
file will be updated to include the headers while a list of available
@@ -1810,10 +1811,9 @@ article numbers will be returned."
(cdr active))))
(gnus-uncompress-range (gnus-active group)))
(gnus-list-of-unread-articles group)))
- (gnus-decode-encoded-word-function 'identity)
- (gnus-decode-encoded-address-function 'identity)
(file (gnus-agent-article-name ".overview" group))
- (file-name-coding-system nnmail-pathname-coding-system))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ headers fetched-headers)
(unless fetch-all
;; Add articles with marks to the list of article headers we want to
@@ -1824,7 +1824,7 @@ article numbers will be returned."
(dolist (arts (gnus-info-marks (gnus-get-info group)))
(unless (memq (car arts) '(seen recent killed cache))
(setq articles (gnus-range-add articles (cdr arts)))))
- (setq articles (sort (gnus-uncompress-sequence articles) '<)))
+ (setq articles (sort (gnus-uncompress-range articles) '<)))
;; At this point, I have the list of articles to consider for
;; fetching. This is the list that I'll return to my caller. Some
@@ -1867,38 +1867,52 @@ article numbers will be returned."
10 "gnus-agent-fetch-headers: undownloaded articles are `%s'"
(gnus-compress-sequence articles t)))
- (with-current-buffer nntp-server-buffer
- (if articles
- (progn
- (gnus-message 8 "Fetching headers for %s..." group)
-
- ;; Fetch them.
- (gnus-make-directory (nnheader-translate-file-chars
- (file-name-directory file) t))
-
- (unless (eq 'nov (gnus-retrieve-headers articles group))
- (nnvirtual-convert-headers))
- (gnus-agent-check-overview-buffer)
- ;; Move these headers to the overview buffer so that
- ;; gnus-agent-braid-nov can merge them with the contents
- ;; of FILE.
- (copy-to-buffer
- gnus-agent-overview-buffer (point-min) (point-max))
- ;; NOTE: Call g-a-brand-nov even when the file does not
- ;; exist. As a minimum, it will validate the article
- ;; numbers already in the buffer.
- (gnus-agent-braid-nov articles file)
- (let ((coding-system-for-write
- gnus-agent-file-coding-system))
- (gnus-agent-check-overview-buffer)
- (write-region (point-min) (point-max) file nil 'silent))
- (gnus-agent-update-view-total-fetched-for group t)
- (gnus-agent-save-alist group articles nil)
- articles)
- (ignore-errors
- (erase-buffer)
- (nnheader-insert-file-contents file)))))
- articles))
+ ;; Parse known headers from FILE.
+ (if (file-exists-p file)
+ (with-current-buffer gnus-agent-overview-buffer
+ (erase-buffer)
+ (let ((nnheader-file-coding-system
+ gnus-agent-file-coding-system))
+ (nnheader-insert-nov-file file (car articles))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (insert-buffer-substring gnus-agent-overview-buffer)
+ (setq headers
+ (gnus-get-newsgroup-headers-xover
+ articles nil (buffer-local-value
+ 'gnus-newsgroup-dependencies
+ gnus-summary-buffer)
+ gnus-newsgroup-name)))))
+ (gnus-make-directory (nnheader-translate-file-chars
+ (file-name-directory file) t)))
+
+ ;; Fetch our new headers.
+ (gnus-message 8 "Fetching headers for %s..." group)
+ (if articles
+ (setq fetched-headers (gnus-fetch-headers articles)))
+
+ ;; Merge two sets of headers.
+ (setq headers
+ (if (and headers fetched-headers)
+ (delete-dups
+ (sort (append headers (copy-sequence fetched-headers))
+ (lambda (l r)
+ (< (mail-header-number l)
+ (mail-header-number r)))))
+ (or headers fetched-headers)))
+
+ ;; Save the new set of headers to FILE.
+ (let ((coding-system-for-write
+ gnus-agent-file-coding-system))
+ (with-current-buffer gnus-agent-overview-buffer
+ (goto-char (point-max))
+ (mapc #'nnheader-insert-nov fetched-headers)
+ (sort-numeric-fields 1 (point-min) (point-max))
+ (gnus-agent-check-overview-buffer)
+ (write-region (point-min) (point-max) file nil 'silent))
+ (gnus-agent-update-view-total-fetched-for group t)
+ (gnus-agent-save-alist group articles nil)))
+ headers))
(defsubst gnus-agent-read-article-number ()
"Read the article number at point.
@@ -1924,96 +1938,6 @@ Return nil when a valid article number can not be read."
(set-buffer nntp-server-buffer)
(insert-buffer-substring gnus-agent-overview-buffer b e))))
-(defun gnus-agent-braid-nov (articles file)
- "Merge agent overview data with given file.
-Takes unvalidated headers for ARTICLES from
-`gnus-agent-overview-buffer' and validated headers from the given
-FILE and places the combined valid headers into
-`nntp-server-buffer'. This function can be used, when file
-doesn't exist, to valid the overview buffer."
- (let (start last)
- (set-buffer gnus-agent-overview-buffer)
- (goto-char (point-min))
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (when (file-exists-p file)
- (nnheader-insert-file-contents file))
- (goto-char (point-max))
- (forward-line -1)
-
- (unless (or (= (point-min) (point-max))
- (< (setq last (read (current-buffer))) (car articles)))
- ;; Old and new overlap -- We do it the hard way.
- (when (nnheader-find-nov-line (car articles))
- ;; Replacing existing NOV entry
- (delete-region (point) (progn (forward-line 1) (point))))
- (gnus-agent-copy-nov-line (pop articles))
-
- (ignore-errors
- (while articles
- (while (let ((art (read (current-buffer))))
- (cond ((< art (car articles))
- (forward-line 1)
- t)
- ((= art (car articles))
- (beginning-of-line)
- (delete-region
- (point) (progn (forward-line 1) (point)))
- nil)
- (t
- (beginning-of-line)
- nil))))
-
- (gnus-agent-copy-nov-line (pop articles)))))
-
- (goto-char (point-max))
-
- ;; Append the remaining lines
- (when articles
- (when last
- (set-buffer gnus-agent-overview-buffer)
- (setq start (point))
- (set-buffer nntp-server-buffer))
-
- (let ((p (point)))
- (insert-buffer-substring gnus-agent-overview-buffer start)
- (goto-char p))
-
- (setq last (or last -134217728))
- (while (catch 'problems
- (let (sort art)
- (while (not (eobp))
- (setq art (gnus-agent-read-article-number))
- (cond ((not art)
- ;; Bad art num - delete this line
- (beginning-of-line)
- (delete-region (point) (progn (forward-line 1)
(point))))
- ((< art last)
- ;; Art num out of order - enable sort
- (setq sort t)
- (forward-line 1))
- ((= art last)
- ;; Bad repeat of art number - delete this line
- (beginning-of-line)
- (delete-region (point) (progn (forward-line 1)
(point))))
- (t
- ;; Good art num
- (setq last art)
- (forward-line 1))))
- (when sort
- ;; something is seriously wrong as we simply shouldn't see
out-of-order data.
- ;; First, we'll fix the sort.
- (sort-numeric-fields 1 (point-min) (point-max))
-
- ;; but now we have to consider that we may have duplicate
rows...
- ;; so reset to beginning of file
- (goto-char (point-min))
- (setq last -134217728)
-
- ;; and throw a code that restarts this scan
- (throw 'problems t))
- nil))))))
-
;; Keeps the compiler from warning about the free variable in
;; gnus-agent-read-agentview.
(defvar gnus-agent-read-agentview)
@@ -2386,10 +2310,9 @@ modified) original contents, they are first saved to
their own file."
(gnus-orphan-score gnus-orphan-score)
;; Maybe some other gnus-summary local variables should also
;; be put here.
-
+ fetched-headers
gnus-headers
gnus-score
- articles
predicate info marks
)
(unless (gnus-check-group group)
@@ -2410,38 +2333,35 @@ modified) original contents, they are first saved to
their own file."
(setq info (gnus-get-info group)))))))
(when arts
(setq marked-articles (nconc (gnus-uncompress-range arts)
- marked-articles))
- ))))
+ marked-articles))))))
(setq marked-articles (sort marked-articles '<))
- ;; Fetch any new articles from the server
- (setq articles (gnus-agent-fetch-headers group))
+ (setq gnus-newsgroup-dependencies
+ (or gnus-newsgroup-dependencies
+ (gnus-make-hashtable)))
- ;; Merge new articles with marked
- (setq articles (sort (append marked-articles articles) '<))
+ ;; Fetch headers for any new articles from the server.
+ (setq fetched-headers (gnus-agent-fetch-headers group))
- (when articles
- ;; Parse them and see which articles we want to fetch.
- (setq gnus-newsgroup-dependencies
- (or gnus-newsgroup-dependencies
- (gnus-make-hashtable (length articles))))
+ (when fetched-headers
(setq gnus-newsgroup-headers
- (or gnus-newsgroup-headers
- (gnus-get-newsgroup-headers-xover articles nil nil
- group)))
- ;; `gnus-agent-overview-buffer' may be killed for
- ;; timeout reason. If so, recreate it.
+ (or gnus-newsgroup-headers
+ fetched-headers)))
+ (when marked-articles
+ ;; `gnus-agent-overview-buffer' may be killed for timeout
+ ;; reason. If so, recreate it.
(gnus-agent-create-buffer)
(setq predicate
- (gnus-get-predicate
- (gnus-agent-find-parameter group 'agent-predicate)))
+ (gnus-get-predicate
+ (gnus-agent-find-parameter group 'agent-predicate)))
+
+ ;; If the selection predicate requires scoring, score each header.
- ;; If the selection predicate requires scoring, score each header
(unless (memq predicate '(gnus-agent-true gnus-agent-false))
(let ((score-param
(gnus-agent-find-parameter group 'agent-score-file)))
- ;; Translate score-param into real one
+ ;; Translate score-param into real one.
(cond
((not score-param))
((eq score-param 'file)
@@ -3661,11 +3581,9 @@ has been fetched."
(defun gnus-agent-retrieve-headers (articles group &optional fetch-old)
(save-excursion
(gnus-agent-create-buffer)
- (let ((gnus-decode-encoded-word-function 'identity)
- (gnus-decode-encoded-address-function 'identity)
- (file (gnus-agent-article-name ".overview" group))
- uncached-articles
- (file-name-coding-system nnmail-pathname-coding-system))
+ (let ((file (gnus-agent-article-name ".overview" group))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ uncached-articles headers fetched-headers)
(gnus-make-directory (nnheader-translate-file-chars
(file-name-directory file) t))
@@ -3676,122 +3594,63 @@ has been fetched."
1)
(car (last articles))))))
- ;; Populate temp buffer with known headers
+ ;; See if we've got cached headers for ARTICLES and put them in
+ ;; HEADERS. Articles with no cached headers go in
+ ;; UNCACHED-ARTICLES to be fetched from the server.
(when (file-exists-p file)
(with-current-buffer gnus-agent-overview-buffer
(erase-buffer)
(let ((nnheader-file-coding-system
gnus-agent-file-coding-system))
- (nnheader-insert-nov-file file (car articles)))))
-
- (if (setq uncached-articles (gnus-agent-uncached-articles articles group
- t))
- (progn
- ;; Populate nntp-server-buffer with uncached headers
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent
- (gnus-retrieve-headers
- uncached-articles group))))
- (nnvirtual-convert-headers))
- ((eq 'nntp (car gnus-current-select-method))
- ;; The author of gnus-get-newsgroup-headers-xover
- ;; reports that the XOVER command is commonly
- ;; unreliable. The problem is that recently
- ;; posted articles may not be entered into the
- ;; NOV database in time to respond to my XOVER
- ;; query.
- ;;
- ;; I'm going to use his assumption that the NOV
- ;; database is updated in order of ascending
- ;; article ID. Therefore, a response containing
- ;; article ID N implies that all articles from 1
- ;; to N-1 are up-to-date. Therefore, missing
- ;; articles in that range have expired.
-
- (set-buffer nntp-server-buffer)
- (let* ((fetched-articles (list nil))
- (tail-fetched-articles fetched-articles)
- (min (car articles))
- (max (car (last articles))))
-
- ;; Get the list of articles that were fetched
- (goto-char (point-min))
- (let ((pm (point-max))
- art)
- (while (< (point) pm)
- (when (setq art (gnus-agent-read-article-number))
- (gnus-agent-append-to-list tail-fetched-articles
art))
- (forward-line 1)))
-
- ;; Clip this list to the headers that will
- ;; actually be returned
- (setq fetched-articles (gnus-list-range-intersection
- (cdr fetched-articles)
- (cons min max)))
-
- ;; Clip the uncached articles list to exclude
- ;; IDs after the last FETCHED header. The
- ;; excluded IDs may be fetchable using HEAD.
- (if (car tail-fetched-articles)
- (setq uncached-articles
- (gnus-list-range-intersection
- uncached-articles
- (cons (car uncached-articles)
- (car tail-fetched-articles)))))
-
- ;; Create the list of articles that were
- ;; "successfully" fetched. Success, in this
- ;; case, means that the ID should not be
- ;; fetched again. In the case of an expired
- ;; article, the header will not be fetched.
- (setq uncached-articles
- (gnus-sorted-nunion fetched-articles
- uncached-articles))
- )))
-
- ;; Erase the temp buffer
- (set-buffer gnus-agent-overview-buffer)
- (erase-buffer)
-
- ;; Copy the nntp-server-buffer to the temp buffer
- (set-buffer nntp-server-buffer)
- (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
-
- ;; Merge the temp buffer with the known headers (found on
- ;; disk in FILE) into the nntp-server-buffer
- (when uncached-articles
- (gnus-agent-braid-nov uncached-articles file))
-
- ;; Save the new set of known headers to FILE
- (set-buffer nntp-server-buffer)
+ (nnheader-insert-nov-file file (car articles))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (insert-buffer-substring gnus-agent-overview-buffer)
+ (setq headers
+ (gnus-get-newsgroup-headers-xover
+ articles nil (buffer-local-value
+ 'gnus-newsgroup-dependencies
+ gnus-summary-buffer)
+ gnus-newsgroup-name))))))
+
+ (setq uncached-articles
+ (gnus-agent-uncached-articles articles group t))
+
+ (when uncached-articles
+ (let ((gnus-newsgroup-name group)
+ gnus-agent) ; Prevent loop.
+ ;; Fetch additional headers for the uncached articles.
+ (setq fetched-headers (gnus-fetch-headers uncached-articles))
+ ;; Merge headers we got from the overview file with our
+ ;; newly-fetched headers.
+ (when fetched-headers
+ (setq headers
+ (delete-dups
+ (sort (append headers (copy-sequence fetched-headers))
+ (lambda (l r)
+ (< (mail-header-number l)
+ (mail-header-number r))))))
+
+ ;; Add the new set of known headers to the overview file.
(let ((coding-system-for-write
gnus-agent-file-coding-system))
- (gnus-agent-check-overview-buffer)
- (write-region (point-min) (point-max) file nil 'silent))
-
- (gnus-agent-update-view-total-fetched-for group t)
-
- ;; Update the group's article alist to include the newly
- ;; fetched articles.
- (gnus-agent-load-alist group)
- (gnus-agent-save-alist group uncached-articles nil)
- )
-
- ;; Copy the temp buffer to the nntp-server-buffer
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (insert-buffer-substring gnus-agent-overview-buffer)))
-
- (if (and fetch-old
- (not (numberp fetch-old)))
- t ; Don't remove anything.
- (nnheader-nov-delete-outside-range
- (car articles)
- (car (last articles)))
- t)
-
- 'nov))
+ (with-current-buffer gnus-agent-overview-buffer
+ ;; We stick the new headers in at the end, then
+ ;; re-sort the whole buffer with
+ ;; `sort-numeric-fields'. If this turns out to be
+ ;; slow, we could consider a loop to add the headers
+ ;; in sorted order to begin with.
+ (goto-char (point-max))
+ (mapc #'nnheader-insert-nov fetched-headers)
+ (sort-numeric-fields 1 (point-min) (point-max))
+ (gnus-agent-check-overview-buffer)
+ (write-region (point-min) (point-max) file nil 'silent)
+ (gnus-agent-update-view-total-fetched-for group t)
+ ;; Update the group's article alist to include the
+ ;; newly fetched articles.
+ (gnus-agent-load-alist group)
+ (gnus-agent-save-alist group uncached-articles nil))))))
+ headers)))
(defun gnus-agent-request-article (article group)
"Retrieve ARTICLE in GROUP from the agent cache."
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el
index fefd02c..ed948a2 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -357,8 +357,13 @@ that was fetched."
(let ((nntp-server-buffer (current-buffer))
(nnheader-callback-function
(lambda (_arg)
- (setq gnus-async-header-prefetched
- (cons group unread)))))
+ (setq gnus-async-header-prefetched
+ (cons group unread)))))
+ ;; FIXME: If header prefetch is ever put into use, we'll
+ ;; have to handle the possibility that
+ ;; `gnus-retrieve-headers' might return a list of header
+ ;; vectors directly, rather than writing them into the
+ ;; current buffer.
(gnus-retrieve-headers unread group gnus-fetch-old-headers))))))
(defun gnus-async-retrieve-fetched-headers (articles group)
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index 36657e4..9423d9f 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -294,49 +294,47 @@ it's not cached."
(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
"Retrieve the headers for ARTICLES in GROUP."
(let ((cached
- (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))))
+ (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))
+ (gnus-newsgroup-name group)
+ (gnus-fetch-old-headers fetch-old))
(if (not cached)
;; No cached articles here, so we just retrieve them
;; the normal way.
(let ((gnus-use-cache nil))
- (gnus-retrieve-headers articles group fetch-old))
+ (gnus-retrieve-headers articles group))
(let ((uncached-articles (gnus-sorted-difference articles cached))
(cache-file (gnus-cache-file-name group ".overview"))
- type
- (file-name-coding-system nnmail-pathname-coding-system))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ headers)
;; We first retrieve all the headers that we don't have in
;; the cache.
(let ((gnus-use-cache nil))
(when uncached-articles
- (setq type (and articles
- (gnus-retrieve-headers
- uncached-articles group fetch-old)))))
+ (setq headers (and articles
+ (gnus-fetch-headers uncached-articles)))))
(gnus-cache-save-buffers)
- ;; Then we insert the cached headers.
- (save-excursion
- (cond
- ((not (file-exists-p cache-file))
- ;; There are no cached headers.
- type)
- ((null type)
- ;; There were no uncached headers (or retrieval was
- ;; unsuccessful), so we use the cached headers exclusively.
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (let ((coding-system-for-read
- gnus-cache-overview-coding-system))
- (insert-file-contents cache-file))
- 'nov)
- ((eq type 'nov)
- ;; We have both cached and uncached NOV headers, so we
- ;; braid them.
- (gnus-cache-braid-nov group cached)
- type)
- (t
- ;; We braid HEADs.
- (gnus-cache-braid-heads group (gnus-sorted-intersection
- cached articles))
- type)))))))
+ ;; Then we include the cached headers.
+ (when (file-exists-p cache-file)
+ (setq headers
+ (delete-dups
+ (sort
+ (append headers
+ (let ((coding-system-for-read
+ gnus-cache-overview-coding-system))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (insert-file-contents cache-file)
+ (gnus-get-newsgroup-headers-xover
+ (gnus-sorted-difference
+ cached uncached-articles)
+ nil (buffer-local-value
+ 'gnus-newsgroup-dependencies
+ gnus-summary-buffer)
+ group))))
+ (lambda (l r)
+ (< (mail-header-number l)
+ (mail-header-number r)))))))
+ headers))))
(defun gnus-cache-enter-article (&optional n)
"Enter the next N articles into the cache.
@@ -529,70 +527,6 @@ Returns the list of articles removed."
(setq gnus-cache-active-altered t)))
articles)))
-(defun gnus-cache-braid-nov (group cached &optional file)
- (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))
- beg end)
- (gnus-cache-save-buffers)
- (with-current-buffer cache-buf
- (erase-buffer)
- (let ((coding-system-for-read gnus-cache-overview-coding-system)
- (file-name-coding-system nnmail-pathname-coding-system))
- (insert-file-contents
- (or file (gnus-cache-file-name group ".overview"))))
- (goto-char (point-min))
- (insert "\n")
- (goto-char (point-min)))
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (while cached
- (while (and (not (eobp))
- (< (read (current-buffer)) (car cached)))
- (forward-line 1))
- (beginning-of-line)
- (set-buffer cache-buf)
- (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
- nil t)
- (setq beg (point-at-bol)
- end (progn (end-of-line) (point)))
- (setq beg nil))
- (set-buffer nntp-server-buffer)
- (when beg
- (insert-buffer-substring cache-buf beg end)
- (insert "\n"))
- (setq cached (cdr cached)))
- (kill-buffer cache-buf)))
-
-(defun gnus-cache-braid-heads (group cached)
- (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
- (with-current-buffer cache-buf
- (erase-buffer))
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (dolist (entry cached)
- (while (and (not (eobp))
- (looking-at "2.. +\\([0-9]+\\) ")
- (< (progn (goto-char (match-beginning 1))
- (read (current-buffer)))
- entry))
- (search-forward "\n.\n" nil 'move))
- (beginning-of-line)
- (set-buffer cache-buf)
- (erase-buffer)
- (let ((coding-system-for-read gnus-cache-coding-system)
- (file-name-coding-system nnmail-pathname-coding-system))
- (insert-file-contents (gnus-cache-file-name group entry)))
- (goto-char (point-min))
- (insert "220 ")
- (princ (pop cached) (current-buffer))
- (insert " Article retrieved.\n")
- (search-forward "\n\n" nil 'move)
- (delete-region (point) (point-max))
- (forward-char -1)
- (insert ".")
- (set-buffer nntp-server-buffer)
- (insert-buffer-substring cache-buf))
- (kill-buffer cache-buf)))
-
;;;###autoload
(defun gnus-jog-cache ()
"Go through all groups and put the articles into the cache.
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index f7c71f4..00b85f5 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -30,6 +30,8 @@
(require 'parse-time)
(require 'nnimap)
+(declare-function gnus-fetch-headers "gnus-sum")
+(defvar gnus-alter-header-function)
(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
(autoload 'epg-make-context "epg")
@@ -391,8 +393,6 @@ 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))
@@ -407,14 +407,10 @@ When FULL is t, upload everything, not just a difference
from the last full."
(gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method)
(let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
(active (gnus-active group))
- headers head)
- (when (gnus-retrieve-headers (gnus-uncompress-range active) group)
- (with-current-buffer nntp-server-buffer
- (goto-char (point-min))
- (while (setq head (nnheader-parse-head))
- (when gnus-alter-header-function
- (funcall gnus-alter-header-function head))
- (push head headers))))
+ (gnus-newsgroup-name group)
+ (headers (gnus-fetch-headers (gnus-uncompress-range active))))
+ (when gnus-alter-header-function
+ (mapc gnus-alter-header-function headers))
(sort (nreverse headers)
(lambda (h1 h2)
(> (gnus-cloud-chunk-sequence (mail-header-subject h1))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index b0f9ed4..5bd58b6 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -5658,10 +5658,21 @@ or a straight list of headers."
(setf (mail-header-subject header) subject))))))
(defun gnus-fetch-headers (articles &optional limit force-new dependencies)
- "Fetch headers of ARTICLES."
+ "Fetch headers of ARTICLES.
+This calls the `gnus-retrieve-headers' function of the current
+group's backend server. The server can do one of two things:
+
+1. Write the headers for ARTICLES into the
+ `nntp-server-buffer' (the current buffer) in a parseable format, or
+2. Return the headers directly as a list of vectors.
+
+In the first case, `gnus-retrieve-headers' returns a symbol
+value, either `nov' or `headers'. This value determines which
+parsing function is used to read the headers. It is also stored
+into the variable `gnus-headers-retrieved-by', which is consulted
+later when possibly building full threads."
(gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name)
- (prog1
- (pcase (setq gnus-headers-retrieved-by
+ (let ((res (setq gnus-headers-retrieved-by
(gnus-retrieve-headers
articles gnus-newsgroup-name
(or limit
@@ -5671,22 +5682,34 @@ or a straight list of headers."
(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)))
+ gnus-fetch-old-headers))))))
+ (prog1
+ (pcase res
+ ('nov
+ (gnus-get-newsgroup-headers-xover
+ articles force-new dependencies gnus-newsgroup-name t))
+ ;; For now, assume that any backend returning its own
+ ;; headers takes some effort to do so, so return `headers'.
+ ((pred listp)
+ (setq gnus-headers-retrieved-by 'headers)
+ (let ((dependencies
+ (or dependencies
+ (buffer-local-value
+ 'gnus-newsgroup-dependencies gnus-summary-buffer))))
+ (when (functionp gnus-alter-header-function)
+ (mapc gnus-alter-header-function res))
+ (mapc (lambda (header)
+ ;; The agent or the cache may have already
+ ;; registered this header in the dependency
+ ;; table.
+ (unless (gethash (mail-header-id header) dependencies)
+ (gnus-dependencies-add-header
+ header dependencies force-new)))
+ res)
+ res))
+ (_ (gnus-get-newsgroup-headers dependencies force-new)))
+ (gnus-message 7 "Fetching headers for %s...done"
+ gnus-newsgroup-name))))
(defun gnus-select-newsgroup (group &optional read-all select-articles)
"Select newsgroup GROUP.
@@ -6443,6 +6466,10 @@ The resulting hash table is returned, or nil if no Xrefs
were found."
(unless (gnus-ephemeral-group-p group)
(gnus-group-update-group group t))))))
+;; FIXME: Refactor this with `gnus-get-newsgroup-headers-xover' and
+;; extract the necessary bits for the direct-header-return case. Also
+;; look at this and see how similar it is to
+;; `nnheader-parse-naked-head'.
(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
(let ((dependencies
(or dependencies
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 3b172db..2e9ee71 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -2388,7 +2388,14 @@ Typical marks are those that make no sense in a
standalone back end,
such as a mark that says whether an article is stored in the cache
\(which doesn't make sense in a standalone back end).")
-(defvar gnus-headers-retrieved-by nil)
+(defvar gnus-headers-retrieved-by nil
+ "Holds the return value of `gnus-retrieve-headers'.
+This is either the symbol `nov' or the symbol `headers'. This
+value is checked during the summary creation process, when
+building threads. A value of `nov' indicates that header
+retrieval is relatively cheap and threading is encouraged to
+include more old articles. A value of `headers' indicates that
+retrieval is expensive and should be minimized.")
(defvar gnus-article-reply nil)
(defvar gnus-override-method nil)
(defvar gnus-opened-servers nil)
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index 1e2feda..ba29343 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -101,15 +101,10 @@ It is computed from the marks of individual component
groups.")
(erase-buffer)
(if (stringp (car articles))
'headers
- (let ((vbuf (nnheader-set-temp-buffer
- (gnus-get-buffer-create " *virtual headers*")))
- (carticles (nnvirtual-partition-sequence articles))
+ (let ((carticles (nnvirtual-partition-sequence articles))
(sysname (system-name))
- cgroup carticle article result prefix)
- (while carticles
- (setq cgroup (caar carticles))
- (setq articles (cdar carticles))
- (pop carticles)
+ cgroup headers all-headers article prefix)
+ (pcase-dolist (`(,cgroup . ,articles) carticles)
(when (and articles
(gnus-check-server
(gnus-find-method-for-group cgroup) t)
@@ -119,69 +114,37 @@ It is computed from the marks of individual component
groups.")
;; This is probably evil if people have set
;; gnus-use-cache to nil themselves, but I
;; have no way of finding the true value of it.
- (let ((gnus-use-cache t))
- (setq result (gnus-retrieve-headers
- articles cgroup nil))))
- (set-buffer nntp-server-buffer)
- ;; If we got HEAD headers, we convert them into NOV
- ;; headers. This is slow, inefficient and, come to think
- ;; of it, downright evil. So sue me. I couldn't be
- ;; bothered to write a header parse routine that could
- ;; parse a mixed HEAD/NOV buffer.
- (when (eq result 'headers)
- (nnvirtual-convert-headers))
- (goto-char (point-min))
- (while (not (eobp))
- (delete-region (point)
- (progn
- (setq carticle (read nntp-server-buffer))
- (point)))
-
- ;; We remove this article from the articles list, if
- ;; anything is left in the articles list after going through
- ;; the entire buffer, then those articles have been
- ;; expired or canceled, so we appropriately update the
- ;; component group below. They should be coming up
- ;; generally in order, so this shouldn't be slow.
- (setq articles (delq carticle articles))
-
- (setq article (nnvirtual-reverse-map-article cgroup carticle))
- (if (null article)
- ;; This line has no reverse mapping, that means it
- ;; was an extra article reference returned by nntp.
- (progn
- (beginning-of-line)
- (delete-region (point) (progn (forward-line 1) (point))))
- ;; Otherwise insert the virtual article number,
- ;; and clean up the xrefs.
- (princ article nntp-server-buffer)
- (nnvirtual-update-xref-header cgroup carticle
- prefix sysname)
- (forward-line 1))
- )
-
- (set-buffer vbuf)
- (goto-char (point-max))
- (insert-buffer-substring nntp-server-buffer))
- ;; Anything left in articles is expired or canceled.
- ;; Could be smart and not tell it about articles already known?
- (when articles
- (gnus-group-make-articles-read cgroup articles))
- )
-
- ;; The headers are ready for reading, so they are inserted into
- ;; the nntp-server-buffer, which is where Gnus expects to find
- ;; them.
- (prog1
- (with-current-buffer nntp-server-buffer
- (erase-buffer)
- (insert-buffer-substring vbuf)
- ;; FIX FIX FIX, we should be able to sort faster than
- ;; this if needed, since each cgroup is sorted, we just
- ;; need to merge
- (sort-numeric-fields 1 (point-min) (point-max))
- 'nov)
- (kill-buffer vbuf)))))))
+ (let ((gnus-use-cache t)
+ (gnus-newsgroup-name cgroup)
+ (gnus-fetch-old-headers nil))
+ (setq headers (gnus-fetch-headers articles))))
+ (erase-buffer)
+ ;; Remove all header article numbers from `articles'.
+ ;; If there's anything left, those are expired or
+ ;; canceled articles, so we update the component group
+ ;; below.
+ (dolist (h headers)
+ (setq articles (delq (mail-header-number h) articles)
+ article (nnvirtual-reverse-map-article
+ cgroup (mail-header-number h)))
+ ;; Update all the header numbers according to their
+ ;; reverse mapping, and drop any with no such mapping.
+ (when article
+ ;; Do this first, before we re-set the header's
+ ;; article number.
+ (nnvirtual-update-xref-header
+ h cgroup prefix sysname)
+ (setf (mail-header-number h) article)
+ (push h all-headers)))
+ ;; Anything left in articles is expired or canceled.
+ ;; Could be smart and not tell it about articles already
+ ;; known?
+ (when articles
+ (gnus-group-make-articles-read cgroup articles))))
+
+ (sort all-headers (lambda (h1 h2)
+ (< (mail-header-number h1)
+ (mail-header-number h2)))))))))
(defvoo nnvirtual-last-accessed-component-group nil)
@@ -372,61 +335,18 @@ It is computed from the marks of individual component
groups.")
;;; Internal functions.
-(defun nnvirtual-convert-headers ()
- "Convert HEAD headers into NOV headers."
- (with-current-buffer nntp-server-buffer
- (let* ((dependencies (make-hash-table :test #'equal))
- (headers (gnus-get-newsgroup-headers dependencies)))
- (erase-buffer)
- (mapc 'nnheader-insert-nov headers))))
-
-
-(defun nnvirtual-update-xref-header (group article prefix sysname)
- "Edit current NOV header in current buffer to have an xref to the component
group, and also server prefix any existing xref lines."
- ;; Move to beginning of Xref field, creating a slot if needed.
- (beginning-of-line)
- (looking-at
- "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
- (goto-char (match-end 0))
- (unless (search-forward "\t" (point-at-eol) 'move)
- (insert "\t"))
-
- ;; Remove any spaces at the beginning of the Xref field.
- (while (eq (char-after (1- (point))) ? )
- (forward-char -1)
- (delete-char 1))
-
- (insert "Xref: " sysname " " group ":")
- (princ article (current-buffer))
- (insert " ")
-
- ;; If there were existing xref lines, clean them up to have the correct
- ;; component server prefix.
- (save-restriction
- (narrow-to-region (point)
- (or (search-forward "\t" (point-at-eol) t)
- (point-at-eol)))
- (goto-char (point-min))
- (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t)
- (replace-match "" t t))
- (goto-char (point-min))
- (when (re-search-forward
- (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+")
- nil t)
- (replace-match "" t t))
- (unless (eobp)
- (insert " ")
- (when (not (string= "" prefix))
- (while (re-search-forward "[^ ]+:[0-9]+" nil t)
- (save-excursion
- (goto-char (match-beginning 0))
- (insert prefix))))))
-
- ;; Ensure a trailing \t.
- (end-of-line)
- (or (eq (char-after (1- (point))) ?\t)
- (insert ?\t)))
-
+(defun nnvirtual-update-xref-header (header group prefix sysname)
+ "Add xref to component GROUP to HEADER.
+Also add a server PREFIX any existing xref lines."
+ (let ((bits (split-string (mail-header-xref header)
+ nil t "[[:blank:]]"))
+ (art-no (mail-header-number header)))
+ (setf (mail-header-xref header)
+ (concat
+ (format "%s %s:%d " sysname group art-no)
+ (mapconcat (lambda (bit)
+ (concat prefix bit))
+ bits " ")))))
(defun nnvirtual-possibly-change-server (server)
(or (not server)
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 7be1b3d..ed5c9c0 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -1823,18 +1823,12 @@ When BUF nil, default to the buffer at current line."
;;;###autoload
(defun ibuffer-mark-by-file-name-regexp (regexp)
"Mark all buffers whose file name matches REGEXP."
- (interactive "sMark by file name (regexp): ")
+ (interactive (list (read-regexp "Mark by file name (regexp)")))
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (let ((name (or (buffer-file-name buf)
- (with-current-buffer buf
- (and
- (boundp 'dired-directory)
- (stringp dired-directory)
- dired-directory)))))
- (when name
- ;; Match on the displayed file name (which is abbreviated).
- (string-match regexp (abbreviate-file-name name)))))))
+ (lambda (buf)
+ (when-let ((name (with-current-buffer buf (ibuffer-buffer-file-name))))
+ ;; Match on the displayed file name (which is abbreviated).
+ (string-match-p regexp (ibuffer--abbreviate-file-name name))))))
;;;###autoload
(defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers)
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index 4800e02..84c53b1 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1308,6 +1308,11 @@ a new window in the current frame, splitting vertically."
(car dired-directory)))))
(and dirname (expand-file-name dirname))))))
+(defun ibuffer--abbreviate-file-name (filename)
+ "Abbreviate FILENAME using `ibuffer-directory-abbrev-alist'."
+ (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist))
+ (abbreviate-file-name filename)))
+
(define-ibuffer-op ibuffer-do-save ()
"Save marked buffers as with `save-buffer'."
(:complex t
@@ -1885,9 +1890,7 @@ If point is on a group name, this function operates on
that group."
(cond ((zerop total) "No files")
((= 1 total) "1 file")
(t (format "%d files" total))))))
- (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist))
- (abbreviate-file-name
- (or (ibuffer-buffer-file-name) ""))))
+ (ibuffer--abbreviate-file-name (or (ibuffer-buffer-file-name) "")))
(define-ibuffer-column filename-and-process
(:name "Filename/Process"
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index 14e7b89..8f0f263 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -719,6 +719,7 @@
georgian
cherokee
canadian-aboriginal
+ cham
ogham
runic
symbol
diff --git a/lisp/language/cham.el b/lisp/language/cham.el
index 194574f..089988d 100644
--- a/lisp/language/cham.el
+++ b/lisp/language/cham.el
@@ -35,7 +35,8 @@
"Cham" '((charset unicode)
(coding-system utf-8)
(coding-priority utf-8)
- (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨰꨁ")
+ (input-method . "cham")
+ (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨁꨰ")
(documentation . "\
The Cham script is a Brahmic script used to write Cham,
an Austronesian language spoken by some 245,000 Chams
diff --git a/lisp/leim/quail/cham.el b/lisp/leim/quail/cham.el
new file mode 100644
index 0000000..d12ae6c
--- /dev/null
+++ b/lisp/leim/quail/cham.el
@@ -0,0 +1,116 @@
+;;; cham.el --- Quail package for inputting Cham characters -*- coding:
utf-8; lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Eli Zaretskii <eliz@gnu.org>
+;; Keywords: i18n
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file defines the following Cham keyboards:
+;;
+;; - QWERTY-based Cham.
+
+;;; Code:
+
+(require 'quail)
+
+(quail-define-package
+ "cham" "Cham" "ꨌꩌ" t
+ "A QWERTY-based Cham input method."
+ nil t nil nil t nil nil nil nil nil t)
+
+(quail-define-rules
+ ("a" ?ꨀ)
+ ("A" ?ꨄ)
+ ("i" ?ꨁ)
+ ("u" ?ꨂ)
+ ("e" ?ꨃ)
+ ("o" ?ꨅ)
+ ("k" ?ꨆ)
+ ("K" ?ꨇ)
+ ("g" ?ꨈ)
+ ("G" ?ꨉ)
+ ("q" ?ꨊ)
+ ("Q" ?ꨋ)
+ ("c" ?ꨌ)
+ ("C" ?ꨍ)
+ ("j" ?ꨎ)
+ ("J" ?ꨏ)
+ ("z" ?ꨐ)
+ ("Z" ?ꨑ)
+ ("zz" ?ꨒ)
+ ("t" ?ꨓ)
+ ("T" ?ꨔ)
+ ("d" ?ꨕ)
+ ("D" ?ꨖ)
+ ("n" ?ꨗ)
+ ("N" ?ꨘ)
+ ("p" ?ꨚ)
+ ("P" ?ꨛ)
+ ("f" ?ꨜ)
+ ("b" ?ꨝ)
+ ("B" ?ꨞ)
+ ("m" ?ꨟ)
+ ("M" ?ꨠ)
+ ("mm" ?ꨡ)
+ ("y" ?ꨢ)
+ ("r" ?ꨣ)
+ ("l" ?ꨤ)
+ ("w" ?ꨥ)
+ ("v" ?ꨥ)
+ ("x" ?ꨦ)
+ ("s" ?ꨧ)
+ ("h" ?ꨨ)
+ ("kk" ?ꩀ)
+ ("ww" ?ꩁ)
+ ("vv" ?ꩁ)
+ ("qq" ?ꩂ)
+ ("cc" ?ꩄ)
+ ("tt" ?ꩅ)
+ ("nn" ?ꩆ)
+ ("pp" ?ꩇ)
+ ("yy" ?ꩈ)
+ ("rr" ?ꩉ)
+ ("ll" ?ꩊ)
+ ("gg" ?ꩊ)
+ ("xx" ?ꩋ)
+ ("." ?ꩌ)
+ ("H" ?ꩍ)
+ ("0" ?꩐)
+ ("1" ?꩑)
+ ("2" ?꩒)
+ ("3" ?꩓)
+ ("4" ?꩔)
+ ("5" ?꩕)
+ ("6" ?꩖)
+ ("7" ?꩗)
+ ("8" ?꩘)
+ ("9" ?꩙)
+ ("!" ?ꨩ)
+ ("#" ?ꨪ)
+ ("$" ?ꨫ)
+ ("^" ?ꨬ)
+ ("&" ?ꨮ)
+ ("`" ?꩜)
+ ("=" ?ꨱ)
+ ("-" ?ꩃ)
+ ("~" ?꩟)
+ )
+
+;;; cham.el ends here
diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el
index 147efed..0b7d1e4 100644
--- a/lisp/obsolete/nnir.el
+++ b/lisp/obsolete/nnir.el
@@ -504,7 +504,6 @@ Add an entry here when adding a new search engine.")
,@(mapcar (lambda (elem) (list 'const (car elem)))
nnir-engines)))))
-
(defmacro nnir-add-result (dirnam artno score prefix server artlist)
"Construct a result vector and add it to ARTLIST.
DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index b6778de..aecb30a 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1001,8 +1001,12 @@ When only one definition found, jump to it right away
instead."
When there is more than one definition, split the selected window
and show the list in a small window at the bottom. And use a
local keymap that binds `RET' to `xref-quit-and-goto-xref'."
- (let ((xrefs (funcall fetcher))
- (dd default-directory))
+ (let* ((xrefs (funcall fetcher))
+ (dd default-directory)
+ ;; XXX: Make percentage customizable maybe?
+ (max-height (/ (window-height) 2))
+ (size-fun (lambda (window)
+ (fit-window-to-buffer window max-height))))
(cond
((not (cdr xrefs))
(xref-pop-to-location (car xrefs)
@@ -1013,7 +1017,8 @@ local keymap that binds `RET' to
`xref-quit-and-goto-xref'."
(xref--transient-buffer-mode)
(xref--show-common-initialize (xref--analyze xrefs) fetcher alist)
(pop-to-buffer (current-buffer)
- '(display-buffer-in-direction . ((direction . below))))
+ `(display-buffer-in-direction . ((direction . below)
+ (window-height .
,size-fun))))
(current-buffer))))))
(define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom
diff --git a/lisp/replace.el b/lisp/replace.el
index d41dc98..8f8cbfa 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -866,13 +866,10 @@ If nil, uses `regexp-history'."
;; Do not automatically add default to the history for empty input.
(history-add-new-input nil)
(input (read-from-minibuffer
- (cond ((string-match-p ":[ \t]*\\'" prompt)
- prompt)
- ((and default (> (length default) 0))
- (format "%s (default %s): " prompt
- (query-replace-descr default)))
- (t
- (format "%s: " prompt)))
+ (if (string-match-p ":[ \t]*\\'" prompt)
+ prompt
+ (format-prompt prompt (and (length> default 0)
+ (query-replace-descr default))))
nil nil nil (or history 'regexp-history) suggestions t)))
(if (equal input "")
;; Return the default value when the user enters empty input.
diff --git a/src/nsselect.m b/src/nsselect.m
index 27db924..5ab3ef7 100644
--- a/src/nsselect.m
+++ b/src/nsselect.m
@@ -78,7 +78,13 @@ ns_string_to_symbol (NSString *t)
return QSECONDARY;
if ([t isEqualToString: NSPasteboardTypeString])
return QTEXT;
- if ([t isEqualToString: NSFilenamesPboardType])
+ if ([t isEqualToString:
+#if NS_USE_NSPasteboardTypeFileURL != 0
+ NSPasteboardTypeFileURL
+#else
+ NSFilenamesPboardType
+#endif
+ ])
return QFILE_NAME;
if ([t isEqualToString: NSPasteboardTypeTabularText])
return QTEXT;
@@ -467,7 +473,12 @@ nxatoms_of_nsselect (void)
[NSNumber numberWithLong:0], NXPrimaryPboard,
[NSNumber numberWithLong:0], NXSecondaryPboard,
[NSNumber numberWithLong:0], NSPasteboardTypeString,
- [NSNumber numberWithLong:0], NSFilenamesPboardType,
+ [NSNumber numberWithLong:0],
+#if NS_USE_NSPasteboardTypeFileURL != 0
+ NSPasteboardTypeFileURL,
+#else
+ NSFilenamesPboardType,
+#endif
[NSNumber numberWithLong:0], NSPasteboardTypeTabularText,
nil] retain];
}
diff --git a/src/nsterm.h b/src/nsterm.h
index 2c9d8e8..eae1d07 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -39,6 +39,15 @@ typedef CGFloat EmacsCGFloat;
typedef float EmacsCGFloat;
#endif
+/* NSFilenamesPboardType is deprecated in macOS 10.14, but
+ NSPasteboardTypeFileURL is only available in 10.13 (and GNUstep
+ probably lacks it too). */
+#if defined NS_IMPL_COCOA && MAC_OS_X_VERSION_MIN_REQUIRED >= 101300
+#define NS_USE_NSPasteboardTypeFileURL 1
+#else
+#define NS_USE_NSPasteboardTypeFileURL 0
+#endif
+
/* ==========================================================================
Trace support
diff --git a/src/nsterm.m b/src/nsterm.m
index 2defb9e..c5815ce 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -5602,7 +5602,11 @@ ns_term_init (Lisp_Object display_name)
ns_drag_types = [[NSArray arrayWithObjects:
NSPasteboardTypeString,
NSPasteboardTypeTabularText,
+#if NS_USE_NSPasteboardTypeFileURL != 0
+ NSPasteboardTypeFileURL,
+#else
NSFilenamesPboardType,
+#endif
NSPasteboardTypeURL, nil] retain];
/* If fullscreen is in init/default-frame-alist, focus isn't set
@@ -8533,9 +8537,19 @@ not_in_argv (NSString *arg)
{
return NO;
}
- /* FIXME: NSFilenamesPboardType is deprecated in 10.14, but the
- NSURL method can only handle one file at a time. Stick with the
- existing code at the moment. */
+#if NS_USE_NSPasteboardTypeFileURL != 0
+ else if ([type isEqualToString: NSPasteboardTypeFileURL])
+ {
+ type_sym = Qfile;
+
+ NSArray *urls = [pb readObjectsForClasses: @[[NSURL self]]
+ options: nil];
+ NSEnumerator *uenum = [urls objectEnumerator];
+ NSURL *url;
+ while ((url = [uenum nextObject]))
+ strings = Fcons ([[url path] lispString], strings);
+ }
+#else // !NS_USE_NSPasteboardTypeFileURL
else if ([type isEqualToString: NSFilenamesPboardType])
{
NSArray *files;
@@ -8551,6 +8565,7 @@ not_in_argv (NSString *arg)
while ( (file = [fenum nextObject]) )
strings = Fcons ([file lispString], strings);
}
+#endif // !NS_USE_NSPasteboardTypeFileURL
else if ([type isEqualToString: NSPasteboardTypeURL])
{
NSURL *url = [NSURL URLFromPasteboard: pb];
diff --git a/src/process.c b/src/process.c
index aca87f8..09f8790 100644
--- a/src/process.c
+++ b/src/process.c
@@ -5323,6 +5323,15 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
compute_input_wait_mask (&Atemp);
compute_write_mask (&Ctemp);
+ /* If a process status has changed, the child signal pipe
+ will likely be readable. We want to ignore it for now,
+ because otherwise we wouldn't run into a timeout
+ below. */
+ int fd = child_signal_read_fd;
+ eassert (fd < FD_SETSIZE);
+ if (0 <= fd)
+ FD_CLR (fd, &Atemp);
+
timeout = make_timespec (0, 0);
if ((thread_select (pselect, max_desc + 1,
&Atemp,
diff --git a/test/Makefile.in b/test/Makefile.in
index 2d595d9..4ca43c8 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -246,11 +246,17 @@ endef
$(foreach test,${TESTS},$(eval $(call test_template,${test})))
-# Get the tests for only a specific directory
-NET_TESTS := $(patsubst %.el,%,$(wildcard lisp/net/*.el))
-LISP_TESTS := $(patsubst %.el,%,$(wildcard lisp/*.el))
-check-net: ${NET_TESTS}
-check-lisp: ${LISP_TESTS}
+## Get the tests for only a specific directory.
+SUBDIRS = $(sort $(shell find lisp src -type d ! -path "*resources*" -print))
+
+define subdir_template
+ .PHONY: check-$(subst /,-,$(1))
+ check-$(subst /,-,$(1)):
+ @${MAKE} check LOGFILES="$(patsubst %.el,%.log, \
+ $(patsubst $(srcdir)/%,%,$(wildcard $(1)/*.el)))"
+endef
+
+$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir))))
ifeq (@HAVE_MODULES@, yes)
# -fPIC is a no-op on Windows, but causes a compiler warning
@@ -318,10 +324,10 @@ check-doit:
ifeq ($(TEST_INTERACTIVE), yes)
HOME=$(TEST_HOME) $(emacs) \
-l ert ${ert_opts} \
- $(patsubst %,-l %,$(if $(findstring
$(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \
+ $(patsubst %,-l %,$(if $(findstring
$(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \
$(TEST_RUN_ERT)
else
- -@${MAKE} -k ${LOGFILES}
+ -@${MAKE} -k ${LOGFILES}
@$(emacs) --batch -l ert --eval \
"(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES}
endif
diff --git a/test/README b/test/README
index 38f4a10..58f5f38 100644
--- a/test/README
+++ b/test/README
@@ -39,11 +39,10 @@ The Makefile in this directory supports the following
targets:
* make check-all
Like "make check", but run all tests.
-* make check-lisp
- Like "make check", but run only the tests in test/lisp/*.el
-
-* make check-net
- Like "make check", but run only the tests in test/lisp/net/*.el
+* make check-<dirname>
+ Like "make check", but run only the tests in test/<dirname>/*.el.
+ <dirname> is a relative directory path, which has replaced "/" by "-",
+ like in "check-src" or "check-lisp-net".
* make <filename> -or- make <filename>.log
Run all tests declared in <filename>.el. This includes expensive
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml
index f9c0e0c..3214f01 100644
--- a/test/infra/gitlab-ci.yml
+++ b/test/infra/gitlab-ci.yml
@@ -59,6 +59,30 @@ default:
- docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD}
${CI_REGISTRY}
.job-template:
+ rules:
+ - changes:
+ - "**/Makefile.in"
+ - .gitlab-ci.yml
+ - aclocal.m4
+ - autogen.sh
+ - configure.ac
+ - lib/*.{h,c}
+ - lisp/**/*.el
+ - src/*.{h,c}
+ - test/infra/*
+ - test/lisp/**/*.el
+ - test/src/*.el
+ - changes:
+ # gfilemonitor, kqueue
+ - src/gfilenotify.c
+ - src/kqueue.c
+ # MS Windows
+ - "**/w32*"
+ # GNUstep
+ - lisp/term/ns-win.el
+ - src/ns*.{h,m}
+ - src/macfont.{h,m}
+ when: never
# these will be cached across builds
cache:
key: ${CI_COMMIT_SHA}
@@ -70,6 +94,11 @@ default:
paths: []
# - "test/**/*.log"
# - "**/*.log"
+ # using the variables for each job
+ script:
+ - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA}
+ # TODO: with make -j4 several of the tests were failing, for example
shadowfile-tests, but passed without it
+ - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI}
${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} make ${make_params}
.build-template:
script:
@@ -103,38 +132,6 @@ default:
- test/lisp/autorevert-tests.el
- test/lisp/filenotify-tests.el
-.test-template:
- rules:
- - changes:
- - "**/Makefile.in"
- - .gitlab-ci.yml
- - aclocal.m4
- - autogen.sh
- - configure.ac
- - lib/*.{h,c}
- - lisp/**/*.el
- - src/*.{h,c}
- - test/infra/*
- - test/lisp/**/*.el
- - test/src/*.el
- - changes:
- # gfilemonitor, kqueue
- - src/gfilenotify.c
- - src/kqueue.c
- # MS Windows
- - "**/w32*"
- # GNUstep
- - lisp/term/ns-win.el
- - src/ns*.{h,m}
- - src/macfont.{h,m}
- when: never
-
- # using the variables for each job
- script:
- - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA}
- # TODO: with make -j4 several of the tests were failing, for example
shadowfile-tests, but passed without it
- - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI}
${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} make ${make_params}
-
stages:
- prep-images
- build-images
@@ -158,7 +155,7 @@ build-image-inotify:
test-fast-inotify:
stage: fast
- extends: [.job-template, .test-template]
+ extends: [.job-template]
variables:
target: emacs-inotify
make_params: "-C test check"
@@ -177,22 +174,22 @@ build-image-gnustep:
test-lisp-inotify:
stage: normal
- extends: [.job-template, .test-template]
+ extends: [.job-template]
variables:
target: emacs-inotify
make_params: "-C test check-lisp"
-test-net-inotify:
+test-lisp-net-inotify:
stage: normal
- extends: [.job-template, .test-template]
+ extends: [.job-template]
variables:
target: emacs-inotify
- make_params: "-C test check-net"
+ make_params: "-C test check-lisp-net"
test-filenotify-gio:
# This tests file monitor libraries gfilemonitor and gio.
stage: platforms
- extends: [.job-template, .test-template, .filenotify-gio-template]
+ extends: [.job-template, .filenotify-gio-template]
variables:
target: emacs-filenotify-gio
make_params: "-k -C test autorevert-tests filenotify-tests"
@@ -200,7 +197,7 @@ test-filenotify-gio:
test-gnustep:
# This tests the GNUstep build process
stage: platforms
- extends: [.job-template, .test-template, .gnustep-template]
+ extends: [.job-template, .gnustep-template]
variables:
target: emacs-gnustep
make_params: install
@@ -208,7 +205,7 @@ test-gnustep:
test-all-inotify:
# This tests also file monitor libraries inotify and inotifywatch.
stage: slow
- extends: [.job-template, .test-template]
+ extends: [.job-template]
rules:
# note there's no "changes" section, so this always runs on a schedule
- if: '$CI_PIPELINE_SOURCE == "schedule"'
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el
index 81488c3..4ae3c19 100644
--- a/test/lisp/time-stamp-tests.el
+++ b/test/lisp/time-stamp-tests.el
@@ -262,40 +262,48 @@
(ert-deftest time-stamp-format-day-of-week ()
"Test time-stamp formats for named day of week."
(with-time-stamp-test-env
- ;; implemented and documented since 1997
- (should (equal (time-stamp-string "%3a" ref-time1) "Mon"))
- (should (equal (time-stamp-string "%#A" ref-time1) "MONDAY"))
- ;; documented 1997-2019
- (should (equal (time-stamp-string "%3A" ref-time1) "MON"))
- (should (equal (time-stamp-string "%:a" ref-time1) "Monday"))
- ;; implemented since 2001, documented since 2019
- (should (equal (time-stamp-string "%#a" ref-time1) "MON"))
- (should (equal (time-stamp-string "%:A" ref-time1) "Monday"))
- ;; allowed but undocumented since 2019 (warned 1997-2019)
- (should (equal (time-stamp-string "%^A" ref-time1) "MONDAY"))
- ;; warned 1997-2019, changed in 2019
- (should (equal (time-stamp-string "%a" ref-time1) "Mon"))
- (should (equal (time-stamp-string "%^a" ref-time1) "MON"))
- (should (equal (time-stamp-string "%A" ref-time1) "Monday"))))
+ (let ((Mon (format-time-string "%a" ref-time1 t))
+ (MON (format-time-string "%^a" ref-time1 t))
+ (Monday (format-time-string "%A" ref-time1 t))
+ (MONDAY (format-time-string "%^A" ref-time1 t)))
+ ;; implemented and documented since 1997
+ (should (equal (time-stamp-string "%3a" ref-time1) Mon))
+ (should (equal (time-stamp-string "%#A" ref-time1) MONDAY))
+ ;; documented 1997-2019
+ (should (equal (time-stamp-string "%3A" ref-time1) MON))
+ (should (equal (time-stamp-string "%:a" ref-time1) Monday))
+ ;; implemented since 2001, documented since 2019
+ (should (equal (time-stamp-string "%#a" ref-time1) MON))
+ (should (equal (time-stamp-string "%:A" ref-time1) Monday))
+ ;; allowed but undocumented since 2019 (warned 1997-2019)
+ (should (equal (time-stamp-string "%^A" ref-time1) MONDAY))
+ ;; warned 1997-2019, changed in 2019
+ (should (equal (time-stamp-string "%a" ref-time1) Mon))
+ (should (equal (time-stamp-string "%^a" ref-time1) MON))
+ (should (equal (time-stamp-string "%A" ref-time1) Monday)))))
(ert-deftest time-stamp-format-month-name ()
"Test time-stamp formats for month name."
(with-time-stamp-test-env
- ;; implemented and documented since 1997
- (should (equal (time-stamp-string "%3b" ref-time1) "Jan"))
- (should (equal (time-stamp-string "%#B" ref-time1) "JANUARY"))
- ;; documented 1997-2019
- (should (equal (time-stamp-string "%3B" ref-time1) "JAN"))
- (should (equal (time-stamp-string "%:b" ref-time1) "January"))
- ;; implemented since 2001, documented since 2019
- (should (equal (time-stamp-string "%#b" ref-time1) "JAN"))
- (should (equal (time-stamp-string "%:B" ref-time1) "January"))
- ;; allowed but undocumented since 2019 (warned 1997-2019)
- (should (equal (time-stamp-string "%^B" ref-time1) "JANUARY"))
- ;; warned 1997-2019, changed in 2019
- (should (equal (time-stamp-string "%b" ref-time1) "Jan"))
- (should (equal (time-stamp-string "%^b" ref-time1) "JAN"))
- (should (equal (time-stamp-string "%B" ref-time1) "January"))))
+ (let ((Jan (format-time-string "%b" ref-time1 t))
+ (JAN (format-time-string "%^b" ref-time1 t))
+ (January (format-time-string "%B" ref-time1 t))
+ (JANUARY (format-time-string "%^B" ref-time1 t)))
+ ;; implemented and documented since 1997
+ (should (equal (time-stamp-string "%3b" ref-time1) Jan))
+ (should (equal (time-stamp-string "%#B" ref-time1) JANUARY))
+ ;; documented 1997-2019
+ (should (equal (time-stamp-string "%3B" ref-time1) JAN))
+ (should (equal (time-stamp-string "%:b" ref-time1) January))
+ ;; implemented since 2001, documented since 2019
+ (should (equal (time-stamp-string "%#b" ref-time1) JAN))
+ (should (equal (time-stamp-string "%:B" ref-time1) January))
+ ;; allowed but undocumented since 2019 (warned 1997-2019)
+ (should (equal (time-stamp-string "%^B" ref-time1) JANUARY))
+ ;; warned 1997-2019, changed in 2019
+ (should (equal (time-stamp-string "%b" ref-time1) Jan))
+ (should (equal (time-stamp-string "%^b" ref-time1) JAN))
+ (should (equal (time-stamp-string "%B" ref-time1) January)))))
(ert-deftest time-stamp-format-day-of-month ()
"Test time-stamp formats for day of month."
@@ -483,14 +491,18 @@
(ert-deftest time-stamp-format-am-pm ()
"Test time-stamp formats for AM and PM strings."
(with-time-stamp-test-env
- ;; implemented and documented since 1997
- (should (equal (time-stamp-string "%#p" ref-time1) "pm"))
- (should (equal (time-stamp-string "%#p" ref-time3) "am"))
- (should (equal (time-stamp-string "%P" ref-time1) "PM"))
- (should (equal (time-stamp-string "%P" ref-time3) "AM"))
- ;; warned 1997-2019, changed in 2019
- (should (equal (time-stamp-string "%p" ref-time1) "PM"))
- (should (equal (time-stamp-string "%p" ref-time3) "AM"))))
+ (let ((pm (format-time-string "%#p" ref-time1 t))
+ (am (format-time-string "%#p" ref-time3 t))
+ (PM (format-time-string "%p" ref-time1 t))
+ (AM (format-time-string "%p" ref-time3 t)))
+ ;; implemented and documented since 1997
+ (should (equal (time-stamp-string "%#p" ref-time1) pm))
+ (should (equal (time-stamp-string "%#p" ref-time3) am))
+ (should (equal (time-stamp-string "%P" ref-time1) PM))
+ (should (equal (time-stamp-string "%P" ref-time3) AM))
+ ;; warned 1997-2019, changed in 2019
+ (should (equal (time-stamp-string "%p" ref-time1) PM))
+ (should (equal (time-stamp-string "%p" ref-time3) AM)))))
(ert-deftest time-stamp-format-day-number-in-week ()
"Test time-stamp formats for day number in week."
@@ -567,10 +579,15 @@
(ert-deftest time-stamp-format-ignored-modifiers ()
"Test additional args allowed (but ignored) to allow for future expansion."
(with-time-stamp-test-env
- ;; allowed modifiers
- (should (equal (time-stamp-string "%.,@-+_ ^(stuff)P" ref-time3) "AM"))
- ;; not all punctuation is allowed
- (should-not (equal (time-stamp-string "%&P" ref-time3) "AM"))))
+ (let ((May (format-time-string "%B" ref-time3 t)))
+ ;; allowed modifiers
+ (should (equal (time-stamp-string "%.,@+ (stuff)B" ref-time3) May))
+ ;; parens nest
+ (should (equal (time-stamp-string "%(st(u)ff)B" ref-time3) May))
+ ;; escaped parens do not change the nesting level
+ (should (equal (time-stamp-string "%(st\\)u\\(ff)B" ref-time3) May))
+ ;; not all punctuation is allowed
+ (should-not (equal (time-stamp-string "%&B" ref-time3) May)))))
(ert-deftest time-stamp-format-non-conversions ()
"Test that without a %, the text is copied literally."
@@ -580,16 +597,22 @@
(ert-deftest time-stamp-format-string-width ()
"Test time-stamp string width modifiers."
(with-time-stamp-test-env
- ;; strings truncate on the right or are blank-padded on the left
- (should (equal (time-stamp-string "%0P" ref-time3) ""))
- (should (equal (time-stamp-string "%1P" ref-time3) "A"))
- (should (equal (time-stamp-string "%2P" ref-time3) "AM"))
- (should (equal (time-stamp-string "%3P" ref-time3) " AM"))
- (should (equal (time-stamp-string "%0%" ref-time3) ""))
- (should (equal (time-stamp-string "%1%" ref-time3) "%"))
- (should (equal (time-stamp-string "%2%" ref-time3) " %"))
- (should (equal (time-stamp-string "%#3a" ref-time3) "SUN"))
- (should (equal (time-stamp-string "%#3b" ref-time2) "NOV"))))
+ (let ((May (format-time-string "%b" ref-time3 t))
+ (SUN (format-time-string "%^a" ref-time3 t))
+ (NOV (format-time-string "%^b" ref-time2 t)))
+ ;; strings truncate on the right or are blank-padded on the left
+ (should (equal (time-stamp-string "%0b" ref-time3) ""))
+ (should (equal (time-stamp-string "%1b" ref-time3) (substring May 0 1)))
+ (should (equal (time-stamp-string "%2b" ref-time3) (substring May 0 2)))
+ (should (equal (time-stamp-string "%3b" ref-time3) May))
+ (should (equal (time-stamp-string "%4b" ref-time3) (concat " " May)))
+ (should (equal (time-stamp-string "%0%" ref-time3) ""))
+ (should (equal (time-stamp-string "%1%" ref-time3) "%"))
+ (should (equal (time-stamp-string "%2%" ref-time3) " %"))
+ (should (equal (time-stamp-string "%9%" ref-time3) " %"))
+ (should (equal (time-stamp-string "%10%" ref-time3) " %"))
+ (should (equal (time-stamp-string "%#3a" ref-time3) SUN))
+ (should (equal (time-stamp-string "%#3b" ref-time2) NOV)))))
;;; Tests of helper functions
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index dad3642..949f735 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -734,5 +734,120 @@ Return nil if that can't be determined."
(match-string-no-properties 1))))))
process-tests--EMFILE-message)
+(ert-deftest process-tests/sentinel-called ()
+ "Check that sentinels are called after processes finish"
+ (let ((command (process-tests--emacs-command)))
+ (skip-unless command)
+ (dolist (conn-type '(pipe pty))
+ (ert-info ((format "Connection type: %s" conn-type))
+ (process-tests--with-processes processes
+ (let* ((calls ())
+ (process (make-process
+ :name "echo"
+ :command (process-tests--eval
+ command '(print "first"))
+ :noquery t
+ :connection-type conn-type
+ :coding 'utf-8-unix
+ :sentinel (lambda (process message)
+ (push (list process message)
+ calls)))))
+ (push process processes)
+ (while (accept-process-output process))
+ (should (equal calls
+ (list (list process "finished\n"))))))))))
+
+(ert-deftest process-tests/sentinel-with-multiple-processes ()
+ "Check that sentinels are called in time even when other processes
+have written output."
+ (let ((command (process-tests--emacs-command)))
+ (skip-unless command)
+ (dolist (conn-type '(pipe pty))
+ (ert-info ((format "Connection type: %s" conn-type))
+ (process-tests--with-processes processes
+ (let* ((calls ())
+ (process (make-process
+ :name "echo"
+ :command (process-tests--eval
+ command '(print "first"))
+ :noquery t
+ :connection-type conn-type
+ :coding 'utf-8-unix
+ :sentinel (lambda (process message)
+ (push (list process message)
+ calls)))))
+ (push process processes)
+ (push (make-process
+ :name "bash"
+ :command (process-tests--eval
+ command
+ '(progn (sleep-for 10) (print "second")))
+ :noquery t
+ :connection-type conn-type)
+ processes)
+ (while (accept-process-output process))
+ (should (equal calls
+ (list (list process "finished\n"))))))))))
+
+(defun process-tests--eval (command form)
+ "Return a command that evaluates FORM in an Emacs subprocess.
+COMMAND must be a list returned by
+`process-tests--emacs-command'."
+ (let ((print-gensym t)
+ (print-circle t)
+ (print-length nil)
+ (print-level nil)
+ (print-escape-control-characters t)
+ (print-escape-newlines t)
+ (print-escape-multibyte t)
+ (print-escape-nonascii t))
+ `(,@command "--quick" "--batch" ,(format "--eval=%S" form))))
+
+(defun process-tests--emacs-command ()
+ "Return a command to reinvoke the current Emacs instance.
+Return nil if that doesn't appear to be possible."
+ (when-let ((binary (process-tests--emacs-binary))
+ (dump (process-tests--dump-file)))
+ (cons binary
+ (unless (eq dump :not-needed)
+ (list (concat "--dump-file="
+ (file-name-unquote dump)))))))
+
+(defun process-tests--emacs-binary ()
+ "Return the filename of the currently running Emacs binary.
+Return nil if that can't be determined."
+ (and (stringp invocation-name)
+ (not (file-remote-p invocation-name))
+ (not (file-name-absolute-p invocation-name))
+ (stringp invocation-directory)
+ (not (file-remote-p invocation-directory))
+ (file-name-absolute-p invocation-directory)
+ (when-let ((file (process-tests--usable-file-for-reinvoke
+ (expand-file-name invocation-name
+ invocation-directory))))
+ (and (file-executable-p file) file))))
+
+(defun process-tests--dump-file ()
+ "Return the filename of the dump file used to start Emacs.
+Return nil if that can't be determined. Return `:not-needed' if
+Emacs wasn't started with a dump file."
+ (if-let ((stats (and (fboundp 'pdumper-stats) (pdumper-stats))))
+ (when-let ((file (process-tests--usable-file-for-reinvoke
+ (cdr (assq 'dump-file-name stats)))))
+ (and (file-readable-p file) file))
+ :not-needed))
+
+(defun process-tests--usable-file-for-reinvoke (filename)
+ "Return a version of FILENAME that can be used to reinvoke Emacs.
+Return nil if FILENAME doesn't exist."
+ (when (and (stringp filename)
+ (not (file-remote-p filename)))
+ (cl-callf file-truename filename)
+ (and (stringp filename)
+ (not (file-remote-p filename))
+ (file-name-absolute-p filename)
+ (file-regular-p filename)
+ filename)))
+
(provide 'process-tests)
;;; process-tests.el ends here
diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el
index ec96d77..4e7d2ad 100644
--- a/test/src/xdisp-tests.el
+++ b/test/src/xdisp-tests.el
@@ -75,31 +75,28 @@
(ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748
(with-temp-buffer
(insert "xxx")
- (let* ((window
- (display-buffer (current-buffer) '(display-buffer-in-child-frame .
nil)))
- (char-width (frame-char-width))
- (size (window-text-pixel-size nil t t)))
- (delete-frame (window-frame window))
- (should (equal (/ (car size) char-width) 3)))))
+ (switch-to-buffer (current-buffer))
+ (let* ((char-width (frame-char-width))
+ (size (window-text-pixel-size nil t t))
+ (width-in-chars (/ (car size) char-width)))
+ (should (equal width-in-chars 3)))))
(ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748
(with-temp-buffer
(insert " xx")
- (let* ((window
- (display-buffer (current-buffer) '(display-buffer-in-child-frame .
nil)))
- (char-width (frame-char-width))
- (size (window-text-pixel-size nil t t)))
- (delete-frame (window-frame window))
- (should (equal (/ (car size) char-width) 3)))))
+ (switch-to-buffer (current-buffer))
+ (let* ((char-width (frame-char-width))
+ (size (window-text-pixel-size nil t t))
+ (width-in-chars (/ (car size) char-width)))
+ (should (equal width-in-chars 3)))))
(ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748
(with-temp-buffer
(insert "xx ")
- (let* ((window
- (display-buffer (current-buffer) '(display-buffer-in-child-frame .
nil)))
- (char-width (frame-char-width))
- (size (window-text-pixel-size nil t t)))
- (delete-frame (window-frame window))
- (should (equal (/ (car size) char-width) 3)))))
+ (switch-to-buffer (current-buffer))
+ (let* ((char-width (frame-char-width))
+ (size (window-text-pixel-size nil t t))
+ (width-in-chars (/ (car size) char-width)))
+ (should (equal width-in-chars 3)))))
;;; xdisp-tests.el ends here
- scratch/etags-regen updated (153a549 -> f4a1d47), Dmitry Gutov, 2021/02/07
- scratch/etags-regen 8d00e2f 1/8: Merge branch 'master' into scratch/etags-regen, Dmitry Gutov, 2021/02/07
- scratch/etags-regen 1daad17 2/8: Merge branch 'master' into scratch/etags-regen,
Dmitry Gutov <=
- scratch/etags-regen 44f19c7 3/8: Merge branch 'master' into scratch/etags-regen, Dmitry Gutov, 2021/02/07
- scratch/etags-regen 25b2915 7/8: Introduce project-files-filtered and use it, Dmitry Gutov, 2021/02/07
- scratch/etags-regen f4a1d47 8/8: Brute force refresh implementation, Dmitry Gutov, 2021/02/07
- scratch/etags-regen 3098e47 4/8: Merge branch 'master' into scratch/etags-regen, Dmitry Gutov, 2021/02/07
- scratch/etags-regen 4f7b533 6/8: etags-regen--all-files: Extract to a separate function, Dmitry Gutov, 2021/02/07
- scratch/etags-regen f520e5d 5/8: Merge branch 'master' into scratch/etags-regen, Dmitry Gutov, 2021/02/07