Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-23 05:17:35 +00:00
Code Issues Projects Releases Packages Wiki Activity

Rework gnus-search-indexed-parse-output

Browse source 
* lisp/gnus/gnus-search.el (gnus-search-indexed-parse-output): Be more
careful about matching filesystem paths to Gnus group names; make
absolutely sure that we only return valid article numbers.
This commit is contained in:
Eric Abrahamsen 2021-06-26 10:16:19 -07:00
parent 0897ade8f9
commit e7f6bb38dd
1 changed files with 43 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

95
lisp/gnus/gnus-search.el
View file

@ -1351,68 +1351,59 @@ Returns a list of [group article score] vectors."
(cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed)
server query &optional groups)
(let ((prefix (slot-value engine 'remove-prefix))
(group-regexp (when groups
(mapconcat
(lambda (group-name)
(mapconcat #'regexp-quote
(split-string
(gnus-group-real-name group-name)
"[.\\/]")
"[.\\\\/]"))
groups
"\\|")))
artlist vectors article group)
(let ((prefix (or (slot-value engine 'remove-prefix)
""))
artlist article group)
(goto-char (point-min))
;; Prep prefix, we want to at least be removing the root
;; filesystem separator.
(when (stringp prefix)
(setq prefix (file-name-as-directory
(expand-file-name prefix "/"))))
(while (not (or (eobp)
(looking-at-p
"\\(?:[[:space:]\n]+\\)?Process .+ finished")))
(pcase-let ((`(,f-name ,score) (gnus-search-indexed-extract engine)))
(when (and f-name
(file-readable-p f-name)
(null (file-directory-p f-name))
(or (null groups)
(and (gnus-search-single-p query)
(alist-get 'thread query))
(string-match-p group-regexp f-name)))
(push (list f-name score) artlist))))
(null (file-directory-p f-name)))
(setq group
(replace-regexp-in-string
"[/\\]" "."
(replace-regexp-in-string
"/?\\(cur\\|new\\|tmp\\)?/\\'" ""
(replace-regexp-in-string
"\\`\\." ""
(string-remove-prefix
prefix (file-name-directory f-name))
nil t)
nil t)
nil t))
(setq group (gnus-group-full-name group server))
(setq article (file-name-nondirectory f-name)
article
;; TODO: Provide a cleaner way of producing final
;; article numbers for the various backends.
(if (string-match-p "\\`[[:digit:]]+\\'" article)
(string-to-number article)
(nnmaildir-base-name-to-article-number
(substring article 0 (string-match ":" article))
group (string-remove-prefix "nnmaildir:" server))))
(when (and (numberp article)
(or (null groups)
(member group groups)))
(push (list f-name article group score)
artlist)))))
;; Are we running an additional grep query?
(when-let ((grep-reg (alist-get 'grep query)))
(setq artlist (gnus-search-grep-search engine artlist grep-reg)))
;; Prep prefix.
(when (and prefix (null (string-empty-p prefix)))
(setq prefix (file-name-as-directory (expand-file-name prefix))))
;; Turn (file-name score) into [group article score].
(pcase-dolist (`(,f-name ,score) artlist)
(setq article (file-name-nondirectory f-name)
group (file-name-directory f-name))
;; Remove prefix.
(when prefix
(setq group (string-remove-prefix prefix group)))
;; Break the directory name down until it's something that
;; (probably) can be used as a group name.
(setq group
(replace-regexp-in-string
"[/\\]" "."
(replace-regexp-in-string
"/?\\(cur\\|new\\|tmp\\)?/\\'" ""
(replace-regexp-in-string
"^[./\\]" ""
group nil t)
nil t)
nil t))
(push (vector (gnus-group-full-name group server)
(if (string-match-p "\\`[[:digit:]]+\\'" article)
(string-to-number article)
(nnmaildir-base-name-to-article-number
(substring article 0 (string-match ":" article))
group (string-remove-prefix "nnmaildir:" server)))
(if (numberp score)
score
(string-to-number score)))
vectors))
vectors))
;; Munge into the list of vectors expected by nnselect.
(mapcar (pcase-lambda (`(,_ ,article ,group ,score))
(vector group article
(if (numberp score)
score
(string-to-number score))))
artlist)))
(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-indexed))
"Base implementation treats the whole line as a filename, and