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

Change Gnus hash tables into real hash tables

Browse source 
Gnus has used obarrays as makeshift hash tables for groups: group
names are coerced to unibyte and interned in custom obarrays, and
their symbol-value set to whatever value needs to be stored. This
patch replaces those obarrays with actual hash tables.

* lisp/gnus/gnus-util.el (gnus-intern-safe, gnus-create-hash-size):
  Remove functions.
  (gnus-make-hashtable): Change to return a real hash table.
  (gnus-text-property-search): Utility similar to `text-property-any',
  but compares on `equal'. Needed because the 'gnus-group text
  property is now a string.
* lisp/gnus/gnus.el (gnus-gethash, gnus-gethash-safe, gnus-sethash):
  Remove macros.
  (gnus-group-list): New variable holding all group names as an
  ordered list. Used because `gnus-newsrc-hashtb' used to preserve
  `gnus-newsrc-alist' ordering, but now doesn't.
* lisp/gnus/nnmaildir.el (nnmaildir--servers): Change from obarray to
  alist.
  (nnmaildir--up2-1): Remove function.
* lisp/thingatpt.el (thing-at-point-newsgroup-p): This was making use
  of Gnus obarrays, replace with a cond that can handle many different
  possibilities.
* lisp/gnus/gnus-bcklg.el (gnus-backlog-articles): Remove
  gnus-backlog-hashtb, which wasn't doing anything. Just keep a list
  of ident strings in gnus-backlog-articles.
  (gnus-backlog-setup): Delete unnecessary function.
  (gnus-backlog-enter-article, gnus-backlog-remove-oldest-article,
  gnus-backlog-remove-article, gnus-backlog-request-article): Alter
  calls accordingly.
* lisp/gnus/gnus-dup.el (gnus-duplicate-list-max-length): Rename from
  `gnus-duplicate-list-length', for accuracy.
* lisp/gnus/gnus-start.el (gnus-active-to-gnus-format,
  gnus-groups-to-gnus-format, gnus-newsrc-to-gnus-format): Read group
  names as strings.
  (gnus-gnus-to-quick-newsrc-format): Write `gnus-newsrc-alist' using
  the ordering in `gnus-group-list'.
* lisp/gnus/gnus-agent.el:
* lisp/gnus/gnus-async.el:
* lisp/gnus/gnus-cache.el:
* lisp/gnus/gnus-group.el:
* lisp/gnus/gnus-score.el:
* lisp/gnus/gnus-sum.el:
* lisp/gnus/gnus-topic.el:
* lisp/gnus/message.el:
* lisp/gnus/mml.el:
* lisp/gnus/nnagent.el:
* lisp/gnus/nnbabyl.el:
* lisp/gnus/nnvirtual.el:
* lisp/gnus/nnweb.el: In all files, change obarrays to hash-tables,
  and swap `gnus-sethash' for `puthash', `gnus-gethash' for `gethash',
  `mapatoms' for `maphash', etc.
* test/lisp/gnus/gnus-test-headers.el (gnus-headers-make-dependency-table,
  gnus-headers-loop-dependencies): New tests to make sure we're
  building `gnus-newsgroup-dependencies' correctly.
This commit is contained in:
Eric Abrahamsen 2018-04-26 16:26:27 -07:00
parent 3375d08299
commit c1b63af445
20 changed files with 1155 additions and 1073 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -225,7 +225,9 @@ NOTES:
(defvar gnus-agent-overview-buffer nil) (defvar gnus-agent-overview-buffer nil)
(defvar gnus-category-predicate-cache nil) (defvar gnus-category-predicate-cache nil)
(defvar gnus-category-group-cache nil) (defvar gnus-category-group-cache nil)
(defvar gnus-agent-spam-hashtb nil) (defvar gnus-agent-spam-hashtb nil
"Cache of message subjects for spam messages.
Actually a hash table holding subjects mapped to t.")
(defvar gnus-agent-file-name nil) (defvar gnus-agent-file-name nil)
(defvar gnus-agent-file-coding-system 'raw-text) (defvar gnus-agent-file-coding-system 'raw-text)
(defvar gnus-agent-file-loading-cache nil) (defvar gnus-agent-file-loading-cache nil)
@ -642,8 +644,8 @@ minor mode in all Gnus buffers."
(defun gnus-agent-queue-setup (&optional group-name) (defun gnus-agent-queue-setup (&optional group-name)
"Make sure the queue group exists. "Make sure the queue group exists.
Optional arg GROUP-NAME allows another group to be specified." Optional arg GROUP-NAME allows another group to be specified."
(unless (gnus-gethash (format "nndraft:%s" (or group-name "queue")) (unless (gethash (format "nndraft:%s" (or group-name "queue"))
gnus-newsrc-hashtb) gnus-newsrc-hashtb)
(gnus-request-create-group (or group-name "queue") '(nndraft "")) (gnus-request-create-group (or group-name "queue") '(nndraft ""))
(let ((gnus-level-default-subscribed 1)) (let ((gnus-level-default-subscribed 1))
(gnus-subscribe-group (format "nndraft:%s" (or group-name "queue")) (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue"))
@ -1330,11 +1332,11 @@ downloaded into the agent."
(when (re-search-forward (when (re-search-forward
(concat "^" (regexp-quote group) " ") nil t) (concat "^" (regexp-quote group) " ") nil t)
(save-excursion (save-excursion
(setq oactive-max (read (current-buffer)) ;; max (setq oactive-max (read (current-buffer)) ;; max
oactive-min (read (current-buffer)))) ;; min oactive-min (read (current-buffer)))) ;; min
(gnus-delete-line))) (gnus-delete-line)))
(when active (when active
(insert (format "%S %d %d y\n" (intern group) (insert (format "%s %d %d y\n" group
(max (or oactive-max (cdr active)) (cdr active)) (max (or oactive-max (cdr active)) (cdr active))
(min (or oactive-min (car active)) (car active)))) (min (or oactive-min (car active)) (car active))))
(goto-char (point-max)) (goto-char (point-max))
@ -2161,7 +2163,10 @@ doesn't exist, to valid the overview buffer."
(gnus-agent-update-view-total-fetched-for group nil))) (gnus-agent-update-view-total-fetched-for group nil)))
(defvar gnus-agent-article-local nil) ;; FIXME: Why would this be a hash table? Wouldn't a simple alist or
;; something suffice?
(defvar gnus-agent-article-local nil
"Hashtable holding information about a group.")
(defvar gnus-agent-article-local-times nil) (defvar gnus-agent-article-local-times nil)
(defvar gnus-agent-file-loading-local nil) (defvar gnus-agent-file-loading-local nil)
@ -2173,12 +2178,12 @@ article counts for each of the method's subscribed groups."
(zerop gnus-agent-article-local-times) (zerop gnus-agent-article-local-times)
(not (gnus-methods-equal-p (not (gnus-methods-equal-p
gnus-command-method gnus-command-method
(symbol-value (intern "+method" gnus-agent-article-local))))) (gethash "+method" gnus-agent-article-local))))
(setq gnus-agent-article-local (setq gnus-agent-article-local
(gnus-cache-file-contents (gnus-cache-file-contents
(gnus-agent-lib-file "local") (gnus-agent-lib-file "local")
'gnus-agent-file-loading-local 'gnus-agent-file-loading-local
'gnus-agent-read-and-cache-local)) #'gnus-agent-read-and-cache-local))
(when gnus-agent-article-local-times (when gnus-agent-article-local-times
(cl-incf gnus-agent-article-local-times))) (cl-incf gnus-agent-article-local-times)))
gnus-agent-article-local)) gnus-agent-article-local))
@ -2188,14 +2193,15 @@ article counts for each of the method's subscribed groups."
gnus-agent-article-local. If that variable had `dirty' (also known as gnus-agent-article-local. If that variable had `dirty' (also known as
modified) original contents, they are first saved to their own file." modified) original contents, they are first saved to their own file."
(if (and gnus-agent-article-local (if (and gnus-agent-article-local
(symbol-value (intern "+dirty" gnus-agent-article-local))) (gethash "+dirty" gnus-agent-article-local))
(gnus-agent-save-local)) (gnus-agent-save-local))
(gnus-agent-read-local file)) (gnus-agent-read-local file))
(defun gnus-agent-read-local (file) (defun gnus-agent-read-local (file)
"Load FILE and do a `read' there." "Load FILE and do a `read' there."
(let ((my-obarray (gnus-make-hashtable (count-lines (point-min) (let ((hashtb (gnus-make-hashtable
(point-max)))) (count-lines (point-min)
(point-max))))
(line 1)) (line 1))
(with-temp-buffer (with-temp-buffer
(condition-case nil (condition-case nil
@ -2204,7 +2210,8 @@ modified) original contents, they are first saved to their own file."
(file-error)) (file-error))
(goto-char (point-min)) (goto-char (point-min))
;; Skip any comments at the beginning of the file (the only place where they may appear) ;; Skip any comments at the beginning of the file (the only
;; place where they may appear)
(while (= (following-char) ?\;) (while (= (following-char) ?\;)
(forward-line 1) (forward-line 1)
(setq line (1+ line))) (setq line (1+ line)))
@ -2214,33 +2221,32 @@ modified) original contents, they are first saved to their own file."
(let (group (let (group
min min
max max
(cur (current-buffer)) (cur (current-buffer)))
(obarray my-obarray))
(setq group (read cur) (setq group (read cur)
min (read cur) min (read cur)
max (read cur)) max (read cur))
(when (stringp group) (unless (stringp group)
(setq group (intern group my-obarray))) (setq group (symbol-name group)))
;; NOTE: The '+ 0' ensure that min and max are both numerics. ;; NOTE: The '+ 0' ensure that min and max are both numerics.
(set group (cons (+ 0 min) (+ 0 max)))) (puthash group (cons (+ 0 min) (+ 0 max)) hashtb))
(error (error
(gnus-message 3 "Warning - invalid agent local: %s on line %d: %s" (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s"
file line (error-message-string err)))) file line (error-message-string err))))
(forward-line 1) (forward-line 1)
(setq line (1+ line)))) (setq line (1+ line))))
(set (intern "+dirty" my-obarray) nil) (puthash "+dirty" nil hashtb)
(set (intern "+method" my-obarray) gnus-command-method) (puthash "+method" gnus-command-method hashtb)
my-obarray)) hashtb))
(defun gnus-agent-save-local (&optional force) (defun gnus-agent-save-local (&optional force)
"Save gnus-agent-article-local under it method's agent.lib directory." "Save gnus-agent-article-local under it method's agent.lib directory."
(let ((my-obarray gnus-agent-article-local)) (let ((hashtb gnus-agent-article-local))
(when (and my-obarray (when (and hashtb
(or force (symbol-value (intern "+dirty" my-obarray)))) (or force (gethash "+dirty" hashtb)))
(let* ((gnus-command-method (symbol-value (intern "+method" my-obarray))) (let* ((gnus-command-method (gethash "+method" hashtb))
;; NOTE: gnus-command-method is used within gnus-agent-lib-file. ;; NOTE: gnus-command-method is used within gnus-agent-lib-file.
(dest (gnus-agent-lib-file "local"))) (dest (gnus-agent-lib-file "local")))
(gnus-make-directory (gnus-agent-lib-file "")) (gnus-make-directory (gnus-agent-lib-file ""))
@ -2248,31 +2254,30 @@ modified) original contents, they are first saved to their own file."
(let ((coding-system-for-write gnus-agent-file-coding-system) (let ((coding-system-for-write gnus-agent-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system)) (file-name-coding-system nnmail-pathname-coding-system))
(with-temp-file dest (with-temp-file dest
(let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) ;; FIXME: Why are we letting this again?
(let ((gnus-command-method (gethash "+method" hashtb))
print-level print-length print-level print-length
(standard-output (current-buffer))) (standard-output (current-buffer)))
(mapatoms (lambda (symbol) (maphash (lambda (group active)
(cond ((not (boundp symbol)) (cond ((null active)
nil) nil)
((member (symbol-name symbol) '("+dirty" "+method")) ((member group '("+dirty" "+method"))
nil) nil)
(t (t
(let ((range (symbol-value symbol))) (when active
(when range (prin1 group)
(prin1 symbol) (princ " ")
(princ " ") (princ (car active))
(princ (car range)) (princ " ")
(princ " ") (princ (cdr active))
(princ (cdr range)) (princ "\n")))))
(princ "\n")))))) hashtb))))))))
my-obarray))))))))
(defun gnus-agent-get-local (group &optional gmane method) (defun gnus-agent-get-local (group &optional gmane method)
(let* ((gmane (or gmane (gnus-group-real-name group))) (let* ((gmane (or gmane (gnus-group-real-name group)))
(gnus-command-method (or method (gnus-find-method-for-group group))) (gnus-command-method (or method (gnus-find-method-for-group group)))
(local (gnus-agent-load-local)) (local (gnus-agent-load-local))
(symb (intern gmane local)) (minmax (gethash gmane local)))
(minmax (and (boundp symb) (symbol-value symb))))
(unless minmax (unless minmax
;; Bind these so that gnus-agent-load-alist doesn't change the ;; Bind these so that gnus-agent-load-alist doesn't change the
;; current alist (i.e. gnus-agent-article-alist) ;; current alist (i.e. gnus-agent-article-alist)
@ -2291,24 +2296,23 @@ modified) original contents, they are first saved to their own file."
(let* ((gmane (or gmane (gnus-group-real-name group))) (let* ((gmane (or gmane (gnus-group-real-name group)))
(gnus-command-method (or method (gnus-find-method-for-group group))) (gnus-command-method (or method (gnus-find-method-for-group group)))
(local (or local (gnus-agent-load-local))) (local (or local (gnus-agent-load-local)))
(symb (intern gmane local)) (minmax (gethash gmane local)))
(minmax (and (boundp symb) (symbol-value symb))))
(if (cond ((and minmax (if (cond ((and minmax
(or (not (eq min (car minmax))) (or (not (eq min (car minmax)))
(not (eq max (cdr minmax)))) (not (eq max (cdr minmax))))
min min
max) max)
(setcar minmax min) (setcar (gethash gmane local) min)
(setcdr minmax max) (setcdr (gethash gmane local) max)
t) t)
(minmax (minmax
nil) nil)
((and min max) ((and min max)
(set symb (cons min max)) (puthash gmane (cons min max) local)
t) t)
(t (t
(unintern symb local))) (remhash gmane local)))
(set (intern "+dirty" local) t)))) (puthash "+dirty" t local))))
(defun gnus-agent-article-name (article group) (defun gnus-agent-article-name (article group)
(expand-file-name article (expand-file-name article
@ -2878,8 +2882,8 @@ The following commands are available:
nil nil
(let ((string (gnus-simplify-subject (mail-header-subject gnus-headers)))) (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers))))
(prog1 (prog1
(gnus-gethash string gnus-agent-spam-hashtb) (gethash string gnus-agent-spam-hashtb)
(gnus-sethash string t gnus-agent-spam-hashtb))))) (puthash string t gnus-agent-spam-hashtb)))))
(defun gnus-agent-short-p () (defun gnus-agent-short-p ()
"Say whether an article is short or not." "Say whether an article is short or not."
@ -3007,13 +3011,13 @@ articles."
(unless gnus-category-group-cache (unless gnus-category-group-cache
(setq gnus-category-group-cache (gnus-make-hashtable 1000)) (setq gnus-category-group-cache (gnus-make-hashtable 1000))
(let ((cs gnus-category-alist) (let ((cs gnus-category-alist)
groups cat) groups)
(while (setq cat (pop cs)) (dolist (cat cs)
(setq groups (gnus-agent-cat-groups cat)) (setq groups (gnus-agent-cat-groups cat))
(while groups (dolist (g groups)
(gnus-sethash (pop groups) cat gnus-category-group-cache))))) (puthash g cat gnus-category-group-cache)))))
(or (gnus-gethash group gnus-category-group-cache) (gethash group gnus-category-group-cache
(assq 'default gnus-category-alist))) (assq 'default gnus-category-alist)))
(defvar gnus-agent-expire-current-dirs) (defvar gnus-agent-expire-current-dirs)
(defvar gnus-agent-expire-stats) (defvar gnus-agent-expire-stats)
@ -3053,7 +3057,7 @@ FORCE is equivalent to setting the expiration predicates to true."
(count-lines (point-min) (point-max)))))) (count-lines (point-min) (point-max))))))
(save-excursion (save-excursion
(gnus-agent-expire-group-1 (gnus-agent-expire-group-1
group overview (gnus-gethash-safe group orig) group overview (gethash group orig)
articles force)))) articles force))))
(kill-buffer overview)))) (kill-buffer overview))))
(gnus-message 4 "%s" (gnus-agent-expire-done-message))))) (gnus-message 4 "%s" (gnus-agent-expire-done-message)))))
@ -3471,9 +3475,7 @@ articles in every agentized group? "))
(count-lines (point-min) (point-max)))))) (count-lines (point-min) (point-max))))))
(dolist (expiring-group (gnus-groups-from-server (dolist (expiring-group (gnus-groups-from-server
gnus-command-method)) gnus-command-method))
(let* ((active (let ((active (gethash expiring-group orig)))
(gnus-gethash-safe expiring-group orig)))
(when active (when active
(save-excursion (save-excursion
(gnus-agent-expire-group-1 (gnus-agent-expire-group-1
@ -3503,83 +3505,80 @@ articles in every agentized group? "))
(defun gnus-agent-expire-unagentized-dirs () (defun gnus-agent-expire-unagentized-dirs ()
(when (and gnus-agent-expire-unagentized-dirs (when (and gnus-agent-expire-unagentized-dirs
(boundp 'gnus-agent-expire-current-dirs)) (boundp 'gnus-agent-expire-current-dirs))
(let* ((keep (gnus-make-hashtable)) (let ((file-name-coding-system nnmail-pathname-coding-system)
(file-name-coding-system nnmail-pathname-coding-system)) ;; Another hash table that could just be a list.
(keep (gnus-make-hashtable 20))
(gnus-sethash gnus-agent-directory t keep) to-remove)
(puthash gnus-agent-directory t keep)
(dolist (dir gnus-agent-expire-current-dirs) (dolist (dir gnus-agent-expire-current-dirs)
(when (and (stringp dir) (when (and (stringp dir)
(file-directory-p dir)) (file-directory-p dir))
(while (not (gnus-gethash dir keep)) (while (not (gethash dir keep))
(gnus-sethash dir t keep) (puthash dir t keep)
(setq dir (file-name-directory (directory-file-name dir)))))) (setq dir (file-name-directory (directory-file-name dir))))))
(let* (to-remove (cl-labels ((checker
checker (d)
(checker ;; Given a directory, check it and its subdirectories
(function ;; for membership in the keep list. If it isn't found,
(lambda (d) ;; add it to to-remove.
"Given a directory, check it and its subdirectories for (let ((files (directory-files d))
membership in the keep hash. If it isn't found, add file)
it to to-remove." (while (setq file (pop files))
(let ((files (directory-files d)) (cond ((equal file ".") ; Ignore self
file) nil)
(while (setq file (pop files)) ((equal file "..") ; Ignore parent
(cond ((equal file ".") ; Ignore self nil)
nil) ((equal file ".overview")
((equal file "..") ; Ignore parent ;; Directory must contain .overview to be
nil) ;; agent's cache of a group.
((equal file ".overview") (let ((d (file-name-as-directory d))
;; Directory must contain .overview to be r)
;; agent's cache of a group. ;; Search ancestors for last directory NOT
(let ((d (file-name-as-directory d)) ;; found in keep.
r) (while (not (gethash (setq d (file-name-directory d)) keep))
;; Search ancestor's for last directory NOT (setq r d
;; found in keep hash. d (directory-file-name d)))
(while (not (gnus-gethash ;; if ANY ancestor was NOT in keep hash and
(setq d (file-name-directory d)) keep)) ;; it's not already in to-remove, add it to
(setq r d ;; to-remove.
d (directory-file-name d))) (if (and r
;; if ANY ancestor was NOT in keep hash and (not (member r to-remove)))
;; it's not already in to-remove, add it to (push r to-remove))))
;; to-remove. ((file-directory-p (setq file (nnheader-concat d file)))
(if (and r (checker file)))))))
(not (member r to-remove))) (checker (expand-file-name gnus-agent-directory)))
(push r to-remove))))
((file-directory-p (setq file (nnheader-concat d file)))
(funcall checker file)))))))))
(funcall checker (expand-file-name gnus-agent-directory))
(when (and to-remove (when (and to-remove
(or gnus-expert-user (or gnus-expert-user
(gnus-y-or-n-p (gnus-y-or-n-p
"gnus-agent-expire has identified local directories that are\ "gnus-agent-expire has identified local directories that are\
not currently required by any agentized group. Do you wish to consider\ not currently required by any agentized group. Do you wish to consider\
deleting them?"))) deleting them?")))
(while to-remove (while to-remove
(let ((dir (pop to-remove))) (let ((dir (pop to-remove)))
(if (or gnus-expert-user (if (or gnus-expert-user
(gnus-y-or-n-p (format "Delete %s? " dir))) (gnus-y-or-n-p (format "Delete %s? " dir)))
(let* (delete-recursive (let* (delete-recursive
files f files f
(delete-recursive (delete-recursive
(function (function
(lambda (f-or-d) (lambda (f-or-d)
(ignore-errors (ignore-errors
(if (file-directory-p f-or-d) (if (file-directory-p f-or-d)
(condition-case nil (condition-case nil
(delete-directory f-or-d) (delete-directory f-or-d)
(file-error (file-error
(setq files (directory-files f-or-d)) (setq files (directory-files f-or-d))
(while files (while files
(setq f (pop files)) (setq f (pop files))
(or (member f '("." "..")) (or (member f '("." ".."))
(funcall delete-recursive (funcall delete-recursive
(nnheader-concat (nnheader-concat
f-or-d f)))) f-or-d f))))
(delete-directory f-or-d))) (delete-directory f-or-d)))
(delete-file f-or-d))))))) (delete-file f-or-d)))))))
(funcall delete-recursive dir)))))))))) (funcall delete-recursive dir)))))))))
;;;###autoload ;;;###autoload
(defun gnus-agent-batch () (defun gnus-agent-batch ()
@ -4097,8 +4096,8 @@ agent has fetched."
;; if null, gnus-agent-group-pathname will calc method. ;; if null, gnus-agent-group-pathname will calc method.
(let* ((gnus-command-method method) (let* ((gnus-command-method method)
(path (or path (gnus-agent-group-pathname group))) (path (or path (gnus-agent-group-pathname group)))
(entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) (entry (or (gethash path gnus-agent-total-fetched-hashtb)
(gnus-sethash path (make-list 3 0) (puthash path (make-list 3 0)
gnus-agent-total-fetched-hashtb))) gnus-agent-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system)) (file-name-coding-system nnmail-pathname-coding-system))
(when (file-exists-p path) (when (file-exists-p path)
@ -4128,7 +4127,7 @@ agent has fetched."
(cl-incf (nth 2 entry) delta)))))) (cl-incf (nth 2 entry) delta))))))
(defun gnus-agent-update-view-total-fetched-for (defun gnus-agent-update-view-total-fetched-for
(group agent-over &optional method path) (group agent-over &optional method path)
"Update, or set, the total disk space used by the .agentview and "Update, or set, the total disk space used by the .agentview and
.overview files. These files are calculated separately as they can be .overview files. These files are calculated separately as they can be
modified." modified."
@ -4138,9 +4137,9 @@ modified."
;; if null, gnus-agent-group-pathname will calc method. ;; if null, gnus-agent-group-pathname will calc method.
(let* ((gnus-command-method method) (let* ((gnus-command-method method)
(path (or path (gnus-agent-group-pathname group))) (path (or path (gnus-agent-group-pathname group)))
(entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) (entry (or (gethash path gnus-agent-total-fetched-hashtb)
(gnus-sethash path (make-list 3 0) (puthash path (make-list 3 0)
gnus-agent-total-fetched-hashtb))) gnus-agent-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system) (file-name-coding-system nnmail-pathname-coding-system)
(size (or (file-attribute-size (file-attributes (size (or (file-attribute-size (file-attributes
(nnheader-concat (nnheader-concat
@ -4155,12 +4154,13 @@ modified."
"Get the total disk space used by the specified GROUP." "Get the total disk space used by the specified GROUP."
(unless (equal group "dummy.group") (unless (equal group "dummy.group")
(unless gnus-agent-total-fetched-hashtb (unless gnus-agent-total-fetched-hashtb
(setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024))) (setq gnus-agent-total-fetched-hashtb
(gnus-make-hashtable 1000)))
;; if null, gnus-agent-group-pathname will calc method. ;; if null, gnus-agent-group-pathname will calc method.
(let* ((gnus-command-method method) (let* ((gnus-command-method method)
(path (gnus-agent-group-pathname group)) (path (gnus-agent-group-pathname group))
(entry (gnus-gethash path gnus-agent-total-fetched-hashtb))) (entry (gethash path gnus-agent-total-fetched-hashtb)))
(if entry (if entry
(apply '+ entry) (apply '+ entry)
(let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit))) (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit)))

29
lisp/gnus/gnus-async.el
View file

@ -84,7 +84,6 @@ that was fetched."
(defvar gnus-async-article-alist nil) (defvar gnus-async-article-alist nil)
(defvar gnus-async-article-semaphore '(nil)) (defvar gnus-async-article-semaphore '(nil))
(defvar gnus-async-fetch-list nil) (defvar gnus-async-fetch-list nil)
(defvar gnus-async-hashtb nil)
(defvar gnus-async-current-prefetch-group nil) (defvar gnus-async-current-prefetch-group nil)
(defvar gnus-async-current-prefetch-article nil) (defvar gnus-async-current-prefetch-article nil)
(defvar gnus-async-timer nil) (defvar gnus-async-timer nil)
@ -127,14 +126,11 @@ that was fetched."
(defun gnus-async-close () (defun gnus-async-close ()
(gnus-kill-buffer gnus-async-prefetch-article-buffer) (gnus-kill-buffer gnus-async-prefetch-article-buffer)
(gnus-kill-buffer gnus-async-prefetch-headers-buffer) (gnus-kill-buffer gnus-async-prefetch-headers-buffer)
(setq gnus-async-hashtb nil (setq gnus-async-article-alist nil
gnus-async-article-alist nil
gnus-async-header-prefetched nil)) gnus-async-header-prefetched nil))
(defun gnus-async-set-buffer () (defun gnus-async-set-buffer ()
(nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t) (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t))
(unless gnus-async-hashtb
(setq gnus-async-hashtb (gnus-make-hashtable 1023))))
(defun gnus-async-halt-prefetch () (defun gnus-async-halt-prefetch ()
"Stop prefetching." "Stop prefetching."
@ -242,13 +238,10 @@ that was fetched."
(when gnus-async-post-fetch-function (when gnus-async-post-fetch-function
(funcall gnus-async-post-fetch-function summary)))) (funcall gnus-async-post-fetch-function summary))))
(gnus-async-with-semaphore (gnus-async-with-semaphore
(setq (push (list (format "%s-%d" group article)
gnus-async-article-alist mark (point-max-marker)
(cons (list (intern (format "%s-%d" group article) group article)
gnus-async-hashtb) gnus-async-article-alist)))
mark (point-max-marker)
group article)
gnus-async-article-alist))))
(if (not (gnus-buffer-live-p summary)) (if (not (gnus-buffer-live-p summary))
(gnus-async-with-semaphore (gnus-async-with-semaphore
(setq gnus-async-fetch-list nil)) (setq gnus-async-fetch-list nil))
@ -314,8 +307,7 @@ that was fetched."
(set-marker (caddr entry) nil)) (set-marker (caddr entry) nil))
(gnus-async-with-semaphore (gnus-async-with-semaphore
(setq gnus-async-article-alist (setq gnus-async-article-alist
(delq entry gnus-async-article-alist)) (delete entry gnus-async-article-alist))))
(unintern (car entry) gnus-async-hashtb)))
(defun gnus-async-prefetch-remove-group (group) (defun gnus-async-prefetch-remove-group (group)
"Remove all articles belonging to GROUP from the prefetch buffer." "Remove all articles belonging to GROUP from the prefetch buffer."
@ -331,9 +323,8 @@ that was fetched."
"Return the entry for ARTICLE in GROUP if it has been prefetched." "Return the entry for ARTICLE in GROUP if it has been prefetched."
(let ((entry (save-excursion (let ((entry (save-excursion
(gnus-async-set-buffer) (gnus-async-set-buffer)
(assq (intern-soft (format "%s-%d" group article) (assoc (format "%s-%d" group article)
gnus-async-hashtb) gnus-async-article-alist))))
gnus-async-article-alist))))
;; Perhaps something has emptied the buffer? ;; Perhaps something has emptied the buffer?
(if (and entry (if (and entry
(= (cadr entry) (caddr entry))) (= (cadr entry) (caddr entry)))
@ -342,7 +333,7 @@ that was fetched."
(set-marker (cadr entry) nil) (set-marker (cadr entry) nil)
(set-marker (caddr entry) nil)) (set-marker (caddr entry) nil))
(setq gnus-async-article-alist (setq gnus-async-article-alist
(delq entry gnus-async-article-alist)) (delete entry gnus-async-article-alist))
nil) nil)
entry))) entry)))

114
lisp/gnus/gnus-bcklg.el
View file

@ -22,17 +22,16 @@
;;; Commentary: ;;; Commentary:
;; The backlog caches the text of a certain number of read articles in
;; a separate buffer, so they can be retrieved quickly if the user
;; opens them again. Also see `gnus-keep-backlog'.
;;; Code: ;;; Code:
(require 'gnus) (require 'gnus)
;;;
;;; Buffering of read articles.
;;;
(defvar gnus-backlog-buffer " *Gnus Backlog*") (defvar gnus-backlog-buffer " *Gnus Backlog*")
(defvar gnus-backlog-articles nil) (defvar gnus-backlog-articles '())
(defvar gnus-backlog-hashtb nil)
(defun gnus-backlog-buffer () (defun gnus-backlog-buffer ()
"Return the backlog buffer." "Return the backlog buffer."
@ -42,11 +41,6 @@
(setq buffer-read-only t) (setq buffer-read-only t)
(get-buffer gnus-backlog-buffer)))) (get-buffer gnus-backlog-buffer))))
(defun gnus-backlog-setup ()
"Initialize backlog variables."
(unless gnus-backlog-hashtb
(setq gnus-backlog-hashtb (gnus-make-hashtable 1024))))
(gnus-add-shutdown 'gnus-backlog-shutdown 'gnus) (gnus-add-shutdown 'gnus-backlog-shutdown 'gnus)
(defun gnus-backlog-shutdown () (defun gnus-backlog-shutdown ()
@ -54,46 +48,42 @@
(interactive) (interactive)
(when (get-buffer gnus-backlog-buffer) (when (get-buffer gnus-backlog-buffer)
(gnus-kill-buffer gnus-backlog-buffer)) (gnus-kill-buffer gnus-backlog-buffer))
(setq gnus-backlog-hashtb nil (setq gnus-backlog-articles nil))
gnus-backlog-articles nil))
(defun gnus-backlog-enter-article (group number buffer) (defun gnus-backlog-enter-article (group number buffer)
(when (and (numberp number) (when (and (numberp number)
(not (gnus-virtual-group-p group))) (not (gnus-virtual-group-p group)))
(gnus-backlog-setup) (let ((ident (format "%s:%d" group number))
(let ((ident (intern (concat group ":" (int-to-string number))
gnus-backlog-hashtb))
b) b)
(if (memq ident gnus-backlog-articles) (unless (member ident gnus-backlog-articles) ; It's already kept.
() ; It's already kept. ;; Remove the oldest article, if necessary.
;; Remove the oldest article, if necessary. (and (numberp gnus-keep-backlog)
(and (numberp gnus-keep-backlog) (>= (length gnus-backlog-articles) gnus-keep-backlog)
(>= (length gnus-backlog-articles) gnus-keep-backlog) (gnus-backlog-remove-oldest-article))
(gnus-backlog-remove-oldest-article)) (push ident gnus-backlog-articles)
(push ident gnus-backlog-articles) ;; Insert the new article.
;; Insert the new article. (with-current-buffer (gnus-backlog-buffer)
(with-current-buffer (gnus-backlog-buffer) (let (buffer-read-only)
(let (buffer-read-only) (goto-char (point-max))
(goto-char (point-max)) (unless (bolp)
(unless (bolp) (insert "\n"))
(insert "\n")) (setq b (point))
(setq b (point)) (insert-buffer-substring buffer)
(insert-buffer-substring buffer) ;; Tag the beginning of the article with the ident.
;; Tag the beginning of the article with the ident. (if (> (point-max) b)
(if (> (point-max) b) (put-text-property b (1+ b) 'gnus-backlog ident)
(put-text-property b (1+ b) 'gnus-backlog ident) (gnus-error 3 "Article %d is blank" number))))))))
(gnus-error 3 "Article %d is blank" number))))))))
(defun gnus-backlog-remove-oldest-article () (defun gnus-backlog-remove-oldest-article ()
(with-current-buffer (gnus-backlog-buffer) (with-current-buffer (gnus-backlog-buffer)
(goto-char (point-min)) (goto-char (point-min))
(if (zerop (buffer-size)) (unless (zerop (buffer-size)) ; The buffer is empty.
() ; The buffer is empty.
(let ((ident (get-text-property (point) 'gnus-backlog)) (let ((ident (get-text-property (point) 'gnus-backlog))
buffer-read-only) buffer-read-only)
;; Remove the ident from the list of articles. ;; Remove the ident from the list of articles.
(when ident (when ident
(setq gnus-backlog-articles (delq ident gnus-backlog-articles))) (setq gnus-backlog-articles
(delete ident gnus-backlog-articles)))
;; Delete the article itself. ;; Delete the article itself.
(delete-region (delete-region
(point) (next-single-property-change (point) (next-single-property-change
@ -102,42 +92,40 @@
(defun gnus-backlog-remove-article (group number) (defun gnus-backlog-remove-article (group number)
"Remove article NUMBER in GROUP from the backlog." "Remove article NUMBER in GROUP from the backlog."
(when (numberp number) (when (numberp number)
(gnus-backlog-setup) (let ((ident (format "%s:%d" group number))
(let ((ident (intern (concat group ":" (int-to-string number)) beg)
gnus-backlog-hashtb)) (when (member ident gnus-backlog-articles)
beg end)
(when (memq ident gnus-backlog-articles)
;; It was in the backlog. ;; It was in the backlog.
(with-current-buffer (gnus-backlog-buffer) (with-current-buffer (gnus-backlog-buffer)
(let (buffer-read-only) (save-excursion
(when (setq beg (text-property-any (let (buffer-read-only)
(point-min) (point-max) 'gnus-backlog (goto-char (point-min))
ident)) (when (setq beg (gnus-text-property-search
;; Find the end (i. e., the beginning of the next article). 'gnus-backlog ident))
(setq end ;; Find the end (i. e., the beginning of the next article).
(next-single-property-change (goto-char
(1+ beg) 'gnus-backlog (current-buffer) (point-max))) (next-single-property-change
(delete-region beg end) (1+ beg) 'gnus-backlog (current-buffer) (point-max)))
;; Return success. (delete-region beg (point))
t)) ;; Return success.
(setq gnus-backlog-articles (delq ident gnus-backlog-articles))))))) t)))
(setq gnus-backlog-articles
(delete ident gnus-backlog-articles)))))))
(defun gnus-backlog-request-article (group number &optional buffer) (defun gnus-backlog-request-article (group number &optional buffer)
(when (and (numberp number) (when (and (numberp number)
(not (gnus-virtual-group-p group))) (not (gnus-virtual-group-p group)))
(gnus-backlog-setup) (let ((ident (format "%s:%d" group number))
(let ((ident (intern (concat group ":" (int-to-string number))
gnus-backlog-hashtb))
beg end) beg end)
(when (memq ident gnus-backlog-articles) (when (member ident gnus-backlog-articles)
;; It was in the backlog. ;; It was in the backlog.
(with-current-buffer (gnus-backlog-buffer) (with-current-buffer (gnus-backlog-buffer)
(if (not (setq beg (text-property-any (if (not (setq beg (gnus-text-property-search
(point-min) (point-max) 'gnus-backlog 'gnus-backlog ident)))
ident)))
;; It wasn't in the backlog after all. ;; It wasn't in the backlog after all.
(ignore (ignore
(setq gnus-backlog-articles (delq ident gnus-backlog-articles))) (setq gnus-backlog-articles
(delete ident gnus-backlog-articles)))
;; Find the end (i. e., the beginning of the next article). ;; Find the end (i. e., the beginning of the next article).
(setq end (setq end
(next-single-property-change (next-single-property-change

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

@ -272,7 +272,7 @@ it's not cached."
(defun gnus-cache-possibly-alter-active (group active) (defun gnus-cache-possibly-alter-active (group active)
"Alter the ACTIVE info for GROUP to reflect the articles in the cache." "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
(when gnus-cache-active-hashtb (when gnus-cache-active-hashtb
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) (let ((cache-active (gethash group gnus-cache-active-hashtb)))
(when cache-active (when cache-active
(when (< (car cache-active) (car active)) (when (< (car cache-active) (car active))
(setcar active (car cache-active))) (setcar active (car cache-active)))
@ -522,7 +522,7 @@ system for example was used.")
(gnus-delete-line))) (gnus-delete-line)))
(unless (setq gnus-newsgroup-cached (unless (setq gnus-newsgroup-cached
(delq article gnus-newsgroup-cached)) (delq article gnus-newsgroup-cached))
(gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb) (remhash gnus-newsgroup-name gnus-cache-active-hashtb)
(setq gnus-cache-active-altered t)) (setq gnus-cache-active-altered t))
(gnus-summary-update-secondary-mark article) (gnus-summary-update-secondary-mark article)
t))) t)))
@ -542,8 +542,8 @@ system for example was used.")
(progn (progn
(gnus-cache-update-active group (car articles) t) (gnus-cache-update-active group (car articles) t)
(gnus-cache-update-active group (car (last articles)))) (gnus-cache-update-active group (car (last articles))))
(when (gnus-gethash group gnus-cache-active-hashtb) (when (gethash group gnus-cache-active-hashtb)
(gnus-sethash group nil gnus-cache-active-hashtb) (remhash group gnus-cache-active-hashtb)
(setq gnus-cache-active-altered t))) (setq gnus-cache-active-altered t)))
articles))) articles)))
@ -666,13 +666,16 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
;; Mark the active hashtb as unaltered. ;; Mark the active hashtb as unaltered.
(setq gnus-cache-active-altered nil))) (setq gnus-cache-active-altered nil)))
;; FIXME: Why is there a `gnus-cache-possibly-alter-active',
;; `gnus-cache-possibly-update-active', and
;; `gnus-cache-update-active'? Do we really need all three?
(defun gnus-cache-possibly-update-active (group active) (defun gnus-cache-possibly-update-active (group active)
"Update active info bounds of GROUP with ACTIVE if necessary. "Update active info bounds of GROUP with ACTIVE if necessary.
The update is performed if ACTIVE contains a higher or lower bound The update is performed if ACTIVE contains a higher or lower bound
than the current." than the current."
(let ((lower t) (higher t)) (let ((lower t) (higher t))
(if gnus-cache-active-hashtb (if gnus-cache-active-hashtb
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) (let ((cache-active (gethash group gnus-cache-active-hashtb)))
(when cache-active (when cache-active
(unless (< (car active) (car cache-active)) (unless (< (car active) (car cache-active))
(setq lower nil)) (setq lower nil))
@ -687,10 +690,10 @@ than the current."
(defun gnus-cache-update-active (group number &optional low) (defun gnus-cache-update-active (group number &optional low)
"Update the upper bound of the active info of GROUP to NUMBER. "Update the upper bound of the active info of GROUP to NUMBER.
If LOW, update the lower bound instead." If LOW, update the lower bound instead."
(let ((active (gnus-gethash group gnus-cache-active-hashtb))) (let ((active (gethash group gnus-cache-active-hashtb)))
(if (null active) (if (null active)
;; We just create a new active entry for this group. ;; We just create a new active entry for this group.
(gnus-sethash group (cons number number) gnus-cache-active-hashtb) (puthash group (cons number number) gnus-cache-active-hashtb)
;; Update the lower or upper bound. ;; Update the lower or upper bound.
(if low (if low
(setcar active number) (setcar active number)
@ -734,10 +737,10 @@ If LOW, update the lower bound instead."
;; FIXME: this is kind of a workaround. The active file should ;; FIXME: this is kind of a workaround. The active file should
;; be updated at the time articles are cached. It will make ;; be updated at the time articles are cached. It will make
;; `gnus-cache-unified-group-names' needless. ;; `gnus-cache-unified-group-names' needless.
(gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names)) (puthash (or (cdr (assoc group gnus-cache-unified-group-names))
group) group)
(cons (car nums) (car (last nums))) (cons (car nums) (car (last nums)))
gnus-cache-active-hashtb)) gnus-cache-active-hashtb))
;; Go through all the other files. ;; Go through all the other files.
(dolist (file alphs) (dolist (file alphs)
(when (and (file-directory-p file) (when (and (file-directory-p file)
@ -798,13 +801,13 @@ supported."
(unless gnus-cache-active-hashtb (unless gnus-cache-active-hashtb
(gnus-cache-read-active)) (gnus-cache-read-active))
(let* ((old-group-hash-value (let* ((old-group-hash-value
(gnus-gethash old-group gnus-cache-active-hashtb)) (gethash old-group gnus-cache-active-hashtb))
(new-group-hash-value (new-group-hash-value
(gnus-gethash new-group gnus-cache-active-hashtb)) (gethash new-group gnus-cache-active-hashtb))
(delta (delta
(or old-group-hash-value new-group-hash-value))) (or old-group-hash-value new-group-hash-value)))
(gnus-sethash new-group old-group-hash-value gnus-cache-active-hashtb) (puthash new-group old-group-hash-value gnus-cache-active-hashtb)
(gnus-sethash old-group nil gnus-cache-active-hashtb) (puthash old-group nil gnus-cache-active-hashtb)
(if no-save (if no-save
(setq gnus-cache-active-altered delta) (setq gnus-cache-active-altered delta)
@ -826,8 +829,8 @@ supported."
(let ((no-save gnus-cache-active-hashtb)) (let ((no-save gnus-cache-active-hashtb))
(unless gnus-cache-active-hashtb (unless gnus-cache-active-hashtb
(gnus-cache-read-active)) (gnus-cache-read-active))
(let* ((group-hash-value (gnus-gethash group gnus-cache-active-hashtb))) (let* ((group-hash-value (gethash group gnus-cache-active-hashtb)))
(gnus-sethash group nil gnus-cache-active-hashtb) (remhash group gnus-cache-active-hashtb)
(if no-save (if no-save
(setq gnus-cache-active-altered group-hash-value) (setq gnus-cache-active-altered group-hash-value)
@ -849,9 +852,9 @@ supported."
(when gnus-cache-total-fetched-hashtb (when gnus-cache-total-fetched-hashtb
(gnus-cache-with-refreshed-group (gnus-cache-with-refreshed-group
group group
(let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb)
(gnus-sethash group (make-vector 2 0) (puthash group (make-vector 2 0)
gnus-cache-total-fetched-hashtb))) gnus-cache-total-fetched-hashtb)))
size) size)
(if file (if file
@ -874,8 +877,8 @@ supported."
(when gnus-cache-total-fetched-hashtb (when gnus-cache-total-fetched-hashtb
(gnus-cache-with-refreshed-group (gnus-cache-with-refreshed-group
group group
(let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb)
(gnus-sethash group (make-list 2 0) (puthash group (make-list 2 0)
gnus-cache-total-fetched-hashtb))) gnus-cache-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system) (file-name-coding-system nnmail-pathname-coding-system)
(size (or (file-attribute-size (file-attributes (size (or (file-attribute-size (file-attributes
@ -888,22 +891,21 @@ supported."
(defun gnus-cache-rename-group-total-fetched-for (old-group new-group) (defun gnus-cache-rename-group-total-fetched-for (old-group new-group)
"Record of disk space used by OLD-GROUP now associated with NEW-GROUP." "Record of disk space used by OLD-GROUP now associated with NEW-GROUP."
(when gnus-cache-total-fetched-hashtb (when gnus-cache-total-fetched-hashtb
(let ((entry (gnus-gethash old-group gnus-cache-total-fetched-hashtb))) (let ((entry (gethash old-group gnus-cache-total-fetched-hashtb)))
(gnus-sethash new-group entry gnus-cache-total-fetched-hashtb) (puthash new-group entry gnus-cache-total-fetched-hashtb)
(gnus-sethash old-group nil gnus-cache-total-fetched-hashtb)))) (remhash old-group gnus-cache-total-fetched-hashtb))))
(defun gnus-cache-delete-group-total-fetched-for (group) (defun gnus-cache-delete-group-total-fetched-for (group)
"Delete record of disk space used by GROUP being deleted." "Delete record of disk space used by GROUP being deleted."
(when gnus-cache-total-fetched-hashtb (when gnus-cache-total-fetched-hashtb
(gnus-sethash group nil gnus-cache-total-fetched-hashtb))) (remhash group gnus-cache-total-fetched-hashtb)))
(defun gnus-cache-total-fetched-for (group &optional no-inhibit) (defun gnus-cache-total-fetched-for (group &optional no-inhibit)
"Get total disk space used by the cache for the specified GROUP." "Get total disk space used by the cache for the specified GROUP."
(unless (equal group "dummy.group") (unless (equal group "dummy.group")
(unless gnus-cache-total-fetched-hashtb (unless gnus-cache-total-fetched-hashtb
(setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024))) (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1000)))
(let* ((entry (gethash group gnus-cache-total-fetched-hashtb)))
(let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb)))
(if entry (if entry
(apply '+ entry) (apply '+ entry)
(let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit))) (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))

22
lisp/gnus/gnus-dup.el
View file

@ -44,7 +44,7 @@ seen in the same session."
:type 'boolean) :type 'boolean)
(defcustom gnus-duplicate-list-length 10000 (defcustom gnus-duplicate-list-length 10000
"The number of Message-IDs to keep in the duplicate suppression list." "The maximum number of duplicate Message-IDs to keep track of."
:group 'gnus-duplicate :group 'gnus-duplicate
:type 'integer) :type 'integer)
@ -55,8 +55,10 @@ seen in the same session."
;;; Internal variables ;;; Internal variables
(defvar gnus-dup-list nil) (defvar gnus-dup-list nil
(defvar gnus-dup-hashtb nil) "List of seen message IDs, as strings.")
(defvar gnus-dup-hashtb nil
"Hash table of seen message IDs, for fast lookup.")
(defvar gnus-dup-list-dirty nil) (defvar gnus-dup-list-dirty nil)
@ -80,8 +82,8 @@ seen in the same session."
(setq gnus-dup-list nil)) (setq gnus-dup-list nil))
(setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length)) (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
;; Enter all Message-IDs into the hash table. ;; Enter all Message-IDs into the hash table.
(let ((obarray gnus-dup-hashtb)) (dolist (g gnus-dup-list)
(mapc 'intern gnus-dup-list))) (puthash g t gnus-dup-hashtb)))
(defun gnus-dup-read () (defun gnus-dup-read ()
"Read the duplicate suppression list." "Read the duplicate suppression list."
@ -116,13 +118,13 @@ seen in the same session."
(not (= (gnus-data-mark datum) gnus-canceled-mark)) (not (= (gnus-data-mark datum) gnus-canceled-mark))
(setq msgid (mail-header-id (gnus-data-header datum))) (setq msgid (mail-header-id (gnus-data-header datum)))
(not (nnheader-fake-message-id-p msgid)) (not (nnheader-fake-message-id-p msgid))
(not (intern-soft msgid gnus-dup-hashtb))) (not (gethash msgid gnus-dup-hashtb)))
(push msgid gnus-dup-list) (push msgid gnus-dup-list)
(intern msgid gnus-dup-hashtb)))) (puthash msgid t gnus-dup-hashtb))))
;; Chop off excess Message-IDs from the list. ;; Chop off excess Message-IDs from the list.
(let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
(when end (when end
(mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr end)) (mapc (lambda (id) (remhash id gnus-dup-hashtb)) (cdr end))
(setcdr end nil)))) (setcdr end nil))))
(defun gnus-dup-suppress-articles () (defun gnus-dup-suppress-articles ()
@ -134,7 +136,7 @@ seen in the same session."
(memq gnus-duplicate-mark gnus-auto-expirable-marks))) (memq gnus-duplicate-mark gnus-auto-expirable-marks)))
number) number)
(dolist (header gnus-newsgroup-headers) (dolist (header gnus-newsgroup-headers)
(when (and (intern-soft (mail-header-id header) gnus-dup-hashtb) (when (and (gethash (mail-header-id header) gnus-dup-hashtb)
(gnus-summary-article-unread-p (mail-header-number header))) (gnus-summary-article-unread-p (mail-header-number header)))
(setq gnus-newsgroup-unreads (setq gnus-newsgroup-unreads
(delq (setq number (mail-header-number header)) (delq (setq number (mail-header-number header))
@ -152,7 +154,7 @@ seen in the same session."
(when id (when id
(setq gnus-dup-list-dirty t) (setq gnus-dup-list-dirty t)
(setq gnus-dup-list (delete id gnus-dup-list)) (setq gnus-dup-list (delete id gnus-dup-list))
(unintern id gnus-dup-hashtb)))) (remhash id gnus-dup-hashtb))))
(provide 'gnus-dup) (provide 'gnus-dup)

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

@ -38,6 +38,7 @@
(eval-when-compile (eval-when-compile
(require 'mm-url) (require 'mm-url)
(require 'subr-x)
(let ((features (cons 'gnus-group features))) (let ((features (cons 'gnus-group features)))
(require 'gnus-sum)) (require 'gnus-sum))
(unless (boundp 'gnus-cache-active-hashtb) (unless (boundp 'gnus-cache-active-hashtb)
@ -1142,7 +1143,7 @@ The following commands are available:
(let ((gnus-process-mark ?\200) (let ((gnus-process-mark ?\200)
(gnus-group-update-hook nil) (gnus-group-update-hook nil)
(gnus-group-marked '("dummy.group")) (gnus-group-marked '("dummy.group"))
(gnus-active-hashtb (make-vector 10 0))) (gnus-active-hashtb (gnus-make-hashtable 10)))
(gnus-set-active "dummy.group" '(0 . 0)) (gnus-set-active "dummy.group" '(0 . 0))
(gnus-set-work-buffer) (gnus-set-work-buffer)
(gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil)
@ -1186,6 +1187,9 @@ The following commands are available:
(unless (derived-mode-p 'gnus-group-mode) (unless (derived-mode-p 'gnus-group-mode)
(gnus-group-mode))) (gnus-group-mode)))
;; FIXME: If we never have to coerce group names to unibyte now, how
;; much of this is necessary? How much encoding/decoding do we still
;; have to do?
(defun gnus-group-name-charset (method group) (defun gnus-group-name-charset (method group)
(unless method (unless method
(setq method (gnus-find-method-for-group group))) (setq method (gnus-find-method-for-group group)))
@ -1267,20 +1271,14 @@ Also see the `gnus-group-use-permanent-levels' variable."
;; has disappeared in the new listing, try to find the next ;; has disappeared in the new listing, try to find the next
;; one. If no next one can be found, just leave point at the ;; one. If no next one can be found, just leave point at the
;; first newsgroup in the buffer. ;; first newsgroup in the buffer.
(when (not (gnus-goto-char (when (not (gnus-text-property-search
(text-property-any 'gnus-group group nil 'goto))
(point-min) (point-max) (let ((groups (cdr-safe (member group gnus-group-list))))
'gnus-group (gnus-intern-safe (while (and groups
group gnus-active-hashtb)))) (not (gnus-text-property-search
(let ((newsrc (cdddr (gnus-group-entry group)))) 'gnus-group (car groups) 'forward 'goto)))
(while (and newsrc (setq groups (cdr groups)))
(not (gnus-goto-char (unless groups
(text-property-any
(point-min) (point-max) 'gnus-group
(gnus-intern-safe
(caar newsrc) gnus-active-hashtb)))))
(setq newsrc (cdr newsrc)))
(unless newsrc
(goto-char (point-max)) (goto-char (point-max))
(forward-line -1))))))) (forward-line -1)))))))
;; Adjust cursor point. ;; Adjust cursor point.
@ -1313,7 +1311,6 @@ If REGEXP is a function, list dead groups that the function returns non-nil;
if it is a string, only list groups matching REGEXP." if it is a string, only list groups matching REGEXP."
(set-buffer gnus-group-buffer) (set-buffer gnus-group-buffer)
(let ((buffer-read-only nil) (let ((buffer-read-only nil)
(newsrc (cdr gnus-newsrc-alist))
(lowest (or lowest 1)) (lowest (or lowest 1))
(not-in-list (and gnus-group-listed-groups (not-in-list (and gnus-group-listed-groups
(copy-sequence gnus-group-listed-groups))) (copy-sequence gnus-group-listed-groups)))
@ -1321,12 +1318,11 @@ if it is a string, only list groups matching REGEXP."
(erase-buffer) (erase-buffer)
(when (or (< lowest gnus-level-zombie) (when (or (< lowest gnus-level-zombie)
gnus-group-listed-groups) gnus-group-listed-groups)
;; List living groups. ;; List living groups, according to order in `gnus-group-list'.
(while newsrc (dolist (g (cdr gnus-group-list))
(setq info (car newsrc) (setq info (nth 1 (gethash g gnus-newsrc-hashtb))
group (gnus-info-group info) group (gnus-info-group info)
params (gnus-info-params info) params (gnus-info-params info)
newsrc (cdr newsrc)
unread (gnus-group-unread group)) unread (gnus-group-unread group))
(when not-in-list (when not-in-list
(setq not-in-list (delete group not-in-list))) (setq not-in-list (delete group not-in-list)))
@ -1407,7 +1403,7 @@ if it is a string, only list groups matching REGEXP."
(insert " " mark " *: " (insert " " mark " *: "
(gnus-group-decoded-name group) (gnus-group-decoded-name group)
"\n")) "\n"))
(list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) (list 'gnus-group (gethash group gnus-active-hashtb)
'gnus-unread t 'gnus-unread t
'gnus-level level)))) 'gnus-level level))))
(while groups (while groups
@ -1438,7 +1434,7 @@ if it is a string, only list groups matching REGEXP."
(not (gnus-ephemeral-group-p group)) (not (gnus-ephemeral-group-p group))
(gnus-dribble-enter (gnus-dribble-enter
(concat "(gnus-group-set-info '" (concat "(gnus-group-set-info '"
(gnus-prin1-to-string (nth 2 entry)) (gnus-prin1-to-string (nth 1 entry))
")") ")")
(concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))) (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\"")))
(setq gnus-group-indentation (gnus-group-group-indentation)) (setq gnus-group-indentation (gnus-group-group-indentation))
@ -1455,7 +1451,7 @@ if it is a string, only list groups matching REGEXP."
(if entry (if entry
(progn (progn
;; (Un)subscribed group. ;; (Un)subscribed group.
(setq info (nth 2 entry)) (setq info (nth 1 entry))
(gnus-group-insert-group-line (gnus-group-insert-group-line
group (gnus-info-level info) (gnus-info-marks info) group (gnus-info-level info) (gnus-info-marks info)
(or (car entry) t) (gnus-info-method info))) (or (car entry) t) (gnus-info-method info)))
@ -1472,7 +1468,7 @@ if it is a string, only list groups matching REGEXP."
(gnus-method-simplify (gnus-find-method-for-group group)))))) (gnus-method-simplify (gnus-find-method-for-group group))))))
(defun gnus-number-of-unseen-articles-in-group (group) (defun gnus-number-of-unseen-articles-in-group (group)
(let* ((info (nth 2 (gnus-group-entry group))) (let* ((info (nth 1 (gnus-group-entry group)))
(marked (gnus-info-marks info)) (marked (gnus-info-marks info))
(seen (cdr (assq 'seen marked))) (seen (cdr (assq 'seen marked)))
(active (gnus-active group))) (active (gnus-active group)))
@ -1544,12 +1540,12 @@ if it is a string, only list groups matching REGEXP."
(gnus-tmp-newsgroup-description (gnus-tmp-newsgroup-description
(if gnus-description-hashtb (if gnus-description-hashtb
(or (gnus-group-name-decode (or (gnus-group-name-decode
(gnus-gethash gnus-tmp-group gnus-description-hashtb) (gethash gnus-tmp-group gnus-description-hashtb)
group-name-charset) "") group-name-charset) "")
"")) ""))
(gnus-tmp-moderated (gnus-tmp-moderated
(if (and gnus-moderated-hashtb (if (and gnus-moderated-hashtb
(gnus-gethash gnus-tmp-group gnus-moderated-hashtb)) (gethash gnus-tmp-group gnus-moderated-hashtb))
?m ? )) ?m ? ))
(gnus-tmp-moderated-string (gnus-tmp-moderated-string
(if (eq gnus-tmp-moderated ?m) "(m)" "")) (if (eq gnus-tmp-moderated ?m) "(m)" ""))
@ -1575,7 +1571,7 @@ if it is a string, only list groups matching REGEXP."
gnus-process-mark ? )) gnus-process-mark ? ))
(buffer-read-only nil) (buffer-read-only nil)
beg end beg end
gnus-tmp-header) ; passed as parameter to user-funcs. gnus-tmp-header) ; passed as parameter to user-funcs.
(beginning-of-line) (beginning-of-line)
(setq beg (point)) (setq beg (point))
(add-text-properties (add-text-properties
@ -1585,7 +1581,7 @@ if it is a string, only list groups matching REGEXP."
(let ((gnus-tmp-decoded-group (gnus-group-name-decode (let ((gnus-tmp-decoded-group (gnus-group-name-decode
gnus-tmp-group group-name-charset))) gnus-tmp-group group-name-charset)))
(eval gnus-group-line-format-spec))) (eval gnus-group-line-format-spec)))
`(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb) `(gnus-group ,gnus-tmp-group
gnus-unread ,(if (numberp number) gnus-unread ,(if (numberp number)
(string-to-number gnus-tmp-number-of-unread) (string-to-number gnus-tmp-number-of-unread)
t) t)
@ -1619,7 +1615,7 @@ Some value are bound so the form can use them."
(when list (when list
(let* ((entry (gnus-group-entry group)) (let* ((entry (gnus-group-entry group))
(active (gnus-active group)) (active (gnus-active group))
(info (nth 2 entry)) (info (nth 1 entry))
(method (inline (gnus-server-get-method (method (inline (gnus-server-get-method
group (gnus-info-method info)))) group (gnus-info-method info))))
(marked (gnus-info-marks info)) (marked (gnus-info-marks info))
@ -1690,9 +1686,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
;; The buffer may be narrowed. ;; The buffer may be narrowed.
(save-restriction (save-restriction
(widen) (widen)
(let ((ident (gnus-intern-safe group gnus-active-hashtb)) (let (found buffer-read-only)
(loc (point-min))
found buffer-read-only)
(unless info-unchanged (unless info-unchanged
;; Enter the current status into the dribble buffer. ;; Enter the current status into the dribble buffer.
(let ((entry (gnus-group-entry group))) (let ((entry (gnus-group-entry group)))
@ -1700,37 +1694,33 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
(not (gnus-ephemeral-group-p group))) (not (gnus-ephemeral-group-p group)))
(gnus-dribble-enter (gnus-dribble-enter
(concat "(gnus-group-set-info '" (concat "(gnus-group-set-info '"
(gnus-prin1-to-string (nth 2 entry)) (gnus-prin1-to-string (nth 1 entry))
")") ")")
(concat "^(gnus-group-set-info '(\"" (concat "^(gnus-group-set-info '(\""
(regexp-quote group) "\""))))) (regexp-quote group) "\"")))))
;; Find all group instances. If topics are in use, each group ;; Find all group instances. If topics are in use, groups
;; may be listed in more than once. ;; may be listed more than once.
(while (setq loc (text-property-any (goto-char (point-min))
loc (point-max) 'gnus-group ident)) (while (gnus-text-property-search
'gnus-group group 'forward 'goto)
(setq found t) (setq found t)
(goto-char loc)
(let ((gnus-group-indentation (gnus-group-group-indentation))) (let ((gnus-group-indentation (gnus-group-group-indentation)))
(gnus-delete-line) (gnus-delete-line)
(gnus-group-insert-group-line-info group) (gnus-group-insert-group-line-info group)
(save-excursion (save-excursion
(forward-line -1) (forward-line -1)
(gnus-run-hooks 'gnus-group-update-group-hook))) (gnus-run-hooks 'gnus-group-update-group-hook))))
(setq loc (1+ loc)))
(unless (or found visible-only) (unless (or found visible-only)
;; No such line in the buffer, find out where it's supposed to ;; No such line in the buffer, find out where it's supposed to
;; go, and insert it there (or at the end of the buffer). ;; go, and insert it there (or at the end of the buffer).
(if gnus-goto-missing-group-function (if gnus-goto-missing-group-function
(funcall gnus-goto-missing-group-function group) (funcall gnus-goto-missing-group-function group)
(let ((entry (cddr (gnus-group-entry group)))) (let ((entry (cdr (member group gnus-group-list))))
(while (and entry (car entry) (goto-char (point-min))
(while (and (car-safe entry)
(not (not
(gnus-goto-char (gnus-text-property-search
(text-property-any 'gnus-group (car entry) 'forward 'goto)))
(point-min) (point-max)
'gnus-group (gnus-intern-safe
(caar entry)
gnus-active-hashtb)))))
(setq entry (cdr entry))) (setq entry (cdr entry)))
(or entry (goto-char (point-max))))) (or entry (goto-char (point-max)))))
;; Finally insert the line. ;; Finally insert the line.
@ -2062,7 +2052,7 @@ that group."
(unless group (unless group
(error "No group on current line")) (error "No group on current line"))
(setq marked (gnus-info-marks (setq marked (gnus-info-marks
(nth 2 (setq entry (gnus-group-entry group))))) (nth 1 (setq entry (gnus-group-entry group)))))
;; This group might be a dead group. In that case we have to get ;; This group might be a dead group. In that case we have to get
;; the number of unread articles from `gnus-active-hashtb'. ;; the number of unread articles from `gnus-active-hashtb'.
(setq number (setq number
@ -2137,6 +2127,7 @@ be permanent."
(let ((group (gnus-group-group-name))) (let ((group (gnus-group-group-name)))
(when group (when group
(gnus-group-decoded-name group))) (gnus-group-decoded-name group)))
;; FIXME: Use rx.
(let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\ (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\
\\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\ \\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\
[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\ [^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\
@ -2175,34 +2166,46 @@ be permanent."
(defun gnus-group-completing-read (&optional prompt collection (defun gnus-group-completing-read (&optional prompt collection
require-match initial-input hist require-match initial-input hist
def) def)
"Read a group name with completion. Non-ASCII group names are allowed. "Read a group name with completion.
The arguments are the same as `completing-read' except that COLLECTION Non-ASCII group names are allowed. The arguments are the same as
and HIST default to `gnus-active-hashtb' and `gnus-group-history' `completing-read' except that COLLECTION and HIST default to
respectively if they are omitted. Regards COLLECTION as a hash table `gnus-active-hashtb' and `gnus-group-history' respectively if
if it is not a list." they are omitted. Can handle COLLECTION as a list, hash table,
or vector."
(or collection (setq collection gnus-active-hashtb)) (or collection (setq collection gnus-active-hashtb))
(let (choices group) (let (choices group)
(if (listp collection) (cond ((listp collection)
(dolist (symbol collection) (if (symbolp (car collection))
(setq group (symbol-name symbol)) (dolist (symbol collection)
(push (if (string-match "[^\000-\177]" group) (setq group (symbol-name symbol))
(gnus-group-decoded-name group) (push (if (string-match "[^\000-\177]" group)
group) (gnus-group-decoded-name group)
choices)) group)
(mapatoms (lambda (symbol) choices))
(setq group (symbol-name symbol)) (setq choices collection)))
(push (if (string-match "[^\000-\177]" group) ((vectorp collection)
(gnus-group-decoded-name group) (mapatoms (lambda (symbol)
group) (setq group (symbol-name symbol))
choices)) (push (if (string-match "[^\000-\177]" group)
collection)) (gnus-group-decoded-name group)
(setq group (gnus-completing-read (or prompt "Group") (nreverse choices) group)
choices))
collection))
((hash-table-p collection)
(setq choices (hash-table-keys collection))))
(setq group (gnus-completing-read (or prompt "Group") (reverse choices)
require-match initial-input require-match initial-input
(or hist 'gnus-group-history) (or hist 'gnus-group-history)
def)) def))
(unless (if (listp collection) (unless (cond ((and (listp collection)
(member group (mapcar 'symbol-name collection)) (symbolp (car collection)))
(symbol-value (intern-soft group collection))) (member group (mapcar 'symbol-name collection)))
((listp collection)
(member group collection))
((vectorp collection)
(symbol-value (intern-soft group collection)))
((hash-table-p collection)
(gethash group collection)))
(setq group (setq group
(encode-coding-string (encode-coding-string
group (gnus-group-name-charset nil group)))) group (gnus-group-name-charset nil group))))
@ -2280,7 +2283,7 @@ Return the name of the group if selection was successful."
(nnheader-init-server-buffer) (nnheader-init-server-buffer)
;; Necessary because of funky inlining. ;; Necessary because of funky inlining.
(require 'gnus-cache) (require 'gnus-cache)
(setq gnus-newsrc-hashtb (gnus-make-hashtable))) (setq gnus-newsrc-hashtb (gnus-make-hashtable 100)))
;; Transform the select method into a unique server. ;; Transform the select method into a unique server.
(when (stringp method) (when (stringp method)
(setq method (gnus-server-to-method method))) (setq method (gnus-server-to-method method)))
@ -2297,23 +2300,23 @@ Return the name of the group if selection was successful."
(gnus-group-prefixed-name (gnus-group-real-name group) (gnus-group-prefixed-name (gnus-group-real-name group)
method)))) method))))
(gnus-set-active group nil) (gnus-set-active group nil)
(gnus-sethash (puthash
group group
`(-1 nil (,group `(-1 (,group
,gnus-level-default-subscribed nil nil ,method ,gnus-level-default-subscribed nil nil ,method
,(cons ,(cons
(cons 'quit-config (cons 'quit-config
(cond (cond
(quit-config (quit-config
quit-config) quit-config)
((assq gnus-current-window-configuration ((assq gnus-current-window-configuration
gnus-buffer-configuration) gnus-buffer-configuration)
(cons gnus-summary-buffer (cons gnus-summary-buffer
gnus-current-window-configuration)) gnus-current-window-configuration))
(t (t
(cons (current-buffer) (cons (current-buffer)
(current-window-configuration))))) (current-window-configuration)))))
parameters))) parameters)))
gnus-newsrc-hashtb) gnus-newsrc-hashtb)
(push method gnus-ephemeral-servers) (push method gnus-ephemeral-servers)
(when (gnus-buffer-live-p gnus-group-buffer) (when (gnus-buffer-live-p gnus-group-buffer)
@ -2562,30 +2565,29 @@ If PROMPT (the prefix) is a number, use the prompt specified in
If FAR, it is likely that the group is not on the current line. If FAR, it is likely that the group is not on the current line.
If TEST-MARKED, the line must be marked." If TEST-MARKED, the line must be marked."
(when group (when group
(let ((start (point))) (let ((start (point))
(active (and (gethash group gnus-active-hashtb)
group)))
(beginning-of-line) (beginning-of-line)
(cond (cond
;; It's quite likely that we are on the right line, so ;; It's quite likely that we are on the right line, so
;; we check the current line first. ;; we check the current line first.
((and (not far) ((and (not far)
(eq (get-text-property (point) 'gnus-group) (equal (get-text-property (point) 'gnus-group) active)
(gnus-intern-safe group gnus-active-hashtb))
(or (not test-marked) (gnus-group-mark-line-p))) (or (not test-marked) (gnus-group-mark-line-p)))
(point)) (point))
;; Previous and next line are also likely, so we check them as well. ;; Previous and next line are also likely, so we check them as well.
((and (not far) ((and (not far)
(save-excursion (save-excursion
(forward-line -1) (forward-line -1)
(and (eq (get-text-property (point) 'gnus-group) (and (equal (get-text-property (point) 'gnus-group) active)
(gnus-intern-safe group gnus-active-hashtb))
(or (not test-marked) (gnus-group-mark-line-p))))) (or (not test-marked) (gnus-group-mark-line-p)))))
(forward-line -1) (forward-line -1)
(point)) (point))
((and (not far) ((and (not far)
(save-excursion (save-excursion
(forward-line 1) (forward-line 1)
(and (eq (get-text-property (point) 'gnus-group) (and (equal (get-text-property (point) 'gnus-group) active)
(gnus-intern-safe group gnus-active-hashtb))
(or (not test-marked) (gnus-group-mark-line-p))))) (or (not test-marked) (gnus-group-mark-line-p)))))
(forward-line 1) (forward-line 1)
(point)) (point))
@ -2593,21 +2595,16 @@ If TEST-MARKED, the line must be marked."
(goto-char (point-min)) (goto-char (point-min))
(let (found) (let (found)
(while (and (not found) (while (and (not found)
(gnus-goto-char (gnus-text-property-search
(text-property-any 'gnus-group active 'forward 'goto))
(point) (point-max)
'gnus-group
(gnus-intern-safe group gnus-active-hashtb))))
(if (gnus-group-mark-line-p) (if (gnus-group-mark-line-p)
(setq found t) (setq found t)
(forward-line 1))) (forward-line 1)))
found)) found))
(t (t
;; Search through the entire buffer. ;; Search through the entire buffer.
(if (gnus-goto-char (if (gnus-text-property-search
(text-property-any 'gnus-group active nil 'goto)
(point-min) (point-max)
'gnus-group (gnus-intern-safe group gnus-active-hashtb)))
(point) (point)
(goto-char start) (goto-char start)
nil)))))) nil))))))
@ -2775,9 +2772,7 @@ server."
(gnus-group-change-level (gnus-group-change-level
(setq info (list t nname gnus-level-default-subscribed nil nil meth)) (setq info (list t nname gnus-level-default-subscribed nil nil meth))
gnus-level-default-subscribed gnus-level-killed gnus-level-default-subscribed gnus-level-killed
(and (gnus-group-group-name) (gnus-group-group-name) t)
(gnus-group-entry (gnus-group-group-name)))
t)
;; Make it active. ;; Make it active.
(gnus-set-active nname (cons 1 0)) (gnus-set-active nname (cons 1 0))
(unless (gnus-ephemeral-group-p name) (unless (gnus-ephemeral-group-p name)
@ -2837,6 +2832,7 @@ If FORCE (the prefix) is non-nil, all the articles in the group will
be deleted. This is \"deleted\" as in \"removed forever from the face be deleted. This is \"deleted\" as in \"removed forever from the face
of the Earth\". There is no undo. The user will be prompted before of the Earth\". There is no undo. The user will be prompted before
doing the deletion. doing the deletion.
Note that you also have to specify FORCE if you want the group to Note that you also have to specify FORCE if you want the group to
be removed from the server, even when it's empty." be removed from the server, even when it's empty."
(interactive (interactive
@ -2848,12 +2844,11 @@ be removed from the server, even when it's empty."
(error "This back end does not support group deletion")) (error "This back end does not support group deletion"))
(prog1 (prog1
(let ((group-decoded (gnus-group-decoded-name group))) (let ((group-decoded (gnus-group-decoded-name group)))
(if (and (not no-prompt) (when (or no-prompt
(not (gnus-yes-or-no-p (gnus-yes-or-no-p
(format (format
"Do you really want to delete %s%s? " "Do you really want to delete %s%s? "
group-decoded (if force " and all its contents" ""))))) group-decoded (if force " and all its contents" ""))))
() ; Whew!
(gnus-message 6 "Deleting group %s..." group-decoded) (gnus-message 6 "Deleting group %s..." group-decoded)
(if (not (gnus-request-delete-group group force)) (if (not (gnus-request-delete-group group force))
(gnus-error 3 "Couldn't delete group %s" group-decoded) (gnus-error 3 "Couldn't delete group %s" group-decoded)
@ -3234,7 +3229,7 @@ mail messages or news articles in files that have numeric names."
;; Subscribe the new group after the group on the current line. ;; Subscribe the new group after the group on the current line.
(gnus-subscribe-group pgroup (gnus-group-group-name) method) (gnus-subscribe-group pgroup (gnus-group-group-name) method)
(gnus-group-update-group pgroup) (gnus-group-update-group pgroup)
(forward-line -1) (forward-line)
(gnus-group-position-point))) (gnus-group-position-point)))
(defun gnus-group-enter-directory (dir) (defun gnus-group-enter-directory (dir)
@ -3627,7 +3622,7 @@ The return value is the number of articles that were marked as read,
or nil if no action could be taken." or nil if no action could be taken."
(let* ((entry (gnus-group-entry group)) (let* ((entry (gnus-group-entry group))
(num (car entry)) (num (car entry))
(marks (gnus-info-marks (nth 2 entry))) (marks (gnus-info-marks (nth 1 entry)))
(unread (gnus-sequence-of-unread-articles group))) (unread (gnus-sequence-of-unread-articles group)))
;; Remove entries for this group. ;; Remove entries for this group.
(nnmail-purge-split-history (gnus-group-real-name group)) (nnmail-purge-split-history (gnus-group-real-name group))
@ -3809,8 +3804,7 @@ group line."
(or (and (member group gnus-zombie-list) (or (and (member group gnus-zombie-list)
gnus-level-zombie) gnus-level-zombie)
gnus-level-killed) gnus-level-killed)
(when (gnus-group-group-name) (gnus-group-group-name))
(gnus-group-entry (gnus-group-group-name))))
(unless silent (unless silent
(gnus-group-update-group group))) (gnus-group-update-group group)))
(t (error "No such newsgroup: %s" group))) (t (error "No such newsgroup: %s" group)))
@ -3881,10 +3875,12 @@ of groups killed."
`(progn `(progn
(gnus-group-goto-group ,(gnus-group-group-name)) (gnus-group-goto-group ,(gnus-group-group-name))
(gnus-group-yank-group))) (gnus-group-yank-group)))
(push (cons (car entry) (nth 2 entry)) (push (cons (car entry) (nth 1 entry))
gnus-list-of-killed-groups)) gnus-list-of-killed-groups))
(gnus-group-change-level (gnus-group-change-level
(if entry entry group) gnus-level-killed (if entry nil level)) (if entry entry group) gnus-level-killed (if entry nil level))
;; FIXME: Since the group has already been removed from
;; `gnus-newsrc-hashtb', this check will always return nil.
(when (numberp (gnus-group-unread group)) (when (numberp (gnus-group-unread group))
(gnus-request-update-group-status group 'unsubscribe)) (gnus-request-update-group-status group 'unsubscribe))
(message "Killed group %s" (gnus-group-decoded-name group))) (message "Killed group %s" (gnus-group-decoded-name group)))
@ -3902,7 +3898,7 @@ of groups killed."
group gnus-level-killed 3)) group gnus-level-killed 3))
(cond (cond
((setq entry (gnus-group-entry group)) ((setq entry (gnus-group-entry group))
(push (cons (car entry) (nth 2 entry)) (push (cons (car entry) (nth 1 entry))
gnus-list-of-killed-groups) gnus-list-of-killed-groups)
(setcdr (cdr entry) (cdddr entry))) (setcdr (cdr entry) (cdddr entry)))
((member group gnus-zombie-list) ((member group gnus-zombie-list)
@ -3935,9 +3931,7 @@ yanked) a list of yanked groups is returned."
;; first newsgroup. ;; first newsgroup.
(setq prev (gnus-group-group-name)) (setq prev (gnus-group-group-name))
(gnus-group-change-level (gnus-group-change-level
info (gnus-info-level (cdr info)) gnus-level-killed info (gnus-info-level (cdr info)) gnus-level-killed prev t)
(and prev (gnus-group-entry prev))
t)
(gnus-group-insert-group-line-info group) (gnus-group-insert-group-line-info group)
(gnus-request-update-group-status group 'subscribe) (gnus-request-update-group-status group 'subscribe)
(gnus-undo-register (gnus-undo-register
@ -4023,14 +4017,7 @@ entail asking the server for the groups."
;; Find all groups and sort them. ;; Find all groups and sort them.
(let ((groups (let ((groups
(sort (sort
(let (list) (hash-table-keys gnus-active-hashtb)
(mapatoms
(lambda (sym)
(and (boundp sym)
(symbol-value sym)
(push (symbol-name sym) list)))
gnus-active-hashtb)
list)
'string<)) 'string<))
(buffer-read-only nil) (buffer-read-only nil)
group) group)
@ -4042,7 +4029,7 @@ entail asking the server for the groups."
(insert " *: " (insert " *: "
(gnus-group-decoded-name group) (gnus-group-decoded-name group)
"\n")) "\n"))
(list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) (list 'gnus-group (gethash group gnus-active-hashtb)
'gnus-unread t 'gnus-unread t
'gnus-level (inline (gnus-group-level group))))) 'gnus-level (inline (gnus-group-level group)))))
(goto-char (point-min)))) (goto-char (point-min))))
@ -4142,17 +4129,17 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
desc) desc)
(when (and force (when (and force
gnus-description-hashtb) gnus-description-hashtb)
(gnus-sethash mname nil gnus-description-hashtb)) (remhash mname gnus-description-hashtb))
(unless group (unless group
(error "No group name given")) (error "No group name given"))
(when (or (and gnus-description-hashtb (when (or (and gnus-description-hashtb
;; We check whether this group's method has been ;; We check whether this group's method has been
;; queried for a description file. ;; queried for a description file.
(gnus-gethash mname gnus-description-hashtb)) (gethash mname gnus-description-hashtb))
(setq desc (gnus-group-get-description group)) (setq desc (gnus-group-get-description group))
(gnus-read-descriptions-file method)) (gnus-read-descriptions-file method))
(gnus-message 1 "%s" (gnus-message 1 "%s"
(or desc (gnus-gethash group gnus-description-hashtb) (or desc (gethash group gnus-description-hashtb)
"No description available"))))) "No description available")))))
;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>. ;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
@ -4165,12 +4152,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(gnus-read-all-descriptions-files))) (gnus-read-all-descriptions-files)))
(error "Couldn't request descriptions file")) (error "Couldn't request descriptions file"))
(let ((buffer-read-only nil) (let ((buffer-read-only nil)
b groups) (groups (sort (hash-table-keys gnus-description-hashtb)))
(mapatoms b)
(lambda (group)
(push (symbol-name group) groups))
gnus-description-hashtb)
(setq groups (sort groups 'string<))
(erase-buffer) (erase-buffer)
(dolist (group groups) (dolist (group groups)
(setq b (point)) (setq b (point))
@ -4193,20 +4176,16 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(obuf (current-buffer)) (obuf (current-buffer))
groups des) groups des)
;; Go through all newsgroups that are known to Gnus. ;; Go through all newsgroups that are known to Gnus.
(mapatoms (maphash
(lambda (group) (lambda (g-name _)
(and (symbol-name group) (and (string-match regexp g-name)
(string-match regexp (symbol-name group)) (push g-name groups)))
(symbol-value group)
(push (symbol-name group) groups)))
gnus-active-hashtb) gnus-active-hashtb)
;; Also go through all descriptions that are known to Gnus. ;; Also go through all descriptions that are known to Gnus.
(when search-description (when search-description
(mapatoms (dolist (g-name (hash-table-keys gnus-description-hashtb))
(lambda (group) (when (string-match regexp g-name)
(and (string-match regexp (symbol-value group)) (push g-name groups))))
(push (symbol-name group) groups)))
gnus-description-hashtb))
(if (not groups) (if (not groups)
(gnus-message 3 "No groups matched \"%s\"." regexp) (gnus-message 3 "No groups matched \"%s\"." regexp)
;; Print out all the groups. ;; Print out all the groups.
@ -4222,8 +4201,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(let ((charset (gnus-group-name-charset nil prev))) (let ((charset (gnus-group-name-charset nil prev)))
(insert (gnus-group-name-decode prev charset) "\n") (insert (gnus-group-name-decode prev charset) "\n")
(when (and gnus-description-hashtb (when (and gnus-description-hashtb
(setq des (gnus-gethash (car groups) (setq des (gethash (car groups)
gnus-description-hashtb))) gnus-description-hashtb)))
(insert " " (gnus-group-name-decode des charset) "\n")))) (insert " " (gnus-group-name-decode des charset) "\n"))))
(setq groups (cdr groups))) (setq groups (cdr groups)))
(goto-char (point-min)))) (goto-char (point-min))))
@ -4468,7 +4447,7 @@ and the second element is the address."
(let* ((entry (gnus-group-entry (let* ((entry (gnus-group-entry
(or method-only-group (gnus-info-group info)))) (or method-only-group (gnus-info-group info))))
(part-info info) (part-info info)
(info (if method-only-group (nth 2 entry) info)) (info (if method-only-group (nth 1 entry) info))
method) method)
(when method-only-group (when method-only-group
(unless entry (unless entry
@ -4510,7 +4489,7 @@ and the second element is the address."
;; can do the update. ;; can do the update.
(if entry (if entry
(progn (progn
(setcar (nthcdr 2 entry) info) (setcar (nthcdr 1 entry) info)
(when (and (not (eq (car entry) t)) (when (and (not (eq (car entry) t))
(gnus-active (gnus-info-group info))) (gnus-active (gnus-info-group info)))
(setcar entry (length (setcar entry (length
@ -4619,11 +4598,11 @@ This command may read the active file."
(assq 'cache marks))) (assq 'cache marks)))
lowest lowest
#'(lambda (group) #'(lambda (group)
(or (gnus-gethash group (or (gethash group
gnus-cache-active-hashtb) gnus-cache-active-hashtb)
;; Cache active file might use "." ;; Cache active file might use "."
;; instead of ":". ;; instead of ":".
(gnus-gethash (gethash
(mapconcat 'identity (mapconcat 'identity
(split-string group ":") (split-string group ":")
".") ".")

27
lisp/gnus/gnus-score.el
View file

@ -2234,8 +2234,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(let* ((score (or (nth 1 kill) gnus-score-interactive-default-score)) (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score))
(date (nth 2 kill)) (date (nth 2 kill))
found) found)
(when (setq arts (intern-soft (nth 0 kill) hashtb)) (when (setq arts (gethash (nth 0 kill) hashtb))
(setq arts (symbol-value arts))
(setq found t) (setq found t)
(if trace (if trace
(while (setq art (pop arts)) (while (setq art (pop arts))
@ -2273,11 +2272,11 @@ score in `gnus-newsgroup-scored' by SCORE."
(with-syntax-table gnus-adaptive-word-syntax-table (with-syntax-table gnus-adaptive-word-syntax-table
(while (re-search-forward "\\b\\w+\\b" nil t) (while (re-search-forward "\\b\\w+\\b" nil t)
(setq val (setq val
(gnus-gethash (gethash
(setq word (downcase (buffer-substring (setq word (downcase (buffer-substring
(match-beginning 0) (match-end 0)))) (match-beginning 0) (match-end 0))))
hashtb)) hashtb))
(gnus-sethash (puthash
word word
(append (get-text-property (point-at-eol) 'articles) val) (append (get-text-property (point-at-eol) 'articles) val)
hashtb))) hashtb)))
@ -2289,7 +2288,7 @@ score in `gnus-newsgroup-scored' by SCORE."
".")) "."))
gnus-default-ignored-adaptive-words))) gnus-default-ignored-adaptive-words)))
(while ignored (while ignored
(gnus-sethash (pop ignored) nil hashtb))))) (remhash (pop ignored) hashtb)))))
(defun gnus-score-string< (a1 a2) (defun gnus-score-string< (a1 a2)
;; Compare headers in articles A2 and A2. ;; Compare headers in articles A2 and A2.
@ -2400,8 +2399,8 @@ score in `gnus-newsgroup-scored' by SCORE."
(goto-char (point-min)) (goto-char (point-min))
(while (re-search-forward "\\b\\w+\\b" nil t) (while (re-search-forward "\\b\\w+\\b" nil t)
;; Put the word and score into the hashtb. ;; Put the word and score into the hashtb.
(setq val (gnus-gethash (setq word (match-string 0)) (setq val (gethash (setq word (match-string 0))
hashtb)) hashtb))
(when (or (not gnus-adaptive-word-length-limit) (when (or (not gnus-adaptive-word-length-limit)
(> (length word) (> (length word)
gnus-adaptive-word-length-limit)) gnus-adaptive-word-length-limit))
@ -2409,7 +2408,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(if (and gnus-adaptive-word-minimum (if (and gnus-adaptive-word-minimum
(< val gnus-adaptive-word-minimum)) (< val gnus-adaptive-word-minimum))
(setq val gnus-adaptive-word-minimum)) (setq val gnus-adaptive-word-minimum))
(gnus-sethash word val hashtb))) (puthash word val hashtb)))
(erase-buffer)))) (erase-buffer))))
;; Make all the ignorable words ignored. ;; Make all the ignorable words ignored.
(let ((ignored (append gnus-ignored-adaptive-words (let ((ignored (append gnus-ignored-adaptive-words
@ -2420,16 +2419,14 @@ score in `gnus-newsgroup-scored' by SCORE."
".")) "."))
gnus-default-ignored-adaptive-words))) gnus-default-ignored-adaptive-words)))
(while ignored (while ignored
(gnus-sethash (pop ignored) nil hashtb))) (remhash (pop ignored) hashtb)))
;; Now we have all the words and scores, so we ;; Now we have all the words and scores, so we
;; add these rules to the ADAPT file. ;; add these rules to the ADAPT file.
(set-buffer gnus-summary-buffer) (set-buffer gnus-summary-buffer)
(mapatoms (maphash
(lambda (word) (lambda (word val)
(when (symbol-value word) (gnus-summary-score-entry
(gnus-summary-score-entry "subject" word 'w val date nil t))
"subject" (symbol-name word) 'w (symbol-value word)
date nil t)))
hashtb)))))) hashtb))))))
(defun gnus-score-edit-done () (defun gnus-score-edit-done ()

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

@ -543,29 +543,21 @@ Can be used to turn version control on or off."
(message "Descend hierarchy %s? ([y]nsq): " (message "Descend hierarchy %s? ([y]nsq): "
(substring prefix 1 (1- (length prefix))))) (substring prefix 1 (1- (length prefix)))))
(cond ((= ans ?n) (cond ((= ans ?n)
(while (and groups (dolist (g groups)
(setq group (car groups) (when (string-match prefix (gnus-group-real-name g))
real-group (gnus-group-real-name group)) (push g gnus-killed-list)
(string-match prefix real-group)) (puthash g t gnus-killed-hashtb)))
(push group gnus-killed-list)
(gnus-sethash group group gnus-killed-hashtb)
(setq groups (cdr groups)))
(setq starts (cdr starts))) (setq starts (cdr starts)))
((= ans ?s) ((= ans ?s)
(while (and groups (dolist (g groups)
(setq group (car groups) (when (string-match prefix (gnus-group-real-name g))
real-group (gnus-group-real-name group)) (puthash g t gnus-killed-hashtb)
(string-match prefix real-group)) (gnus-subscribe-alphabetically g)))
(gnus-sethash group group gnus-killed-hashtb)
(gnus-subscribe-alphabetically (car groups))
(setq groups (cdr groups)))
(setq starts (cdr starts))) (setq starts (cdr starts)))
((= ans ?q) ((= ans ?q)
(while groups (dolist (g groups)
(setq group (car groups)) (push g gnus-killed-list)
(push group gnus-killed-list) (puthash g t gnus-killed-hashtb)))
(gnus-sethash group group gnus-killed-hashtb)
(setq groups (cdr groups))))
(t nil))) (t nil)))
(message "Subscribe %s? ([n]yq)" (car groups)) (message "Subscribe %s? ([n]yq)" (car groups))
(while (not (memq (setq ans (read-char-exclusive)) (while (not (memq (setq ans (read-char-exclusive))
@ -575,16 +567,14 @@ Can be used to turn version control on or off."
(setq group (car groups)) (setq group (car groups))
(cond ((= ans ?y) (cond ((= ans ?y)
(gnus-subscribe-alphabetically (car groups)) (gnus-subscribe-alphabetically (car groups))
(gnus-sethash group group gnus-killed-hashtb)) (puthash group t gnus-killed-hashtb))
((= ans ?q) ((= ans ?q)
(while groups (dolist (g groups)
(setq group (car groups)) (push g gnus-killed-list)
(push group gnus-killed-list) (puthash g t gnus-killed-hashtb)))
(gnus-sethash group group gnus-killed-hashtb)
(setq groups (cdr groups))))
(t (t
(push group gnus-killed-list) (push group gnus-killed-list)
(gnus-sethash group group gnus-killed-hashtb))) (puthash group t gnus-killed-hashtb)))
(setq groups (cdr groups))))))) (setq groups (cdr groups)))))))
(defun gnus-subscribe-randomly (newsgroup) (defun gnus-subscribe-randomly (newsgroup)
@ -647,7 +637,7 @@ the first newsgroup."
;; We subscribe the group by changing its level to `subscribed'. ;; We subscribe the group by changing its level to `subscribed'.
(gnus-group-change-level (gnus-group-change-level
newsgroup gnus-level-default-subscribed newsgroup gnus-level-default-subscribed
gnus-level-killed (gnus-group-entry (or next "dummy.group"))) gnus-level-killed (or next "dummy.group"))
(gnus-request-update-group-status newsgroup 'subscribe) (gnus-request-update-group-status newsgroup 'subscribe)
(gnus-message 5 "Subscribe newsgroup: %s" newsgroup) (gnus-message 5 "Subscribe newsgroup: %s" newsgroup)
(run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup)
@ -696,6 +686,7 @@ the first newsgroup."
gnus-agent-file-loading-cache nil gnus-agent-file-loading-cache nil
gnus-server-method-cache nil gnus-server-method-cache nil
gnus-newsrc-alist nil gnus-newsrc-alist nil
gnus-group-list nil
gnus-newsrc-hashtb nil gnus-newsrc-hashtb nil
gnus-killed-list nil gnus-killed-list nil
gnus-zombie-list nil gnus-zombie-list nil
@ -1018,7 +1009,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
(eq gnus-read-active-file 'some)) (eq gnus-read-active-file 'some))
(gnus-update-active-hashtb-from-killed)) (gnus-update-active-hashtb-from-killed))
(unless gnus-active-hashtb (unless gnus-active-hashtb
(setq gnus-active-hashtb (gnus-make-hashtable 4096))) (setq gnus-active-hashtb (gnus-make-hashtable 4000)))
;; Initialize the cache. ;; Initialize the cache.
(when gnus-use-cache (when gnus-use-cache
(gnus-cache-open)) (gnus-cache-open))
@ -1108,7 +1099,7 @@ for new groups, and subscribe the new groups as zombies."
(gnus-ask-server-for-new-groups) (gnus-ask-server-for-new-groups)
;; Go through the active hashtb and look for new groups. ;; Go through the active hashtb and look for new groups.
(let ((groups 0) (let ((groups 0)
group new-newsgroups) new-newsgroups)
(gnus-message 5 "Looking for new newsgroups...") (gnus-message 5 "Looking for new newsgroups...")
(unless gnus-have-read-active-file (unless gnus-have-read-active-file
(gnus-read-active-file)) (gnus-read-active-file))
@ -1117,30 +1108,26 @@ for new groups, and subscribe the new groups as zombies."
(gnus-make-hashtable-from-killed)) (gnus-make-hashtable-from-killed))
;; Go though every newsgroup in `gnus-active-hashtb' and compare ;; Go though every newsgroup in `gnus-active-hashtb' and compare
;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'.
(mapatoms (maphash
(lambda (sym) (lambda (g-name active)
(if (or (null (setq group (symbol-name sym))) (unless (or (gethash g-name gnus-killed-hashtb)
(not (boundp sym)) (gethash g-name gnus-newsrc-hashtb))
(null (symbol-value sym)) (let ((do-sub (gnus-matches-options-n g-name)))
(gnus-gethash group gnus-killed-hashtb)
(gnus-gethash group gnus-newsrc-hashtb))
()
(let ((do-sub (gnus-matches-options-n group)))
(cond (cond
((eq do-sub 'subscribe) ((eq do-sub 'subscribe)
(setq groups (1+ groups)) (setq groups (1+ groups))
(gnus-sethash group group gnus-killed-hashtb) (puthash g-name t gnus-killed-hashtb)
(gnus-call-subscribe-functions (gnus-call-subscribe-functions
gnus-subscribe-options-newsgroup-method group)) gnus-subscribe-options-newsgroup-method g-name))
((eq do-sub 'ignore) ((eq do-sub 'ignore)
nil) nil)
(t (t
(setq groups (1+ groups)) (setq groups (1+ groups))
(gnus-sethash group group gnus-killed-hashtb) (puthash g-name t gnus-killed-hashtb)
(if gnus-subscribe-hierarchical-interactive (if gnus-subscribe-hierarchical-interactive
(push group new-newsgroups) (push g-name new-newsgroups)
(gnus-call-subscribe-functions (gnus-call-subscribe-functions
gnus-subscribe-newsgroup-method group))))))) gnus-subscribe-newsgroup-method g-name)))))))
gnus-active-hashtb) gnus-active-hashtb)
(when new-newsgroups (when new-newsgroups
(gnus-subscribe-hierarchical-interactive new-newsgroups)) (gnus-subscribe-hierarchical-interactive new-newsgroups))
@ -1213,36 +1200,32 @@ for new groups, and subscribe the new groups as zombies."
;; Enter all the new groups into a hashtable. ;; Enter all the new groups into a hashtable.
(gnus-active-to-gnus-format method hashtb 'ignore)) (gnus-active-to-gnus-format method hashtb 'ignore))
;; Now all new groups from `method' are in `hashtb'. ;; Now all new groups from `method' are in `hashtb'.
(mapatoms (maphash
(lambda (group-sym) (lambda (g-name val)
(if (or (null (setq group (symbol-name group-sym))) (unless (or (null val) ; The group is already known.
(not (boundp group-sym)) (gethash g-name gnus-newsrc-hashtb)
(null (symbol-value group-sym)) (member g-name gnus-zombie-list)
(gnus-gethash group gnus-newsrc-hashtb) (member g-name gnus-killed-list))
(member group gnus-zombie-list)
(member group gnus-killed-list))
;; The group is already known.
()
;; Make this group active. ;; Make this group active.
(when (symbol-value group-sym) (when val
(gnus-set-active group (symbol-value group-sym))) (gnus-set-active g-name val))
;; Check whether we want it or not. ;; Check whether we want it or not.
(let ((do-sub (gnus-matches-options-n group))) (let ((do-sub (gnus-matches-options-n g-name)))
(cond (cond
((eq do-sub 'subscribe) ((eq do-sub 'subscribe)
(cl-incf groups) (cl-incf groups)
(gnus-sethash group group gnus-killed-hashtb) (puthash g-name group gnus-killed-hashtb)
(gnus-call-subscribe-functions (gnus-call-subscribe-functions
gnus-subscribe-options-newsgroup-method group)) gnus-subscribe-options-newsgroup-method g-name))
((eq do-sub 'ignore) ((eq do-sub 'ignore)
nil) nil)
(t (t
(cl-incf groups) (cl-incf groups)
(gnus-sethash group group gnus-killed-hashtb) (puthash g-name group gnus-killed-hashtb)
(if gnus-subscribe-hierarchical-interactive (if gnus-subscribe-hierarchical-interactive
(push group new-newsgroups) (push g-name new-newsgroups)
(gnus-call-subscribe-functions (gnus-call-subscribe-functions
gnus-subscribe-newsgroup-method group))))))) gnus-subscribe-newsgroup-method g-name)))))))
hashtb)) hashtb))
(when new-newsgroups (when new-newsgroups
(gnus-subscribe-hierarchical-interactive new-newsgroups))) (gnus-subscribe-hierarchical-interactive new-newsgroups)))
@ -1263,29 +1246,28 @@ for new groups, and subscribe the new groups as zombies."
gnus-level-default-subscribed gnus-level-killed previous t) gnus-level-default-subscribed gnus-level-killed previous t)
t) t)
;; `gnus-group-change-level' is the fundamental function for changing
;; subscription levels of newsgroups. This might mean just changing
;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back
;; again, which subscribes/unsubscribes a group, which is equally
;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and
;; from 8-9 to 1-7 means that you remove the group from the list of
;; killed (or zombie) groups and add them to the (kinda) subscribed
;; groups. And last but not least, moving from 8 to 9 and 9 to 8,
;; which is trivial.
;; ENTRY can either be a string (newsgroup name) or a list (if
;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST),
;; otherwise it's a list in the format of the `gnus-newsrc-hashtb'
;; entries.
;; LEVEL is the new level of the group, OLDLEVEL is the old level and
;; PREVIOUS is the group (in hashtb entry format) to insert this group
;; after.
(defun gnus-group-change-level (entry level &optional oldlevel (defun gnus-group-change-level (entry level &optional oldlevel
previous fromkilled) previous fromkilled)
"Change level of group ENTRY to LEVEL.
This is the fundamental function for changing subscription levels
of newsgroups. This might mean just changing from level 1 to 2,
which is pretty trivial, from 2 to 6 or back again, which
subscribes/unsubscribes a group, which is equally trivial.
Changing from 1-7 to 8-9 means that you kill a group, and from
8-9 to 1-7 means that you remove the group from the list of
killed (or zombie) groups and add them to the (kinda) subscribed
groups. And last but not least, moving from 8 to 9 and 9 to 8,
which is trivial. ENTRY can either be a string (newsgroup name)
or a list (if FROMKILLED is t, it's a list on the format (NUM
INFO-LIST), otherwise it's a list in the format of the
`gnus-newsrc-hashtb' entries. LEVEL is the new level of the
group, OLDLEVEL is the old level and PREVIOUS is the group (a
string name) to insert this group after."
(let (group info active num) (let (group info active num)
;; Glean what info we can from the arguments ;; Glean what info we can from the arguments.
(if (consp entry) (if (consp entry)
(if fromkilled (setq group (nth 1 entry)) (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry))))
(setq group (car (nth 2 entry))))
(setq group entry)) (setq group entry))
(when (and (stringp entry) (when (and (stringp entry)
oldlevel oldlevel
@ -1293,21 +1275,17 @@ for new groups, and subscribe the new groups as zombies."
(setq entry (gnus-group-entry entry))) (setq entry (gnus-group-entry entry)))
(if (and (not oldlevel) (if (and (not oldlevel)
(consp entry)) (consp entry))
(setq oldlevel (gnus-info-level (nth 2 entry))) (setq oldlevel (gnus-info-level (nth 1 entry)))
(setq oldlevel (or oldlevel gnus-level-killed))) (setq oldlevel (or oldlevel gnus-level-killed)))
(when (stringp previous) (when (stringp previous)
(setq previous (gnus-group-entry previous))) (setq previous (gnus-group-entry previous)))
;; Group is already subscribed.
(if (and (>= oldlevel gnus-level-zombie) (unless (and (>= oldlevel gnus-level-zombie)
(gnus-group-entry group)) (gnus-group-entry group))
;; We are trying to subscribe a group that is already
;; subscribed.
() ; Do nothing.
(unless (gnus-ephemeral-group-p group) (unless (gnus-ephemeral-group-p group)
(gnus-dribble-enter (gnus-dribble-enter
(format "(gnus-group-change-level %S %S %S %S %S)" (format "(gnus-group-change-level %S %S %S %S %S)"
group level oldlevel (car (nth 2 previous)) fromkilled))) group level oldlevel previous fromkilled)))
;; Then we remove the newgroup from any old structures, if needed. ;; Then we remove the newgroup from any old structures, if needed.
;; If the group was killed, we remove it from the killed or zombie ;; If the group was killed, we remove it from the killed or zombie
@ -1321,11 +1299,10 @@ for new groups, and subscribe the new groups as zombies."
(t (t
(when (and (>= level gnus-level-zombie) (when (and (>= level gnus-level-zombie)
entry) entry)
(gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb) (remhash (car (nth 1 entry)) gnus-newsrc-hashtb)
(when (nth 3 entry) (setq gnus-group-list (remove group gnus-group-list))
(setcdr (gnus-group-entry (car (nth 3 entry))) (setq gnus-newsrc-alist (delq (assoc group gnus-newsrc-alist)
(cdr entry))) gnus-newsrc-alist)))))
(setcdr (cdr entry) (cdddr entry)))))
;; Finally we enter (if needed) the list where it is supposed to ;; Finally we enter (if needed) the list where it is supposed to
;; go, and change the subscription level. If it is to be killed, ;; go, and change the subscription level. If it is to be killed,
@ -1333,12 +1310,13 @@ for new groups, and subscribe the new groups as zombies."
(cond (cond
((>= level gnus-level-zombie) ((>= level gnus-level-zombie)
;; Remove from the hash table. ;; Remove from the hash table.
(gnus-sethash group nil gnus-newsrc-hashtb) (remhash group gnus-newsrc-hashtb)
(setq gnus-group-list (remove group gnus-group-list))
(if (= level gnus-level-zombie) (if (= level gnus-level-zombie)
(push group gnus-zombie-list) (push group gnus-zombie-list)
(if (= oldlevel gnus-level-killed) (if (= oldlevel gnus-level-killed)
;; Remove from active hashtb. ;; Remove from active hashtb.
(unintern group gnus-active-hashtb) (remhash group gnus-active-hashtb)
;; Don't add it into killed-list if it was killed. ;; Don't add it into killed-list if it was killed.
(push group gnus-killed-list)))) (push group gnus-killed-list))))
(t (t
@ -1349,7 +1327,7 @@ for new groups, and subscribe the new groups as zombies."
;; It was alive, and it is going to stay alive, so we ;; It was alive, and it is going to stay alive, so we
;; just change the level and don't change any pointers or ;; just change the level and don't change any pointers or
;; hash table entries. ;; hash table entries.
(setcar (cdaddr entry) level) (setcar (cdadr entry) level)
(if (listp entry) (if (listp entry)
(setq info (cdr entry) (setq info (cdr entry)
num (car entry)) num (car entry))
@ -1364,23 +1342,16 @@ for new groups, and subscribe the new groups as zombies."
(if method (if method
(setq info (list group level nil nil method)) (setq info (list group level nil nil method))
(setq info (list group level nil))))) (setq info (list group level nil)))))
(unless previous ;; Add group. The exact ordering only matters for
(setq previous ;; `gnus-group-list', though we need to keep the dummy group
(let ((p gnus-newsrc-alist)) ;; at the head of `gnus-newsrc-alist'.
(while (cddr p) (push info (cdr gnus-newsrc-alist))
(setq p (cdr p))) (puthash group (list num info) gnus-newsrc-hashtb)
p))) (let* ((prev-idx (seq-position gnus-group-list (caadr previous)))
(setq entry (cons info (cddr previous))) (idx (if prev-idx
(if (cdr previous) (1+ prev-idx)
(progn (length gnus-group-list))))
(setcdr (cdr previous) entry) (push group (nthcdr idx gnus-group-list)))
(gnus-sethash group (cons num (cdr previous))
gnus-newsrc-hashtb))
(setcdr previous entry)
(gnus-sethash group (cons num previous)
gnus-newsrc-hashtb))
(when (cdr entry)
(setcdr (gnus-group-entry (caadr entry)) entry))
(gnus-dribble-enter (gnus-dribble-enter
(format "(gnus-group-set-info '%S)" info) (format "(gnus-group-set-info '%S)" info)
(concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))))) (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\"")))))
@ -1455,7 +1426,7 @@ newsgroup."
(defun gnus-cache-possibly-alter-active (group active) (defun gnus-cache-possibly-alter-active (group active)
"Alter the ACTIVE info for GROUP to reflect the articles in the cache." "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
(when gnus-cache-active-hashtb (when gnus-cache-active-hashtb
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) (let ((cache-active (gethash group gnus-cache-active-hashtb)))
(when cache-active (when cache-active
(when (< (car cache-active) (car active)) (when (< (car cache-active) (car active))
(setcar active (car cache-active))) (setcar active (car cache-active)))
@ -1837,19 +1808,24 @@ backend check whether the group actually exists."
(dolist (info infos) (dolist (info infos)
(gnus-activate-group (gnus-info-group info) nil nil method t)))))) (gnus-activate-group (gnus-info-group info) nil nil method t))))))
;; Create a hash table out of the newsrc alist. The `car's of the
;; alist elements are used as keys.
(defun gnus-make-hashtable-from-newsrc-alist () (defun gnus-make-hashtable-from-newsrc-alist ()
"Create a hash table from `gnus-newsrc-alist'.
The keys are group names, and values are a cons of (unread info),
where unread is an integer count of calculated unread
messages (or nil), and info is a regular gnus info entry.
The info element is shared with the same element of
`gnus-newrc-alist', so as to conserve space."
(let ((alist gnus-newsrc-alist) (let ((alist gnus-newsrc-alist)
(ohashtb gnus-newsrc-hashtb) (ohashtb gnus-newsrc-hashtb)
prev info method rest methods) info method gname rest methods)
(setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist)))
(setq alist (setq alist
(setq prev (setq gnus-newsrc-alist (setq gnus-newsrc-alist
(if (equal (caar gnus-newsrc-alist) (if (equal (caar gnus-newsrc-alist)
"dummy.group") "dummy.group")
gnus-newsrc-alist gnus-newsrc-alist
(cons (list "dummy.group" 0 nil) alist))))) (cons (list "dummy.group" 0 nil) alist))))
(while alist (while alist
(setq info (car alist)) (setq info (car alist))
;; Make the same select-methods identical Lisp objects. ;; Make the same select-methods identical Lisp objects.
@ -1858,17 +1834,18 @@ backend check whether the group actually exists."
(gnus-info-set-method info (car rest)) (gnus-info-set-method info (car rest))
(push method methods))) (push method methods)))
;; Check for duplicates. ;; Check for duplicates.
(if (gnus-gethash (car info) gnus-newsrc-hashtb) (if (gethash (car info) gnus-newsrc-hashtb)
;; Remove this entry from the alist. ;; Remove this entry from the alist.
(setcdr prev (cddr prev)) (setcdr alist (cddr alist))
(gnus-sethash (puthash
(car info) (car info)
;; Preserve number of unread articles in groups. ;; Preserve number of unread articles in groups.
(cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) (list (and ohashtb (car (gethash (car info) ohashtb)))
prev) info)
gnus-newsrc-hashtb) gnus-newsrc-hashtb)
(setq prev alist)) (push (car info) gnus-group-list))
(setq alist (cdr alist))) (setq alist (cdr alist)))
(setq gnus-group-list (nreverse gnus-group-list))
;; Make the same select-methods in `gnus-server-alist' identical ;; Make the same select-methods in `gnus-server-alist' identical
;; as well. ;; as well.
(while methods (while methods
@ -1883,10 +1860,10 @@ backend check whether the group actually exists."
(setq gnus-killed-hashtb (setq gnus-killed-hashtb
(gnus-make-hashtable (gnus-make-hashtable
(+ (length gnus-killed-list) (length gnus-zombie-list)))) (+ (length gnus-killed-list) (length gnus-zombie-list))))
(while lists (dolist (g (append gnus-killed-list gnus-zombie-list))
(setq list (symbol-value (pop lists))) ;; NOTE: We have lost the ordering that used to be kept in this
(while list ;; variable.
(gnus-sethash (car list) (pop list) gnus-killed-hashtb))))) (puthash g t gnus-killed-hashtb))))
(defun gnus-parse-active () (defun gnus-parse-active ()
"Parse active info in the nntp server buffer." "Parse active info in the nntp server buffer."
@ -1900,7 +1877,7 @@ backend check whether the group actually exists."
(defun gnus-make-articles-unread (group articles) (defun gnus-make-articles-unread (group articles)
"Mark ARTICLES in GROUP as unread." "Mark ARTICLES in GROUP as unread."
(let* ((info (nth 2 (or (gnus-group-entry group) (let* ((info (nth 1 (or (gnus-group-entry group)
(gnus-group-entry (gnus-group-entry
(gnus-group-real-name group))))) (gnus-group-real-name group)))))
(ranges (gnus-info-read info)) (ranges (gnus-info-read info))
@ -1924,7 +1901,7 @@ backend check whether the group actually exists."
"Mark ascending ARTICLES in GROUP as unread." "Mark ascending ARTICLES in GROUP as unread."
(let* ((entry (or (gnus-group-entry group) (let* ((entry (or (gnus-group-entry group)
(gnus-group-entry (gnus-group-real-name group)))) (gnus-group-entry (gnus-group-real-name group))))
(info (nth 2 entry)) (info (nth 1 entry))
(ranges (gnus-info-read info)) (ranges (gnus-info-read info))
(r ranges) (r ranges)
modified) modified)
@ -1987,12 +1964,11 @@ backend check whether the group actually exists."
;; Insert the change into the group buffer and the dribble file. ;; Insert the change into the group buffer and the dribble file.
(gnus-group-update-group group t)))) (gnus-group-update-group group t))))
;; Enter all dead groups into the hashtb.
(defun gnus-update-active-hashtb-from-killed () (defun gnus-update-active-hashtb-from-killed ()
(let ((hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096)))) (let ((hashtb (setq gnus-active-hashtb
(dolist (list (list gnus-killed-list gnus-zombie-list)) (gnus-make-hashtable 4000))))
(dolist (group list) (dolist (g (append gnus-killed-list gnus-zombie-list))
(gnus-sethash group nil hashtb))))) (remhash g hashtb))))
(defun gnus-get-killed-groups () (defun gnus-get-killed-groups ()
"Go through the active hashtb and mark all unknown groups as killed." "Go through the active hashtb and mark all unknown groups as killed."
@ -2003,20 +1979,16 @@ backend check whether the group actually exists."
(unless gnus-killed-hashtb (unless gnus-killed-hashtb
(gnus-make-hashtable-from-killed)) (gnus-make-hashtable-from-killed))
;; Go through all newsgroups that are known to Gnus - enlarge kill list. ;; Go through all newsgroups that are known to Gnus - enlarge kill list.
(mapatoms (maphash
(lambda (sym) (lambda (g-name active)
(let ((groups 0) (let ((groups 0))
(group (symbol-name sym))) (unless (or (gethash g-name gnus-killed-hashtb)
(if (or (null group) (gethash g-name gnus-newsrc-hashtb))
(gnus-gethash group gnus-killed-hashtb) (let ((do-sub (gnus-matches-options-n g-name)))
(gnus-gethash group gnus-newsrc-hashtb)) (unless (or (eq do-sub 'subscribe) (eq do-sub 'ignore))
()
(let ((do-sub (gnus-matches-options-n group)))
(if (or (eq do-sub 'subscribe) (eq do-sub 'ignore))
()
(setq groups (1+ groups)) (setq groups (1+ groups))
(push group gnus-killed-list) (push g-name gnus-killed-list)
(gnus-sethash group group gnus-killed-hashtb)))))) (puthash g-name t gnus-killed-hashtb))))))
gnus-active-hashtb) gnus-active-hashtb)
(gnus-dribble-touch)) (gnus-dribble-touch))
@ -2129,11 +2101,13 @@ backend check whether the group actually exists."
(not (equal method gnus-select-method))) (not (equal method gnus-select-method)))
gnus-active-hashtb gnus-active-hashtb
(setq gnus-active-hashtb (setq gnus-active-hashtb
(if (equal method gnus-select-method) (gnus-make-hashtable
(gnus-make-hashtable (if (equal method gnus-select-method)
(count-lines (point-min) (point-max))) (count-lines (point-min) (point-max))
(gnus-make-hashtable 4096)))))) 4000))))))
group max min) group max min)
(unless gnus-moderated-hashtb
(setq gnus-moderated-hashtb (gnus-make-hashtable 100)))
;; Delete unnecessary lines. ;; Delete unnecessary lines.
(goto-char (point-min)) (goto-char (point-min))
(cond (cond
@ -2143,12 +2117,6 @@ backend check whether the group actually exists."
(delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups)))) (delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups))))
(goto-char (point-min)) (goto-char (point-min))
(unless (re-search-forward "[\\\"]" nil t)
;; Make the group names readable as a lisp expression even if they
;; contain special characters.
(goto-char (point-max))
(while (re-search-backward "[][';?()#]" nil t)
(insert ?\\)))
;; Let the Gnus agent save the active file. ;; Let the Gnus agent save the active file.
(when (and gnus-agent real-active (gnus-online method)) (when (and gnus-agent real-active (gnus-online method))
@ -2168,49 +2136,35 @@ backend check whether the group actually exists."
(insert prefix) (insert prefix)
(zerop (forward-line 1))))))) (zerop (forward-line 1)))))))
;; Store the active file in a hash table. ;; Store the active file in a hash table.
;; Use a unibyte buffer in order to make `read' read non-ASCII
;; group names (which have been encoded) as unibyte strings. (with-temp-buffer
(mm-with-unibyte-buffer
(insert-buffer-substring cur) (insert-buffer-substring cur)
(setq cur (current-buffer)) (setq cur (current-buffer))
(goto-char (point-min)) (goto-char (point-min))
(while (not (eobp)) (while (not (eobp))
(condition-case () (condition-case ()
(progn (if (and (stringp (progn
(narrow-to-region (point) (point-at-eol)) (setq group (read cur)
;; group gets set to a symbol interned in the hash table group (if (numberp group)
;; (what a hack!!) - jwz (number-to-string group)
(setq group (let ((obarray hashtb)) (read cur))) (symbol-name group)))))
;; ### The extended group name scheme makes (numberp (setq max (read cur)))
;; the previous optimization strategy sort of pointless... (numberp (setq min (read cur)))
(when (stringp group) (null (progn
(setq group (intern group hashtb))) (skip-chars-forward " \t")
(if (and (numberp (setq max (read cur))) (memq (char-after)
(numberp (setq min (read cur))) '(?= ?x ?j)))))
(progn (progn (puthash group (cons min max) hashtb)
(skip-chars-forward " \t") ;; If group is moderated, stick it in the
(not ;; moderation cache.
(or (eq (char-after) ?=) (when (eq (char-after) ?m)
(eq (char-after) ?x) (puthash group t gnus-moderated-hashtb)))
(eq (char-after) ?j))))) (setq group nil))
(progn
(set group (cons min max))
;; if group is moderated, stick in moderation table
(when (eq (char-after) ?m)
(unless gnus-moderated-hashtb
(setq gnus-moderated-hashtb (gnus-make-hashtable)))
(gnus-sethash (symbol-name group) t
gnus-moderated-hashtb)))
(set group nil)))
(error (error
(and group
(symbolp group)
(set group nil))
(unless ignore-errors (unless ignore-errors
(gnus-message 3 "Warning - invalid active: %s" (gnus-message 3 "Warning - invalid active: %s"
(buffer-substring (buffer-substring
(point-at-bol) (point-at-eol)))))) (point-at-bol) (point-at-eol))))))
(widen)
(forward-line 1))))) (forward-line 1)))))
(defun gnus-groups-to-gnus-format (method &optional hashtb real-active) (defun gnus-groups-to-gnus-format (method &optional hashtb real-active)
@ -2238,35 +2192,23 @@ backend check whether the group actually exists."
(gnus-active-to-gnus-format method hashtb nil real-active)) (gnus-active-to-gnus-format method hashtb nil real-active))
(goto-char (point-min)) (goto-char (point-min))
;; We split this into to separate loops, one with the prefix (let (min max group)
;; and one without to speed the reading up somewhat. (while (not (eobp))
(if prefix (condition-case ()
(let (min max opoint group) (when (eq (char-after) ?2)
(while (not (eobp)) (read cur) (read cur)
(condition-case () (setq min (read cur)
(progn max (read cur)
(read cur) (read cur) group (read cur)
(setq min (read cur) group (if (numberp group)
max (read cur) (number-to-string group)
opoint (point)) (symbol-name group)))
(skip-chars-forward " \t") (puthash (if prefix
(insert prefix) (concat prefix group)
(goto-char opoint) group)
(set (let ((obarray hashtb)) (read cur)) (cons min max) hashtb))
(cons min max))) (error (remhash group hashtb)))
(error (and group (symbolp group) (set group nil)))) (forward-line 1))))))
(forward-line 1)))
(let (min max group)
(while (not (eobp))
(condition-case ()
(when (eq (char-after) ?2)
(read cur) (read cur)
(setq min (read cur)
max (read cur))
(set (setq group (let ((obarray hashtb)) (read cur)))
(cons min max)))
(error (and group (symbolp group) (set group nil))))
(forward-line 1)))))))
(defun gnus-read-newsrc-file (&optional force) (defun gnus-read-newsrc-file (&optional force)
"Read startup file. "Read startup file.
@ -2529,16 +2471,11 @@ If FORCE is non-nil, the .newsrc file is read."
(setq gnus-newsrc-options-n nil) (setq gnus-newsrc-options-n nil)
(unless gnus-active-hashtb (unless gnus-active-hashtb
(setq gnus-active-hashtb (gnus-make-hashtable 4096))) (setq gnus-active-hashtb (gnus-make-hashtable 4000)))
(let ((buf (current-buffer)) (let ((buf (current-buffer))
(already-read (> (length gnus-newsrc-alist) 1)) (already-read (> (length gnus-newsrc-alist) 1))
group subscribed options-symbol newsrc Options-symbol group subscribed newsrc reads num1)
symbol reads num1)
(goto-char (point-min)) (goto-char (point-min))
;; We intern the symbol `options' in the active hashtb so that we
;; can `eq' against it later.
(set (setq options-symbol (intern "options" gnus-active-hashtb)) nil)
(set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil)
(while (not (eobp)) (while (not (eobp))
;; We first read the first word on the line by narrowing and ;; We first read the first word on the line by narrowing and
@ -2549,15 +2486,16 @@ If FORCE is non-nil, the .newsrc file is read."
(point) (point)
(progn (skip-chars-forward "^ \t!:\n") (point))) (progn (skip-chars-forward "^ \t!:\n") (point)))
(goto-char (point-min)) (goto-char (point-min))
(setq symbol (setq group
(and (/= (point-min) (point-max)) (and (/= (point-min) (point-max))
(let ((obarray gnus-active-hashtb)) (read buf)))) (read buf))
group (if (numberp group)
(number-to-string group)
(symbol-name group)))
(widen) (widen)
;; Now, the symbol we have read is either `options' or a group
;; name. If it is an options line, we just add it to a string.
(cond (cond
((or (eq symbol options-symbol) ;; It's possible that "group" is actually an options line.
(eq symbol Options-symbol)) ((string-equal (downcase group) "options")
(setq gnus-newsrc-options (setq gnus-newsrc-options
;; This concatting is quite inefficient, but since our ;; This concatting is quite inefficient, but since our
;; thorough studies show that approx 99.37% of all ;; thorough studies show that approx 99.37% of all
@ -2571,19 +2509,13 @@ If FORCE is non-nil, the .newsrc file is read."
(point-at-bol)) (point-at-bol))
(point))))) (point)))))
(forward-line -1)) (forward-line -1))
(symbol (group
;; Group names can be just numbers.
(when (numberp symbol)
(setq symbol (intern (int-to-string symbol) gnus-active-hashtb)))
(unless (boundp symbol)
(set symbol nil))
;; It was a group name. ;; It was a group name.
(setq subscribed (eq (char-after) ?:) (setq subscribed (eq (char-after) ?:)
group (symbol-name symbol)
reads nil) reads nil)
(if (eolp) (if (eolp)
;; If the line ends here, this is clearly a buggy line, so ;; If the line ends here, this is clearly a buggy line, so
;; we put point a the beginning of line and let the cond ;; we put point at the beginning of line and let the cond
;; below do the error handling. ;; below do the error handling.
(beginning-of-line) (beginning-of-line)
;; We skip to the beginning of the ranges. ;; We skip to the beginning of the ranges.
@ -2622,7 +2554,7 @@ If FORCE is non-nil, the .newsrc file is read."
;; It was just a simple number, so we add it to the ;; It was just a simple number, so we add it to the
;; list of ranges. ;; list of ranges.
(push num1 reads)) (push num1 reads))
;; If the next char in ?\n, then we have reached the end ;; If the next char is ?\n, then we have reached the end
;; of the line and return nil. ;; of the line and return nil.
(not (eq (char-after) ?\n))) (not (eq (char-after) ?\n)))
((eq (char-after) ?\n) ((eq (char-after) ?\n)
@ -2651,7 +2583,8 @@ If FORCE is non-nil, the .newsrc file is read."
(let ((info (gnus-get-info group)) (let ((info (gnus-get-info group))
level) level)
(if info (if info
;; There is an entry for this file in the alist. ;; There is an entry for this file in
;; `gnus-newsrc-hashtb'.
(progn (progn
(gnus-info-set-read info (nreverse reads)) (gnus-info-set-read info (nreverse reads))
;; We update the level very gently. In fact, we ;; We update the level very gently. In fact, we
@ -2679,8 +2612,7 @@ If FORCE is non-nil, the .newsrc file is read."
(setq newsrc (nreverse newsrc)) (setq newsrc (nreverse newsrc))
(if (not already-read) (unless already-read
()
;; We now have two newsrc lists - `newsrc', which is what we ;; We now have two newsrc lists - `newsrc', which is what we
;; have read from .newsrc, and `gnus-newsrc-alist', which is ;; have read from .newsrc, and `gnus-newsrc-alist', which is
;; what we've read from .newsrc.eld. We have to merge these ;; what we've read from .newsrc.eld. We have to merge these
@ -2777,9 +2709,10 @@ If FORCE is non-nil, the .newsrc file is read."
(defvar gnus-save-newsrc-file-last-timestamp nil) (defvar gnus-save-newsrc-file-last-timestamp nil)
(defun gnus-save-newsrc-file (&optional force) (defun gnus-save-newsrc-file (&optional force)
"Save .newsrc file." "Save .newsrc file.
;; Note: We cannot save .newsrc file if all newsgroups are removed Use the group string names in `gnus-group-list' to pull info
;; from the variable gnus-newsrc-alist. values from `gnus-newsrc-hashtb', and write a new value of
`gnus-newsrc-alist'."
(when (and (or gnus-newsrc-alist gnus-killed-list) (when (and (or gnus-newsrc-alist gnus-killed-list)
gnus-current-startup-file) gnus-current-startup-file)
;; Save agent range limits for the currently active method. ;; Save agent range limits for the currently active method.
@ -2895,7 +2828,13 @@ If FORCE is non-nil, the .newsrc file is read."
(gnus-group-set-mode-line))))) (gnus-group-set-mode-line)))))
(defun gnus-gnus-to-quick-newsrc-format (&optional minimal name &rest specific-variables) (defun gnus-gnus-to-quick-newsrc-format (&optional minimal name &rest specific-variables)
"Print Gnus variables such as `gnus-newsrc-alist' in Lisp format." "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format.
Unless optional argument MINIMAL is non-nil, print human-readable
information in the header of the file, including the file
version. If NAME is present, print that as part of the header.
Variables printed are either the variables specified in
SPECIFIC-VARIABLES, or those in `gnus-variable-list'."
(princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n" (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n"
gnus-ding-file-coding-system)) gnus-ding-file-coding-system))
(if name (if name
@ -2929,9 +2868,18 @@ If FORCE is non-nil, the .newsrc file is read."
;; Remove the `gnus-killed-list' from the list of variables ;; Remove the `gnus-killed-list' from the list of variables
;; to be saved, if required. ;; to be saved, if required.
(delq 'gnus-killed-list (copy-sequence gnus-variable-list))))) (delq 'gnus-killed-list (copy-sequence gnus-variable-list)))))
;; Peel off the "dummy" group.
(gnus-newsrc-alist (cdr gnus-newsrc-alist))
variable) variable)
;; A bit of a fake-out here: the original value of
;; `gnus-newsrc-alist' isn't written to file, instead it is
;; constructed at the last minute by combining the group
;; ordering in `gnus-group-list' with the group infos from
;; `gnus-newsrc-hashtb'.
(set (nth (seq-position gnus-variable-list 'gnus-newsrc-alist)
gnus-variable-list)
(mapcar (lambda (g)
(nth 1 (gethash g gnus-newsrc-hashtb)))
gnus-group-list))
;; Insert the variables into the file. ;; Insert the variables into the file.
(while variables (while variables
(when (and (boundp (setq variable (pop variables))) (when (and (boundp (setq variable (pop variables)))
@ -2956,8 +2904,8 @@ If FORCE is non-nil, the .newsrc file is read."
(interactive (list (gnus-y-or-n-p "write foreign groups too? "))) (interactive (list (gnus-y-or-n-p "write foreign groups too? ")))
;; Generate and save the .newsrc file. ;; Generate and save the .newsrc file.
(with-current-buffer (create-file-buffer gnus-current-startup-file) (with-current-buffer (create-file-buffer gnus-current-startup-file)
(let ((newsrc (cdr gnus-newsrc-alist)) (let ((standard-output (current-buffer))
(standard-output (current-buffer)) (groups (delete "dummy.group" (copy-sequence gnus-group-list)))
info ranges range method) info ranges range method)
(setq buffer-file-name gnus-current-startup-file) (setq buffer-file-name gnus-current-startup-file)
(setq default-directory (file-name-directory buffer-file-name)) (setq default-directory (file-name-directory buffer-file-name))
@ -2971,13 +2919,14 @@ If FORCE is non-nil, the .newsrc file is read."
(when gnus-newsrc-options (when gnus-newsrc-options
(insert gnus-newsrc-options)) (insert gnus-newsrc-options))
;; Write subscribed and unsubscribed. ;; Write subscribed and unsubscribed.
(while (setq info (pop newsrc)) (dolist (g-name groups)
;; Don't write foreign groups to .newsrc. (setq info (nth 1 (gnus-group-entry g-name)))
;; Maybe don't write foreign groups to .newsrc.
(when (or (null (setq method (gnus-info-method info))) (when (or (null (setq method (gnus-info-method info)))
(equal method "native") (equal method "native")
(inline (gnus-server-equal method gnus-select-method)) (inline (gnus-server-equal method gnus-select-method))
foreign-ok) foreign-ok)
(insert (gnus-info-group info) (insert g-name
(if (> (gnus-info-level info) gnus-level-subscribed) (if (> (gnus-info-level info) gnus-level-subscribed)
"!" ":")) "!" ":"))
(when (setq ranges (gnus-info-read info)) (when (setq ranges (gnus-info-read info))
@ -3105,10 +3054,10 @@ If FORCE is non-nil, the .newsrc file is read."
;; to avoid trying to re-read after a failed read. ;; to avoid trying to re-read after a failed read.
(unless gnus-description-hashtb (unless gnus-description-hashtb
(setq gnus-description-hashtb (setq gnus-description-hashtb
(gnus-make-hashtable (length gnus-active-hashtb)))) (gnus-make-hashtable (hash-table-size gnus-active-hashtb))))
;; Mark this method's desc file as read. ;; Mark this method's desc file as read.
(gnus-sethash (gnus-group-prefixed-name "" method) "Has read" (puthash (gnus-group-prefixed-name "" method) "Has read"
gnus-description-hashtb) gnus-description-hashtb)
(gnus-message 5 "Reading descriptions file via %s..." (car method)) (gnus-message 5 "Reading descriptions file via %s..." (car method))
(cond (cond
@ -3144,29 +3093,26 @@ If FORCE is non-nil, the .newsrc file is read."
(zerop (forward-line 1))))))) (zerop (forward-line 1)))))))
(goto-char (point-min)) (goto-char (point-min))
(while (not (eobp)) (while (not (eobp))
;; If we get an error, we set group to 0, which is not a
;; symbol...
(setq group (setq group
(condition-case () (condition-case ()
(let ((obarray gnus-description-hashtb)) (read nntp-server-buffer)
;; Group is set to a symbol interned in this (error nil)))
;; hash table.
(read nntp-server-buffer))
(error 0)))
(skip-chars-forward " \t") (skip-chars-forward " \t")
;; ... which leads to this line being effectively ignored. (when group
(when (symbolp group) (setq group (if (numberp group)
(number-to-string group)
(symbol-name group)))
(let* ((str (buffer-substring (let* ((str (buffer-substring
(point) (progn (end-of-line) (point)))) (point) (progn (end-of-line) (point))))
(name (symbol-name group))
(charset (charset
(or (gnus-group-name-charset method name) (or (gnus-group-name-charset method group)
(gnus-parameter-charset name) (gnus-parameter-charset group)
gnus-default-charset))) gnus-default-charset)))
;; Fixme: Don't decode in unibyte mode. ;; Fixme: Don't decode in unibyte mode.
;; Double fixme: We're not in unibyte mode, are we?
(when (and str charset) (when (and str charset)
(setq str (decode-coding-string str charset))) (setq str (decode-coding-string str charset)))
(set group str))) (puthash group str gnus-description-hashtb)))
(forward-line 1)))) (forward-line 1))))
(gnus-message 5 "Reading descriptions file...done") (gnus-message 5 "Reading descriptions file...done")
t)))) t))))

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

@ -39,6 +39,8 @@
(require 'gmm-utils) (require 'gmm-utils)
(require 'mm-decode) (require 'mm-decode)
(require 'nnoo) (require 'nnoo)
(eval-when-compile
(require 'subr-x))
(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) (autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t)
(autoload 'gnus-cache-write-active "gnus-cache") (autoload 'gnus-cache-write-active "gnus-cache")
@ -1361,7 +1363,15 @@ the normal Gnus MIME machinery."
(defvar gnus-current-crosspost-group nil) (defvar gnus-current-crosspost-group nil)
(defvar gnus-newsgroup-display nil) (defvar gnus-newsgroup-display nil)
(defvar gnus-newsgroup-dependencies nil) (defvar gnus-newsgroup-dependencies nil
"A hash table holding dependencies between messages.")
;; Dependencies are held in a tree structure: a list with the root
;; message as car, and each immediate child a sublist (perhaps
;; containing further sublists). Each message is represented as a
;; vector of headers. Each message's list can be looked up in the
;; dependency table using the message's Message-ID as the key. The
;; root key is the string "none".
(defvar gnus-newsgroup-adaptive nil) (defvar gnus-newsgroup-adaptive nil)
(defvar gnus-summary-display-article-function nil) (defvar gnus-summary-display-article-function nil)
(defvar gnus-summary-highlight-line-function nil (defvar gnus-summary-highlight-line-function nil
@ -3937,7 +3947,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
;; Killed foreign groups can't be entered. ;; Killed foreign groups can't be entered.
;; (when (and (not (gnus-group-native-p group)) ;; (when (and (not (gnus-group-native-p group))
;; (not (gnus-gethash group gnus-newsrc-hashtb))) ;; (not (gethash group gnus-newsrc-hashtb)))
;; (error "Dead non-native groups can't be entered")) ;; (error "Dead non-native groups can't be entered"))
(gnus-message 7 "Retrieving newsgroup: %s..." (gnus-message 7 "Retrieving newsgroup: %s..."
(gnus-group-decoded-name group)) (gnus-group-decoded-name group))
@ -4167,7 +4177,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
"Gather threads by looking at Subject headers." "Gather threads by looking at Subject headers."
(if (not gnus-summary-make-false-root) (if (not gnus-summary-make-false-root)
threads threads
(let ((hashtb (gnus-make-hashtable 1024)) (let ((hashtb (gnus-make-hashtable 1000))
(prev threads) (prev threads)
(result threads) (result threads)
subject hthread whole-subject) subject hthread whole-subject)
@ -4176,7 +4186,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(setq whole-subject (mail-header-subject (setq whole-subject (mail-header-subject
(caar threads))))) (caar threads)))))
(when subject (when subject
(if (setq hthread (gnus-gethash subject hashtb)) (if (setq hthread (gethash subject hashtb))
(progn (progn
;; We enter a dummy root into the thread, if we ;; We enter a dummy root into the thread, if we
;; haven't done that already. ;; haven't done that already.
@ -4190,24 +4200,24 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(setcdr prev (cdr threads)) (setcdr prev (cdr threads))
(setq threads prev)) (setq threads prev))
;; Enter this thread into the hash table. ;; Enter this thread into the hash table.
(gnus-sethash subject (puthash subject
(if gnus-summary-make-false-root-always (if gnus-summary-make-false-root-always
(progn (progn
;; If you want a dummy root above all ;; If you want a dummy root above all
;; threads... ;; threads...
(setcar threads (list whole-subject (setcar threads (list whole-subject
(car threads))) (car threads)))
threads) threads)
threads) threads)
hashtb))) hashtb)))
(setq prev threads) (setq prev threads)
(setq threads (cdr threads))) (setq threads (cdr threads)))
result))) result)))
(defun gnus-gather-threads-by-references (threads) (defun gnus-gather-threads-by-references (threads)
"Gather threads by looking at References headers." "Gather threads by looking at References headers."
(let ((idhashtb (gnus-make-hashtable 1024)) (let ((idhashtb (gnus-make-hashtable 1000))
(thhashtb (gnus-make-hashtable 1024)) (thhashtb (gnus-make-hashtable 1000))
(prev threads) (prev threads)
(result threads) (result threads)
ids references id gthread gid entered ref) ids references id gthread gid entered ref)
@ -4218,11 +4228,11 @@ If SELECT-ARTICLES, only select those articles from GROUP."
entered nil) entered nil)
(while (setq ref (pop ids)) (while (setq ref (pop ids))
(setq ids (delete ref ids)) (setq ids (delete ref ids))
(if (not (setq gid (gnus-gethash ref idhashtb))) (if (not (setq gid (gethash ref idhashtb)))
(progn (progn
(gnus-sethash ref id idhashtb) (puthash ref id idhashtb)
(gnus-sethash id threads thhashtb)) (puthash id threads thhashtb))
(setq gthread (gnus-gethash gid thhashtb)) (setq gthread (gethash gid thhashtb))
(unless entered (unless entered
;; We enter a dummy root into the thread, if we ;; We enter a dummy root into the thread, if we
;; haven't done that already. ;; haven't done that already.
@ -4234,7 +4244,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(setcdr (car gthread) (setcdr (car gthread)
(nconc (cdar gthread) (list (car threads))))) (nconc (cdar gthread) (list (car threads)))))
;; Add it into the thread hash table. ;; Add it into the thread hash table.
(gnus-sethash id gthread thhashtb) (puthash id gthread thhashtb)
(setq entered t) (setq entered t)
;; Remove it from the list of threads. ;; Remove it from the list of threads.
(setcdr prev (cdr threads)) (setcdr prev (cdr threads))
@ -4267,12 +4277,12 @@ If SELECT-ARTICLES, only select those articles from GROUP."
;; We have found a loop. ;; We have found a loop.
(let (ref-dep) (let (ref-dep)
(setcdr thread (delq (car th) (cdr thread))) (setcdr thread (delq (car th) (cdr thread)))
(if (boundp (setq ref-dep (intern "none" (if (setq ref-dep (gethash "none"
gnus-newsgroup-dependencies))) gnus-newsgroup-dependencies))
(setcdr (symbol-value ref-dep) (setcdr ref-dep
(nconc (cdr (symbol-value ref-dep)) (nconc (cdr ref-dep)
(list (car th)))) (list (car th))))
(set ref-dep (list nil (car th)))) (puthash ref-dep (list nil (car th)) gnus-newsgroup-dependencies))
(setq infloop 1 (setq infloop 1
stack nil)) stack nil))
;; Push all the subthreads onto the stack. ;; Push all the subthreads onto the stack.
@ -4283,31 +4293,30 @@ If SELECT-ARTICLES, only select those articles from GROUP."
"Go through the dependency hashtb and find the roots. Return all threads." "Go through the dependency hashtb and find the roots. Return all threads."
(let (threads) (let (threads)
(while (catch 'infloop (while (catch 'infloop
(mapatoms (maphash
(lambda (refs) (lambda (_id refs)
;; Deal with self-referencing References loops. ;; Deal with self-referencing References loops.
(when (and (car (symbol-value refs)) (when (and (car refs)
(not (zerop (not (zerop
(apply (apply
'+ '+
(mapcar (mapcar
(lambda (thread) (lambda (thread)
(gnus-thread-loop-p (gnus-thread-loop-p
(car (symbol-value refs)) thread)) (car refs) thread))
(cdr (symbol-value refs))))))) (cdr refs))))))
(setq threads nil) (setq threads nil)
(throw 'infloop t)) (throw 'infloop t))
(unless (car (symbol-value refs)) (unless (car refs)
;; These threads do not refer back to any other ;; These threads do not refer back to any other
;; articles, so they're roots. ;; articles, so they're roots.
(setq threads (append (cdr (symbol-value refs)) threads)))) (setq threads (append (cdr refs) threads))))
gnus-newsgroup-dependencies))) gnus-newsgroup-dependencies)))
threads)) threads))
;; Build the thread tree. ;; Build the thread tree.
(defsubst gnus-dependencies-add-header (header dependencies force-new) (defsubst gnus-dependencies-add-header (header dependencies force-new)
"Enter HEADER into the DEPENDENCIES table if it is not already there. "Enter HEADER into the DEPENDENCIES table if it is not already there.
If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even
if it was already present. if it was already present.
@ -4318,33 +4327,38 @@ Message-ID before being entered.
Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
(let* ((id (mail-header-id header)) (let* ((id (mail-header-id header))
(id-dep (and id (intern id dependencies))) ;; An "id-dep" is a list holding the vector headers of this
;; message, plus equivalent "id-deps" for each immediate
;; child message.
(id-dep (and id (gethash id dependencies)))
parent-id ref ref-dep ref-header replaced) parent-id ref ref-dep ref-header replaced)
;; Enter this `header' in the `dependencies' table. ;; Enter this `header' in the `dependencies' table.
(cond (cond
((not id-dep) ((null id)
;; Omit this article altogether if there is no Message-ID.
(setq header nil)) (setq header nil))
;; The first two cases do the normal part: enter a new `header' ;; Enter a new id and `header' in the `dependencies' table.
;; in the `dependencies' table. ((null id-dep)
((not (boundp id-dep)) (setq id-dep (puthash id (list header) dependencies)))
(set id-dep (list header))) ;; A child message has already added this id, just insert the header.
((null (car (symbol-value id-dep))) ((null (car id-dep))
(setcar (symbol-value id-dep) header)) (setcar (gethash id dependencies) header)
(setq id-dep (gethash id dependencies)))
;; From here the `header' was already present in the ;; From here the `header' was already present in the
;; `dependencies' table. ;; `dependencies' table.
(force-new (force-new
;; Overrides an existing entry; ;; Overrides an existing entry;
;; just set the header part of the entry. ;; just set the header part of the entry.
(setcar (symbol-value id-dep) header) (setcar (gethash id dependencies) header)
(setq replaced t)) (setq replaced t))
;; Renames the existing `header' to a unique Message-ID. ;; Renames the existing `header' to a unique Message-ID.
((not gnus-summary-ignore-duplicates) ((not gnus-summary-ignore-duplicates)
;; An article with this Message-ID has already been seen. ;; An article with this Message-ID has already been seen.
;; We rename the Message-ID. ;; We rename the Message-ID.
(set (setq id-dep (intern (setq id (nnmail-message-id)) dependencies)) (setq id-dep (puthash (setq id (nnmail-message-id))
(list header)) (list header)
dependencies))
(mail-header-set-id header id)) (mail-header-set-id header id))
;; The last case ignores an existing entry, except it adds any ;; The last case ignores an existing entry, except it adds any
@ -4354,8 +4368,8 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
;; table was *not* modified. ;; table was *not* modified.
(t (t
(mail-header-set-xref (mail-header-set-xref
(car (symbol-value id-dep)) (car id-dep)
(concat (or (mail-header-xref (car (symbol-value id-dep))) (concat (or (mail-header-xref (car id-dep))
"") "")
(or (mail-header-xref header) ""))) (or (mail-header-xref header) "")))
(setq header nil))) (setq header nil)))
@ -4365,23 +4379,27 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
(setq parent-id (gnus-parent-id (mail-header-references header))) (setq parent-id (gnus-parent-id (mail-header-references header)))
(setq ref parent-id) (setq ref parent-id)
(while (and ref (while (and ref
(setq ref-dep (intern-soft ref dependencies)) (setq ref-dep (gethash ref dependencies))
(boundp ref-dep) (setq ref-header (car-safe ref-dep)))
(setq ref-header (car (symbol-value ref-dep))))
(if (string= id ref) (if (string= id ref)
;; Yuk! This is a reference loop. Make the article be a ;; Yuk! This is a reference loop. Make the article be a
;; root article. ;; root article.
(progn (progn
(mail-header-set-references (car (symbol-value id-dep)) "none") (mail-header-set-references (car id-dep) "none")
(setq ref nil) (setq ref nil)
(setq parent-id nil)) (setq parent-id nil))
(setq ref (gnus-parent-id (mail-header-references ref-header))))) (setq ref (gnus-parent-id (mail-header-references ref-header)))))
(setq ref-dep (intern (or parent-id "none") dependencies)) (setq ref (or parent-id "none")
(if (boundp ref-dep) ref-dep (gethash ref dependencies))
(setcdr (symbol-value ref-dep) ;; Add `header' to its parent's list of children, creating that
(nconc (cdr (symbol-value ref-dep)) ;; list if the parent isn't yet registered in the dependency
(list (symbol-value id-dep)))) ;; table.
(set ref-dep (list nil (symbol-value id-dep))))) (if ref-dep
(setcdr (gethash ref dependencies)
(nconc (cdr ref-dep)
(list id-dep)))
(puthash ref (list nil id-dep)
dependencies)))
header)) header))
(defun gnus-extract-message-id-from-in-reply-to (string) (defun gnus-extract-message-id-from-in-reply-to (string)
@ -4444,15 +4462,14 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
;; server, that is. ;; server, that is.
(let ((mail-parse-charset gnus-newsgroup-charset) (let ((mail-parse-charset gnus-newsgroup-charset)
id heads) id heads)
(mapatoms (maphash
(lambda (refs) (lambda (id refs)
(when (not (car (symbol-value refs))) (when (not (car refs))
(setq heads (cdr (symbol-value refs))) (setq heads (cdr refs))
(while heads (while heads
(if (memq (mail-header-number (caar heads)) (if (memq (mail-header-number (caar heads))
gnus-newsgroup-dormant) gnus-newsgroup-dormant)
(setq heads (cdr heads)) (setq heads (cdr heads))
(setq id (symbol-name refs))
(while (and (setq id (gnus-build-get-header id)) (while (and (setq id (gnus-build-get-header id))
(not (car (gnus-id-to-thread id))))) (not (car (gnus-id-to-thread id)))))
(setq heads nil))))) (setq heads nil)))))
@ -4733,7 +4750,7 @@ If LINE, insert the rebuilt thread starting on line LINE."
(defun gnus-id-to-thread (id) (defun gnus-id-to-thread (id)
"Return the (sub-)thread where ID appears." "Return the (sub-)thread where ID appears."
(gnus-gethash id gnus-newsgroup-dependencies)) (gethash id gnus-newsgroup-dependencies))
(defun gnus-id-to-article (id) (defun gnus-id-to-article (id)
"Return the article number of ID." "Return the article number of ID."
@ -5586,7 +5603,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual)
t t
gnus-summary-ignore-duplicates)) gnus-summary-ignore-duplicates))
(info (nth 2 entry)) (info (nth 1 entry))
charset articles fetched-articles cached) charset articles fetched-articles cached)
(unless (gnus-check-server (unless (gnus-check-server
@ -5605,7 +5622,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(decode-coding-string group charset) (decode-coding-string group charset)
(decode-coding-string (gnus-status-message group) charset)))) (decode-coding-string (gnus-status-message group) charset))))
(unless (gnus-request-group group t nil (gnus-get-info group)) (unless (gnus-request-group group t nil info)
(when (derived-mode-p 'gnus-summary-mode) (when (derived-mode-p 'gnus-summary-mode)
(gnus-kill-buffer (current-buffer))) (gnus-kill-buffer (current-buffer)))
(error "Couldn't request group %s: %s" (error "Couldn't request group %s: %s"
@ -6208,9 +6225,9 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(setq number (setq number
(string-to-number (substring xrefs (match-beginning 2) (string-to-number (substring xrefs (match-beginning 2)
(match-end 2)))) (match-end 2))))
(if (setq entry (gnus-gethash group xref-hashtb)) (if (setq entry (gethash group xref-hashtb))
(setcdr entry (cons number (cdr entry))) (setcdr entry (cons number (cdr entry)))
(gnus-sethash group (cons number nil) xref-hashtb))))) (puthash group (cons number nil) xref-hashtb)))))
(and start xref-hashtb))) (and start xref-hashtb)))
(defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads) (defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads)
@ -6220,10 +6237,9 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(with-current-buffer gnus-group-buffer (with-current-buffer gnus-group-buffer
(when (setq xref-hashtb (when (setq xref-hashtb
(gnus-create-xref-hashtb from-newsgroup headers unreads)) (gnus-create-xref-hashtb from-newsgroup headers unreads))
(mapatoms (maphash
(lambda (group) (lambda (group idlist)
(unless (string= from-newsgroup (setq name (symbol-name group))) (unless (string= from-newsgroup group)
(setq idlist (symbol-value group))
;; Dead groups are not updated. ;; Dead groups are not updated.
(and (prog1 (and (prog1
(setq info (gnus-get-info name)) (setq info (gnus-get-info name))
@ -6249,7 +6265,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(defun gnus-compute-read-articles (group articles) (defun gnus-compute-read-articles (group articles)
(let* ((entry (gnus-group-entry group)) (let* ((entry (gnus-group-entry group))
(info (nth 2 entry)) (info (nth 1 entry))
(active (gnus-active group)) (active (gnus-active group))
ninfo) ninfo)
(when entry (when entry
@ -6286,7 +6302,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
"Update the info of GROUP to say that ARTICLES are read." "Update the info of GROUP to say that ARTICLES are read."
(let* ((num 0) (let* ((num 0)
(entry (gnus-group-entry group)) (entry (gnus-group-entry group))
(info (nth 2 entry)) (info (nth 1 entry))
(active (gnus-active group)) (active (gnus-active group))
(set-marks (set-marks
(gnus-method-option-p (gnus-method-option-p
@ -8848,11 +8864,11 @@ fetch-old-headers verbiage, and so on."
(null gnus-thread-expunge-below))) (null gnus-thread-expunge-below)))
(push gnus-newsgroup-limit gnus-newsgroup-limits) (push gnus-newsgroup-limit gnus-newsgroup-limits)
(setq gnus-newsgroup-limit nil) (setq gnus-newsgroup-limit nil)
(mapatoms (maphash
(lambda (node) (lambda (id deps)
(unless (car (symbol-value node)) (unless (car deps)
;; These threads have no parents -- they are roots. ;; These threads have no parents -- they are roots.
(let ((nodes (cdr (symbol-value node))) (let ((nodes (cdr deps))
thread) thread)
(while nodes (while nodes
(if (and gnus-thread-expunge-below (if (and gnus-thread-expunge-below
@ -12288,12 +12304,11 @@ save those articles instead."
(nreverse split-name))) (nreverse split-name)))
(defun gnus-valid-move-group-p (group) (defun gnus-valid-move-group-p (group)
(and (symbolp group) (when (and (stringp group)
(boundp group) (null (string-empty-p group)))
(symbol-name group) (gnus-get-function (gnus-find-method-for-group
(symbol-value group) group)
(gnus-get-function (gnus-find-method-for-group 'request-accept-article t)))
(symbol-name group)) 'request-accept-article t)))
(defun gnus-read-move-group-name (prompt default articles prefix) (defun gnus-read-move-group-name (prompt default articles prefix)
"Read a group name." "Read a group name."
@ -12304,27 +12319,24 @@ save those articles instead."
(if (> (length articles) 1) (if (> (length articles) 1)
(format "these %d articles" (length articles)) (format "these %d articles" (length articles))
"this article"))) "this article")))
valid-names (valid-names
(seq-filter #'gnus-valid-move-group-p
(hash-table-keys gnus-active-hashtb)))
(to-newsgroup (to-newsgroup
(progn (cond
(mapatoms (lambda (g) ((null split-name)
(when (gnus-valid-move-group-p g) (gnus-group-completing-read
(push g valid-names))) prom
gnus-active-hashtb) valid-names
(cond nil prefix nil default))
((null split-name) ((= 1 (length split-name))
(gnus-group-completing-read (gnus-group-completing-read
prom prom
valid-names valid-names
nil prefix nil default)) nil prefix 'gnus-group-history (car split-name)))
((= 1 (length split-name)) (t
(gnus-group-completing-read (gnus-completing-read
prom prom (nreverse split-name) nil nil 'gnus-group-history))))
valid-names
nil prefix 'gnus-group-history (car split-name)))
(t
(gnus-completing-read
prom (nreverse split-name) nil nil 'gnus-group-history)))))
(to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))
encoded) encoded)
(when to-newsgroup (when to-newsgroup

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

@ -31,6 +31,8 @@
(require 'gnus-group) (require 'gnus-group)
(require 'gnus-start) (require 'gnus-start)
(require 'gnus-util) (require 'gnus-util)
(eval-when-compile
(require 'subr-x))
(defgroup gnus-topic nil (defgroup gnus-topic nil
"Group topics." "Group topics."
@ -99,8 +101,7 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-group-topic-name () (defun gnus-group-topic-name ()
"The name of the topic on the current line." "The name of the topic on the current line."
(let ((topic (get-text-property (point-at-bol) 'gnus-topic))) (get-text-property (point-at-bol) 'gnus-topic))
(and topic (symbol-name topic))))
(defun gnus-group-topic-level () (defun gnus-group-topic-level ()
"The level of the topic on the current line." "The level of the topic on the current line."
@ -144,8 +145,7 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-topic-goto-topic (topic) (defun gnus-topic-goto-topic (topic)
(when topic (when topic
(gnus-goto-char (text-property-any (point-min) (point-max) (gnus-text-property-search 'gnus-topic topic nil 'goto)))
'gnus-topic (intern topic)))))
(defun gnus-topic-jump-to-topic (topic) (defun gnus-topic-jump-to-topic (topic)
"Go to TOPIC." "Go to TOPIC."
@ -167,8 +167,7 @@ See Info node `(gnus)Formatting Variables'."
(point) 'gnus-topic)) (point) 'gnus-topic))
(get-text-property (max (1- (point)) (point-min)) (get-text-property (max (1- (point)) (point-min))
'gnus-topic)))))) 'gnus-topic))))))
(when result result))
(symbol-name result))))
(defun gnus-current-topics (&optional topic) (defun gnus-current-topics (&optional topic)
"Return a list of all current topics, lowest in hierarchy first. "Return a list of all current topics, lowest in hierarchy first.
@ -195,7 +194,7 @@ If RECURSIVE is t, return groups in its subtopics too."
(while groups (while groups
(when (setq group (pop groups)) (when (setq group (pop groups))
(setq entry (gnus-group-entry group) (setq entry (gnus-group-entry group)
info (nth 2 entry) info (nth 1 entry)
params (gnus-info-params info) params (gnus-info-params info)
active (gnus-active group) active (gnus-active group)
unread (or (car entry) unread (or (car entry)
@ -462,7 +461,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
(gnus-group-prepare-flat-list-dead (gnus-group-prepare-flat-list-dead
(seq-remove (lambda (group) (seq-remove (lambda (group)
(or (gnus-group-entry group) (or (gnus-group-entry group)
(gnus-gethash group gnus-killed-hashtb))) (gethash group gnus-killed-hashtb)))
not-in-list) not-in-list)
gnus-level-killed ?K regexp))) gnus-level-killed ?K regexp)))
@ -536,7 +535,7 @@ articles in the topic and its subtopics."
(funcall regexp entry)) (funcall regexp entry))
((null regexp) t) ((null regexp) t)
(t nil)))) (t nil))))
(setq info (nth 2 entry)) (setq info (nth 1 entry))
(gnus-group-prepare-logic (gnus-group-prepare-logic
(gnus-info-group info) (gnus-info-group info)
(and (or (not gnus-group-listed-groups) (and (or (not gnus-group-listed-groups)
@ -557,7 +556,7 @@ articles in the topic and its subtopics."
(car active)) (car active))
nil) nil)
;; Living groups. ;; Living groups.
(when (setq info (nth 2 entry)) (when (setq info (nth 1 entry))
(gnus-group-insert-group-line (gnus-group-insert-group-line
(gnus-info-group info) (gnus-info-group info)
(gnus-info-level info) (gnus-info-marks info) (gnus-info-level info) (gnus-info-marks info)
@ -646,7 +645,7 @@ articles in the topic and its subtopics."
(point) (point)
(prog1 (1+ (point)) (prog1 (1+ (point))
(eval gnus-topic-line-format-spec)) (eval gnus-topic-line-format-spec))
(list 'gnus-topic (intern name) (list 'gnus-topic name
'gnus-topic-level level 'gnus-topic-level level
'gnus-topic-unread unread 'gnus-topic-unread unread
'gnus-active active-topic 'gnus-active active-topic
@ -844,10 +843,9 @@ articles in the topic and its subtopics."
;; they belong to some topic. ;; they belong to some topic.
(let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist))) (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist)))
(entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
(newsrc (cdr gnus-newsrc-alist)) (groups (cdr gnus-group-list)))
group) (dolist (group groups)
(while newsrc (unless (member group tgroups)
(unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
(setcdr entry (list group)) (setcdr entry (list group))
(setq entry (cdr entry))))) (setq entry (cdr entry)))))
;; Go through all topics and make sure they contain only living groups. ;; Go through all topics and make sure they contain only living groups.
@ -888,7 +886,7 @@ articles in the topic and its subtopics."
(while (setq group (pop topic)) (while (setq group (pop topic))
(when (and (or (gnus-active group) (when (and (or (gnus-active group)
(gnus-info-method (gnus-get-info group))) (gnus-info-method (gnus-get-info group)))
(not (gnus-gethash group gnus-killed-hashtb))) (not (gethash group gnus-killed-hashtb)))
(push group filtered-topic))) (push group filtered-topic)))
(push (cons topic-name (nreverse filtered-topic)) result))) (push (cons topic-name (nreverse filtered-topic)) result)))
(setq gnus-topic-alist (nreverse result)))) (setq gnus-topic-alist (nreverse result))))
@ -898,7 +896,7 @@ articles in the topic and its subtopics."
(with-current-buffer gnus-group-buffer (with-current-buffer gnus-group-buffer
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(unless gnus-topic-inhibit-change-level (unless gnus-topic-inhibit-change-level
(gnus-group-goto-group (or (car (nth 2 previous)) group)) (gnus-group-goto-group (or (car (nth 1 previous)) group))
(when (and gnus-topic-mode (when (and gnus-topic-mode
gnus-topic-alist gnus-topic-alist
(not gnus-topic-inhibit-change-level)) (not gnus-topic-inhibit-change-level))
@ -956,7 +954,7 @@ articles in the topic and its subtopics."
(if (not group) (if (not group)
(if (not (memq 'gnus-topic props)) (if (not (memq 'gnus-topic props))
(goto-char (point-max)) (goto-char (point-max))
(let ((topic (symbol-name (cadr (memq 'gnus-topic props))))) (let ((topic (cadr (memq 'gnus-topic props))))
(or (gnus-topic-goto-topic topic) (or (gnus-topic-goto-topic topic)
(gnus-topic-goto-topic (gnus-topic-next-topic topic))))) (gnus-topic-goto-topic (gnus-topic-next-topic topic)))))
(if (gnus-group-goto-group group) (if (gnus-group-goto-group group)
@ -992,12 +990,8 @@ articles in the topic and its subtopics."
;; First we make sure that we have really read the active file. ;; First we make sure that we have really read the active file.
(when (or force (when (or force
(not gnus-topic-active-alist)) (not gnus-topic-active-alist))
(let (groups) ;; Get a list of all groups available.
;; Get a list of all groups available. (let ((groups (sort (hash-table-keys gnus-active-hashtb) #'string<)))
(mapatoms (lambda (g) (when (symbol-value g)
(push (symbol-name g) groups)))
gnus-active-hashtb)
(setq groups (sort groups 'string<))
;; Init the variables. ;; Init the variables.
(setq gnus-topic-active-topology (list (list "" 'visible))) (setq gnus-topic-active-topology (list (list "" 'visible)))
(setq gnus-topic-active-alist nil) (setq gnus-topic-active-alist nil)
@ -1202,7 +1196,7 @@ If performed over a topic line, toggle folding the topic."
(save-excursion (save-excursion
(gnus-message 5 "Expiring groups in %s..." topic) (gnus-message 5 "Expiring groups in %s..." topic)
(let ((gnus-group-marked (let ((gnus-group-marked
(mapcar (lambda (entry) (car (nth 2 entry))) (mapcar (lambda (entry) (car (nth 1 entry)))
(gnus-topic-find-groups topic gnus-level-killed t (gnus-topic-find-groups topic gnus-level-killed t
nil t)))) nil t))))
(gnus-group-expire-articles nil)) (gnus-group-expire-articles nil))
@ -1216,7 +1210,7 @@ Also see `gnus-group-catchup'."
(call-interactively 'gnus-group-catchup-current) (call-interactively 'gnus-group-catchup-current)
(save-excursion (save-excursion
(let* ((groups (let* ((groups
(mapcar (lambda (entry) (car (nth 2 entry))) (mapcar (lambda (entry) (car (nth 1 entry)))
(gnus-topic-find-groups topic gnus-level-killed t (gnus-topic-find-groups topic gnus-level-killed t
nil t))) nil t)))
(inhibit-read-only t) (inhibit-read-only t)
@ -1449,7 +1443,7 @@ If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics."
(not non-recursive)))) (not non-recursive))))
(while groups (while groups
(funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
(gnus-info-group (nth 2 (pop groups))))))))) (gnus-info-group (nth 1 (pop groups)))))))))
(defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive) (defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive)
"Remove the process mark from all groups in the TOPIC. "Remove the process mark from all groups in the TOPIC.

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

@ -35,6 +35,7 @@
(eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'cl-lib))
(require 'time-date) (require 'time-date)
(require 'text-property-search)
(defcustom gnus-completing-read-function 'gnus-emacs-completing-read (defcustom gnus-completing-read-function 'gnus-emacs-completing-read
"Function use to do completing read." "Function use to do completing read."
@ -104,13 +105,6 @@ This is a compatibility function for different Emacsen."
(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
(defmacro gnus-intern-safe (string hashtable)
"Get hash value. Arguments are STRING and HASHTABLE."
`(let ((symbol (intern ,string ,hashtable)))
(or (boundp symbol)
(set symbol nil))
symbol))
(defsubst gnus-goto-char (point) (defsubst gnus-goto-char (point)
(and point (goto-char point))) (and point (goto-char point)))
@ -199,6 +193,36 @@ is slower."
(search-forward ":" eol t) (search-forward ":" eol t)
(point))))) (point)))))
(defun gnus-text-property-search (prop value &optional forward-only goto end)
"Search current buffer for text property PROP with VALUE.
Behaves like a combination of `text-property-any' and
`text-property-search-forward'. Searches for the beginning of a
text property `equal' to VALUE. Returns the value of point at
the beginning of the matching text property span.
If FORWARD-ONLY is non-nil, only search forward from point.
If GOTO is non-nil, move point to the beginning of that span
instead.
If END is non-nil, use the end of the span instead."
(let* ((start (point))
(found (progn
(unless forward-only
(goto-char (point-min)))
(text-property-search-forward
prop value #'equal)))
(target (when found
(if end
(prop-match-end found)
(prop-match-beginning found)))))
(when target
(if goto
(goto-char target)
(prog1
target
(goto-char start))))))
(declare-function gnus-find-method-for-group "gnus" (group &optional info)) (declare-function gnus-find-method-for-group "gnus" (group &optional info))
(declare-function gnus-group-name-decode "gnus-group" (string charset)) (declare-function gnus-group-name-decode "gnus-group" (string charset))
(declare-function gnus-group-name-charset "gnus-group" (method group)) (declare-function gnus-group-name-charset "gnus-group" (method group))
@ -390,22 +414,9 @@ Cache the result as a text property stored in DATE."
"Quote all \"%\"'s in STRING." "Quote all \"%\"'s in STRING."
(replace-regexp-in-string "%" "%%" string)) (replace-regexp-in-string "%" "%%" string))
;; Make a hash table (default and minimum size is 256). (defsubst gnus-make-hashtable (&optional size)
;; Optional argument HASHSIZE specifies the table size. "Make a hash table of SIZE, testing on `equal'."
(defun gnus-make-hashtable (&optional hashsize) (make-hash-table :size (or size 300) :test #'equal))
(make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0))
;; Make a number that is suitable for hashing; bigger than MIN and
;; equal to some 2^x. Many machines (such as sparcs) do not have a
;; hardware modulo operation, so they implement it in software. On
;; many sparcs over 50% of the time to intern is spent in the modulo.
;; Yes, it's slower than actually computing the hash from the string!
;; So we use powers of 2 so people can optimize the modulo to a mask.
(defun gnus-create-hash-size (min)
(let ((i 1))
(while (< i min)
(setq i (* 2 i)))
i))
(defcustom gnus-verbose 6 (defcustom gnus-verbose 6
"Integer that says how verbose Gnus should be. "Integer that says how verbose Gnus should be.
@ -1174,18 +1185,16 @@ ARG is passed to the first function."
;; The buffer should be in the unibyte mode because group names ;; The buffer should be in the unibyte mode because group names
;; are ASCII text or encoded non-ASCII text (i.e., unibyte). ;; are ASCII text or encoded non-ASCII text (i.e., unibyte).
(mm-disable-multibyte) (mm-disable-multibyte)
(mapatoms (maphash
(lambda (sym) (lambda (group active)
(when (and sym (when active
(boundp sym) (insert (format "%s %d %d y\n"
(symbol-value sym))
(insert (format "%S %d %d y\n"
(if full-names (if full-names
sym group
(intern (gnus-group-real-name (symbol-name sym)))) (gnus-group-real-name group))
(or (cdr (symbol-value sym)) (or (cdr active)
(car (symbol-value sym))) (car active))
(car (symbol-value sym)))))) (car active)))))
hashtb) hashtb)
(goto-char (point-max)) (goto-char (point-max))
(while (search-backward "\\." nil t) (while (search-backward "\\." nil t)

51
lisp/gnus/gnus.el
View file

@ -29,7 +29,8 @@
(run-hooks 'gnus-load-hook) (run-hooks 'gnus-load-hook)
(eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'cl-lib)
(require 'subr-x))
(require 'wid-edit) (require 'wid-edit)
(require 'mm-util) (require 'mm-util)
(require 'nnheader) (require 'nnheader)
@ -2453,28 +2454,37 @@ such as a mark that says whether an article is stored in the cache
gnus-registry.el will populate this if it's loaded.") gnus-registry.el will populate this if it's loaded.")
(defvar gnus-newsrc-hashtb nil (defvar gnus-newsrc-hashtb nil
"Hashtable of `gnus-newsrc-alist'.") "Hash table of `gnus-newsrc-alist'.")
(defvar gnus-group-list nil
"Ordered list of group names as strings.
This variable only exists to provide easy access to the ordering
of `gnus-newsrc-alist'.")
(defvar gnus-killed-list nil (defvar gnus-killed-list nil
"List of killed newsgroups.") "List of killed newsgroups.")
(defvar gnus-killed-hashtb nil (defvar gnus-killed-hashtb nil
"Hash table equivalent of `gnus-killed-list'.") "Hash table equivalent of `gnus-killed-list'.
This is a hash table purely for the fast membership test: values
are always t.")
(defvar gnus-zombie-list nil (defvar gnus-zombie-list nil
"List of almost dead newsgroups.") "List of almost dead newsgroups.")
(defvar gnus-description-hashtb nil (defvar gnus-description-hashtb nil
"Descriptions of newsgroups.") "Hash table mapping group names to their descriptions.")
(defvar gnus-list-of-killed-groups nil (defvar gnus-list-of-killed-groups nil
"List of newsgroups that have recently been killed by the user.") "List of newsgroups that have recently been killed by the user.")
(defvar gnus-active-hashtb nil (defvar gnus-active-hashtb nil
"Hashtable of active articles.") "Hash table mapping group names to their active entry.")
(defvar gnus-moderated-hashtb nil (defvar gnus-moderated-hashtb nil
"Hashtable of moderated newsgroups.") "Hash table of moderated groups.
This is a hash table purely for the fast membership test: values
are always t.")
;; Save window configuration. ;; Save window configuration.
(defvar gnus-prev-winconf nil) (defvar gnus-prev-winconf nil)
@ -2800,36 +2810,21 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-header-from (header) (defun gnus-header-from (header)
(mail-header-from header)) (mail-header-from header))
(defmacro gnus-gethash (string hashtable)
"Get hash value of STRING in HASHTABLE."
`(symbol-value (intern-soft ,string ,hashtable)))
(defmacro gnus-gethash-safe (string hashtable)
"Get hash value of STRING in HASHTABLE.
Return nil if not defined."
`(let ((sym (intern-soft ,string ,hashtable)))
(and (boundp sym) (symbol-value sym))))
(defmacro gnus-sethash (string value hashtable)
"Set hash value. Arguments are STRING, VALUE, and HASHTABLE."
`(set (intern ,string ,hashtable) ,value))
(put 'gnus-sethash 'edebug-form-spec '(form form form))
(defmacro gnus-group-unread (group) (defmacro gnus-group-unread (group)
"Get the currently computed number of unread articles in GROUP." "Get the currently computed number of unread articles in GROUP."
`(car (gnus-gethash ,group gnus-newsrc-hashtb))) `(car (gethash ,group gnus-newsrc-hashtb)))
(defmacro gnus-group-entry (group) (defmacro gnus-group-entry (group)
"Get the newsrc entry for GROUP." "Get the newsrc entry for GROUP."
`(gnus-gethash ,group gnus-newsrc-hashtb)) `(gethash ,group gnus-newsrc-hashtb))
(defmacro gnus-active (group) (defmacro gnus-active (group)
"Get active info on GROUP." "Get active info on GROUP."
`(gnus-gethash ,group gnus-active-hashtb)) `(gethash ,group gnus-active-hashtb))
(defmacro gnus-set-active (group active) (defmacro gnus-set-active (group active)
"Set GROUP's active info." "Set GROUP's active info."
`(gnus-sethash ,group ,active gnus-active-hashtb)) `(puthash ,group ,active gnus-active-hashtb))
;; Info access macros. ;; Info access macros.
@ -2893,10 +2888,10 @@ Return nil if not defined."
(setcar rank (cons (car rank) ,score))))) (setcar rank (cons (car rank) ,score)))))
(defmacro gnus-get-info (group) (defmacro gnus-get-info (group)
`(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb))) `(nth 1 (gethash ,group gnus-newsrc-hashtb)))
(defun gnus-set-info (group info) (defun gnus-set-info (group info)
(setcar (nthcdr 2 (gnus-gethash group gnus-newsrc-hashtb)) (setcdr (gethash group gnus-newsrc-hashtb)
info)) info))
@ -3185,7 +3180,7 @@ that that variable is buffer-local to the summary buffers."
(defun gnus-kill-ephemeral-group (group) (defun gnus-kill-ephemeral-group (group)
"Remove ephemeral GROUP from relevant structures." "Remove ephemeral GROUP from relevant structures."
(gnus-sethash group nil gnus-newsrc-hashtb)) (remhash group gnus-newsrc-hashtb))
(defun gnus-simplify-mode-line () (defun gnus-simplify-mode-line ()
"Make mode lines a bit simpler." "Make mode lines a bit simpler."

17
lisp/gnus/message.el
View file

@ -8024,18 +8024,11 @@ regular text mode tabbing command."
(skip-chars-backward "^, \t\n") (point)))) (skip-chars-backward "^, \t\n") (point))))
(completion-ignore-case t) (completion-ignore-case t)
(e (progn (skip-chars-forward "^,\t\n ") (point))) (e (progn (skip-chars-forward "^,\t\n ") (point)))
group collection) (collection (when (and (boundp 'gnus-active-hashtb)
(when (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)
gnus-active-hashtb) (hash-table-keys gnus-active-hashtb))))
(mapatoms (when collection
(lambda (symbol) (completion-in-region b e collection))))
(setq group (symbol-name symbol))
(push (if (string-match "[^\000-\177]" group)
(gnus-group-decoded-name group)
group)
collection))
gnus-active-hashtb))
(completion-in-region b e collection)))
(defun message-expand-name () (defun message-expand-name ()
(cond ((and (memq 'eudc message-expand-name-databases) (cond ((and (memq 'eudc message-expand-name-databases)

2
lisp/gnus/mml.el
View file

@ -29,6 +29,7 @@
(require 'mml-sec) (require 'mml-sec)
(eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'url)) (eval-when-compile (require 'url))
(eval-when-compile (require 'gnus-util))
(autoload 'message-make-message-id "message") (autoload 'message-make-message-id "message")
(declare-function gnus-setup-posting-charset "gnus-msg" (group)) (declare-function gnus-setup-posting-charset "gnus-msg" (group))
@ -1547,7 +1548,6 @@ Should be adopted if code in `message-send-mail' is changed."
(defvar mml-preview-buffer nil) (defvar mml-preview-buffer nil)
(autoload 'gnus-make-hashtable "gnus-util")
(autoload 'widget-button-press "wid-edit" nil t) (autoload 'widget-button-press "wid-edit" nil t)
(declare-function widget-event-point "wid-edit" (event)) (declare-function widget-event-point "wid-edit" (event))
;; If gnus-buffer-configuration is bound this is loaded. ;; If gnus-buffer-configuration is bound this is loaded.

6
lisp/gnus/nnbabyl.el
View file

@ -624,7 +624,7 @@
(defun nnbabyl-check-mbox () (defun nnbabyl-check-mbox ()
"Go through the nnbabyl mbox and make sure that no article numbers are reused." "Go through the nnbabyl mbox and make sure that no article numbers are reused."
(interactive) (interactive)
(let ((idents (make-vector 1000 0)) (let ((idents (gnus-make-hashtable 1000))
id) id)
(save-excursion (save-excursion
(when (or (not nnbabyl-mbox-buffer) (when (or (not nnbabyl-mbox-buffer)
@ -633,13 +633,13 @@
(set-buffer nnbabyl-mbox-buffer) (set-buffer nnbabyl-mbox-buffer)
(goto-char (point-min)) (goto-char (point-min))
(while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t) (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t)
(if (intern-soft (setq id (match-string 1)) idents) (if (gethash (setq id (match-string 1)) idents)
(progn (progn
(delete-region (point-at-bol) (progn (forward-line 1) (point))) (delete-region (point-at-bol) (progn (forward-line 1) (point)))
(nnheader-message 7 "Moving %s..." id) (nnheader-message 7 "Moving %s..." id)
(nnbabyl-save-mail (nnbabyl-save-mail
(nnmail-article-group 'nnbabyl-active-number))) (nnmail-article-group 'nnbabyl-active-number)))
(intern id idents))) (puthash id t idents)))
(when (buffer-modified-p (current-buffer)) (when (buffer-modified-p (current-buffer))
(save-buffer)) (save-buffer))
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)

269
lisp/gnus/nnmaildir.el
View file

@ -68,7 +68,9 @@
(require 'message) (require 'message)
(require 'nnmail) (require 'nnmail)
(eval-when-compile (require 'cl-lib)) (eval-when-compile
(require 'cl-lib)
(require 'subr-x))
(defconst nnmaildir-version "Gnus") (defconst nnmaildir-version "Gnus")
@ -135,11 +137,10 @@ This variable is set by `nnmaildir-request-article'.")
(defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid)))) (defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
(defvar nnmaildir--delivery-count nil) (defvar nnmaildir--delivery-count nil)
;; An obarry containing symbols whose names are server names and whose values (defvar nnmaildir--servers nil
;; are servers: "Alist mapping server name strings to servers.")
(defvar nnmaildir--servers (make-vector 3 0)) (defvar nnmaildir--cur-server nil
;; The current server: "The current server.")
(defvar nnmaildir--cur-server nil)
;; A copy of nnmail-extra-headers ;; A copy of nnmail-extra-headers
(defvar nnmaildir--extra nil) (defvar nnmaildir--extra nil)
@ -172,17 +173,17 @@ This variable is set by `nnmaildir-request-article'.")
(nov nil :type vector)) ;; cached nov structure, or nil (nov nil :type vector)) ;; cached nov structure, or nil
(cl-defstruct nnmaildir--grp (cl-defstruct nnmaildir--grp
(name nil :type string) ;; "group.name" (name nil :type string) ;; "group.name"
(new nil :type list) ;; new/ modtime (new nil :type list) ;; new/ modtime
(cur nil :type list) ;; cur/ modtime (cur nil :type list) ;; cur/ modtime
(min 1 :type natnum) ;; minimum article number (min 1 :type natnum) ;; minimum article number
(count 0 :type natnum) ;; count of articles (count 0 :type natnum) ;; count of articles
(nlist nil :type list) ;; list of articles, ordered descending by number (nlist nil :type list) ;; list of articles, ordered descending by number
(flist nil :type vector) ;; obarray mapping filename prefix->article (flist nil :type hash-table) ;; hash table mapping filename prefix->article
(mlist nil :type vector) ;; obarray mapping message-id->article (mlist nil :type hash-table) ;; hash table mapping message-id->article
(cache nil :type vector) ;; nov cache (cache nil :type vector) ;; nov cache
(index nil :type natnum) ;; index of next cache entry to replace (index nil :type natnum) ;; index of next cache entry to replace
(mmth nil :type vector)) ;; obarray mapping mark name->dir modtime (mmth nil :type hash-table)) ;; hash table mapping mark name->dir modtime
; ("Mark Mod Time Hash") ; ("Mark Mod Time Hash")
(cl-defstruct nnmaildir--srv (cl-defstruct nnmaildir--srv
@ -191,7 +192,7 @@ This variable is set by `nnmaildir-request-article'.")
(prefix nil :type string) ;; "nnmaildir+address:" (prefix nil :type string) ;; "nnmaildir+address:"
(dir nil :type string) ;; "/expanded/path/to/server/dir/" (dir nil :type string) ;; "/expanded/path/to/server/dir/"
(ls nil :type function) ;; directory-files function (ls nil :type function) ;; directory-files function
(groups nil :type vector) ;; obarray mapping group name->group (groups nil :type hash-table) ;; hash table mapping group name->group
(curgrp nil :type nnmaildir--grp) ;; current group, or nil (curgrp nil :type nnmaildir--grp) ;; current group, or nil
(error nil :type string) ;; last error message, or nil (error nil :type string) ;; last error message, or nil
(mtime nil :type list) ;; modtime of dir (mtime nil :type list) ;; modtime of dir
@ -238,17 +239,17 @@ This variable is set by `nnmaildir-request-article'.")
(setf (nnmaildir--grp-count group) count) (setf (nnmaildir--grp-count group) count)
(setf (nnmaildir--grp-nlist group) new-nlist) (setf (nnmaildir--grp-nlist group) new-nlist)
(setcdr nlist-pre nlist-post) (setcdr nlist-pre nlist-post)
(unintern prefix flist) (remhash prefix flist)
(unintern msgid mlist)))) (remhash msgid mlist))))
(defun nnmaildir--nlist-art (group num) (defun nnmaildir--nlist-art (group num)
(let ((entry (assq num (nnmaildir--grp-nlist group)))) (let ((entry (assq num (nnmaildir--grp-nlist group))))
(if entry (if entry
(cdr entry)))) (cdr entry))))
(defmacro nnmaildir--flist-art (list file) (defmacro nnmaildir--flist-art (list file)
`(symbol-value (intern-soft ,file ,list))) `(gethash ,file ,list))
(defmacro nnmaildir--mlist-art (list msgid) (defmacro nnmaildir--mlist-art (list msgid)
`(symbol-value (intern-soft ,msgid ,list))) `(gethash ,msgid ,list))
(defun nnmaildir--pgname (server gname) (defun nnmaildir--pgname (server gname)
(let ((prefix (nnmaildir--srv-prefix server))) (let ((prefix (nnmaildir--srv-prefix server)))
@ -337,12 +338,12 @@ This variable is set by `nnmaildir-request-article'.")
(if (null server) (if (null server)
(unless (setq server nnmaildir--cur-server) (unless (setq server nnmaildir--cur-server)
(throw 'return nil)) (throw 'return nil))
(unless (setq server (intern-soft server nnmaildir--servers)) (unless (setq server (alist-get server nnmaildir--servers
nil nil #'equal))
(throw 'return nil)) (throw 'return nil))
(setq server (symbol-value server) (setq nnmaildir--cur-server server))
nnmaildir--cur-server server))
(let ((groups (nnmaildir--srv-groups server))) (let ((groups (nnmaildir--srv-groups server)))
(when groups (when (and groups (null (hash-table-empty-p groups)))
(unless (nnmaildir--srv-method server) (unless (nnmaildir--srv-method server)
(setf (nnmaildir--srv-method server) (setf (nnmaildir--srv-method server)
(or (gnus-server-to-method (or (gnus-server-to-method
@ -350,7 +351,7 @@ This variable is set by `nnmaildir-request-article'.")
(throw 'return nil)))) (throw 'return nil))))
(if (null group) (if (null group)
(nnmaildir--srv-curgrp server) (nnmaildir--srv-curgrp server)
(symbol-value (intern-soft group groups))))))) (gethash group groups))))))
(defun nnmaildir--tab-to-space (string) (defun nnmaildir--tab-to-space (string)
(let ((pos 0)) (let ((pos 0))
@ -574,15 +575,15 @@ This variable is set by `nnmaildir-request-article'.")
(if insert-nlist (if insert-nlist
(setcdr nlist (cons (cons num article) nlist-cdr)) (setcdr nlist (cons (cons num article) nlist-cdr))
(setf (nnmaildir--grp-nlist group) nlist)) (setf (nnmaildir--grp-nlist group) nlist))
(set (intern (nnmaildir--art-prefix article) (puthash (nnmaildir--art-prefix article)
(nnmaildir--grp-flist group)) article
article) (nnmaildir--grp-flist group))
(set (intern (nnmaildir--art-msgid article) (puthash (nnmaildir--art-msgid article)
(nnmaildir--grp-mlist group)) article
article) (nnmaildir--grp-mlist group))
(set (intern (nnmaildir--grp-name group) (puthash (nnmaildir--grp-name group)
(nnmaildir--srv-groups server)) group
group)) (nnmaildir--srv-groups server)))
(nnmaildir--cache-nov group article nov) (nnmaildir--cache-nov group article nov)
t))) t)))
@ -650,9 +651,6 @@ This variable is set by `nnmaildir-request-article'.")
(if (< (car entry) low) (throw 'iterate-loop nil)) (if (< (car entry) low) (throw 'iterate-loop nil))
(funcall func (cdr entry))))))) (funcall func (cdr entry)))))))
(defun nnmaildir--up2-1 (n)
(if (zerop n) 1 (1- (ash 1 (1+ (logb n))))))
(defun nnmaildir--system-name () (defun nnmaildir--system-name ()
(replace-regexp-in-string (replace-regexp-in-string
":" "\\072" ":" "\\072"
@ -677,19 +675,20 @@ This variable is set by `nnmaildir-request-article'.")
(nnmaildir--srv-groups nnmaildir--cur-server) (nnmaildir--srv-groups nnmaildir--cur-server)
t)) t))
(defun nnmaildir-open-server (server &optional defs) (defun nnmaildir-open-server (server-string &optional defs)
(let ((x server) (let ((server (alist-get server-string nnmaildir--servers
dir size) nil nil #'equal))
dir size x)
(catch 'return (catch 'return
(setq server (intern-soft x nnmaildir--servers))
(if server (if server
(and (setq server (symbol-value server)) (and (nnmaildir--srv-groups server)
(nnmaildir--srv-groups server)
(setq nnmaildir--cur-server server) (setq nnmaildir--cur-server server)
(throw 'return t)) (throw 'return t))
(setq server (make-nnmaildir--srv :address x)) (setq server (make-nnmaildir--srv :address server-string))
(let ((inhibit-quit t)) (let ((inhibit-quit t))
(set (intern x nnmaildir--servers) server))) (setf (alist-get server-string nnmaildir--servers
nil nil #'equal)
server)))
(setq dir (assq 'directory defs)) (setq dir (assq 'directory defs))
(unless dir (unless dir
(setf (nnmaildir--srv-error server) (setf (nnmaildir--srv-error server)
@ -713,8 +712,7 @@ This variable is set by `nnmaildir-request-article'.")
(concat "Not a function: " (prin1-to-string x))) (concat "Not a function: " (prin1-to-string x)))
(throw 'return nil))) (throw 'return nil)))
(setf (nnmaildir--srv-ls server) x) (setf (nnmaildir--srv-ls server) x)
(setq size (length (funcall x dir nil "\\`[^.]" 'nosort)) (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)))
size (nnmaildir--up2-1 size))
(and (setq x (assq 'get-new-mail defs)) (and (setq x (assq 'get-new-mail defs))
(setq x (cdr x)) (setq x (cdr x))
(car x) (car x)
@ -734,7 +732,8 @@ This variable is set by `nnmaildir-request-article'.")
x (file-name-as-directory x)) x (file-name-as-directory x))
(setf (nnmaildir--srv-target-prefix server) x)) (setf (nnmaildir--srv-target-prefix server) x))
(setf (nnmaildir--srv-target-prefix server) ""))) (setf (nnmaildir--srv-target-prefix server) "")))
(setf (nnmaildir--srv-groups server) (make-vector size 0)) (setf (nnmaildir--srv-groups server)
(gnus-make-hashtable size))
(setq nnmaildir--cur-server server) (setq nnmaildir--cur-server server)
t))) t)))
@ -833,10 +832,10 @@ This variable is set by `nnmaildir-request-article'.")
(cons (match-string 1 f) (match-string 2 f))) (cons (match-string 1 f) (match-string 2 f)))
files))) files)))
(when isnew (when isnew
(setq num (nnmaildir--up2-1 (length files))) (setq num (length files))
(setf (nnmaildir--grp-flist group) (make-vector num 0)) (setf (nnmaildir--grp-flist group) (gnus-make-hashtable num))
(setf (nnmaildir--grp-mlist group) (make-vector num 0)) (setf (nnmaildir--grp-mlist group) (gnus-make-hashtable num))
(setf (nnmaildir--grp-mmth group) (make-vector 1 0)) (setf (nnmaildir--grp-mmth group) (gnus-make-hashtable 1))
(setq num (nnmaildir--param pgname 'nov-cache-size)) (setq num (nnmaildir--param pgname 'nov-cache-size))
(if (numberp num) (if (< num 1) (setq num 1)) (if (numberp num) (if (< num 1) (setq num 1))
(setq num 16 (setq num 16
@ -862,7 +861,7 @@ This variable is set by `nnmaildir-request-article'.")
(cl-incf num))))) (cl-incf num)))))
(setf (nnmaildir--grp-cache group) (make-vector num nil)) (setf (nnmaildir--grp-cache group) (make-vector num nil))
(let ((inhibit-quit t)) (let ((inhibit-quit t))
(set (intern gname groups) group)) (puthash gname group groups))
(or scan-msgs (throw 'return t))) (or scan-msgs (throw 'return t)))
(setq flist (nnmaildir--grp-flist group) (setq flist (nnmaildir--grp-flist group)
files (mapcar files (mapcar
@ -901,49 +900,46 @@ This variable is set by `nnmaildir-request-article'.")
groups (nnmaildir--srv-groups nnmaildir--cur-server) groups (nnmaildir--srv-groups nnmaildir--cur-server)
target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
(nnmaildir--with-work-buffer (nnmaildir--with-work-buffer
(save-match-data (save-match-data
(if (stringp scan-group) (if (stringp scan-group)
(if (nnmaildir--scan scan-group t groups method srv-dir srv-ls) (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
(if (nnmaildir--srv-gnm nnmaildir--cur-server) (when (nnmaildir--srv-gnm nnmaildir--cur-server)
(nnmail-get-new-mail 'nnmaildir nil nil scan-group)) (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
(unintern scan-group groups)) (remhash scan-group groups))
(setq x (file-attribute-modification-time (file-attributes srv-dir)) (setq x (file-attribute-modification-time (file-attributes srv-dir))
scan-group (null scan-group)) scan-group (null scan-group))
(if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server)) (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
(if scan-group (when scan-group
(mapatoms (lambda (sym) (maphash (lambda (group-name _group)
(nnmaildir--scan (symbol-name sym) t groups (nnmaildir--scan group-name t groups
method srv-dir srv-ls)) method srv-dir srv-ls))
groups)) groups))
(setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
dirs (if (zerop (length target-prefix)) dirs (if (zerop (length target-prefix))
dirs dirs
(seq-remove (seq-remove
(lambda (dir) (lambda (dir)
(and (>= (length dir) (length target-prefix)) (and (>= (length dir) (length target-prefix))
(string= (substring dir 0 (string= (substring dir 0
(length target-prefix)) (length target-prefix))
target-prefix))) target-prefix)))
dirs)) dirs)))
seen (nnmaildir--up2-1 (length dirs)) (dolist (grp-dir dirs)
seen (make-vector seen 0)) (when (nnmaildir--scan grp-dir scan-group groups
(dolist (grp-dir dirs) method srv-dir srv-ls)
(if (nnmaildir--scan grp-dir scan-group groups method srv-dir (push grp-dir seen)))
srv-ls) (setq x nil)
(intern grp-dir seen))) (maphash (lambda (gname _group)
(setq x nil) (unless (member gname seen)
(mapatoms (lambda (group) (push gname x)))
(setq group (symbol-name group)) groups)
(unless (intern-soft group seen) (dolist (grp x)
(setq x (cons group x)))) (remhash grp groups))
groups) (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
(dolist (grp x) (file-attribute-modification-time (file-attributes srv-dir))))
(unintern grp groups)) (and scan-group
(setf (nnmaildir--srv-mtime nnmaildir--cur-server) (nnmaildir--srv-gnm nnmaildir--cur-server)
(file-attribute-modification-time (file-attributes srv-dir)))) (nnmail-get-new-mail 'nnmaildir nil nil))))))
(and scan-group
(nnmaildir--srv-gnm nnmaildir--cur-server)
(nnmail-get-new-mail 'nnmaildir nil nil))))))
t) t)
(defun nnmaildir-request-list (&optional server) (defun nnmaildir-request-list (&optional server)
@ -952,10 +948,9 @@ This variable is set by `nnmaildir-request-article'.")
(nnmaildir--prepare server nil) (nnmaildir--prepare server nil)
(nnmaildir--with-nntp-buffer (nnmaildir--with-nntp-buffer
(erase-buffer) (erase-buffer)
(mapatoms (lambda (group) (maphash (lambda (gname group)
(setq pgname (symbol-name group) (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
group (symbol-value group)
ro (nnmaildir--param pgname 'read-only)) ro (nnmaildir--param pgname 'read-only))
(insert (replace-regexp-in-string (insert (replace-regexp-in-string
" " "\\ " " " "\\ "
@ -1035,8 +1030,7 @@ This variable is set by `nnmaildir-request-article'.")
(append (append
(mapcar 'cdr nnmaildir-flag-mark-mapping) (mapcar 'cdr nnmaildir-flag-mark-mapping)
(mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort)))) (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort))))
new-mmth (nnmaildir--up2-1 (length all-marks)) new-mmth (make-hash-table :size (length all-marks))
new-mmth (make-vector new-mmth 0)
old-mmth (nnmaildir--grp-mmth group)) old-mmth (nnmaildir--grp-mmth group))
(dolist (mark all-marks) (dolist (mark all-marks)
(setq markdir (nnmaildir--subdir dir (symbol-name mark)) (setq markdir (nnmaildir--subdir dir (symbol-name mark))
@ -1063,8 +1057,8 @@ This variable is set by `nnmaildir-request-article'.")
curdir-mtime) curdir-mtime)
(t (t
markdir-mtime)))) markdir-mtime))))
(set (intern (symbol-name mark) new-mmth) mtime) (puthash mark mtime new-mmth)
(when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth))) (when (equal mtime (gethash mark old-mmth))
(setq ranges (assq mark old-marks)) (setq ranges (assq mark old-marks))
(if ranges (setq ranges (cdr ranges))) (if ranges (setq ranges (cdr ranges)))
(throw 'got-ranges nil)) (throw 'got-ranges nil))
@ -1126,7 +1120,7 @@ This variable is set by `nnmaildir-request-article'.")
(nnmaildir--prepare server nil) (nnmaildir--prepare server nil)
(catch 'return (catch 'return
(let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
srv-dir dir groups) srv-dir dir)
(when (zerop (length gname)) (when (zerop (length gname))
(setf (nnmaildir--srv-error nnmaildir--cur-server) (setf (nnmaildir--srv-error nnmaildir--cur-server)
"Invalid (empty) group name") "Invalid (empty) group name")
@ -1140,8 +1134,8 @@ This variable is set by `nnmaildir-request-article'.")
(concat "Invalid characters (null, tab, or /) in group name: " (concat "Invalid characters (null, tab, or /) in group name: "
gname)) gname))
(throw 'return nil)) (throw 'return nil))
(setq groups (nnmaildir--srv-groups nnmaildir--cur-server)) (when (gethash
(when (intern-soft gname groups) gname (nnmaildir--srv-groups nnmaildir--cur-server))
(setf (nnmaildir--srv-error nnmaildir--cur-server) (setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "Group already exists: " gname)) (concat "Group already exists: " gname))
(throw 'return nil)) (throw 'return nil))
@ -1186,7 +1180,7 @@ This variable is set by `nnmaildir-request-article'.")
new-name)) new-name))
(throw 'return nil)) (throw 'return nil))
(if (string-equal gname new-name) (throw 'return t)) (if (string-equal gname new-name) (throw 'return t))
(when (intern-soft new-name (when (gethash new-name
(nnmaildir--srv-groups nnmaildir--cur-server)) (nnmaildir--srv-groups nnmaildir--cur-server))
(setf (nnmaildir--srv-error nnmaildir--cur-server) (setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "Group already exists: " new-name)) (concat "Group already exists: " new-name))
@ -1199,16 +1193,18 @@ This variable is set by `nnmaildir-request-article'.")
(setf (nnmaildir--srv-error nnmaildir--cur-server) (setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "Error renaming link: " (prin1-to-string err))) (concat "Error renaming link: " (prin1-to-string err)))
(throw 'return nil))) (throw 'return nil)))
;; FIXME: Why are we making copies of the group and the groups
;; hashtable? Why not just set the group's new name, and puthash the
;; group under that new name?
(setq x (nnmaildir--srv-groups nnmaildir--cur-server) (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
groups (make-vector (length x) 0)) groups (gnus-make-hashtable (hash-table-size x)))
(mapatoms (lambda (sym) (maphash (lambda (gname g)
(unless (eq (symbol-value sym) group) (unless (eq g group)
(set (intern (symbol-name sym) groups) (puthash gname g groups)))
(symbol-value sym))))
x) x)
(setq group (copy-sequence group)) (setq group (copy-sequence group))
(setf (nnmaildir--grp-name group) new-name) (setf (nnmaildir--grp-name group) new-name)
(set (intern new-name groups) group) (puthash new-name group groups)
(setf (nnmaildir--srv-groups nnmaildir--cur-server) groups) (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
t))) t)))
@ -1231,7 +1227,7 @@ This variable is set by `nnmaildir-request-article'.")
(throw 'return nil)) (throw 'return nil))
(if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server)) (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
(setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil)) (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
(unintern gname (nnmaildir--srv-groups nnmaildir--cur-server)) (remhash gname (nnmaildir--srv-groups nnmaildir--cur-server))
(if (not force) (if (not force)
(progn (progn
(setq grp-dir (directory-file-name grp-dir)) (setq grp-dir (directory-file-name grp-dir))
@ -1332,10 +1328,9 @@ This variable is set by `nnmaildir-request-article'.")
article (nnmaildir--mlist-art list num-msgid)) article (nnmaildir--mlist-art list num-msgid))
(if article (setq num-msgid (nnmaildir--art-num article)) (if article (setq num-msgid (nnmaildir--art-num article))
(catch 'found (catch 'found
(mapatoms (maphash
(lambda (group-sym) (lambda (_gname group)
(setq group (symbol-value group-sym) (setq list (nnmaildir--grp-mlist group)
list (nnmaildir--grp-mlist group)
article (nnmaildir--mlist-art list num-msgid)) article (nnmaildir--mlist-art list num-msgid))
(when article (when article
(setq num-msgid (nnmaildir--art-num article)) (setq num-msgid (nnmaildir--art-num article))
@ -1522,7 +1517,7 @@ This variable is set by `nnmaildir-request-article'.")
(setq groups (nnmaildir--srv-groups nnmaildir--cur-server) (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
ga (car group-art) group-art (cdr group-art) ga (car group-art) group-art (cdr group-art)
gname (car ga)) gname (car ga))
(or (intern-soft gname groups) (or (gethash gname groups)
(nnmaildir-request-create-group gname) (nnmaildir-request-create-group gname)
(throw 'return nil)) ;; not that nnmail bothers to check :( (throw 'return nil)) ;; not that nnmail bothers to check :(
(unless (nnmaildir-request-accept-article gname) (unless (nnmaildir-request-accept-article gname)
@ -1539,7 +1534,7 @@ This variable is set by `nnmaildir-request-article'.")
(mapcar (mapcar
(lambda (ga) (lambda (ga)
(setq gname (car ga)) (setq gname (car ga))
(and (or (intern-soft gname groups) (and (or (gethash gname groups)
(nnmaildir-request-create-group gname)) (nnmaildir-request-create-group gname))
(nnmaildir-request-accept-article gname) (nnmaildir-request-accept-article gname)
ga)) ga))
@ -1749,36 +1744,38 @@ This variable is set by `nnmaildir-request-article'.")
(lambda (dir) (lambda (dir)
(cons dir (funcall ls dir nil "\\`[^.]" 'nosort))) (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
dirs) dirs)
files (funcall ls msgdir nil "\\`[^.]" 'nosort) files (funcall ls msgdir nil "\\`[^.]" 'nosort))
flist (nnmaildir--up2-1 (length files))
flist (make-vector flist 0))
(save-match-data (save-match-data
(dolist (file files) (dolist (file files)
(string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
(intern (match-string 1 file) flist))) (push (match-string 1 file) flist)))
(dolist (dir dirs) (dolist (dir dirs)
(setq files (cdr dir) (setq files (cdr dir)
dir (file-name-as-directory (car dir))) dir (file-name-as-directory (car dir)))
(dolist (file files) (dolist (file files)
(unless (or (intern-soft file flist) (string= file ":")) (unless (or (member file flist) (string= file ":"))
(setq file (concat dir file)) (setq file (concat dir file))
(delete-file file)))) (delete-file file))))
t))) t)))
(defun nnmaildir-close-server (&optional server) (defun nnmaildir-close-server (&optional server)
(nnmaildir--prepare server nil) "Close SERVER, or the current maildir server."
(when nnmaildir--cur-server (when (nnmaildir--prepare server nil)
(setq server nnmaildir--cur-server (setq server nnmaildir--cur-server
nnmaildir--cur-server nil) nnmaildir--cur-server nil)
(unintern (nnmaildir--srv-address server) nnmaildir--servers))
;; This slightly obscure invocation of `alist-get' removes SERVER from
;; `nnmaildir-servers'.
(setf (alist-get (nnmaildir--srv-address server)
nnmaildir--servers server 'remove #'equal)
server))
t) t)
(defun nnmaildir-request-close () (defun nnmaildir-request-close ()
(let (servers buffer) (let ((servers
(mapatoms (lambda (server) (mapcar #'car nnmaildir--servers))
(setq servers (cons (symbol-name server) servers))) buffer)
nnmaildir--servers) (mapc #'nnmaildir-close-server servers)
(mapc 'nnmaildir-close-server servers)
(setq buffer (get-buffer " *nnmaildir work*")) (setq buffer (get-buffer " *nnmaildir work*"))
(if buffer (kill-buffer buffer)) (if buffer (kill-buffer buffer))
(setq buffer (get-buffer " *nnmaildir nov*")) (setq buffer (get-buffer " *nnmaildir nov*"))

16
lisp/gnus/nnvirtual.el
View file

@ -234,14 +234,12 @@ component group will show up when you enter the virtual group.")
nnvirtual-mapping-marks nil nnvirtual-mapping-marks nil
nnvirtual-info-installed nil) nnvirtual-info-installed nil)
(when nnvirtual-component-regexp (when nnvirtual-component-regexp
;; Go through the newsrc alist and find all component groups. ;; Go through the list of groups and find all component groups.
(let ((newsrc (cdr gnus-newsrc-alist)) (dolist (group (cdr gnus-group-list))
group) (when (string-match nnvirtual-component-regexp group) ; Match
(while (setq group (car (pop newsrc))) ;; Add this group to the list of component groups.
(when (string-match nnvirtual-component-regexp group) ; Match (setq nnvirtual-component-groups
;; Add this group to the list of component groups. (cons group (delete group nnvirtual-component-groups))))))
(setq nnvirtual-component-groups
(cons group (delete group nnvirtual-component-groups)))))))
(if (not nnvirtual-component-groups) (if (not nnvirtual-component-groups)
(nnheader-report 'nnvirtual "No component groups: %s" server) (nnheader-report 'nnvirtual "No component groups: %s" server)
t))) t)))
@ -372,7 +370,7 @@ component group will show up when you enter the virtual group.")
(defun nnvirtual-convert-headers () (defun nnvirtual-convert-headers ()
"Convert HEAD headers into NOV headers." "Convert HEAD headers into NOV headers."
(with-current-buffer nntp-server-buffer (with-current-buffer nntp-server-buffer
(let* ((dependencies (make-vector 100 0)) (let* ((dependencies (make-hash-table :test #'equal))
(headers (gnus-get-newsgroup-headers dependencies))) (headers (gnus-get-newsgroup-headers dependencies)))
(erase-buffer) (erase-buffer)
(mapc 'nnheader-insert-nov headers)))) (mapc 'nnheader-insert-nov headers))))

8
lisp/gnus/nnweb.el
View file

@ -109,7 +109,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(deffoo nnweb-request-scan (&optional group server) (deffoo nnweb-request-scan (&optional group server)
(nnweb-possibly-change-server group server) (nnweb-possibly-change-server group server)
(if nnweb-ephemeral-p (if nnweb-ephemeral-p
(setq nnweb-hashtb (gnus-make-hashtable 4095)) (setq nnweb-hashtb (gnus-make-hashtable 4000))
(unless nnweb-articles (unless nnweb-articles
(nnweb-read-overview group))) (nnweb-read-overview group)))
(funcall (nnweb-definition 'map)) (funcall (nnweb-definition 'map))
@ -229,11 +229,11 @@ Valid types include `google', `dejanews', and `gmane'.")
(nnheader-insert-nov (cadr (pop articles))))))) (nnheader-insert-nov (cadr (pop articles)))))))
(defun nnweb-set-hashtb (header data) (defun nnweb-set-hashtb (header data)
(gnus-sethash (nnweb-identifier (mail-header-xref header)) (puthash (nnweb-identifier (mail-header-xref header))
data nnweb-hashtb)) data nnweb-hashtb))
(defun nnweb-get-hashtb (url) (defun nnweb-get-hashtb (url)
(gnus-gethash (nnweb-identifier url) nnweb-hashtb)) (gethash (nnweb-identifier url) nnweb-hashtb))
(defun nnweb-identifier (ident) (defun nnweb-identifier (ident)
(funcall (nnweb-definition 'identifier) ident)) (funcall (nnweb-definition 'identifier) ident))
@ -268,7 +268,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(unless nnweb-group-alist (unless nnweb-group-alist
(nnweb-read-active)) (nnweb-read-active))
(unless nnweb-hashtb (unless nnweb-hashtb
(setq nnweb-hashtb (gnus-make-hashtable 4095))) (setq nnweb-hashtb (make-hash-table :size 4000 :test #'equal)))
(when group (when group
(setq nnweb-group group))) (setq nnweb-group group)))

13
lisp/thingatpt.el
View file

@ -466,11 +466,14 @@ looks like an email address, \"ftp://\" if it starts with
(while htbs (while htbs
(setq htb (car htbs) htbs (cdr htbs)) (setq htb (car htbs) htbs (cdr htbs))
(ignore-errors (ignore-errors
;; errs: htb symbol may be unbound, or not a hash-table. (setq htb (symbol-value htb))
;; gnus-gethash is just a macro for intern-soft. (when (cond ((obarrayp htb)
(and (symbol-value htb) (intern-soft string htb))
(intern-soft string (symbol-value htb)) ((listp htb)
(setq ret string htbs nil)) (member string htb))
((hash-table-p htb)
(gethash string htb)))
(setq ret string htbs nil))
;; If we made it this far, gnus is running, so ignore "heads": ;; If we made it this far, gnus is running, so ignore "heads":
(setq heads nil))) (setq heads nil)))
(or ret (not heads) (or ret (not heads)

176
test/lisp/gnus/gnus-test-headers.el Normal file
View file

@ -0,0 +1,176 @@
;;; gnus-test-headers.el --- Tests for Gnus header-related functions -*- lexical-binding: t; -*-
;; Copyright (C) 2018 Free Software Foundation, Inc.
;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; The tests her are for
;;; Code:
(require 'ert)
(require 'gnus-sum)
(defconst gnus-headers-test-data
'([2 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>"
"Thu, 14 Sep 2000 11:10:46 +0100"
"<200009141010.LAA26351@djlvig.dl.ac.uk>"
"<20000913175943.A26093@sparky.nisa.net>"
1882 16 "nnmaildir mails:2"
((To . "Jeff Bailey <jbailey@nisa.net>")
(Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[3 "Re: [Emacs-devel] Emacs move" "Sam Steingold <sds@gnu.org>"
"14 Sep 2000 10:21:56 -0400" "<upum7xddn.fsf@xchange.com>"
"<20000913175943.A26093@sparky.nisa.net>"
2991 50 "nnmaildir mails:3"
((To . "Jeff Bailey <jbailey@nisa.net>")
(Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[4 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
"Thu, 14 Sep 2000 09:14:47 -0700"
"<20000914091447.G4827@sparky.nisa.net>"
"<20000913175943.A26093@sparky.nisa.net> <upum7xddn.fsf@xchange.com>"
1780 15 "nnmaildir mails:4"
((To . "sds@gnu.org, Jeff Bailey <jbailey@nisa.net>")
(Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[5 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>"
"Thu, 14 Sep 2000 18:24:36 +0100"
"<200009141724.SAA26807@djlvig.dl.ac.uk>"
"<20000913175943.A26093@sparky.nisa.net>"
1343 9 "nnmaildir mails:5"
((To . "Jeff Bailey <jbailey@nisa.net>")
(Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[6 "Re: [Emacs-devel] Emacs move" "Karl Fogel <kfogel@galois.collab.net>"
"14 Sep 2000 10:37:35 -0500" "<87em2nyog0.fsf@galois.collab.net>"
"<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk>"
3740 124 "nnmaildir mails:6"
((To . "Dave Love <d.love@dl.ac.uk>")
(Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[7 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
"Thu, 14 Sep 2000 10:55:12 -0700"
"<20000914105512.A29291@sparky.nisa.net>"
"<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk> <87em2nyog0.fsf@galois.collab.net>"
1687 16 "nnmaildir mails:7"
((To . "kfogel@red-bean.com, Dave Love <d.love@dl.ac.uk>")
(Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[8 "Re: [Emacs-devel] Emacs move" "John Wiegley <johnw@gnu.org>"
"Thu, 14 Sep 2000 12:19:01 -0700"
"<200009141919.MAA05085@localhost.localdomain>"
"<20000913175943.A26093@sparky.nisa.net>"
1978 27 "nnmaildir mails:8"
((To . "emacs-devel@gnu.org"))]
[9 "Re: [Emacs-devel] Emacs move"
"\"Robert J. Chassell\" <bob@rattlesnake.com>"
"Thu, 14 Sep 2000 07:33:15 -0400 (EDT)"
"<m13ZXGV-000BCgC@megalith.rattlesnake.com>"
"<20000913175943.A26093@sparky.nisa.net>"
3046 72 "nnmaildir mails:9"
((To . "jbailey@nisa.net")
(Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[10 "Re: [Emacs-devel] Emacs move"
"wmperry@aventail.com (William M. Perry)"
"14 Sep 2000 09:10:25 -0500"
"<86g0n3f4j2.fsf@megalith.bp.aventail.com>"
"<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
3104 44 "nnmaildir mails:10"
((To . "bob@rattlesnake.com")
(Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[11 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>"
"Thu, 14 Sep 2000 21:51:05 +0200 (CEST)"
"<200009141951.VAA06005@gerd.segv.de>"
"<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <86g0n3f4j2.fsf@megalith.bp.aventail.com>"
1884 6 "nnmaildir mails:11"
((To . "wmvperry@aventail.com")
(Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[12 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>"
"Thu, 14 Sep 2000 21:49:03 +0200 (CEST)"
"<200009141949.VAA05998@gerd.segv.de>"
"<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
2408 24 "nnmaildir mails:12"
((To . "bob@rattlesnake.com")
(Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[13 "Re: [Emacs-devel] Emacs move"
"\"Robert J. Chassell\" <bob@rattlesnake.com>"
"Thu, 14 Sep 2000 17:50:01 -0400 (EDT)"
"<m13ZgtN-000BD3C@megalith.rattlesnake.com>"
"<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de>"
1968 23 "nnmaildir mails:13"
((To . "gerd@gnu.org")
(Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[14 "Re: [Emacs-devel] Emacs move" "Richard Stallman <rms@gnu.org>"
"Fri, 15 Sep 2000 16:28:12 -0600 (MDT)"
"<200009152228.QAA20526@wijiji.santafe.edu>"
"<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
1288 2 "nnmaildir mails:14"
((To . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
[15 "[Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
"Wed, 13 Sep 2000 17:59:43 -0700"
"<20000913175943.A26093@sparky.nisa.net>" ""
1661 26 "nnmaildir mails:15"
((To . "emacs-devel@gnu.org")
(Cc . "cvs-hackers@gnu.org"))]
[16 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
"Fri, 15 Sep 2000 22:00:12 -0700"
"<20000915220012.A3923@sparky.nisa.net>"
"<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de> <m13ZgtN-000BD3C@megalith.rattlesnake.com>"
2857 51 "nnmaildir mails:16"
((To . "bob@rattlesnake.com, gerd@gnu.org")
(Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))])
"A pile of headers with potential interdependencies.")
(ert-deftest gnus-headers-make-dependency-table ()
(let ((table (gnus-make-hashtable 20))
(data (copy-sequence gnus-headers-test-data))
ret)
(dolist (h data)
;; `gnus-dependencies-add-header' returns nil if it fails to add
;; the header.
(should (gnus-dependencies-add-header h table nil)))
;; Pick a value to test.
(setq ret (gethash "<m13ZXGV-000BCgC@megalith.rattlesnake.com>"
table))
;; The message has three children.
(should (= 3 (length (cdr ret))))
;; The first of those children has one child.
(should (= 1 (length (cdr (nth 1 ret)))))))
(ert-deftest gnus-headers-loop-dependencies ()
"Intentionally create a reference loop."
(let ((table (gnus-make-hashtable 20))
(data (copy-sequence gnus-headers-test-data))
(parent-id "<200009141724.SAA26807@djlvig.dl.ac.uk>")
(child-id "<87em2nyog0.fsf@galois.collab.net>")
parent)
(dolist (h data)
(gnus-dependencies-add-header h table nil))
(setq parent (gethash parent-id table))
;; Put the parent header in the child references of one of its own
;; children. `gnus-thread-loop-p' only checks if there's a loop
;; between parent and immediate child, not parent and random
;; descendant. At least, near as I can tell that's the case.
(push (list (car parent)) (cdr (gethash child-id table)))
(let ((gnus-newsgroup-dependencies table))
(should
(= 1 ; 1 indicates an infloop.
(gnus-thread-loop-p (car parent) (cadr parent)))))))
(provide 'gnus-test-headers)
;;; gnus-test-headers.el ends here