aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorEric Abrahamsen2018-04-26 16:26:27 -0700
committerEric Abrahamsen2019-03-22 10:23:30 -0700
commitc1b63af4458e92bad33da0def2b15c206656e2fa (patch)
tree267503989ec0475b76800bb309f6cdc1da53e74e
parent3375d08299bbc1e224d19a871012cdbbf5d787ee (diff)
downloademacs-c1b63af4458e92bad33da0def2b15c206656e2fa.tar.gz
emacs-c1b63af4458e92bad33da0def2b15c206656e2fa.zip
Change Gnus hash tables into real hash tables
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.
-rw-r--r--lisp/gnus/gnus-agent.el278
-rw-r--r--lisp/gnus/gnus-async.el29
-rw-r--r--lisp/gnus/gnus-bcklg.el114
-rw-r--r--lisp/gnus/gnus-cache.el60
-rw-r--r--lisp/gnus/gnus-dup.el22
-rw-r--r--lisp/gnus/gnus-group.el297
-rw-r--r--lisp/gnus/gnus-score.el27
-rw-r--r--lisp/gnus/gnus-start.el500
-rw-r--r--lisp/gnus/gnus-sum.el220
-rw-r--r--lisp/gnus/gnus-topic.el48
-rw-r--r--lisp/gnus/gnus-util.el77
-rw-r--r--lisp/gnus/gnus.el51
-rw-r--r--lisp/gnus/message.el17
-rw-r--r--lisp/gnus/mml.el2
-rw-r--r--lisp/gnus/nnbabyl.el6
-rw-r--r--lisp/gnus/nnmaildir.el269
-rw-r--r--lisp/gnus/nnvirtual.el16
-rw-r--r--lisp/gnus/nnweb.el8
-rw-r--r--lisp/thingatpt.el13
-rw-r--r--test/lisp/gnus/gnus-test-headers.el176
20 files changed, 1156 insertions, 1074 deletions
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index 1858a1ce8a7..879e1fe2052 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -225,7 +225,9 @@ NOTES:
225(defvar gnus-agent-overview-buffer nil) 225(defvar gnus-agent-overview-buffer nil)
226(defvar gnus-category-predicate-cache nil) 226(defvar gnus-category-predicate-cache nil)
227(defvar gnus-category-group-cache nil) 227(defvar gnus-category-group-cache nil)
228(defvar gnus-agent-spam-hashtb nil) 228(defvar gnus-agent-spam-hashtb nil
229 "Cache of message subjects for spam messages.
230Actually a hash table holding subjects mapped to t.")
229(defvar gnus-agent-file-name nil) 231(defvar gnus-agent-file-name nil)
230(defvar gnus-agent-file-coding-system 'raw-text) 232(defvar gnus-agent-file-coding-system 'raw-text)
231(defvar gnus-agent-file-loading-cache nil) 233(defvar gnus-agent-file-loading-cache nil)
@@ -642,8 +644,8 @@ minor mode in all Gnus buffers."
642(defun gnus-agent-queue-setup (&optional group-name) 644(defun gnus-agent-queue-setup (&optional group-name)
643 "Make sure the queue group exists. 645 "Make sure the queue group exists.
644Optional arg GROUP-NAME allows another group to be specified." 646Optional arg GROUP-NAME allows another group to be specified."
645 (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue")) 647 (unless (gethash (format "nndraft:%s" (or group-name "queue"))
646 gnus-newsrc-hashtb) 648 gnus-newsrc-hashtb)
647 (gnus-request-create-group (or group-name "queue") '(nndraft "")) 649 (gnus-request-create-group (or group-name "queue") '(nndraft ""))
648 (let ((gnus-level-default-subscribed 1)) 650 (let ((gnus-level-default-subscribed 1))
649 (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue")) 651 (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue"))
@@ -1330,11 +1332,11 @@ downloaded into the agent."
1330 (when (re-search-forward 1332 (when (re-search-forward
1331 (concat "^" (regexp-quote group) " ") nil t) 1333 (concat "^" (regexp-quote group) " ") nil t)
1332 (save-excursion 1334 (save-excursion
1333 (setq oactive-max (read (current-buffer)) ;; max 1335 (setq oactive-max (read (current-buffer)) ;; max
1334 oactive-min (read (current-buffer)))) ;; min 1336 oactive-min (read (current-buffer)))) ;; min
1335 (gnus-delete-line))) 1337 (gnus-delete-line)))
1336 (when active 1338 (when active
1337 (insert (format "%S %d %d y\n" (intern group) 1339 (insert (format "%s %d %d y\n" group
1338 (max (or oactive-max (cdr active)) (cdr active)) 1340 (max (or oactive-max (cdr active)) (cdr active))
1339 (min (or oactive-min (car active)) (car active)))) 1341 (min (or oactive-min (car active)) (car active))))
1340 (goto-char (point-max)) 1342 (goto-char (point-max))
@@ -2161,7 +2163,10 @@ doesn't exist, to valid the overview buffer."
2161 2163
2162 (gnus-agent-update-view-total-fetched-for group nil))) 2164 (gnus-agent-update-view-total-fetched-for group nil)))
2163 2165
2164(defvar gnus-agent-article-local nil) 2166;; FIXME: Why would this be a hash table? Wouldn't a simple alist or
2167;; something suffice?
2168(defvar gnus-agent-article-local nil
2169 "Hashtable holding information about a group.")
2165(defvar gnus-agent-article-local-times nil) 2170(defvar gnus-agent-article-local-times nil)
2166(defvar gnus-agent-file-loading-local nil) 2171(defvar gnus-agent-file-loading-local nil)
2167 2172
@@ -2173,12 +2178,12 @@ article counts for each of the method's subscribed groups."
2173 (zerop gnus-agent-article-local-times) 2178 (zerop gnus-agent-article-local-times)
2174 (not (gnus-methods-equal-p 2179 (not (gnus-methods-equal-p
2175 gnus-command-method 2180 gnus-command-method
2176 (symbol-value (intern "+method" gnus-agent-article-local))))) 2181 (gethash "+method" gnus-agent-article-local))))
2177 (setq gnus-agent-article-local 2182 (setq gnus-agent-article-local
2178 (gnus-cache-file-contents 2183 (gnus-cache-file-contents
2179 (gnus-agent-lib-file "local") 2184 (gnus-agent-lib-file "local")
2180 'gnus-agent-file-loading-local 2185 'gnus-agent-file-loading-local
2181 'gnus-agent-read-and-cache-local)) 2186 #'gnus-agent-read-and-cache-local))
2182 (when gnus-agent-article-local-times 2187 (when gnus-agent-article-local-times
2183 (cl-incf gnus-agent-article-local-times))) 2188 (cl-incf gnus-agent-article-local-times)))
2184 gnus-agent-article-local)) 2189 gnus-agent-article-local))
@@ -2188,14 +2193,15 @@ article counts for each of the method's subscribed groups."
2188gnus-agent-article-local. If that variable had `dirty' (also known as 2193gnus-agent-article-local. If that variable had `dirty' (also known as
2189modified) original contents, they are first saved to their own file." 2194modified) original contents, they are first saved to their own file."
2190 (if (and gnus-agent-article-local 2195 (if (and gnus-agent-article-local
2191 (symbol-value (intern "+dirty" gnus-agent-article-local))) 2196 (gethash "+dirty" gnus-agent-article-local))
2192 (gnus-agent-save-local)) 2197 (gnus-agent-save-local))
2193 (gnus-agent-read-local file)) 2198 (gnus-agent-read-local file))
2194 2199
2195(defun gnus-agent-read-local (file) 2200(defun gnus-agent-read-local (file)
2196 "Load FILE and do a `read' there." 2201 "Load FILE and do a `read' there."
2197 (let ((my-obarray (gnus-make-hashtable (count-lines (point-min) 2202 (let ((hashtb (gnus-make-hashtable
2198 (point-max)))) 2203 (count-lines (point-min)
2204 (point-max))))
2199 (line 1)) 2205 (line 1))
2200 (with-temp-buffer 2206 (with-temp-buffer
2201 (condition-case nil 2207 (condition-case nil
@@ -2204,7 +2210,8 @@ modified) original contents, they are first saved to their own file."
2204 (file-error)) 2210 (file-error))
2205 2211
2206 (goto-char (point-min)) 2212 (goto-char (point-min))
2207 ;; Skip any comments at the beginning of the file (the only place where they may appear) 2213 ;; Skip any comments at the beginning of the file (the only
2214 ;; place where they may appear)
2208 (while (= (following-char) ?\;) 2215 (while (= (following-char) ?\;)
2209 (forward-line 1) 2216 (forward-line 1)
2210 (setq line (1+ line))) 2217 (setq line (1+ line)))
@@ -2214,33 +2221,32 @@ modified) original contents, they are first saved to their own file."
2214 (let (group 2221 (let (group
2215 min 2222 min
2216 max 2223 max
2217 (cur (current-buffer)) 2224 (cur (current-buffer)))
2218 (obarray my-obarray))
2219 (setq group (read cur) 2225 (setq group (read cur)
2220 min (read cur) 2226 min (read cur)
2221 max (read cur)) 2227 max (read cur))
2222 2228
2223 (when (stringp group) 2229 (unless (stringp group)
2224 (setq group (intern group my-obarray))) 2230 (setq group (symbol-name group)))
2225 2231
2226 ;; NOTE: The '+ 0' ensure that min and max are both numerics. 2232 ;; NOTE: The '+ 0' ensure that min and max are both numerics.
2227 (set group (cons (+ 0 min) (+ 0 max)))) 2233 (puthash group (cons (+ 0 min) (+ 0 max)) hashtb))
2228 (error 2234 (error
2229 (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s" 2235 (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s"
2230 file line (error-message-string err)))) 2236 file line (error-message-string err))))
2231 (forward-line 1) 2237 (forward-line 1)
2232 (setq line (1+ line)))) 2238 (setq line (1+ line))))
2233 2239
2234 (set (intern "+dirty" my-obarray) nil) 2240 (puthash "+dirty" nil hashtb)
2235 (set (intern "+method" my-obarray) gnus-command-method) 2241 (puthash "+method" gnus-command-method hashtb)
2236 my-obarray)) 2242 hashtb))
2237 2243
2238(defun gnus-agent-save-local (&optional force) 2244(defun gnus-agent-save-local (&optional force)
2239 "Save gnus-agent-article-local under it method's agent.lib directory." 2245 "Save gnus-agent-article-local under it method's agent.lib directory."
2240 (let ((my-obarray gnus-agent-article-local)) 2246 (let ((hashtb gnus-agent-article-local))
2241 (when (and my-obarray 2247 (when (and hashtb
2242 (or force (symbol-value (intern "+dirty" my-obarray)))) 2248 (or force (gethash "+dirty" hashtb)))
2243 (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray))) 2249 (let* ((gnus-command-method (gethash "+method" hashtb))
2244 ;; NOTE: gnus-command-method is used within gnus-agent-lib-file. 2250 ;; NOTE: gnus-command-method is used within gnus-agent-lib-file.
2245 (dest (gnus-agent-lib-file "local"))) 2251 (dest (gnus-agent-lib-file "local")))
2246 (gnus-make-directory (gnus-agent-lib-file "")) 2252 (gnus-make-directory (gnus-agent-lib-file ""))
@@ -2248,31 +2254,30 @@ modified) original contents, they are first saved to their own file."
2248 (let ((coding-system-for-write gnus-agent-file-coding-system) 2254 (let ((coding-system-for-write gnus-agent-file-coding-system)
2249 (file-name-coding-system nnmail-pathname-coding-system)) 2255 (file-name-coding-system nnmail-pathname-coding-system))
2250 (with-temp-file dest 2256 (with-temp-file dest
2251 (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) 2257 ;; FIXME: Why are we letting this again?
2258 (let ((gnus-command-method (gethash "+method" hashtb))
2252 print-level print-length 2259 print-level print-length
2253 (standard-output (current-buffer))) 2260 (standard-output (current-buffer)))
2254 (mapatoms (lambda (symbol) 2261 (maphash (lambda (group active)
2255 (cond ((not (boundp symbol)) 2262 (cond ((null active)
2256 nil) 2263 nil)
2257 ((member (symbol-name symbol) '("+dirty" "+method")) 2264 ((member group '("+dirty" "+method"))
2258 nil) 2265 nil)
2259 (t 2266 (t
2260 (let ((range (symbol-value symbol))) 2267 (when active
2261 (when range 2268 (prin1 group)
2262 (prin1 symbol) 2269 (princ " ")
2263 (princ " ") 2270 (princ (car active))
2264 (princ (car range)) 2271 (princ " ")
2265 (princ " ") 2272 (princ (cdr active))
2266 (princ (cdr range)) 2273 (princ "\n")))))
2267 (princ "\n")))))) 2274 hashtb))))))))
2268 my-obarray))))))))
2269 2275
2270(defun gnus-agent-get-local (group &optional gmane method) 2276(defun gnus-agent-get-local (group &optional gmane method)
2271 (let* ((gmane (or gmane (gnus-group-real-name group))) 2277 (let* ((gmane (or gmane (gnus-group-real-name group)))
2272 (gnus-command-method (or method (gnus-find-method-for-group group))) 2278 (gnus-command-method (or method (gnus-find-method-for-group group)))
2273 (local (gnus-agent-load-local)) 2279 (local (gnus-agent-load-local))
2274 (symb (intern gmane local)) 2280 (minmax (gethash gmane local)))
2275 (minmax (and (boundp symb) (symbol-value symb))))
2276 (unless minmax 2281 (unless minmax
2277 ;; Bind these so that gnus-agent-load-alist doesn't change the 2282 ;; Bind these so that gnus-agent-load-alist doesn't change the
2278 ;; current alist (i.e. gnus-agent-article-alist) 2283 ;; current alist (i.e. gnus-agent-article-alist)
@@ -2291,24 +2296,23 @@ modified) original contents, they are first saved to their own file."
2291 (let* ((gmane (or gmane (gnus-group-real-name group))) 2296 (let* ((gmane (or gmane (gnus-group-real-name group)))
2292 (gnus-command-method (or method (gnus-find-method-for-group group))) 2297 (gnus-command-method (or method (gnus-find-method-for-group group)))
2293 (local (or local (gnus-agent-load-local))) 2298 (local (or local (gnus-agent-load-local)))
2294 (symb (intern gmane local)) 2299 (minmax (gethash gmane local)))
2295 (minmax (and (boundp symb) (symbol-value symb))))
2296 (if (cond ((and minmax 2300 (if (cond ((and minmax
2297 (or (not (eq min (car minmax))) 2301 (or (not (eq min (car minmax)))
2298 (not (eq max (cdr minmax)))) 2302 (not (eq max (cdr minmax))))
2299 min 2303 min
2300 max) 2304 max)
2301 (setcar minmax min) 2305 (setcar (gethash gmane local) min)
2302 (setcdr minmax max) 2306 (setcdr (gethash gmane local) max)
2303 t) 2307 t)
2304 (minmax 2308 (minmax
2305 nil) 2309 nil)
2306 ((and min max) 2310 ((and min max)
2307 (set symb (cons min max)) 2311 (puthash gmane (cons min max) local)
2308 t) 2312 t)
2309 (t 2313 (t
2310 (unintern symb local))) 2314 (remhash gmane local)))
2311 (set (intern "+dirty" local) t)))) 2315 (puthash "+dirty" t local))))
2312 2316
2313(defun gnus-agent-article-name (article group) 2317(defun gnus-agent-article-name (article group)
2314 (expand-file-name article 2318 (expand-file-name article
@@ -2878,8 +2882,8 @@ The following commands are available:
2878 nil 2882 nil
2879 (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers)))) 2883 (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers))))
2880 (prog1 2884 (prog1
2881 (gnus-gethash string gnus-agent-spam-hashtb) 2885 (gethash string gnus-agent-spam-hashtb)
2882 (gnus-sethash string t gnus-agent-spam-hashtb))))) 2886 (puthash string t gnus-agent-spam-hashtb)))))
2883 2887
2884(defun gnus-agent-short-p () 2888(defun gnus-agent-short-p ()
2885 "Say whether an article is short or not." 2889 "Say whether an article is short or not."
@@ -3007,13 +3011,13 @@ articles."
3007 (unless gnus-category-group-cache 3011 (unless gnus-category-group-cache
3008 (setq gnus-category-group-cache (gnus-make-hashtable 1000)) 3012 (setq gnus-category-group-cache (gnus-make-hashtable 1000))
3009 (let ((cs gnus-category-alist) 3013 (let ((cs gnus-category-alist)
3010 groups cat) 3014 groups)
3011 (while (setq cat (pop cs)) 3015 (dolist (cat cs)
3012 (setq groups (gnus-agent-cat-groups cat)) 3016 (setq groups (gnus-agent-cat-groups cat))
3013 (while groups 3017 (dolist (g groups)
3014 (gnus-sethash (pop groups) cat gnus-category-group-cache))))) 3018 (puthash g cat gnus-category-group-cache)))))
3015 (or (gnus-gethash group gnus-category-group-cache) 3019 (gethash group gnus-category-group-cache
3016 (assq 'default gnus-category-alist))) 3020 (assq 'default gnus-category-alist)))
3017 3021
3018(defvar gnus-agent-expire-current-dirs) 3022(defvar gnus-agent-expire-current-dirs)
3019(defvar gnus-agent-expire-stats) 3023(defvar gnus-agent-expire-stats)
@@ -3053,7 +3057,7 @@ FORCE is equivalent to setting the expiration predicates to true."
3053 (count-lines (point-min) (point-max)))))) 3057 (count-lines (point-min) (point-max))))))
3054 (save-excursion 3058 (save-excursion
3055 (gnus-agent-expire-group-1 3059 (gnus-agent-expire-group-1
3056 group overview (gnus-gethash-safe group orig) 3060 group overview (gethash group orig)
3057 articles force)))) 3061 articles force))))
3058 (kill-buffer overview)))) 3062 (kill-buffer overview))))
3059 (gnus-message 4 "%s" (gnus-agent-expire-done-message))))) 3063 (gnus-message 4 "%s" (gnus-agent-expire-done-message)))))
@@ -3471,9 +3475,7 @@ articles in every agentized group? "))
3471 (count-lines (point-min) (point-max)))))) 3475 (count-lines (point-min) (point-max))))))
3472 (dolist (expiring-group (gnus-groups-from-server 3476 (dolist (expiring-group (gnus-groups-from-server
3473 gnus-command-method)) 3477 gnus-command-method))
3474 (let* ((active 3478 (let ((active (gethash expiring-group orig)))
3475 (gnus-gethash-safe expiring-group orig)))
3476
3477 (when active 3479 (when active
3478 (save-excursion 3480 (save-excursion
3479 (gnus-agent-expire-group-1 3481 (gnus-agent-expire-group-1
@@ -3503,83 +3505,80 @@ articles in every agentized group? "))
3503(defun gnus-agent-expire-unagentized-dirs () 3505(defun gnus-agent-expire-unagentized-dirs ()
3504 (when (and gnus-agent-expire-unagentized-dirs 3506 (when (and gnus-agent-expire-unagentized-dirs
3505 (boundp 'gnus-agent-expire-current-dirs)) 3507 (boundp 'gnus-agent-expire-current-dirs))
3506 (let* ((keep (gnus-make-hashtable)) 3508 (let ((file-name-coding-system nnmail-pathname-coding-system)
3507 (file-name-coding-system nnmail-pathname-coding-system)) 3509 ;; Another hash table that could just be a list.
3508 3510 (keep (gnus-make-hashtable 20))
3509 (gnus-sethash gnus-agent-directory t keep) 3511 to-remove)
3512 (puthash gnus-agent-directory t keep)
3510 (dolist (dir gnus-agent-expire-current-dirs) 3513 (dolist (dir gnus-agent-expire-current-dirs)
3511 (when (and (stringp dir) 3514 (when (and (stringp dir)
3512 (file-directory-p dir)) 3515 (file-directory-p dir))
3513 (while (not (gnus-gethash dir keep)) 3516 (while (not (gethash dir keep))
3514 (gnus-sethash dir t keep) 3517 (puthash dir t keep)
3515 (setq dir (file-name-directory (directory-file-name dir)))))) 3518 (setq dir (file-name-directory (directory-file-name dir))))))
3516 3519
3517 (let* (to-remove 3520 (cl-labels ((checker
3518 checker 3521 (d)
3519 (checker 3522 ;; Given a directory, check it and its subdirectories
3520 (function 3523 ;; for membership in the keep list. If it isn't found,
3521 (lambda (d) 3524 ;; add it to to-remove.
3522 "Given a directory, check it and its subdirectories for 3525 (let ((files (directory-files d))
3523 membership in the keep hash. If it isn't found, add 3526 file)
3524 it to to-remove." 3527 (while (setq file (pop files))
3525 (let ((files (directory-files d)) 3528 (cond ((equal file ".") ; Ignore self
3526 file) 3529 nil)
3527 (while (setq file (pop files)) 3530 ((equal file "..") ; Ignore parent
3528 (cond ((equal file ".") ; Ignore self 3531 nil)
3529 nil) 3532 ((equal file ".overview")
3530 ((equal file "..") ; Ignore parent 3533 ;; Directory must contain .overview to be
3531 nil) 3534 ;; agent's cache of a group.
3532 ((equal file ".overview") 3535 (let ((d (file-name-as-directory d))
3533 ;; Directory must contain .overview to be 3536 r)
3534 ;; agent's cache of a group. 3537 ;; Search ancestors for last directory NOT
3535 (let ((d (file-name-as-directory d)) 3538 ;; found in keep.
3536 r) 3539 (while (not (gethash (setq d (file-name-directory d)) keep))
3537 ;; Search ancestor's for last directory NOT 3540 (setq r d
3538 ;; found in keep hash. 3541 d (directory-file-name d)))
3539 (while (not (gnus-gethash 3542 ;; if ANY ancestor was NOT in keep hash and
3540 (setq d (file-name-directory d)) keep)) 3543 ;; it's not already in to-remove, add it to
3541 (setq r d 3544 ;; to-remove.
3542 d (directory-file-name d))) 3545 (if (and r
3543 ;; if ANY ancestor was NOT in keep hash and 3546 (not (member r to-remove)))
3544 ;; it's not already in to-remove, add it to 3547 (push r to-remove))))
3545 ;; to-remove. 3548 ((file-directory-p (setq file (nnheader-concat d file)))
3546 (if (and r 3549 (checker file)))))))
3547 (not (member r to-remove))) 3550 (checker (expand-file-name gnus-agent-directory)))
3548 (push r to-remove)))) 3551
3549 ((file-directory-p (setq file (nnheader-concat d file))) 3552 (when (and to-remove
3550 (funcall checker file))))))))) 3553 (or gnus-expert-user
3551 (funcall checker (expand-file-name gnus-agent-directory)) 3554 (gnus-y-or-n-p
3552 3555 "gnus-agent-expire has identified local directories that are\
3553 (when (and to-remove
3554 (or gnus-expert-user
3555 (gnus-y-or-n-p
3556 "gnus-agent-expire has identified local directories that are\
3557 not currently required by any agentized group. Do you wish to consider\ 3556 not currently required by any agentized group. Do you wish to consider\
3558 deleting them?"))) 3557 deleting them?")))
3559 (while to-remove 3558 (while to-remove
3560 (let ((dir (pop to-remove))) 3559 (let ((dir (pop to-remove)))
3561 (if (or gnus-expert-user 3560 (if (or gnus-expert-user
3562 (gnus-y-or-n-p (format "Delete %s? " dir))) 3561 (gnus-y-or-n-p (format "Delete %s? " dir)))
3563 (let* (delete-recursive 3562 (let* (delete-recursive
3564 files f 3563 files f
3565 (delete-recursive 3564 (delete-recursive
3566 (function 3565 (function
3567 (lambda (f-or-d) 3566 (lambda (f-or-d)
3568 (ignore-errors 3567 (ignore-errors
3569 (if (file-directory-p f-or-d) 3568 (if (file-directory-p f-or-d)
3570 (condition-case nil 3569 (condition-case nil
3571 (delete-directory f-or-d) 3570 (delete-directory f-or-d)
3572 (file-error 3571 (file-error
3573 (setq files (directory-files f-or-d)) 3572 (setq files (directory-files f-or-d))
3574 (while files 3573 (while files
3575 (setq f (pop files)) 3574 (setq f (pop files))
3576 (or (member f '("." "..")) 3575 (or (member f '("." ".."))
3577 (funcall delete-recursive 3576 (funcall delete-recursive
3578 (nnheader-concat 3577 (nnheader-concat
3579 f-or-d f)))) 3578 f-or-d f))))
3580 (delete-directory f-or-d))) 3579 (delete-directory f-or-d)))
3581 (delete-file f-or-d))))))) 3580 (delete-file f-or-d)))))))
3582 (funcall delete-recursive dir)))))))))) 3581 (funcall delete-recursive dir)))))))))
3583 3582
3584;;;###autoload 3583;;;###autoload
3585(defun gnus-agent-batch () 3584(defun gnus-agent-batch ()
@@ -4097,8 +4096,8 @@ agent has fetched."
4097 ;; if null, gnus-agent-group-pathname will calc method. 4096 ;; if null, gnus-agent-group-pathname will calc method.
4098 (let* ((gnus-command-method method) 4097 (let* ((gnus-command-method method)
4099 (path (or path (gnus-agent-group-pathname group))) 4098 (path (or path (gnus-agent-group-pathname group)))
4100 (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) 4099 (entry (or (gethash path gnus-agent-total-fetched-hashtb)
4101 (gnus-sethash path (make-list 3 0) 4100 (puthash path (make-list 3 0)
4102 gnus-agent-total-fetched-hashtb))) 4101 gnus-agent-total-fetched-hashtb)))
4103 (file-name-coding-system nnmail-pathname-coding-system)) 4102 (file-name-coding-system nnmail-pathname-coding-system))
4104 (when (file-exists-p path) 4103 (when (file-exists-p path)
@@ -4128,7 +4127,7 @@ agent has fetched."
4128 (cl-incf (nth 2 entry) delta)))))) 4127 (cl-incf (nth 2 entry) delta))))))
4129 4128
4130(defun gnus-agent-update-view-total-fetched-for 4129(defun gnus-agent-update-view-total-fetched-for
4131 (group agent-over &optional method path) 4130 (group agent-over &optional method path)
4132 "Update, or set, the total disk space used by the .agentview and 4131 "Update, or set, the total disk space used by the .agentview and
4133.overview files. These files are calculated separately as they can be 4132.overview files. These files are calculated separately as they can be
4134modified." 4133modified."
@@ -4138,9 +4137,9 @@ modified."
4138 ;; if null, gnus-agent-group-pathname will calc method. 4137 ;; if null, gnus-agent-group-pathname will calc method.
4139 (let* ((gnus-command-method method) 4138 (let* ((gnus-command-method method)
4140 (path (or path (gnus-agent-group-pathname group))) 4139 (path (or path (gnus-agent-group-pathname group)))
4141 (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) 4140 (entry (or (gethash path gnus-agent-total-fetched-hashtb)
4142 (gnus-sethash path (make-list 3 0) 4141 (puthash path (make-list 3 0)
4143 gnus-agent-total-fetched-hashtb))) 4142 gnus-agent-total-fetched-hashtb)))
4144 (file-name-coding-system nnmail-pathname-coding-system) 4143 (file-name-coding-system nnmail-pathname-coding-system)
4145 (size (or (file-attribute-size (file-attributes 4144 (size (or (file-attribute-size (file-attributes
4146 (nnheader-concat 4145 (nnheader-concat
@@ -4155,12 +4154,13 @@ modified."
4155 "Get the total disk space used by the specified GROUP." 4154 "Get the total disk space used by the specified GROUP."
4156 (unless (equal group "dummy.group") 4155 (unless (equal group "dummy.group")
4157 (unless gnus-agent-total-fetched-hashtb 4156 (unless gnus-agent-total-fetched-hashtb
4158 (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024))) 4157 (setq gnus-agent-total-fetched-hashtb
4158 (gnus-make-hashtable 1000)))
4159 4159
4160 ;; if null, gnus-agent-group-pathname will calc method. 4160 ;; if null, gnus-agent-group-pathname will calc method.
4161 (let* ((gnus-command-method method) 4161 (let* ((gnus-command-method method)
4162 (path (gnus-agent-group-pathname group)) 4162 (path (gnus-agent-group-pathname group))
4163 (entry (gnus-gethash path gnus-agent-total-fetched-hashtb))) 4163 (entry (gethash path gnus-agent-total-fetched-hashtb)))
4164 (if entry 4164 (if entry
4165 (apply '+ entry) 4165 (apply '+ entry)
4166 (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit))) 4166 (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit)))
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el
index 00e91425798..4e2723e8d27 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -84,7 +84,6 @@ that was fetched."
84(defvar gnus-async-article-alist nil) 84(defvar gnus-async-article-alist nil)
85(defvar gnus-async-article-semaphore '(nil)) 85(defvar gnus-async-article-semaphore '(nil))
86(defvar gnus-async-fetch-list nil) 86(defvar gnus-async-fetch-list nil)
87(defvar gnus-async-hashtb nil)
88(defvar gnus-async-current-prefetch-group nil) 87(defvar gnus-async-current-prefetch-group nil)
89(defvar gnus-async-current-prefetch-article nil) 88(defvar gnus-async-current-prefetch-article nil)
90(defvar gnus-async-timer nil) 89(defvar gnus-async-timer nil)
@@ -127,14 +126,11 @@ that was fetched."
127(defun gnus-async-close () 126(defun gnus-async-close ()
128 (gnus-kill-buffer gnus-async-prefetch-article-buffer) 127 (gnus-kill-buffer gnus-async-prefetch-article-buffer)
129 (gnus-kill-buffer gnus-async-prefetch-headers-buffer) 128 (gnus-kill-buffer gnus-async-prefetch-headers-buffer)
130 (setq gnus-async-hashtb nil 129 (setq gnus-async-article-alist nil
131 gnus-async-article-alist nil
132 gnus-async-header-prefetched nil)) 130 gnus-async-header-prefetched nil))
133 131
134(defun gnus-async-set-buffer () 132(defun gnus-async-set-buffer ()
135 (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t) 133 (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t))
136 (unless gnus-async-hashtb
137 (setq gnus-async-hashtb (gnus-make-hashtable 1023))))
138 134
139(defun gnus-async-halt-prefetch () 135(defun gnus-async-halt-prefetch ()
140 "Stop prefetching." 136 "Stop prefetching."
@@ -242,13 +238,10 @@ that was fetched."
242 (when gnus-async-post-fetch-function 238 (when gnus-async-post-fetch-function
243 (funcall gnus-async-post-fetch-function summary)))) 239 (funcall gnus-async-post-fetch-function summary))))
244 (gnus-async-with-semaphore 240 (gnus-async-with-semaphore
245 (setq 241 (push (list (format "%s-%d" group article)
246 gnus-async-article-alist 242 mark (point-max-marker)
247 (cons (list (intern (format "%s-%d" group article) 243 group article)
248 gnus-async-hashtb) 244 gnus-async-article-alist)))
249 mark (point-max-marker)
250 group article)
251 gnus-async-article-alist))))
252 (if (not (gnus-buffer-live-p summary)) 245 (if (not (gnus-buffer-live-p summary))
253 (gnus-async-with-semaphore 246 (gnus-async-with-semaphore
254 (setq gnus-async-fetch-list nil)) 247 (setq gnus-async-fetch-list nil))
@@ -314,8 +307,7 @@ that was fetched."
314 (set-marker (caddr entry) nil)) 307 (set-marker (caddr entry) nil))
315 (gnus-async-with-semaphore 308 (gnus-async-with-semaphore
316 (setq gnus-async-article-alist 309 (setq gnus-async-article-alist
317 (delq entry gnus-async-article-alist)) 310 (delete entry gnus-async-article-alist))))
318 (unintern (car entry) gnus-async-hashtb)))
319 311
320(defun gnus-async-prefetch-remove-group (group) 312(defun gnus-async-prefetch-remove-group (group)
321 "Remove all articles belonging to GROUP from the prefetch buffer." 313 "Remove all articles belonging to GROUP from the prefetch buffer."
@@ -331,9 +323,8 @@ that was fetched."
331 "Return the entry for ARTICLE in GROUP if it has been prefetched." 323 "Return the entry for ARTICLE in GROUP if it has been prefetched."
332 (let ((entry (save-excursion 324 (let ((entry (save-excursion
333 (gnus-async-set-buffer) 325 (gnus-async-set-buffer)
334 (assq (intern-soft (format "%s-%d" group article) 326 (assoc (format "%s-%d" group article)
335 gnus-async-hashtb) 327 gnus-async-article-alist))))
336 gnus-async-article-alist))))
337 ;; Perhaps something has emptied the buffer? 328 ;; Perhaps something has emptied the buffer?
338 (if (and entry 329 (if (and entry
339 (= (cadr entry) (caddr entry))) 330 (= (cadr entry) (caddr entry)))
@@ -342,7 +333,7 @@ that was fetched."
342 (set-marker (cadr entry) nil) 333 (set-marker (cadr entry) nil)
343 (set-marker (caddr entry) nil)) 334 (set-marker (caddr entry) nil))
344 (setq gnus-async-article-alist 335 (setq gnus-async-article-alist
345 (delq entry gnus-async-article-alist)) 336 (delete entry gnus-async-article-alist))
346 nil) 337 nil)
347 entry))) 338 entry)))
348 339
diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el
index a1a585e1bfe..c5a0e3ec4f0 100644
--- a/lisp/gnus/gnus-bcklg.el
+++ b/lisp/gnus/gnus-bcklg.el
@@ -22,17 +22,16 @@
22 22
23;;; Commentary: 23;;; Commentary:
24 24
25;; The backlog caches the text of a certain number of read articles in
26;; a separate buffer, so they can be retrieved quickly if the user
27;; opens them again. Also see `gnus-keep-backlog'.
28
25;;; Code: 29;;; Code:
26 30
27(require 'gnus) 31(require 'gnus)
28 32
29;;;
30;;; Buffering of read articles.
31;;;
32
33(defvar gnus-backlog-buffer " *Gnus Backlog*") 33(defvar gnus-backlog-buffer " *Gnus Backlog*")
34(defvar gnus-backlog-articles nil) 34(defvar gnus-backlog-articles '())
35(defvar gnus-backlog-hashtb nil)
36 35
37(defun gnus-backlog-buffer () 36(defun gnus-backlog-buffer ()
38 "Return the backlog buffer." 37 "Return the backlog buffer."
@@ -42,11 +41,6 @@
42 (setq buffer-read-only t) 41 (setq buffer-read-only t)
43 (get-buffer gnus-backlog-buffer)))) 42 (get-buffer gnus-backlog-buffer))))
44 43
45(defun gnus-backlog-setup ()
46 "Initialize backlog variables."
47 (unless gnus-backlog-hashtb
48 (setq gnus-backlog-hashtb (gnus-make-hashtable 1024))))
49
50(gnus-add-shutdown 'gnus-backlog-shutdown 'gnus) 44(gnus-add-shutdown 'gnus-backlog-shutdown 'gnus)
51 45
52(defun gnus-backlog-shutdown () 46(defun gnus-backlog-shutdown ()
@@ -54,46 +48,42 @@
54 (interactive) 48 (interactive)
55 (when (get-buffer gnus-backlog-buffer) 49 (when (get-buffer gnus-backlog-buffer)
56 (gnus-kill-buffer gnus-backlog-buffer)) 50 (gnus-kill-buffer gnus-backlog-buffer))
57 (setq gnus-backlog-hashtb nil 51 (setq gnus-backlog-articles nil))
58 gnus-backlog-articles nil))
59 52
60(defun gnus-backlog-enter-article (group number buffer) 53(defun gnus-backlog-enter-article (group number buffer)
61 (when (and (numberp number) 54 (when (and (numberp number)
62 (not (gnus-virtual-group-p group))) 55 (not (gnus-virtual-group-p group)))
63 (gnus-backlog-setup) 56 (let ((ident (format "%s:%d" group number))
64 (let ((ident (intern (concat group ":" (int-to-string number))
65 gnus-backlog-hashtb))
66 b) 57 b)
67 (if (memq ident gnus-backlog-articles) 58 (unless (member ident gnus-backlog-articles) ; It's already kept.
68 () ; It's already kept. 59 ;; Remove the oldest article, if necessary.
69 ;; Remove the oldest article, if necessary. 60 (and (numberp gnus-keep-backlog)
70 (and (numberp gnus-keep-backlog) 61 (>= (length gnus-backlog-articles) gnus-keep-backlog)
71 (>= (length gnus-backlog-articles) gnus-keep-backlog) 62 (gnus-backlog-remove-oldest-article))
72 (gnus-backlog-remove-oldest-article)) 63 (push ident gnus-backlog-articles)
73 (push ident gnus-backlog-articles) 64 ;; Insert the new article.
74 ;; Insert the new article. 65 (with-current-buffer (gnus-backlog-buffer)
75 (with-current-buffer (gnus-backlog-buffer) 66 (let (buffer-read-only)
76 (let (buffer-read-only) 67 (goto-char (point-max))
77 (goto-char (point-max)) 68 (unless (bolp)
78 (unless (bolp) 69 (insert "\n"))
79 (insert "\n")) 70 (setq b (point))
80 (setq b (point)) 71 (insert-buffer-substring buffer)
81 (insert-buffer-substring buffer) 72 ;; Tag the beginning of the article with the ident.
82 ;; Tag the beginning of the article with the ident. 73 (if (> (point-max) b)
83 (if (> (point-max) b) 74 (put-text-property b (1+ b) 'gnus-backlog ident)
84 (put-text-property b (1+ b) 'gnus-backlog ident) 75 (gnus-error 3 "Article %d is blank" number))))))))
85 (gnus-error 3 "Article %d is blank" number))))))))
86 76
87(defun gnus-backlog-remove-oldest-article () 77(defun gnus-backlog-remove-oldest-article ()
88 (with-current-buffer (gnus-backlog-buffer) 78 (with-current-buffer (gnus-backlog-buffer)
89 (goto-char (point-min)) 79 (goto-char (point-min))
90 (if (zerop (buffer-size)) 80 (unless (zerop (buffer-size)) ; The buffer is empty.
91 () ; The buffer is empty.
92 (let ((ident (get-text-property (point) 'gnus-backlog)) 81 (let ((ident (get-text-property (point) 'gnus-backlog))
93 buffer-read-only) 82 buffer-read-only)
94 ;; Remove the ident from the list of articles. 83 ;; Remove the ident from the list of articles.
95 (when ident 84 (when ident
96 (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) 85 (setq gnus-backlog-articles
86 (delete ident gnus-backlog-articles)))
97 ;; Delete the article itself. 87 ;; Delete the article itself.
98 (delete-region 88 (delete-region
99 (point) (next-single-property-change 89 (point) (next-single-property-change
@@ -102,42 +92,40 @@
102(defun gnus-backlog-remove-article (group number) 92(defun gnus-backlog-remove-article (group number)
103 "Remove article NUMBER in GROUP from the backlog." 93 "Remove article NUMBER in GROUP from the backlog."
104 (when (numberp number) 94 (when (numberp number)
105 (gnus-backlog-setup) 95 (let ((ident (format "%s:%d" group number))
106 (let ((ident (intern (concat group ":" (int-to-string number)) 96 beg)
107 gnus-backlog-hashtb)) 97 (when (member ident gnus-backlog-articles)
108 beg end)
109 (when (memq ident gnus-backlog-articles)
110 ;; It was in the backlog. 98 ;; It was in the backlog.
111 (with-current-buffer (gnus-backlog-buffer) 99 (with-current-buffer (gnus-backlog-buffer)
112 (let (buffer-read-only) 100 (save-excursion
113 (when (setq beg (text-property-any 101 (let (buffer-read-only)
114 (point-min) (point-max) 'gnus-backlog 102 (goto-char (point-min))
115 ident)) 103 (when (setq beg (gnus-text-property-search
116 ;; Find the end (i. e., the beginning of the next article). 104 'gnus-backlog ident))
117 (setq end 105 ;; Find the end (i. e., the beginning of the next article).
118 (next-single-property-change 106 (goto-char
119 (1+ beg) 'gnus-backlog (current-buffer) (point-max))) 107 (next-single-property-change
120 (delete-region beg end) 108 (1+ beg) 'gnus-backlog (current-buffer) (point-max)))
121 ;; Return success. 109 (delete-region beg (point))
122 t)) 110 ;; Return success.
123 (setq gnus-backlog-articles (delq ident gnus-backlog-articles))))))) 111 t)))
112 (setq gnus-backlog-articles
113 (delete ident gnus-backlog-articles)))))))
124 114
125(defun gnus-backlog-request-article (group number &optional buffer) 115(defun gnus-backlog-request-article (group number &optional buffer)
126 (when (and (numberp number) 116 (when (and (numberp number)
127 (not (gnus-virtual-group-p group))) 117 (not (gnus-virtual-group-p group)))
128 (gnus-backlog-setup) 118 (let ((ident (format "%s:%d" group number))
129 (let ((ident (intern (concat group ":" (int-to-string number))
130 gnus-backlog-hashtb))
131 beg end) 119 beg end)
132 (when (memq ident gnus-backlog-articles) 120 (when (member ident gnus-backlog-articles)
133 ;; It was in the backlog. 121 ;; It was in the backlog.
134 (with-current-buffer (gnus-backlog-buffer) 122 (with-current-buffer (gnus-backlog-buffer)
135 (if (not (setq beg (text-property-any 123 (if (not (setq beg (gnus-text-property-search
136 (point-min) (point-max) 'gnus-backlog 124 'gnus-backlog ident)))
137 ident)))
138 ;; It wasn't in the backlog after all. 125 ;; It wasn't in the backlog after all.
139 (ignore 126 (ignore
140 (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) 127 (setq gnus-backlog-articles
128 (delete ident gnus-backlog-articles)))
141 ;; Find the end (i. e., the beginning of the next article). 129 ;; Find the end (i. e., the beginning of the next article).
142 (setq end 130 (setq end
143 (next-single-property-change 131 (next-single-property-change
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index 0378443377f..5e6483d1053 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -272,7 +272,7 @@ it's not cached."
272(defun gnus-cache-possibly-alter-active (group active) 272(defun gnus-cache-possibly-alter-active (group active)
273 "Alter the ACTIVE info for GROUP to reflect the articles in the cache." 273 "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
274 (when gnus-cache-active-hashtb 274 (when gnus-cache-active-hashtb
275 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) 275 (let ((cache-active (gethash group gnus-cache-active-hashtb)))
276 (when cache-active 276 (when cache-active
277 (when (< (car cache-active) (car active)) 277 (when (< (car cache-active) (car active))
278 (setcar active (car cache-active))) 278 (setcar active (car cache-active)))
@@ -522,7 +522,7 @@ system for example was used.")
522 (gnus-delete-line))) 522 (gnus-delete-line)))
523 (unless (setq gnus-newsgroup-cached 523 (unless (setq gnus-newsgroup-cached
524 (delq article gnus-newsgroup-cached)) 524 (delq article gnus-newsgroup-cached))
525 (gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb) 525 (remhash gnus-newsgroup-name gnus-cache-active-hashtb)
526 (setq gnus-cache-active-altered t)) 526 (setq gnus-cache-active-altered t))
527 (gnus-summary-update-secondary-mark article) 527 (gnus-summary-update-secondary-mark article)
528 t))) 528 t)))
@@ -542,8 +542,8 @@ system for example was used.")
542 (progn 542 (progn
543 (gnus-cache-update-active group (car articles) t) 543 (gnus-cache-update-active group (car articles) t)
544 (gnus-cache-update-active group (car (last articles)))) 544 (gnus-cache-update-active group (car (last articles))))
545 (when (gnus-gethash group gnus-cache-active-hashtb) 545 (when (gethash group gnus-cache-active-hashtb)
546 (gnus-sethash group nil gnus-cache-active-hashtb) 546 (remhash group gnus-cache-active-hashtb)
547 (setq gnus-cache-active-altered t))) 547 (setq gnus-cache-active-altered t)))
548 articles))) 548 articles)))
549 549
@@ -666,13 +666,16 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
666 ;; Mark the active hashtb as unaltered. 666 ;; Mark the active hashtb as unaltered.
667 (setq gnus-cache-active-altered nil))) 667 (setq gnus-cache-active-altered nil)))
668 668
669;; FIXME: Why is there a `gnus-cache-possibly-alter-active',
670;; `gnus-cache-possibly-update-active', and
671;; `gnus-cache-update-active'? Do we really need all three?
669(defun gnus-cache-possibly-update-active (group active) 672(defun gnus-cache-possibly-update-active (group active)
670 "Update active info bounds of GROUP with ACTIVE if necessary. 673 "Update active info bounds of GROUP with ACTIVE if necessary.
671The update is performed if ACTIVE contains a higher or lower bound 674The update is performed if ACTIVE contains a higher or lower bound
672than the current." 675than the current."
673 (let ((lower t) (higher t)) 676 (let ((lower t) (higher t))
674 (if gnus-cache-active-hashtb 677 (if gnus-cache-active-hashtb
675 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) 678 (let ((cache-active (gethash group gnus-cache-active-hashtb)))
676 (when cache-active 679 (when cache-active
677 (unless (< (car active) (car cache-active)) 680 (unless (< (car active) (car cache-active))
678 (setq lower nil)) 681 (setq lower nil))
@@ -687,10 +690,10 @@ than the current."
687(defun gnus-cache-update-active (group number &optional low) 690(defun gnus-cache-update-active (group number &optional low)
688 "Update the upper bound of the active info of GROUP to NUMBER. 691 "Update the upper bound of the active info of GROUP to NUMBER.
689If LOW, update the lower bound instead." 692If LOW, update the lower bound instead."
690 (let ((active (gnus-gethash group gnus-cache-active-hashtb))) 693 (let ((active (gethash group gnus-cache-active-hashtb)))
691 (if (null active) 694 (if (null active)
692 ;; We just create a new active entry for this group. 695 ;; We just create a new active entry for this group.
693 (gnus-sethash group (cons number number) gnus-cache-active-hashtb) 696 (puthash group (cons number number) gnus-cache-active-hashtb)
694 ;; Update the lower or upper bound. 697 ;; Update the lower or upper bound.
695 (if low 698 (if low
696 (setcar active number) 699 (setcar active number)
@@ -734,10 +737,10 @@ If LOW, update the lower bound instead."
734 ;; FIXME: this is kind of a workaround. The active file should 737 ;; FIXME: this is kind of a workaround. The active file should
735 ;; be updated at the time articles are cached. It will make 738 ;; be updated at the time articles are cached. It will make
736 ;; `gnus-cache-unified-group-names' needless. 739 ;; `gnus-cache-unified-group-names' needless.
737 (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names)) 740 (puthash (or (cdr (assoc group gnus-cache-unified-group-names))
738 group) 741 group)
739 (cons (car nums) (car (last nums))) 742 (cons (car nums) (car (last nums)))
740 gnus-cache-active-hashtb)) 743 gnus-cache-active-hashtb))
741 ;; Go through all the other files. 744 ;; Go through all the other files.
742 (dolist (file alphs) 745 (dolist (file alphs)
743 (when (and (file-directory-p file) 746 (when (and (file-directory-p file)
@@ -798,13 +801,13 @@ supported."
798 (unless gnus-cache-active-hashtb 801 (unless gnus-cache-active-hashtb
799 (gnus-cache-read-active)) 802 (gnus-cache-read-active))
800 (let* ((old-group-hash-value 803 (let* ((old-group-hash-value
801 (gnus-gethash old-group gnus-cache-active-hashtb)) 804 (gethash old-group gnus-cache-active-hashtb))
802 (new-group-hash-value 805 (new-group-hash-value
803 (gnus-gethash new-group gnus-cache-active-hashtb)) 806 (gethash new-group gnus-cache-active-hashtb))
804 (delta 807 (delta
805 (or old-group-hash-value new-group-hash-value))) 808 (or old-group-hash-value new-group-hash-value)))
806 (gnus-sethash new-group old-group-hash-value gnus-cache-active-hashtb) 809 (puthash new-group old-group-hash-value gnus-cache-active-hashtb)
807 (gnus-sethash old-group nil gnus-cache-active-hashtb) 810 (puthash old-group nil gnus-cache-active-hashtb)
808 811
809 (if no-save 812 (if no-save
810 (setq gnus-cache-active-altered delta) 813 (setq gnus-cache-active-altered delta)
@@ -826,8 +829,8 @@ supported."
826 (let ((no-save gnus-cache-active-hashtb)) 829 (let ((no-save gnus-cache-active-hashtb))
827 (unless gnus-cache-active-hashtb 830 (unless gnus-cache-active-hashtb
828 (gnus-cache-read-active)) 831 (gnus-cache-read-active))
829 (let* ((group-hash-value (gnus-gethash group gnus-cache-active-hashtb))) 832 (let* ((group-hash-value (gethash group gnus-cache-active-hashtb)))
830 (gnus-sethash group nil gnus-cache-active-hashtb) 833 (remhash group gnus-cache-active-hashtb)
831 834
832 (if no-save 835 (if no-save
833 (setq gnus-cache-active-altered group-hash-value) 836 (setq gnus-cache-active-altered group-hash-value)
@@ -849,9 +852,9 @@ supported."
849 (when gnus-cache-total-fetched-hashtb 852 (when gnus-cache-total-fetched-hashtb
850 (gnus-cache-with-refreshed-group 853 (gnus-cache-with-refreshed-group
851 group 854 group
852 (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) 855 (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb)
853 (gnus-sethash group (make-vector 2 0) 856 (puthash group (make-vector 2 0)
854 gnus-cache-total-fetched-hashtb))) 857 gnus-cache-total-fetched-hashtb)))
855 size) 858 size)
856 859
857 (if file 860 (if file
@@ -874,8 +877,8 @@ supported."
874 (when gnus-cache-total-fetched-hashtb 877 (when gnus-cache-total-fetched-hashtb
875 (gnus-cache-with-refreshed-group 878 (gnus-cache-with-refreshed-group
876 group 879 group
877 (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) 880 (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb)
878 (gnus-sethash group (make-list 2 0) 881 (puthash group (make-list 2 0)
879 gnus-cache-total-fetched-hashtb))) 882 gnus-cache-total-fetched-hashtb)))
880 (file-name-coding-system nnmail-pathname-coding-system) 883 (file-name-coding-system nnmail-pathname-coding-system)
881 (size (or (file-attribute-size (file-attributes 884 (size (or (file-attribute-size (file-attributes
@@ -888,22 +891,21 @@ supported."
888(defun gnus-cache-rename-group-total-fetched-for (old-group new-group) 891(defun gnus-cache-rename-group-total-fetched-for (old-group new-group)
889 "Record of disk space used by OLD-GROUP now associated with NEW-GROUP." 892 "Record of disk space used by OLD-GROUP now associated with NEW-GROUP."
890 (when gnus-cache-total-fetched-hashtb 893 (when gnus-cache-total-fetched-hashtb
891 (let ((entry (gnus-gethash old-group gnus-cache-total-fetched-hashtb))) 894 (let ((entry (gethash old-group gnus-cache-total-fetched-hashtb)))
892 (gnus-sethash new-group entry gnus-cache-total-fetched-hashtb) 895 (puthash new-group entry gnus-cache-total-fetched-hashtb)
893 (gnus-sethash old-group nil gnus-cache-total-fetched-hashtb)))) 896 (remhash old-group gnus-cache-total-fetched-hashtb))))
894 897
895(defun gnus-cache-delete-group-total-fetched-for (group) 898(defun gnus-cache-delete-group-total-fetched-for (group)
896 "Delete record of disk space used by GROUP being deleted." 899 "Delete record of disk space used by GROUP being deleted."
897 (when gnus-cache-total-fetched-hashtb 900 (when gnus-cache-total-fetched-hashtb
898 (gnus-sethash group nil gnus-cache-total-fetched-hashtb))) 901 (remhash group gnus-cache-total-fetched-hashtb)))
899 902
900(defun gnus-cache-total-fetched-for (group &optional no-inhibit) 903(defun gnus-cache-total-fetched-for (group &optional no-inhibit)
901 "Get total disk space used by the cache for the specified GROUP." 904 "Get total disk space used by the cache for the specified GROUP."
902 (unless (equal group "dummy.group") 905 (unless (equal group "dummy.group")
903 (unless gnus-cache-total-fetched-hashtb 906 (unless gnus-cache-total-fetched-hashtb
904 (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024))) 907 (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1000)))
905 908 (let* ((entry (gethash group gnus-cache-total-fetched-hashtb)))
906 (let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb)))
907 (if entry 909 (if entry
908 (apply '+ entry) 910 (apply '+ entry)
909 (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit))) 911 (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el
index 5c085f95aa7..8b876489e1c 100644
--- a/lisp/gnus/gnus-dup.el
+++ b/lisp/gnus/gnus-dup.el
@@ -44,7 +44,7 @@ seen in the same session."
44 :type 'boolean) 44 :type 'boolean)
45 45
46(defcustom gnus-duplicate-list-length 10000 46(defcustom gnus-duplicate-list-length 10000
47 "The number of Message-IDs to keep in the duplicate suppression list." 47 "The maximum number of duplicate Message-IDs to keep track of."
48 :group 'gnus-duplicate 48 :group 'gnus-duplicate
49 :type 'integer) 49 :type 'integer)
50 50
@@ -55,8 +55,10 @@ seen in the same session."
55 55
56;;; Internal variables 56;;; Internal variables
57 57
58(defvar gnus-dup-list nil) 58(defvar gnus-dup-list nil
59(defvar gnus-dup-hashtb nil) 59 "List of seen message IDs, as strings.")
60(defvar gnus-dup-hashtb nil
61 "Hash table of seen message IDs, for fast lookup.")
60 62
61(defvar gnus-dup-list-dirty nil) 63(defvar gnus-dup-list-dirty nil)
62 64
@@ -80,8 +82,8 @@ seen in the same session."
80 (setq gnus-dup-list nil)) 82 (setq gnus-dup-list nil))
81 (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length)) 83 (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
82 ;; Enter all Message-IDs into the hash table. 84 ;; Enter all Message-IDs into the hash table.
83 (let ((obarray gnus-dup-hashtb)) 85 (dolist (g gnus-dup-list)
84 (mapc 'intern gnus-dup-list))) 86 (puthash g t gnus-dup-hashtb)))
85 87
86(defun gnus-dup-read () 88(defun gnus-dup-read ()
87 "Read the duplicate suppression list." 89 "Read the duplicate suppression list."
@@ -116,13 +118,13 @@ seen in the same session."
116 (not (= (gnus-data-mark datum) gnus-canceled-mark)) 118 (not (= (gnus-data-mark datum) gnus-canceled-mark))
117 (setq msgid (mail-header-id (gnus-data-header datum))) 119 (setq msgid (mail-header-id (gnus-data-header datum)))
118 (not (nnheader-fake-message-id-p msgid)) 120 (not (nnheader-fake-message-id-p msgid))
119 (not (intern-soft msgid gnus-dup-hashtb))) 121 (not (gethash msgid gnus-dup-hashtb)))
120 (push msgid gnus-dup-list) 122 (push msgid gnus-dup-list)
121 (intern msgid gnus-dup-hashtb)))) 123 (puthash msgid t gnus-dup-hashtb))))
122 ;; Chop off excess Message-IDs from the list. 124 ;; Chop off excess Message-IDs from the list.
123 (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) 125 (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
124 (when end 126 (when end
125 (mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr end)) 127 (mapc (lambda (id) (remhash id gnus-dup-hashtb)) (cdr end))
126 (setcdr end nil)))) 128 (setcdr end nil))))
127 129
128(defun gnus-dup-suppress-articles () 130(defun gnus-dup-suppress-articles ()
@@ -134,7 +136,7 @@ seen in the same session."
134 (memq gnus-duplicate-mark gnus-auto-expirable-marks))) 136 (memq gnus-duplicate-mark gnus-auto-expirable-marks)))
135 number) 137 number)
136 (dolist (header gnus-newsgroup-headers) 138 (dolist (header gnus-newsgroup-headers)
137 (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb) 139 (when (and (gethash (mail-header-id header) gnus-dup-hashtb)
138 (gnus-summary-article-unread-p (mail-header-number header))) 140 (gnus-summary-article-unread-p (mail-header-number header)))
139 (setq gnus-newsgroup-unreads 141 (setq gnus-newsgroup-unreads
140 (delq (setq number (mail-header-number header)) 142 (delq (setq number (mail-header-number header))
@@ -152,7 +154,7 @@ seen in the same session."
152 (when id 154 (when id
153 (setq gnus-dup-list-dirty t) 155 (setq gnus-dup-list-dirty t)
154 (setq gnus-dup-list (delete id gnus-dup-list)) 156 (setq gnus-dup-list (delete id gnus-dup-list))
155 (unintern id gnus-dup-hashtb)))) 157 (remhash id gnus-dup-hashtb))))
156 158
157(provide 'gnus-dup) 159(provide 'gnus-dup)
158 160
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 9f579bbd96c..f1202e176e7 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -38,6 +38,7 @@
38 38
39(eval-when-compile 39(eval-when-compile
40 (require 'mm-url) 40 (require 'mm-url)
41 (require 'subr-x)
41 (let ((features (cons 'gnus-group features))) 42 (let ((features (cons 'gnus-group features)))
42 (require 'gnus-sum)) 43 (require 'gnus-sum))
43 (unless (boundp 'gnus-cache-active-hashtb) 44 (unless (boundp 'gnus-cache-active-hashtb)
@@ -1142,7 +1143,7 @@ The following commands are available:
1142 (let ((gnus-process-mark ?\200) 1143 (let ((gnus-process-mark ?\200)
1143 (gnus-group-update-hook nil) 1144 (gnus-group-update-hook nil)
1144 (gnus-group-marked '("dummy.group")) 1145 (gnus-group-marked '("dummy.group"))
1145 (gnus-active-hashtb (make-vector 10 0))) 1146 (gnus-active-hashtb (gnus-make-hashtable 10)))
1146 (gnus-set-active "dummy.group" '(0 . 0)) 1147 (gnus-set-active "dummy.group" '(0 . 0))
1147 (gnus-set-work-buffer) 1148 (gnus-set-work-buffer)
1148 (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) 1149 (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil)
@@ -1186,6 +1187,9 @@ The following commands are available:
1186 (unless (derived-mode-p 'gnus-group-mode) 1187 (unless (derived-mode-p 'gnus-group-mode)
1187 (gnus-group-mode))) 1188 (gnus-group-mode)))
1188 1189
1190;; FIXME: If we never have to coerce group names to unibyte now, how
1191;; much of this is necessary? How much encoding/decoding do we still
1192;; have to do?
1189(defun gnus-group-name-charset (method group) 1193(defun gnus-group-name-charset (method group)
1190 (unless method 1194 (unless method
1191 (setq method (gnus-find-method-for-group group))) 1195 (setq method (gnus-find-method-for-group group)))
@@ -1267,20 +1271,14 @@ Also see the `gnus-group-use-permanent-levels' variable."
1267 ;; has disappeared in the new listing, try to find the next 1271 ;; has disappeared in the new listing, try to find the next
1268 ;; one. If no next one can be found, just leave point at the 1272 ;; one. If no next one can be found, just leave point at the
1269 ;; first newsgroup in the buffer. 1273 ;; first newsgroup in the buffer.
1270 (when (not (gnus-goto-char 1274 (when (not (gnus-text-property-search
1271 (text-property-any 1275 'gnus-group group nil 'goto))
1272 (point-min) (point-max) 1276 (let ((groups (cdr-safe (member group gnus-group-list))))
1273 'gnus-group (gnus-intern-safe 1277 (while (and groups
1274 group gnus-active-hashtb)))) 1278 (not (gnus-text-property-search
1275 (let ((newsrc (cdddr (gnus-group-entry group)))) 1279 'gnus-group (car groups) 'forward 'goto)))
1276 (while (and newsrc 1280 (setq groups (cdr groups)))
1277 (not (gnus-goto-char 1281 (unless groups
1278 (text-property-any
1279 (point-min) (point-max) 'gnus-group
1280 (gnus-intern-safe
1281 (caar newsrc) gnus-active-hashtb)))))
1282 (setq newsrc (cdr newsrc)))
1283 (unless newsrc
1284 (goto-char (point-max)) 1282 (goto-char (point-max))
1285 (forward-line -1))))))) 1283 (forward-line -1)))))))
1286 ;; Adjust cursor point. 1284 ;; Adjust cursor point.
@@ -1313,7 +1311,6 @@ If REGEXP is a function, list dead groups that the function returns non-nil;
1313if it is a string, only list groups matching REGEXP." 1311if it is a string, only list groups matching REGEXP."
1314 (set-buffer gnus-group-buffer) 1312 (set-buffer gnus-group-buffer)
1315 (let ((buffer-read-only nil) 1313 (let ((buffer-read-only nil)
1316 (newsrc (cdr gnus-newsrc-alist))
1317 (lowest (or lowest 1)) 1314 (lowest (or lowest 1))
1318 (not-in-list (and gnus-group-listed-groups 1315 (not-in-list (and gnus-group-listed-groups
1319 (copy-sequence gnus-group-listed-groups))) 1316 (copy-sequence gnus-group-listed-groups)))
@@ -1321,12 +1318,11 @@ if it is a string, only list groups matching REGEXP."
1321 (erase-buffer) 1318 (erase-buffer)
1322 (when (or (< lowest gnus-level-zombie) 1319 (when (or (< lowest gnus-level-zombie)
1323 gnus-group-listed-groups) 1320 gnus-group-listed-groups)
1324 ;; List living groups. 1321 ;; List living groups, according to order in `gnus-group-list'.
1325 (while newsrc 1322 (dolist (g (cdr gnus-group-list))
1326 (setq info (car newsrc) 1323 (setq info (nth 1 (gethash g gnus-newsrc-hashtb))
1327 group (gnus-info-group info) 1324 group (gnus-info-group info)
1328 params (gnus-info-params info) 1325 params (gnus-info-params info)
1329 newsrc (cdr newsrc)
1330 unread (gnus-group-unread group)) 1326 unread (gnus-group-unread group))
1331 (when not-in-list 1327 (when not-in-list
1332 (setq not-in-list (delete group not-in-list))) 1328 (setq not-in-list (delete group not-in-list)))
@@ -1407,7 +1403,7 @@ if it is a string, only list groups matching REGEXP."
1407 (insert " " mark " *: " 1403 (insert " " mark " *: "
1408 (gnus-group-decoded-name group) 1404 (gnus-group-decoded-name group)
1409 "\n")) 1405 "\n"))
1410 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) 1406 (list 'gnus-group (gethash group gnus-active-hashtb)
1411 'gnus-unread t 1407 'gnus-unread t
1412 'gnus-level level)))) 1408 'gnus-level level))))
1413 (while groups 1409 (while groups
@@ -1438,7 +1434,7 @@ if it is a string, only list groups matching REGEXP."
1438 (not (gnus-ephemeral-group-p group)) 1434 (not (gnus-ephemeral-group-p group))
1439 (gnus-dribble-enter 1435 (gnus-dribble-enter
1440 (concat "(gnus-group-set-info '" 1436 (concat "(gnus-group-set-info '"
1441 (gnus-prin1-to-string (nth 2 entry)) 1437 (gnus-prin1-to-string (nth 1 entry))
1442 ")") 1438 ")")
1443 (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))) 1439 (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\"")))
1444 (setq gnus-group-indentation (gnus-group-group-indentation)) 1440 (setq gnus-group-indentation (gnus-group-group-indentation))
@@ -1455,7 +1451,7 @@ if it is a string, only list groups matching REGEXP."
1455 (if entry 1451 (if entry
1456 (progn 1452 (progn
1457 ;; (Un)subscribed group. 1453 ;; (Un)subscribed group.
1458 (setq info (nth 2 entry)) 1454 (setq info (nth 1 entry))
1459 (gnus-group-insert-group-line 1455 (gnus-group-insert-group-line
1460 group (gnus-info-level info) (gnus-info-marks info) 1456 group (gnus-info-level info) (gnus-info-marks info)
1461 (or (car entry) t) (gnus-info-method info))) 1457 (or (car entry) t) (gnus-info-method info)))
@@ -1472,7 +1468,7 @@ if it is a string, only list groups matching REGEXP."
1472 (gnus-method-simplify (gnus-find-method-for-group group)))))) 1468 (gnus-method-simplify (gnus-find-method-for-group group))))))
1473 1469
1474(defun gnus-number-of-unseen-articles-in-group (group) 1470(defun gnus-number-of-unseen-articles-in-group (group)
1475 (let* ((info (nth 2 (gnus-group-entry group))) 1471 (let* ((info (nth 1 (gnus-group-entry group)))
1476 (marked (gnus-info-marks info)) 1472 (marked (gnus-info-marks info))
1477 (seen (cdr (assq 'seen marked))) 1473 (seen (cdr (assq 'seen marked)))
1478 (active (gnus-active group))) 1474 (active (gnus-active group)))
@@ -1544,12 +1540,12 @@ if it is a string, only list groups matching REGEXP."
1544 (gnus-tmp-newsgroup-description 1540 (gnus-tmp-newsgroup-description
1545 (if gnus-description-hashtb 1541 (if gnus-description-hashtb
1546 (or (gnus-group-name-decode 1542 (or (gnus-group-name-decode
1547 (gnus-gethash gnus-tmp-group gnus-description-hashtb) 1543 (gethash gnus-tmp-group gnus-description-hashtb)
1548 group-name-charset) "") 1544 group-name-charset) "")
1549 "")) 1545 ""))
1550 (gnus-tmp-moderated 1546 (gnus-tmp-moderated
1551 (if (and gnus-moderated-hashtb 1547 (if (and gnus-moderated-hashtb
1552 (gnus-gethash gnus-tmp-group gnus-moderated-hashtb)) 1548 (gethash gnus-tmp-group gnus-moderated-hashtb))
1553 ?m ? )) 1549 ?m ? ))
1554 (gnus-tmp-moderated-string 1550 (gnus-tmp-moderated-string
1555 (if (eq gnus-tmp-moderated ?m) "(m)" "")) 1551 (if (eq gnus-tmp-moderated ?m) "(m)" ""))
@@ -1575,7 +1571,7 @@ if it is a string, only list groups matching REGEXP."
1575 gnus-process-mark ? )) 1571 gnus-process-mark ? ))
1576 (buffer-read-only nil) 1572 (buffer-read-only nil)
1577 beg end 1573 beg end
1578 gnus-tmp-header) ; passed as parameter to user-funcs. 1574 gnus-tmp-header) ; passed as parameter to user-funcs.
1579 (beginning-of-line) 1575 (beginning-of-line)
1580 (setq beg (point)) 1576 (setq beg (point))
1581 (add-text-properties 1577 (add-text-properties
@@ -1585,7 +1581,7 @@ if it is a string, only list groups matching REGEXP."
1585 (let ((gnus-tmp-decoded-group (gnus-group-name-decode 1581 (let ((gnus-tmp-decoded-group (gnus-group-name-decode
1586 gnus-tmp-group group-name-charset))) 1582 gnus-tmp-group group-name-charset)))
1587 (eval gnus-group-line-format-spec))) 1583 (eval gnus-group-line-format-spec)))
1588 `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb) 1584 `(gnus-group ,gnus-tmp-group
1589 gnus-unread ,(if (numberp number) 1585 gnus-unread ,(if (numberp number)
1590 (string-to-number gnus-tmp-number-of-unread) 1586 (string-to-number gnus-tmp-number-of-unread)
1591 t) 1587 t)
@@ -1619,7 +1615,7 @@ Some value are bound so the form can use them."
1619 (when list 1615 (when list
1620 (let* ((entry (gnus-group-entry group)) 1616 (let* ((entry (gnus-group-entry group))
1621 (active (gnus-active group)) 1617 (active (gnus-active group))
1622 (info (nth 2 entry)) 1618 (info (nth 1 entry))
1623 (method (inline (gnus-server-get-method 1619 (method (inline (gnus-server-get-method
1624 group (gnus-info-method info)))) 1620 group (gnus-info-method info))))
1625 (marked (gnus-info-marks info)) 1621 (marked (gnus-info-marks info))
@@ -1690,9 +1686,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
1690 ;; The buffer may be narrowed. 1686 ;; The buffer may be narrowed.
1691 (save-restriction 1687 (save-restriction
1692 (widen) 1688 (widen)
1693 (let ((ident (gnus-intern-safe group gnus-active-hashtb)) 1689 (let (found buffer-read-only)
1694 (loc (point-min))
1695 found buffer-read-only)
1696 (unless info-unchanged 1690 (unless info-unchanged
1697 ;; Enter the current status into the dribble buffer. 1691 ;; Enter the current status into the dribble buffer.
1698 (let ((entry (gnus-group-entry group))) 1692 (let ((entry (gnus-group-entry group)))
@@ -1700,37 +1694,33 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
1700 (not (gnus-ephemeral-group-p group))) 1694 (not (gnus-ephemeral-group-p group)))
1701 (gnus-dribble-enter 1695 (gnus-dribble-enter
1702 (concat "(gnus-group-set-info '" 1696 (concat "(gnus-group-set-info '"
1703 (gnus-prin1-to-string (nth 2 entry)) 1697 (gnus-prin1-to-string (nth 1 entry))
1704 ")") 1698 ")")
1705 (concat "^(gnus-group-set-info '(\"" 1699 (concat "^(gnus-group-set-info '(\""
1706 (regexp-quote group) "\""))))) 1700 (regexp-quote group) "\"")))))
1707 ;; Find all group instances. If topics are in use, each group 1701 ;; Find all group instances. If topics are in use, groups
1708 ;; may be listed in more than once. 1702 ;; may be listed more than once.
1709 (while (setq loc (text-property-any 1703 (goto-char (point-min))
1710 loc (point-max) 'gnus-group ident)) 1704 (while (gnus-text-property-search
1705 'gnus-group group 'forward 'goto)
1711 (setq found t) 1706 (setq found t)
1712 (goto-char loc)
1713 (let ((gnus-group-indentation (gnus-group-group-indentation))) 1707 (let ((gnus-group-indentation (gnus-group-group-indentation)))
1714 (gnus-delete-line) 1708 (gnus-delete-line)
1715 (gnus-group-insert-group-line-info group) 1709 (gnus-group-insert-group-line-info group)
1716 (save-excursion 1710 (save-excursion
1717 (forward-line -1) 1711 (forward-line -1)
1718 (gnus-run-hooks 'gnus-group-update-group-hook))) 1712 (gnus-run-hooks 'gnus-group-update-group-hook))))
1719 (setq loc (1+ loc)))
1720 (unless (or found visible-only) 1713 (unless (or found visible-only)
1721 ;; No such line in the buffer, find out where it's supposed to 1714 ;; No such line in the buffer, find out where it's supposed to
1722 ;; go, and insert it there (or at the end of the buffer). 1715 ;; go, and insert it there (or at the end of the buffer).
1723 (if gnus-goto-missing-group-function 1716 (if gnus-goto-missing-group-function
1724 (funcall gnus-goto-missing-group-function group) 1717 (funcall gnus-goto-missing-group-function group)
1725 (let ((entry (cddr (gnus-group-entry group)))) 1718 (let ((entry (cdr (member group gnus-group-list))))
1726 (while (and entry (car entry) 1719 (goto-char (point-min))
1720 (while (and (car-safe entry)
1727 (not 1721 (not
1728 (gnus-goto-char 1722 (gnus-text-property-search
1729 (text-property-any 1723 'gnus-group (car entry) 'forward 'goto)))
1730 (point-min) (point-max)
1731 'gnus-group (gnus-intern-safe
1732 (caar entry)
1733 gnus-active-hashtb)))))
1734 (setq entry (cdr entry))) 1724 (setq entry (cdr entry)))
1735 (or entry (goto-char (point-max))))) 1725 (or entry (goto-char (point-max)))))
1736 ;; Finally insert the line. 1726 ;; Finally insert the line.
@@ -2062,7 +2052,7 @@ that group."
2062 (unless group 2052 (unless group
2063 (error "No group on current line")) 2053 (error "No group on current line"))
2064 (setq marked (gnus-info-marks 2054 (setq marked (gnus-info-marks
2065 (nth 2 (setq entry (gnus-group-entry group))))) 2055 (nth 1 (setq entry (gnus-group-entry group)))))
2066 ;; This group might be a dead group. In that case we have to get 2056 ;; This group might be a dead group. In that case we have to get
2067 ;; the number of unread articles from `gnus-active-hashtb'. 2057 ;; the number of unread articles from `gnus-active-hashtb'.
2068 (setq number 2058 (setq number
@@ -2137,6 +2127,7 @@ be permanent."
2137 (let ((group (gnus-group-group-name))) 2127 (let ((group (gnus-group-group-name)))
2138 (when group 2128 (when group
2139 (gnus-group-decoded-name group))) 2129 (gnus-group-decoded-name group)))
2130 ;; FIXME: Use rx.
2140 (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\ 2131 (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\
2141\\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\ 2132\\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\
2142[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\ 2133[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\
@@ -2175,34 +2166,46 @@ be permanent."
2175(defun gnus-group-completing-read (&optional prompt collection 2166(defun gnus-group-completing-read (&optional prompt collection
2176 require-match initial-input hist 2167 require-match initial-input hist
2177 def) 2168 def)
2178 "Read a group name with completion. Non-ASCII group names are allowed. 2169 "Read a group name with completion.
2179The arguments are the same as `completing-read' except that COLLECTION 2170Non-ASCII group names are allowed. The arguments are the same as
2180and HIST default to `gnus-active-hashtb' and `gnus-group-history' 2171`completing-read' except that COLLECTION and HIST default to
2181respectively if they are omitted. Regards COLLECTION as a hash table 2172`gnus-active-hashtb' and `gnus-group-history' respectively if
2182if it is not a list." 2173they are omitted. Can handle COLLECTION as a list, hash table,
2174or vector."
2183 (or collection (setq collection gnus-active-hashtb)) 2175 (or collection (setq collection gnus-active-hashtb))
2184 (let (choices group) 2176 (let (choices group)
2185 (if (listp collection) 2177 (cond ((listp collection)
2186 (dolist (symbol collection) 2178 (if (symbolp (car collection))
2187 (setq group (symbol-name symbol)) 2179 (dolist (symbol collection)
2188 (push (if (string-match "[^\000-\177]" group) 2180 (setq group (symbol-name symbol))
2189 (gnus-group-decoded-name group) 2181 (push (if (string-match "[^\000-\177]" group)
2190 group) 2182 (gnus-group-decoded-name group)
2191 choices)) 2183 group)
2192 (mapatoms (lambda (symbol) 2184 choices))
2193 (setq group (symbol-name symbol)) 2185 (setq choices collection)))
2194 (push (if (string-match "[^\000-\177]" group) 2186 ((vectorp collection)
2195 (gnus-group-decoded-name group) 2187 (mapatoms (lambda (symbol)
2196 group) 2188 (setq group (symbol-name symbol))
2197 choices)) 2189 (push (if (string-match "[^\000-\177]" group)
2198 collection)) 2190 (gnus-group-decoded-name group)
2199 (setq group (gnus-completing-read (or prompt "Group") (nreverse choices) 2191 group)
2192 choices))
2193 collection))
2194 ((hash-table-p collection)
2195 (setq choices (hash-table-keys collection))))
2196 (setq group (gnus-completing-read (or prompt "Group") (reverse choices)
2200 require-match initial-input 2197 require-match initial-input
2201 (or hist 'gnus-group-history) 2198 (or hist 'gnus-group-history)
2202 def)) 2199 def))
2203 (unless (if (listp collection) 2200 (unless (cond ((and (listp collection)
2204 (member group (mapcar 'symbol-name collection)) 2201 (symbolp (car collection)))
2205 (symbol-value (intern-soft group collection))) 2202 (member group (mapcar 'symbol-name collection)))
2203 ((listp collection)
2204 (member group collection))
2205 ((vectorp collection)
2206 (symbol-value (intern-soft group collection)))
2207 ((hash-table-p collection)
2208 (gethash group collection)))
2206 (setq group 2209 (setq group
2207 (encode-coding-string 2210 (encode-coding-string
2208 group (gnus-group-name-charset nil group)))) 2211 group (gnus-group-name-charset nil group))))
@@ -2280,7 +2283,7 @@ Return the name of the group if selection was successful."
2280 (nnheader-init-server-buffer) 2283 (nnheader-init-server-buffer)
2281 ;; Necessary because of funky inlining. 2284 ;; Necessary because of funky inlining.
2282 (require 'gnus-cache) 2285 (require 'gnus-cache)
2283 (setq gnus-newsrc-hashtb (gnus-make-hashtable))) 2286 (setq gnus-newsrc-hashtb (gnus-make-hashtable 100)))
2284 ;; Transform the select method into a unique server. 2287 ;; Transform the select method into a unique server.
2285 (when (stringp method) 2288 (when (stringp method)
2286 (setq method (gnus-server-to-method method))) 2289 (setq method (gnus-server-to-method method)))
@@ -2297,23 +2300,23 @@ Return the name of the group if selection was successful."
2297 (gnus-group-prefixed-name (gnus-group-real-name group) 2300 (gnus-group-prefixed-name (gnus-group-real-name group)
2298 method)))) 2301 method))))
2299 (gnus-set-active group nil) 2302 (gnus-set-active group nil)
2300 (gnus-sethash 2303 (puthash
2301 group 2304 group
2302 `(-1 nil (,group 2305 `(-1 (,group
2303 ,gnus-level-default-subscribed nil nil ,method 2306 ,gnus-level-default-subscribed nil nil ,method
2304 ,(cons 2307 ,(cons
2305 (cons 'quit-config 2308 (cons 'quit-config
2306 (cond 2309 (cond
2307 (quit-config 2310 (quit-config
2308 quit-config) 2311 quit-config)
2309 ((assq gnus-current-window-configuration 2312 ((assq gnus-current-window-configuration
2310 gnus-buffer-configuration) 2313 gnus-buffer-configuration)
2311 (cons gnus-summary-buffer 2314 (cons gnus-summary-buffer
2312 gnus-current-window-configuration)) 2315 gnus-current-window-configuration))
2313 (t 2316 (t
2314 (cons (current-buffer) 2317 (cons (current-buffer)
2315 (current-window-configuration))))) 2318 (current-window-configuration)))))
2316 parameters))) 2319 parameters)))
2317 gnus-newsrc-hashtb) 2320 gnus-newsrc-hashtb)
2318 (push method gnus-ephemeral-servers) 2321 (push method gnus-ephemeral-servers)
2319 (when (gnus-buffer-live-p gnus-group-buffer) 2322 (when (gnus-buffer-live-p gnus-group-buffer)
@@ -2562,30 +2565,29 @@ If PROMPT (the prefix) is a number, use the prompt specified in
2562If FAR, it is likely that the group is not on the current line. 2565If FAR, it is likely that the group is not on the current line.
2563If TEST-MARKED, the line must be marked." 2566If TEST-MARKED, the line must be marked."
2564 (when group 2567 (when group
2565 (let ((start (point))) 2568 (let ((start (point))
2569 (active (and (gethash group gnus-active-hashtb)
2570 group)))
2566 (beginning-of-line) 2571 (beginning-of-line)
2567 (cond 2572 (cond
2568 ;; It's quite likely that we are on the right line, so 2573 ;; It's quite likely that we are on the right line, so
2569 ;; we check the current line first. 2574 ;; we check the current line first.
2570 ((and (not far) 2575 ((and (not far)
2571 (eq (get-text-property (point) 'gnus-group) 2576 (equal (get-text-property (point) 'gnus-group) active)
2572 (gnus-intern-safe group gnus-active-hashtb))
2573 (or (not test-marked) (gnus-group-mark-line-p))) 2577 (or (not test-marked) (gnus-group-mark-line-p)))
2574 (point)) 2578 (point))
2575 ;; Previous and next line are also likely, so we check them as well. 2579 ;; Previous and next line are also likely, so we check them as well.
2576 ((and (not far) 2580 ((and (not far)
2577 (save-excursion 2581 (save-excursion
2578 (forward-line -1) 2582 (forward-line -1)
2579 (and (eq (get-text-property (point) 'gnus-group) 2583 (and (equal (get-text-property (point) 'gnus-group) active)
2580 (gnus-intern-safe group gnus-active-hashtb))
2581 (or (not test-marked) (gnus-group-mark-line-p))))) 2584 (or (not test-marked) (gnus-group-mark-line-p)))))
2582 (forward-line -1) 2585 (forward-line -1)
2583 (point)) 2586 (point))
2584 ((and (not far) 2587 ((and (not far)
2585 (save-excursion 2588 (save-excursion
2586 (forward-line 1) 2589 (forward-line 1)
2587 (and (eq (get-text-property (point) 'gnus-group) 2590 (and (equal (get-text-property (point) 'gnus-group) active)
2588 (gnus-intern-safe group gnus-active-hashtb))
2589 (or (not test-marked) (gnus-group-mark-line-p))))) 2591 (or (not test-marked) (gnus-group-mark-line-p)))))
2590 (forward-line 1) 2592 (forward-line 1)
2591 (point)) 2593 (point))
@@ -2593,21 +2595,16 @@ If TEST-MARKED, the line must be marked."
2593 (goto-char (point-min)) 2595 (goto-char (point-min))
2594 (let (found) 2596 (let (found)
2595 (while (and (not found) 2597 (while (and (not found)
2596 (gnus-goto-char 2598 (gnus-text-property-search
2597 (text-property-any 2599 'gnus-group active 'forward 'goto))
2598 (point) (point-max)
2599 'gnus-group
2600 (gnus-intern-safe group gnus-active-hashtb))))
2601 (if (gnus-group-mark-line-p) 2600 (if (gnus-group-mark-line-p)
2602 (setq found t) 2601 (setq found t)
2603 (forward-line 1))) 2602 (forward-line 1)))
2604 found)) 2603 found))
2605 (t 2604 (t
2606 ;; Search through the entire buffer. 2605 ;; Search through the entire buffer.
2607 (if (gnus-goto-char 2606 (if (gnus-text-property-search
2608 (text-property-any 2607 'gnus-group active nil 'goto)
2609 (point-min) (point-max)
2610 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))
2611 (point) 2608 (point)
2612 (goto-char start) 2609 (goto-char start)
2613 nil)))))) 2610 nil))))))
@@ -2775,9 +2772,7 @@ server."
2775 (gnus-group-change-level 2772 (gnus-group-change-level
2776 (setq info (list t nname gnus-level-default-subscribed nil nil meth)) 2773 (setq info (list t nname gnus-level-default-subscribed nil nil meth))
2777 gnus-level-default-subscribed gnus-level-killed 2774 gnus-level-default-subscribed gnus-level-killed
2778 (and (gnus-group-group-name) 2775 (gnus-group-group-name) t)
2779 (gnus-group-entry (gnus-group-group-name)))
2780 t)
2781 ;; Make it active. 2776 ;; Make it active.
2782 (gnus-set-active nname (cons 1 0)) 2777 (gnus-set-active nname (cons 1 0))
2783 (unless (gnus-ephemeral-group-p name) 2778 (unless (gnus-ephemeral-group-p name)
@@ -2837,6 +2832,7 @@ If FORCE (the prefix) is non-nil, all the articles in the group will
2837be deleted. This is \"deleted\" as in \"removed forever from the face 2832be deleted. This is \"deleted\" as in \"removed forever from the face
2838of the Earth\". There is no undo. The user will be prompted before 2833of the Earth\". There is no undo. The user will be prompted before
2839doing the deletion. 2834doing the deletion.
2835
2840Note that you also have to specify FORCE if you want the group to 2836Note that you also have to specify FORCE if you want the group to
2841be removed from the server, even when it's empty." 2837be removed from the server, even when it's empty."
2842 (interactive 2838 (interactive
@@ -2848,12 +2844,11 @@ be removed from the server, even when it's empty."
2848 (error "This back end does not support group deletion")) 2844 (error "This back end does not support group deletion"))
2849 (prog1 2845 (prog1
2850 (let ((group-decoded (gnus-group-decoded-name group))) 2846 (let ((group-decoded (gnus-group-decoded-name group)))
2851 (if (and (not no-prompt) 2847 (when (or no-prompt
2852 (not (gnus-yes-or-no-p 2848 (gnus-yes-or-no-p
2853 (format 2849 (format
2854 "Do you really want to delete %s%s? " 2850 "Do you really want to delete %s%s? "
2855 group-decoded (if force " and all its contents" ""))))) 2851 group-decoded (if force " and all its contents" ""))))
2856 () ; Whew!
2857 (gnus-message 6 "Deleting group %s..." group-decoded) 2852 (gnus-message 6 "Deleting group %s..." group-decoded)
2858 (if (not (gnus-request-delete-group group force)) 2853 (if (not (gnus-request-delete-group group force))
2859 (gnus-error 3 "Couldn't delete group %s" group-decoded) 2854 (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."
3234 ;; Subscribe the new group after the group on the current line. 3229 ;; Subscribe the new group after the group on the current line.
3235 (gnus-subscribe-group pgroup (gnus-group-group-name) method) 3230 (gnus-subscribe-group pgroup (gnus-group-group-name) method)
3236 (gnus-group-update-group pgroup) 3231 (gnus-group-update-group pgroup)
3237 (forward-line -1) 3232 (forward-line)
3238 (gnus-group-position-point))) 3233 (gnus-group-position-point)))
3239 3234
3240(defun gnus-group-enter-directory (dir) 3235(defun gnus-group-enter-directory (dir)
@@ -3627,7 +3622,7 @@ The return value is the number of articles that were marked as read,
3627or nil if no action could be taken." 3622or nil if no action could be taken."
3628 (let* ((entry (gnus-group-entry group)) 3623 (let* ((entry (gnus-group-entry group))
3629 (num (car entry)) 3624 (num (car entry))
3630 (marks (gnus-info-marks (nth 2 entry))) 3625 (marks (gnus-info-marks (nth 1 entry)))
3631 (unread (gnus-sequence-of-unread-articles group))) 3626 (unread (gnus-sequence-of-unread-articles group)))
3632 ;; Remove entries for this group. 3627 ;; Remove entries for this group.
3633 (nnmail-purge-split-history (gnus-group-real-name group)) 3628 (nnmail-purge-split-history (gnus-group-real-name group))
@@ -3809,8 +3804,7 @@ group line."
3809 (or (and (member group gnus-zombie-list) 3804 (or (and (member group gnus-zombie-list)
3810 gnus-level-zombie) 3805 gnus-level-zombie)
3811 gnus-level-killed) 3806 gnus-level-killed)
3812 (when (gnus-group-group-name) 3807 (gnus-group-group-name))
3813 (gnus-group-entry (gnus-group-group-name))))
3814 (unless silent 3808 (unless silent
3815 (gnus-group-update-group group))) 3809 (gnus-group-update-group group)))
3816 (t (error "No such newsgroup: %s" group))) 3810 (t (error "No such newsgroup: %s" group)))
@@ -3881,10 +3875,12 @@ of groups killed."
3881 `(progn 3875 `(progn
3882 (gnus-group-goto-group ,(gnus-group-group-name)) 3876 (gnus-group-goto-group ,(gnus-group-group-name))
3883 (gnus-group-yank-group))) 3877 (gnus-group-yank-group)))
3884 (push (cons (car entry) (nth 2 entry)) 3878 (push (cons (car entry) (nth 1 entry))
3885 gnus-list-of-killed-groups)) 3879 gnus-list-of-killed-groups))
3886 (gnus-group-change-level 3880 (gnus-group-change-level
3887 (if entry entry group) gnus-level-killed (if entry nil level)) 3881 (if entry entry group) gnus-level-killed (if entry nil level))
3882 ;; FIXME: Since the group has already been removed from
3883 ;; `gnus-newsrc-hashtb', this check will always return nil.
3888 (when (numberp (gnus-group-unread group)) 3884 (when (numberp (gnus-group-unread group))
3889 (gnus-request-update-group-status group 'unsubscribe)) 3885 (gnus-request-update-group-status group 'unsubscribe))
3890 (message "Killed group %s" (gnus-group-decoded-name group))) 3886 (message "Killed group %s" (gnus-group-decoded-name group)))
@@ -3902,7 +3898,7 @@ of groups killed."
3902 group gnus-level-killed 3)) 3898 group gnus-level-killed 3))
3903 (cond 3899 (cond
3904 ((setq entry (gnus-group-entry group)) 3900 ((setq entry (gnus-group-entry group))
3905 (push (cons (car entry) (nth 2 entry)) 3901 (push (cons (car entry) (nth 1 entry))
3906 gnus-list-of-killed-groups) 3902 gnus-list-of-killed-groups)
3907 (setcdr (cdr entry) (cdddr entry))) 3903 (setcdr (cdr entry) (cdddr entry)))
3908 ((member group gnus-zombie-list) 3904 ((member group gnus-zombie-list)
@@ -3935,9 +3931,7 @@ yanked) a list of yanked groups is returned."
3935 ;; first newsgroup. 3931 ;; first newsgroup.
3936 (setq prev (gnus-group-group-name)) 3932 (setq prev (gnus-group-group-name))
3937 (gnus-group-change-level 3933 (gnus-group-change-level
3938 info (gnus-info-level (cdr info)) gnus-level-killed 3934 info (gnus-info-level (cdr info)) gnus-level-killed prev t)
3939 (and prev (gnus-group-entry prev))
3940 t)
3941 (gnus-group-insert-group-line-info group) 3935 (gnus-group-insert-group-line-info group)
3942 (gnus-request-update-group-status group 'subscribe) 3936 (gnus-request-update-group-status group 'subscribe)
3943 (gnus-undo-register 3937 (gnus-undo-register
@@ -4023,14 +4017,7 @@ entail asking the server for the groups."
4023 ;; Find all groups and sort them. 4017 ;; Find all groups and sort them.
4024 (let ((groups 4018 (let ((groups
4025 (sort 4019 (sort
4026 (let (list) 4020 (hash-table-keys gnus-active-hashtb)
4027 (mapatoms
4028 (lambda (sym)
4029 (and (boundp sym)
4030 (symbol-value sym)
4031 (push (symbol-name sym) list)))
4032 gnus-active-hashtb)
4033 list)
4034 'string<)) 4021 'string<))
4035 (buffer-read-only nil) 4022 (buffer-read-only nil)
4036 group) 4023 group)
@@ -4042,7 +4029,7 @@ entail asking the server for the groups."
4042 (insert " *: " 4029 (insert " *: "
4043 (gnus-group-decoded-name group) 4030 (gnus-group-decoded-name group)
4044 "\n")) 4031 "\n"))
4045 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) 4032 (list 'gnus-group (gethash group gnus-active-hashtb)
4046 'gnus-unread t 4033 'gnus-unread t
4047 'gnus-level (inline (gnus-group-level group))))) 4034 'gnus-level (inline (gnus-group-level group)))))
4048 (goto-char (point-min)))) 4035 (goto-char (point-min))))
@@ -4142,17 +4129,17 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
4142 desc) 4129 desc)
4143 (when (and force 4130 (when (and force
4144 gnus-description-hashtb) 4131 gnus-description-hashtb)
4145 (gnus-sethash mname nil gnus-description-hashtb)) 4132 (remhash mname gnus-description-hashtb))
4146 (unless group 4133 (unless group
4147 (error "No group name given")) 4134 (error "No group name given"))
4148 (when (or (and gnus-description-hashtb 4135 (when (or (and gnus-description-hashtb
4149 ;; We check whether this group's method has been 4136 ;; We check whether this group's method has been
4150 ;; queried for a description file. 4137 ;; queried for a description file.
4151 (gnus-gethash mname gnus-description-hashtb)) 4138 (gethash mname gnus-description-hashtb))
4152 (setq desc (gnus-group-get-description group)) 4139 (setq desc (gnus-group-get-description group))
4153 (gnus-read-descriptions-file method)) 4140 (gnus-read-descriptions-file method))
4154 (gnus-message 1 "%s" 4141 (gnus-message 1 "%s"
4155 (or desc (gnus-gethash group gnus-description-hashtb) 4142 (or desc (gethash group gnus-description-hashtb)
4156 "No description available"))))) 4143 "No description available")))))
4157 4144
4158;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>. 4145;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
@@ -4165,12 +4152,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
4165 (gnus-read-all-descriptions-files))) 4152 (gnus-read-all-descriptions-files)))
4166 (error "Couldn't request descriptions file")) 4153 (error "Couldn't request descriptions file"))
4167 (let ((buffer-read-only nil) 4154 (let ((buffer-read-only nil)
4168 b groups) 4155 (groups (sort (hash-table-keys gnus-description-hashtb)))
4169 (mapatoms 4156 b)
4170 (lambda (group)
4171 (push (symbol-name group) groups))
4172 gnus-description-hashtb)
4173 (setq groups (sort groups 'string<))
4174 (erase-buffer) 4157 (erase-buffer)
4175 (dolist (group groups) 4158 (dolist (group groups)
4176 (setq b (point)) 4159 (setq b (point))
@@ -4193,20 +4176,16 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
4193 (obuf (current-buffer)) 4176 (obuf (current-buffer))
4194 groups des) 4177 groups des)
4195 ;; Go through all newsgroups that are known to Gnus. 4178 ;; Go through all newsgroups that are known to Gnus.
4196 (mapatoms 4179 (maphash
4197 (lambda (group) 4180 (lambda (g-name _)
4198 (and (symbol-name group) 4181 (and (string-match regexp g-name)
4199 (string-match regexp (symbol-name group)) 4182 (push g-name groups)))
4200 (symbol-value group)
4201 (push (symbol-name group) groups)))
4202 gnus-active-hashtb) 4183 gnus-active-hashtb)
4203 ;; Also go through all descriptions that are known to Gnus. 4184 ;; Also go through all descriptions that are known to Gnus.
4204 (when search-description 4185 (when search-description
4205 (mapatoms 4186 (dolist (g-name (hash-table-keys gnus-description-hashtb))
4206 (lambda (group) 4187 (when (string-match regexp g-name)
4207 (and (string-match regexp (symbol-value group)) 4188 (push g-name groups))))
4208 (push (symbol-name group) groups)))
4209 gnus-description-hashtb))
4210 (if (not groups) 4189 (if (not groups)
4211 (gnus-message 3 "No groups matched \"%s\"." regexp) 4190 (gnus-message 3 "No groups matched \"%s\"." regexp)
4212 ;; Print out all the groups. 4191 ;; Print out all the groups.
@@ -4222,8 +4201,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
4222 (let ((charset (gnus-group-name-charset nil prev))) 4201 (let ((charset (gnus-group-name-charset nil prev)))
4223 (insert (gnus-group-name-decode prev charset) "\n") 4202 (insert (gnus-group-name-decode prev charset) "\n")
4224 (when (and gnus-description-hashtb 4203 (when (and gnus-description-hashtb
4225 (setq des (gnus-gethash (car groups) 4204 (setq des (gethash (car groups)
4226 gnus-description-hashtb))) 4205 gnus-description-hashtb)))
4227 (insert " " (gnus-group-name-decode des charset) "\n")))) 4206 (insert " " (gnus-group-name-decode des charset) "\n"))))
4228 (setq groups (cdr groups))) 4207 (setq groups (cdr groups)))
4229 (goto-char (point-min)))) 4208 (goto-char (point-min))))
@@ -4468,7 +4447,7 @@ and the second element is the address."
4468 (let* ((entry (gnus-group-entry 4447 (let* ((entry (gnus-group-entry
4469 (or method-only-group (gnus-info-group info)))) 4448 (or method-only-group (gnus-info-group info))))
4470 (part-info info) 4449 (part-info info)
4471 (info (if method-only-group (nth 2 entry) info)) 4450 (info (if method-only-group (nth 1 entry) info))
4472 method) 4451 method)
4473 (when method-only-group 4452 (when method-only-group
4474 (unless entry 4453 (unless entry
@@ -4510,7 +4489,7 @@ and the second element is the address."
4510 ;; can do the update. 4489 ;; can do the update.
4511 (if entry 4490 (if entry
4512 (progn 4491 (progn
4513 (setcar (nthcdr 2 entry) info) 4492 (setcar (nthcdr 1 entry) info)
4514 (when (and (not (eq (car entry) t)) 4493 (when (and (not (eq (car entry) t))
4515 (gnus-active (gnus-info-group info))) 4494 (gnus-active (gnus-info-group info)))
4516 (setcar entry (length 4495 (setcar entry (length
@@ -4619,11 +4598,11 @@ This command may read the active file."
4619 (assq 'cache marks))) 4598 (assq 'cache marks)))
4620 lowest 4599 lowest
4621 #'(lambda (group) 4600 #'(lambda (group)
4622 (or (gnus-gethash group 4601 (or (gethash group
4623 gnus-cache-active-hashtb) 4602 gnus-cache-active-hashtb)
4624 ;; Cache active file might use "." 4603 ;; Cache active file might use "."
4625 ;; instead of ":". 4604 ;; instead of ":".
4626 (gnus-gethash 4605 (gethash
4627 (mapconcat 'identity 4606 (mapconcat 'identity
4628 (split-string group ":") 4607 (split-string group ":")
4629 ".") 4608 ".")
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index 6114fb5f4f5..2faf0f951db 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -2234,8 +2234,7 @@ score in `gnus-newsgroup-scored' by SCORE."
2234 (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score)) 2234 (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score))
2235 (date (nth 2 kill)) 2235 (date (nth 2 kill))
2236 found) 2236 found)
2237 (when (setq arts (intern-soft (nth 0 kill) hashtb)) 2237 (when (setq arts (gethash (nth 0 kill) hashtb))
2238 (setq arts (symbol-value arts))
2239 (setq found t) 2238 (setq found t)
2240 (if trace 2239 (if trace
2241 (while (setq art (pop arts)) 2240 (while (setq art (pop arts))
@@ -2273,11 +2272,11 @@ score in `gnus-newsgroup-scored' by SCORE."
2273 (with-syntax-table gnus-adaptive-word-syntax-table 2272 (with-syntax-table gnus-adaptive-word-syntax-table
2274 (while (re-search-forward "\\b\\w+\\b" nil t) 2273 (while (re-search-forward "\\b\\w+\\b" nil t)
2275 (setq val 2274 (setq val
2276 (gnus-gethash 2275 (gethash
2277 (setq word (downcase (buffer-substring 2276 (setq word (downcase (buffer-substring
2278 (match-beginning 0) (match-end 0)))) 2277 (match-beginning 0) (match-end 0))))
2279 hashtb)) 2278 hashtb))
2280 (gnus-sethash 2279 (puthash
2281 word 2280 word
2282 (append (get-text-property (point-at-eol) 'articles) val) 2281 (append (get-text-property (point-at-eol) 'articles) val)
2283 hashtb))) 2282 hashtb)))
@@ -2289,7 +2288,7 @@ score in `gnus-newsgroup-scored' by SCORE."
2289 ".")) 2288 "."))
2290 gnus-default-ignored-adaptive-words))) 2289 gnus-default-ignored-adaptive-words)))
2291 (while ignored 2290 (while ignored
2292 (gnus-sethash (pop ignored) nil hashtb))))) 2291 (remhash (pop ignored) hashtb)))))
2293 2292
2294(defun gnus-score-string< (a1 a2) 2293(defun gnus-score-string< (a1 a2)
2295 ;; Compare headers in articles A2 and A2. 2294 ;; Compare headers in articles A2 and A2.
@@ -2400,8 +2399,8 @@ score in `gnus-newsgroup-scored' by SCORE."
2400 (goto-char (point-min)) 2399 (goto-char (point-min))
2401 (while (re-search-forward "\\b\\w+\\b" nil t) 2400 (while (re-search-forward "\\b\\w+\\b" nil t)
2402 ;; Put the word and score into the hashtb. 2401 ;; Put the word and score into the hashtb.
2403 (setq val (gnus-gethash (setq word (match-string 0)) 2402 (setq val (gethash (setq word (match-string 0))
2404 hashtb)) 2403 hashtb))
2405 (when (or (not gnus-adaptive-word-length-limit) 2404 (when (or (not gnus-adaptive-word-length-limit)
2406 (> (length word) 2405 (> (length word)
2407 gnus-adaptive-word-length-limit)) 2406 gnus-adaptive-word-length-limit))
@@ -2409,7 +2408,7 @@ score in `gnus-newsgroup-scored' by SCORE."
2409 (if (and gnus-adaptive-word-minimum 2408 (if (and gnus-adaptive-word-minimum
2410 (< val gnus-adaptive-word-minimum)) 2409 (< val gnus-adaptive-word-minimum))
2411 (setq val gnus-adaptive-word-minimum)) 2410 (setq val gnus-adaptive-word-minimum))
2412 (gnus-sethash word val hashtb))) 2411 (puthash word val hashtb)))
2413 (erase-buffer)))) 2412 (erase-buffer))))
2414 ;; Make all the ignorable words ignored. 2413 ;; Make all the ignorable words ignored.
2415 (let ((ignored (append gnus-ignored-adaptive-words 2414 (let ((ignored (append gnus-ignored-adaptive-words
@@ -2420,16 +2419,14 @@ score in `gnus-newsgroup-scored' by SCORE."
2420 ".")) 2419 "."))
2421 gnus-default-ignored-adaptive-words))) 2420 gnus-default-ignored-adaptive-words)))
2422 (while ignored 2421 (while ignored
2423 (gnus-sethash (pop ignored) nil hashtb))) 2422 (remhash (pop ignored) hashtb)))
2424 ;; Now we have all the words and scores, so we 2423 ;; Now we have all the words and scores, so we
2425 ;; add these rules to the ADAPT file. 2424 ;; add these rules to the ADAPT file.
2426 (set-buffer gnus-summary-buffer) 2425 (set-buffer gnus-summary-buffer)
2427 (mapatoms 2426 (maphash
2428 (lambda (word) 2427 (lambda (word val)
2429 (when (symbol-value word) 2428 (gnus-summary-score-entry
2430 (gnus-summary-score-entry 2429 "subject" word 'w val date nil t))
2431 "subject" (symbol-name word) 'w (symbol-value word)
2432 date nil t)))
2433 hashtb)))))) 2430 hashtb))))))
2434 2431
2435(defun gnus-score-edit-done () 2432(defun gnus-score-edit-done ()
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index 33462543d00..82141e02215 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -543,29 +543,21 @@ Can be used to turn version control on or off."
543 (message "Descend hierarchy %s? ([y]nsq): " 543 (message "Descend hierarchy %s? ([y]nsq): "
544 (substring prefix 1 (1- (length prefix))))) 544 (substring prefix 1 (1- (length prefix)))))
545 (cond ((= ans ?n) 545 (cond ((= ans ?n)
546 (while (and groups 546 (dolist (g groups)
547 (setq group (car groups) 547 (when (string-match prefix (gnus-group-real-name g))
548 real-group (gnus-group-real-name group)) 548 (push g gnus-killed-list)
549 (string-match prefix real-group)) 549 (puthash g t gnus-killed-hashtb)))
550 (push group gnus-killed-list)
551 (gnus-sethash group group gnus-killed-hashtb)
552 (setq groups (cdr groups)))
553 (setq starts (cdr starts))) 550 (setq starts (cdr starts)))
554 ((= ans ?s) 551 ((= ans ?s)
555 (while (and groups 552 (dolist (g groups)
556 (setq group (car groups) 553 (when (string-match prefix (gnus-group-real-name g))
557 real-group (gnus-group-real-name group)) 554 (puthash g t gnus-killed-hashtb)
558 (string-match prefix real-group)) 555 (gnus-subscribe-alphabetically g)))
559 (gnus-sethash group group gnus-killed-hashtb)
560 (gnus-subscribe-alphabetically (car groups))
561 (setq groups (cdr groups)))
562 (setq starts (cdr starts))) 556 (setq starts (cdr starts)))
563 ((= ans ?q) 557 ((= ans ?q)
564 (while groups 558 (dolist (g groups)
565 (setq group (car groups)) 559 (push g gnus-killed-list)
566 (push group gnus-killed-list) 560 (puthash g t gnus-killed-hashtb)))
567 (gnus-sethash group group gnus-killed-hashtb)
568 (setq groups (cdr groups))))
569 (t nil))) 561 (t nil)))
570 (message "Subscribe %s? ([n]yq)" (car groups)) 562 (message "Subscribe %s? ([n]yq)" (car groups))
571 (while (not (memq (setq ans (read-char-exclusive)) 563 (while (not (memq (setq ans (read-char-exclusive))
@@ -575,16 +567,14 @@ Can be used to turn version control on or off."
575 (setq group (car groups)) 567 (setq group (car groups))
576 (cond ((= ans ?y) 568 (cond ((= ans ?y)
577 (gnus-subscribe-alphabetically (car groups)) 569 (gnus-subscribe-alphabetically (car groups))
578 (gnus-sethash group group gnus-killed-hashtb)) 570 (puthash group t gnus-killed-hashtb))
579 ((= ans ?q) 571 ((= ans ?q)
580 (while groups 572 (dolist (g groups)
581 (setq group (car groups)) 573 (push g gnus-killed-list)
582 (push group gnus-killed-list) 574 (puthash g t gnus-killed-hashtb)))
583 (gnus-sethash group group gnus-killed-hashtb)
584 (setq groups (cdr groups))))
585 (t 575 (t
586 (push group gnus-killed-list) 576 (push group gnus-killed-list)
587 (gnus-sethash group group gnus-killed-hashtb))) 577 (puthash group t gnus-killed-hashtb)))
588 (setq groups (cdr groups))))))) 578 (setq groups (cdr groups)))))))
589 579
590(defun gnus-subscribe-randomly (newsgroup) 580(defun gnus-subscribe-randomly (newsgroup)
@@ -647,7 +637,7 @@ the first newsgroup."
647 ;; We subscribe the group by changing its level to `subscribed'. 637 ;; We subscribe the group by changing its level to `subscribed'.
648 (gnus-group-change-level 638 (gnus-group-change-level
649 newsgroup gnus-level-default-subscribed 639 newsgroup gnus-level-default-subscribed
650 gnus-level-killed (gnus-group-entry (or next "dummy.group"))) 640 gnus-level-killed (or next "dummy.group"))
651 (gnus-request-update-group-status newsgroup 'subscribe) 641 (gnus-request-update-group-status newsgroup 'subscribe)
652 (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) 642 (gnus-message 5 "Subscribe newsgroup: %s" newsgroup)
653 (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) 643 (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup)
@@ -696,6 +686,7 @@ the first newsgroup."
696 gnus-agent-file-loading-cache nil 686 gnus-agent-file-loading-cache nil
697 gnus-server-method-cache nil 687 gnus-server-method-cache nil
698 gnus-newsrc-alist nil 688 gnus-newsrc-alist nil
689 gnus-group-list nil
699 gnus-newsrc-hashtb nil 690 gnus-newsrc-hashtb nil
700 gnus-killed-list nil 691 gnus-killed-list nil
701 gnus-zombie-list nil 692 gnus-zombie-list nil
@@ -1018,7 +1009,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
1018 (eq gnus-read-active-file 'some)) 1009 (eq gnus-read-active-file 'some))
1019 (gnus-update-active-hashtb-from-killed)) 1010 (gnus-update-active-hashtb-from-killed))
1020 (unless gnus-active-hashtb 1011 (unless gnus-active-hashtb
1021 (setq gnus-active-hashtb (gnus-make-hashtable 4096))) 1012 (setq gnus-active-hashtb (gnus-make-hashtable 4000)))
1022 ;; Initialize the cache. 1013 ;; Initialize the cache.
1023 (when gnus-use-cache 1014 (when gnus-use-cache
1024 (gnus-cache-open)) 1015 (gnus-cache-open))
@@ -1108,7 +1099,7 @@ for new groups, and subscribe the new groups as zombies."
1108 (gnus-ask-server-for-new-groups) 1099 (gnus-ask-server-for-new-groups)
1109 ;; Go through the active hashtb and look for new groups. 1100 ;; Go through the active hashtb and look for new groups.
1110 (let ((groups 0) 1101 (let ((groups 0)
1111 group new-newsgroups) 1102 new-newsgroups)
1112 (gnus-message 5 "Looking for new newsgroups...") 1103 (gnus-message 5 "Looking for new newsgroups...")
1113 (unless gnus-have-read-active-file 1104 (unless gnus-have-read-active-file
1114 (gnus-read-active-file)) 1105 (gnus-read-active-file))
@@ -1117,30 +1108,26 @@ for new groups, and subscribe the new groups as zombies."
1117 (gnus-make-hashtable-from-killed)) 1108 (gnus-make-hashtable-from-killed))
1118 ;; Go though every newsgroup in `gnus-active-hashtb' and compare 1109 ;; Go though every newsgroup in `gnus-active-hashtb' and compare
1119 ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. 1110 ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'.
1120 (mapatoms 1111 (maphash
1121 (lambda (sym) 1112 (lambda (g-name active)
1122 (if (or (null (setq group (symbol-name sym))) 1113 (unless (or (gethash g-name gnus-killed-hashtb)
1123 (not (boundp sym)) 1114 (gethash g-name gnus-newsrc-hashtb))
1124 (null (symbol-value sym)) 1115 (let ((do-sub (gnus-matches-options-n g-name)))
1125 (gnus-gethash group gnus-killed-hashtb)
1126 (gnus-gethash group gnus-newsrc-hashtb))
1127 ()
1128 (let ((do-sub (gnus-matches-options-n group)))
1129 (cond 1116 (cond
1130 ((eq do-sub 'subscribe) 1117 ((eq do-sub 'subscribe)
1131 (setq groups (1+ groups)) 1118 (setq groups (1+ groups))
1132 (gnus-sethash group group gnus-killed-hashtb) 1119 (puthash g-name t gnus-killed-hashtb)
1133 (gnus-call-subscribe-functions 1120 (gnus-call-subscribe-functions
1134 gnus-subscribe-options-newsgroup-method group)) 1121 gnus-subscribe-options-newsgroup-method g-name))
1135 ((eq do-sub 'ignore) 1122 ((eq do-sub 'ignore)
1136 nil) 1123 nil)
1137 (t 1124 (t
1138 (setq groups (1+ groups)) 1125 (setq groups (1+ groups))
1139 (gnus-sethash group group gnus-killed-hashtb) 1126 (puthash g-name t gnus-killed-hashtb)
1140 (if gnus-subscribe-hierarchical-interactive 1127 (if gnus-subscribe-hierarchical-interactive
1141 (push group new-newsgroups) 1128 (push g-name new-newsgroups)
1142 (gnus-call-subscribe-functions 1129 (gnus-call-subscribe-functions
1143 gnus-subscribe-newsgroup-method group))))))) 1130 gnus-subscribe-newsgroup-method g-name)))))))
1144 gnus-active-hashtb) 1131 gnus-active-hashtb)
1145 (when new-newsgroups 1132 (when new-newsgroups
1146 (gnus-subscribe-hierarchical-interactive new-newsgroups)) 1133 (gnus-subscribe-hierarchical-interactive new-newsgroups))
@@ -1213,36 +1200,32 @@ for new groups, and subscribe the new groups as zombies."
1213 ;; Enter all the new groups into a hashtable. 1200 ;; Enter all the new groups into a hashtable.
1214 (gnus-active-to-gnus-format method hashtb 'ignore)) 1201 (gnus-active-to-gnus-format method hashtb 'ignore))
1215 ;; Now all new groups from `method' are in `hashtb'. 1202 ;; Now all new groups from `method' are in `hashtb'.
1216 (mapatoms 1203 (maphash
1217 (lambda (group-sym) 1204 (lambda (g-name val)
1218 (if (or (null (setq group (symbol-name group-sym))) 1205 (unless (or (null val) ; The group is already known.
1219 (not (boundp group-sym)) 1206 (gethash g-name gnus-newsrc-hashtb)
1220 (null (symbol-value group-sym)) 1207 (member g-name gnus-zombie-list)
1221 (gnus-gethash group gnus-newsrc-hashtb) 1208 (member g-name gnus-killed-list))
1222 (member group gnus-zombie-list)
1223 (member group gnus-killed-list))
1224 ;; The group is already known.
1225 ()
1226 ;; Make this group active. 1209 ;; Make this group active.
1227 (when (symbol-value group-sym) 1210 (when val
1228 (gnus-set-active group (symbol-value group-sym))) 1211 (gnus-set-active g-name val))
1229 ;; Check whether we want it or not. 1212 ;; Check whether we want it or not.
1230 (let ((do-sub (gnus-matches-options-n group))) 1213 (let ((do-sub (gnus-matches-options-n g-name)))
1231 (cond 1214 (cond
1232 ((eq do-sub 'subscribe) 1215 ((eq do-sub 'subscribe)
1233 (cl-incf groups) 1216 (cl-incf groups)
1234 (gnus-sethash group group gnus-killed-hashtb) 1217 (puthash g-name group gnus-killed-hashtb)
1235 (gnus-call-subscribe-functions 1218 (gnus-call-subscribe-functions
1236 gnus-subscribe-options-newsgroup-method group)) 1219 gnus-subscribe-options-newsgroup-method g-name))
1237 ((eq do-sub 'ignore) 1220 ((eq do-sub 'ignore)
1238 nil) 1221 nil)
1239 (t 1222 (t
1240 (cl-incf groups) 1223 (cl-incf groups)
1241 (gnus-sethash group group gnus-killed-hashtb) 1224 (puthash g-name group gnus-killed-hashtb)
1242 (if gnus-subscribe-hierarchical-interactive 1225 (if gnus-subscribe-hierarchical-interactive
1243 (push group new-newsgroups) 1226 (push g-name new-newsgroups)
1244 (gnus-call-subscribe-functions 1227 (gnus-call-subscribe-functions
1245 gnus-subscribe-newsgroup-method group))))))) 1228 gnus-subscribe-newsgroup-method g-name)))))))
1246 hashtb)) 1229 hashtb))
1247 (when new-newsgroups 1230 (when new-newsgroups
1248 (gnus-subscribe-hierarchical-interactive new-newsgroups))) 1231 (gnus-subscribe-hierarchical-interactive new-newsgroups)))
@@ -1263,29 +1246,28 @@ for new groups, and subscribe the new groups as zombies."
1263 gnus-level-default-subscribed gnus-level-killed previous t) 1246 gnus-level-default-subscribed gnus-level-killed previous t)
1264 t) 1247 t)
1265 1248
1266;; `gnus-group-change-level' is the fundamental function for changing 1249
1267;; subscription levels of newsgroups. This might mean just changing
1268;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back
1269;; again, which subscribes/unsubscribes a group, which is equally
1270;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and
1271;; from 8-9 to 1-7 means that you remove the group from the list of
1272;; killed (or zombie) groups and add them to the (kinda) subscribed
1273;; groups. And last but not least, moving from 8 to 9 and 9 to 8,
1274;; which is trivial.
1275;; ENTRY can either be a string (newsgroup name) or a list (if
1276;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST),
1277;; otherwise it's a list in the format of the `gnus-newsrc-hashtb'
1278;; entries.
1279;; LEVEL is the new level of the group, OLDLEVEL is the old level and
1280;; PREVIOUS is the group (in hashtb entry format) to insert this group
1281;; after.
1282(defun gnus-group-change-level (entry level &optional oldlevel 1250(defun gnus-group-change-level (entry level &optional oldlevel
1283 previous fromkilled) 1251 previous fromkilled)
1252 "Change level of group ENTRY to LEVEL.
1253This is the fundamental function for changing subscription levels
1254of newsgroups. This might mean just changing from level 1 to 2,
1255which is pretty trivial, from 2 to 6 or back again, which
1256subscribes/unsubscribes a group, which is equally trivial.
1257Changing from 1-7 to 8-9 means that you kill a group, and from
12588-9 to 1-7 means that you remove the group from the list of
1259killed (or zombie) groups and add them to the (kinda) subscribed
1260groups. And last but not least, moving from 8 to 9 and 9 to 8,
1261which is trivial. ENTRY can either be a string (newsgroup name)
1262or a list (if FROMKILLED is t, it's a list on the format (NUM
1263INFO-LIST), otherwise it's a list in the format of the
1264`gnus-newsrc-hashtb' entries. LEVEL is the new level of the
1265group, OLDLEVEL is the old level and PREVIOUS is the group (a
1266string name) to insert this group after."
1284 (let (group info active num) 1267 (let (group info active num)
1285 ;; Glean what info we can from the arguments 1268 ;; Glean what info we can from the arguments.
1286 (if (consp entry) 1269 (if (consp entry)
1287 (if fromkilled (setq group (nth 1 entry)) 1270 (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry))))
1288 (setq group (car (nth 2 entry))))
1289 (setq group entry)) 1271 (setq group entry))
1290 (when (and (stringp entry) 1272 (when (and (stringp entry)
1291 oldlevel 1273 oldlevel
@@ -1293,21 +1275,17 @@ for new groups, and subscribe the new groups as zombies."
1293 (setq entry (gnus-group-entry entry))) 1275 (setq entry (gnus-group-entry entry)))
1294 (if (and (not oldlevel) 1276 (if (and (not oldlevel)
1295 (consp entry)) 1277 (consp entry))
1296 (setq oldlevel (gnus-info-level (nth 2 entry))) 1278 (setq oldlevel (gnus-info-level (nth 1 entry)))
1297 (setq oldlevel (or oldlevel gnus-level-killed))) 1279 (setq oldlevel (or oldlevel gnus-level-killed)))
1298 (when (stringp previous) 1280 (when (stringp previous)
1299 (setq previous (gnus-group-entry previous))) 1281 (setq previous (gnus-group-entry previous)))
1300 1282 ;; Group is already subscribed.
1301 (if (and (>= oldlevel gnus-level-zombie) 1283 (unless (and (>= oldlevel gnus-level-zombie)
1302 (gnus-group-entry group)) 1284 (gnus-group-entry group))
1303 ;; We are trying to subscribe a group that is already
1304 ;; subscribed.
1305 () ; Do nothing.
1306
1307 (unless (gnus-ephemeral-group-p group) 1285 (unless (gnus-ephemeral-group-p group)
1308 (gnus-dribble-enter 1286 (gnus-dribble-enter
1309 (format "(gnus-group-change-level %S %S %S %S %S)" 1287 (format "(gnus-group-change-level %S %S %S %S %S)"
1310 group level oldlevel (car (nth 2 previous)) fromkilled))) 1288 group level oldlevel previous fromkilled)))
1311 1289
1312 ;; Then we remove the newgroup from any old structures, if needed. 1290 ;; Then we remove the newgroup from any old structures, if needed.
1313 ;; If the group was killed, we remove it from the killed or zombie 1291 ;; 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."
1321 (t 1299 (t
1322 (when (and (>= level gnus-level-zombie) 1300 (when (and (>= level gnus-level-zombie)
1323 entry) 1301 entry)
1324 (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb) 1302 (remhash (car (nth 1 entry)) gnus-newsrc-hashtb)
1325 (when (nth 3 entry) 1303 (setq gnus-group-list (remove group gnus-group-list))
1326 (setcdr (gnus-group-entry (car (nth 3 entry))) 1304 (setq gnus-newsrc-alist (delq (assoc group gnus-newsrc-alist)
1327 (cdr entry))) 1305 gnus-newsrc-alist)))))
1328 (setcdr (cdr entry) (cdddr entry)))))
1329 1306
1330 ;; Finally we enter (if needed) the list where it is supposed to 1307 ;; Finally we enter (if needed) the list where it is supposed to
1331 ;; go, and change the subscription level. If it is to be killed, 1308 ;; 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."
1333 (cond 1310 (cond
1334 ((>= level gnus-level-zombie) 1311 ((>= level gnus-level-zombie)
1335 ;; Remove from the hash table. 1312 ;; Remove from the hash table.
1336 (gnus-sethash group nil gnus-newsrc-hashtb) 1313 (remhash group gnus-newsrc-hashtb)
1314 (setq gnus-group-list (remove group gnus-group-list))
1337 (if (= level gnus-level-zombie) 1315 (if (= level gnus-level-zombie)
1338 (push group gnus-zombie-list) 1316 (push group gnus-zombie-list)
1339 (if (= oldlevel gnus-level-killed) 1317 (if (= oldlevel gnus-level-killed)
1340 ;; Remove from active hashtb. 1318 ;; Remove from active hashtb.
1341 (unintern group gnus-active-hashtb) 1319 (remhash group gnus-active-hashtb)
1342 ;; Don't add it into killed-list if it was killed. 1320 ;; Don't add it into killed-list if it was killed.
1343 (push group gnus-killed-list)))) 1321 (push group gnus-killed-list))))
1344 (t 1322 (t
@@ -1349,7 +1327,7 @@ for new groups, and subscribe the new groups as zombies."
1349 ;; It was alive, and it is going to stay alive, so we 1327 ;; It was alive, and it is going to stay alive, so we
1350 ;; just change the level and don't change any pointers or 1328 ;; just change the level and don't change any pointers or
1351 ;; hash table entries. 1329 ;; hash table entries.
1352 (setcar (cdaddr entry) level) 1330 (setcar (cdadr entry) level)
1353 (if (listp entry) 1331 (if (listp entry)
1354 (setq info (cdr entry) 1332 (setq info (cdr entry)
1355 num (car entry)) 1333 num (car entry))
@@ -1364,23 +1342,16 @@ for new groups, and subscribe the new groups as zombies."
1364 (if method 1342 (if method
1365 (setq info (list group level nil nil method)) 1343 (setq info (list group level nil nil method))
1366 (setq info (list group level nil))))) 1344 (setq info (list group level nil)))))
1367 (unless previous 1345 ;; Add group. The exact ordering only matters for
1368 (setq previous 1346 ;; `gnus-group-list', though we need to keep the dummy group
1369 (let ((p gnus-newsrc-alist)) 1347 ;; at the head of `gnus-newsrc-alist'.
1370 (while (cddr p) 1348 (push info (cdr gnus-newsrc-alist))
1371 (setq p (cdr p))) 1349 (puthash group (list num info) gnus-newsrc-hashtb)
1372 p))) 1350 (let* ((prev-idx (seq-position gnus-group-list (caadr previous)))
1373 (setq entry (cons info (cddr previous))) 1351 (idx (if prev-idx
1374 (if (cdr previous) 1352 (1+ prev-idx)
1375 (progn 1353 (length gnus-group-list))))
1376 (setcdr (cdr previous) entry) 1354 (push group (nthcdr idx gnus-group-list)))
1377 (gnus-sethash group (cons num (cdr previous))
1378 gnus-newsrc-hashtb))
1379 (setcdr previous entry)
1380 (gnus-sethash group (cons num previous)
1381 gnus-newsrc-hashtb))
1382 (when (cdr entry)
1383 (setcdr (gnus-group-entry (caadr entry)) entry))
1384 (gnus-dribble-enter 1355 (gnus-dribble-enter
1385 (format "(gnus-group-set-info '%S)" info) 1356 (format "(gnus-group-set-info '%S)" info)
1386 (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))))) 1357 (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\"")))))
@@ -1455,7 +1426,7 @@ newsgroup."
1455 (defun gnus-cache-possibly-alter-active (group active) 1426 (defun gnus-cache-possibly-alter-active (group active)
1456 "Alter the ACTIVE info for GROUP to reflect the articles in the cache." 1427 "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
1457 (when gnus-cache-active-hashtb 1428 (when gnus-cache-active-hashtb
1458 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) 1429 (let ((cache-active (gethash group gnus-cache-active-hashtb)))
1459 (when cache-active 1430 (when cache-active
1460 (when (< (car cache-active) (car active)) 1431 (when (< (car cache-active) (car active))
1461 (setcar active (car cache-active))) 1432 (setcar active (car cache-active)))
@@ -1837,19 +1808,24 @@ backend check whether the group actually exists."
1837 (dolist (info infos) 1808 (dolist (info infos)
1838 (gnus-activate-group (gnus-info-group info) nil nil method t)))))) 1809 (gnus-activate-group (gnus-info-group info) nil nil method t))))))
1839 1810
1840;; Create a hash table out of the newsrc alist. The `car's of the
1841;; alist elements are used as keys.
1842(defun gnus-make-hashtable-from-newsrc-alist () 1811(defun gnus-make-hashtable-from-newsrc-alist ()
1812 "Create a hash table from `gnus-newsrc-alist'.
1813The keys are group names, and values are a cons of (unread info),
1814where unread is an integer count of calculated unread
1815messages (or nil), and info is a regular gnus info entry.
1816
1817The info element is shared with the same element of
1818`gnus-newrc-alist', so as to conserve space."
1843 (let ((alist gnus-newsrc-alist) 1819 (let ((alist gnus-newsrc-alist)
1844 (ohashtb gnus-newsrc-hashtb) 1820 (ohashtb gnus-newsrc-hashtb)
1845 prev info method rest methods) 1821 info method gname rest methods)
1846 (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) 1822 (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist)))
1847 (setq alist 1823 (setq alist
1848 (setq prev (setq gnus-newsrc-alist 1824 (setq gnus-newsrc-alist
1849 (if (equal (caar gnus-newsrc-alist) 1825 (if (equal (caar gnus-newsrc-alist)
1850 "dummy.group") 1826 "dummy.group")
1851 gnus-newsrc-alist 1827 gnus-newsrc-alist
1852 (cons (list "dummy.group" 0 nil) alist))))) 1828 (cons (list "dummy.group" 0 nil) alist))))
1853 (while alist 1829 (while alist
1854 (setq info (car alist)) 1830 (setq info (car alist))
1855 ;; Make the same select-methods identical Lisp objects. 1831 ;; Make the same select-methods identical Lisp objects.
@@ -1858,17 +1834,18 @@ backend check whether the group actually exists."
1858 (gnus-info-set-method info (car rest)) 1834 (gnus-info-set-method info (car rest))
1859 (push method methods))) 1835 (push method methods)))
1860 ;; Check for duplicates. 1836 ;; Check for duplicates.
1861 (if (gnus-gethash (car info) gnus-newsrc-hashtb) 1837 (if (gethash (car info) gnus-newsrc-hashtb)
1862 ;; Remove this entry from the alist. 1838 ;; Remove this entry from the alist.
1863 (setcdr prev (cddr prev)) 1839 (setcdr alist (cddr alist))
1864 (gnus-sethash 1840 (puthash
1865 (car info) 1841 (car info)
1866 ;; Preserve number of unread articles in groups. 1842 ;; Preserve number of unread articles in groups.
1867 (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) 1843 (list (and ohashtb (car (gethash (car info) ohashtb)))
1868 prev) 1844 info)
1869 gnus-newsrc-hashtb) 1845 gnus-newsrc-hashtb)
1870 (setq prev alist)) 1846 (push (car info) gnus-group-list))
1871 (setq alist (cdr alist))) 1847 (setq alist (cdr alist)))
1848 (setq gnus-group-list (nreverse gnus-group-list))
1872 ;; Make the same select-methods in `gnus-server-alist' identical 1849 ;; Make the same select-methods in `gnus-server-alist' identical
1873 ;; as well. 1850 ;; as well.
1874 (while methods 1851 (while methods
@@ -1883,10 +1860,10 @@ backend check whether the group actually exists."
1883 (setq gnus-killed-hashtb 1860 (setq gnus-killed-hashtb
1884 (gnus-make-hashtable 1861 (gnus-make-hashtable
1885 (+ (length gnus-killed-list) (length gnus-zombie-list)))) 1862 (+ (length gnus-killed-list) (length gnus-zombie-list))))
1886 (while lists 1863 (dolist (g (append gnus-killed-list gnus-zombie-list))
1887 (setq list (symbol-value (pop lists))) 1864 ;; NOTE: We have lost the ordering that used to be kept in this
1888 (while list 1865 ;; variable.
1889 (gnus-sethash (car list) (pop list) gnus-killed-hashtb))))) 1866 (puthash g t gnus-killed-hashtb))))
1890 1867
1891(defun gnus-parse-active () 1868(defun gnus-parse-active ()
1892 "Parse active info in the nntp server buffer." 1869 "Parse active info in the nntp server buffer."
@@ -1900,7 +1877,7 @@ backend check whether the group actually exists."
1900 1877
1901(defun gnus-make-articles-unread (group articles) 1878(defun gnus-make-articles-unread (group articles)
1902 "Mark ARTICLES in GROUP as unread." 1879 "Mark ARTICLES in GROUP as unread."
1903 (let* ((info (nth 2 (or (gnus-group-entry group) 1880 (let* ((info (nth 1 (or (gnus-group-entry group)
1904 (gnus-group-entry 1881 (gnus-group-entry
1905 (gnus-group-real-name group))))) 1882 (gnus-group-real-name group)))))
1906 (ranges (gnus-info-read info)) 1883 (ranges (gnus-info-read info))
@@ -1924,7 +1901,7 @@ backend check whether the group actually exists."
1924 "Mark ascending ARTICLES in GROUP as unread." 1901 "Mark ascending ARTICLES in GROUP as unread."
1925 (let* ((entry (or (gnus-group-entry group) 1902 (let* ((entry (or (gnus-group-entry group)
1926 (gnus-group-entry (gnus-group-real-name group)))) 1903 (gnus-group-entry (gnus-group-real-name group))))
1927 (info (nth 2 entry)) 1904 (info (nth 1 entry))
1928 (ranges (gnus-info-read info)) 1905 (ranges (gnus-info-read info))
1929 (r ranges) 1906 (r ranges)
1930 modified) 1907 modified)
@@ -1987,12 +1964,11 @@ backend check whether the group actually exists."
1987 ;; Insert the change into the group buffer and the dribble file. 1964 ;; Insert the change into the group buffer and the dribble file.
1988 (gnus-group-update-group group t)))) 1965 (gnus-group-update-group group t))))
1989 1966
1990;; Enter all dead groups into the hashtb.
1991(defun gnus-update-active-hashtb-from-killed () 1967(defun gnus-update-active-hashtb-from-killed ()
1992 (let ((hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096)))) 1968 (let ((hashtb (setq gnus-active-hashtb
1993 (dolist (list (list gnus-killed-list gnus-zombie-list)) 1969 (gnus-make-hashtable 4000))))
1994 (dolist (group list) 1970 (dolist (g (append gnus-killed-list gnus-zombie-list))
1995 (gnus-sethash group nil hashtb))))) 1971 (remhash g hashtb))))
1996 1972
1997(defun gnus-get-killed-groups () 1973(defun gnus-get-killed-groups ()
1998 "Go through the active hashtb and mark all unknown groups as killed." 1974 "Go through the active hashtb and mark all unknown groups as killed."
@@ -2003,20 +1979,16 @@ backend check whether the group actually exists."
2003 (unless gnus-killed-hashtb 1979 (unless gnus-killed-hashtb
2004 (gnus-make-hashtable-from-killed)) 1980 (gnus-make-hashtable-from-killed))
2005 ;; Go through all newsgroups that are known to Gnus - enlarge kill list. 1981 ;; Go through all newsgroups that are known to Gnus - enlarge kill list.
2006 (mapatoms 1982 (maphash
2007 (lambda (sym) 1983 (lambda (g-name active)
2008 (let ((groups 0) 1984 (let ((groups 0))
2009 (group (symbol-name sym))) 1985 (unless (or (gethash g-name gnus-killed-hashtb)
2010 (if (or (null group) 1986 (gethash g-name gnus-newsrc-hashtb))
2011 (gnus-gethash group gnus-killed-hashtb) 1987 (let ((do-sub (gnus-matches-options-n g-name)))
2012 (gnus-gethash group gnus-newsrc-hashtb)) 1988 (unless (or (eq do-sub 'subscribe) (eq do-sub 'ignore))
2013 ()
2014 (let ((do-sub (gnus-matches-options-n group)))
2015 (if (or (eq do-sub 'subscribe) (eq do-sub 'ignore))
2016 ()
2017 (setq groups (1+ groups)) 1989 (setq groups (1+ groups))
2018 (push group gnus-killed-list) 1990 (push g-name gnus-killed-list)
2019 (gnus-sethash group group gnus-killed-hashtb)))))) 1991 (puthash g-name t gnus-killed-hashtb))))))
2020 gnus-active-hashtb) 1992 gnus-active-hashtb)
2021 (gnus-dribble-touch)) 1993 (gnus-dribble-touch))
2022 1994
@@ -2129,11 +2101,13 @@ backend check whether the group actually exists."
2129 (not (equal method gnus-select-method))) 2101 (not (equal method gnus-select-method)))
2130 gnus-active-hashtb 2102 gnus-active-hashtb
2131 (setq gnus-active-hashtb 2103 (setq gnus-active-hashtb
2132 (if (equal method gnus-select-method) 2104 (gnus-make-hashtable
2133 (gnus-make-hashtable 2105 (if (equal method gnus-select-method)
2134 (count-lines (point-min) (point-max))) 2106 (count-lines (point-min) (point-max))
2135 (gnus-make-hashtable 4096)))))) 2107 4000))))))
2136 group max min) 2108 group max min)
2109 (unless gnus-moderated-hashtb
2110 (setq gnus-moderated-hashtb (gnus-make-hashtable 100)))
2137 ;; Delete unnecessary lines. 2111 ;; Delete unnecessary lines.
2138 (goto-char (point-min)) 2112 (goto-char (point-min))
2139 (cond 2113 (cond
@@ -2143,12 +2117,6 @@ backend check whether the group actually exists."
2143 (delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups)))) 2117 (delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups))))
2144 2118
2145 (goto-char (point-min)) 2119 (goto-char (point-min))
2146 (unless (re-search-forward "[\\\"]" nil t)
2147 ;; Make the group names readable as a lisp expression even if they
2148 ;; contain special characters.
2149 (goto-char (point-max))
2150 (while (re-search-backward "[][';?()#]" nil t)
2151 (insert ?\\)))
2152 2120
2153 ;; Let the Gnus agent save the active file. 2121 ;; Let the Gnus agent save the active file.
2154 (when (and gnus-agent real-active (gnus-online method)) 2122 (when (and gnus-agent real-active (gnus-online method))
@@ -2168,49 +2136,35 @@ backend check whether the group actually exists."
2168 (insert prefix) 2136 (insert prefix)
2169 (zerop (forward-line 1))))))) 2137 (zerop (forward-line 1)))))))
2170 ;; Store the active file in a hash table. 2138 ;; Store the active file in a hash table.
2171 ;; Use a unibyte buffer in order to make `read' read non-ASCII 2139
2172 ;; group names (which have been encoded) as unibyte strings. 2140 (with-temp-buffer
2173 (mm-with-unibyte-buffer
2174 (insert-buffer-substring cur) 2141 (insert-buffer-substring cur)
2175 (setq cur (current-buffer)) 2142 (setq cur (current-buffer))
2176 (goto-char (point-min)) 2143 (goto-char (point-min))
2177 (while (not (eobp)) 2144 (while (not (eobp))
2178 (condition-case () 2145 (condition-case ()
2179 (progn 2146 (if (and (stringp (progn
2180 (narrow-to-region (point) (point-at-eol)) 2147 (setq group (read cur)
2181 ;; group gets set to a symbol interned in the hash table 2148 group (if (numberp group)
2182 ;; (what a hack!!) - jwz 2149 (number-to-string group)
2183 (setq group (let ((obarray hashtb)) (read cur))) 2150 (symbol-name group)))))
2184 ;; ### The extended group name scheme makes 2151 (numberp (setq max (read cur)))
2185 ;; the previous optimization strategy sort of pointless... 2152 (numberp (setq min (read cur)))
2186 (when (stringp group) 2153 (null (progn
2187 (setq group (intern group hashtb))) 2154 (skip-chars-forward " \t")
2188 (if (and (numberp (setq max (read cur))) 2155 (memq (char-after)
2189 (numberp (setq min (read cur))) 2156 '(?= ?x ?j)))))
2190 (progn 2157 (progn (puthash group (cons min max) hashtb)
2191 (skip-chars-forward " \t") 2158 ;; If group is moderated, stick it in the
2192 (not 2159 ;; moderation cache.
2193 (or (eq (char-after) ?=) 2160 (when (eq (char-after) ?m)
2194 (eq (char-after) ?x) 2161 (puthash group t gnus-moderated-hashtb)))
2195 (eq (char-after) ?j))))) 2162 (setq group nil))
2196 (progn
2197 (set group (cons min max))
2198 ;; if group is moderated, stick in moderation table
2199 (when (eq (char-after) ?m)
2200 (unless gnus-moderated-hashtb
2201 (setq gnus-moderated-hashtb (gnus-make-hashtable)))
2202 (gnus-sethash (symbol-name group) t
2203 gnus-moderated-hashtb)))
2204 (set group nil)))
2205 (error 2163 (error
2206 (and group
2207 (symbolp group)
2208 (set group nil))
2209 (unless ignore-errors 2164 (unless ignore-errors
2210 (gnus-message 3 "Warning - invalid active: %s" 2165 (gnus-message 3 "Warning - invalid active: %s"
2211 (buffer-substring 2166 (buffer-substring
2212 (point-at-bol) (point-at-eol)))))) 2167 (point-at-bol) (point-at-eol))))))
2213 (widen)
2214 (forward-line 1))))) 2168 (forward-line 1)))))
2215 2169
2216(defun gnus-groups-to-gnus-format (method &optional hashtb real-active) 2170(defun gnus-groups-to-gnus-format (method &optional hashtb real-active)
@@ -2238,35 +2192,23 @@ backend check whether the group actually exists."
2238 (gnus-active-to-gnus-format method hashtb nil real-active)) 2192 (gnus-active-to-gnus-format method hashtb nil real-active))
2239 2193
2240 (goto-char (point-min)) 2194 (goto-char (point-min))
2241 ;; We split this into to separate loops, one with the prefix 2195 (let (min max group)
2242 ;; and one without to speed the reading up somewhat. 2196 (while (not (eobp))
2243 (if prefix 2197 (condition-case ()
2244 (let (min max opoint group) 2198 (when (eq (char-after) ?2)
2245 (while (not (eobp)) 2199 (read cur) (read cur)
2246 (condition-case () 2200 (setq min (read cur)
2247 (progn 2201 max (read cur)
2248 (read cur) (read cur) 2202 group (read cur)
2249 (setq min (read cur) 2203 group (if (numberp group)
2250 max (read cur) 2204 (number-to-string group)
2251 opoint (point)) 2205 (symbol-name group)))
2252 (skip-chars-forward " \t") 2206 (puthash (if prefix
2253 (insert prefix) 2207 (concat prefix group)
2254 (goto-char opoint) 2208 group)
2255 (set (let ((obarray hashtb)) (read cur)) 2209 (cons min max) hashtb))
2256 (cons min max))) 2210 (error (remhash group hashtb)))
2257 (error (and group (symbolp group) (set group nil)))) 2211 (forward-line 1))))))
2258 (forward-line 1)))
2259 (let (min max group)
2260 (while (not (eobp))
2261 (condition-case ()
2262 (when (eq (char-after) ?2)
2263 (read cur) (read cur)
2264 (setq min (read cur)
2265 max (read cur))
2266 (set (setq group (let ((obarray hashtb)) (read cur)))
2267 (cons min max)))
2268 (error (and group (symbolp group) (set group nil))))
2269 (forward-line 1)))))))
2270 2212
2271(defun gnus-read-newsrc-file (&optional force) 2213(defun gnus-read-newsrc-file (&optional force)
2272 "Read startup file. 2214 "Read startup file.
@@ -2529,16 +2471,11 @@ If FORCE is non-nil, the .newsrc file is read."
2529 (setq gnus-newsrc-options-n nil) 2471 (setq gnus-newsrc-options-n nil)
2530 2472
2531 (unless gnus-active-hashtb 2473 (unless gnus-active-hashtb
2532 (setq gnus-active-hashtb (gnus-make-hashtable 4096))) 2474 (setq gnus-active-hashtb (gnus-make-hashtable 4000)))
2533 (let ((buf (current-buffer)) 2475 (let ((buf (current-buffer))
2534 (already-read (> (length gnus-newsrc-alist) 1)) 2476 (already-read (> (length gnus-newsrc-alist) 1))
2535 group subscribed options-symbol newsrc Options-symbol 2477 group subscribed newsrc reads num1)
2536 symbol reads num1)
2537 (goto-char (point-min)) 2478 (goto-char (point-min))
2538 ;; We intern the symbol `options' in the active hashtb so that we
2539 ;; can `eq' against it later.
2540 (set (setq options-symbol (intern "options" gnus-active-hashtb)) nil)
2541 (set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil)
2542 2479
2543 (while (not (eobp)) 2480 (while (not (eobp))
2544 ;; We first read the first word on the line by narrowing and 2481 ;; 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."
2549 (point) 2486 (point)
2550 (progn (skip-chars-forward "^ \t!:\n") (point))) 2487 (progn (skip-chars-forward "^ \t!:\n") (point)))
2551 (goto-char (point-min)) 2488 (goto-char (point-min))
2552 (setq symbol 2489 (setq group
2553 (and (/= (point-min) (point-max)) 2490 (and (/= (point-min) (point-max))
2554 (let ((obarray gnus-active-hashtb)) (read buf)))) 2491 (read buf))
2492 group (if (numberp group)
2493 (number-to-string group)
2494 (symbol-name group)))
2555 (widen) 2495 (widen)
2556 ;; Now, the symbol we have read is either `options' or a group
2557 ;; name. If it is an options line, we just add it to a string.
2558 (cond 2496 (cond
2559 ((or (eq symbol options-symbol) 2497 ;; It's possible that "group" is actually an options line.
2560 (eq symbol Options-symbol)) 2498 ((string-equal (downcase group) "options")
2561 (setq gnus-newsrc-options 2499 (setq gnus-newsrc-options
2562 ;; This concatting is quite inefficient, but since our 2500 ;; This concatting is quite inefficient, but since our
2563 ;; thorough studies show that approx 99.37% of all 2501 ;; thorough studies show that approx 99.37% of all
@@ -2571,19 +2509,13 @@ If FORCE is non-nil, the .newsrc file is read."
2571 (point-at-bol)) 2509 (point-at-bol))
2572 (point))))) 2510 (point)))))
2573 (forward-line -1)) 2511 (forward-line -1))
2574 (symbol 2512 (group
2575 ;; Group names can be just numbers.
2576 (when (numberp symbol)
2577 (setq symbol (intern (int-to-string symbol) gnus-active-hashtb)))
2578 (unless (boundp symbol)
2579 (set symbol nil))
2580 ;; It was a group name. 2513 ;; It was a group name.
2581 (setq subscribed (eq (char-after) ?:) 2514 (setq subscribed (eq (char-after) ?:)
2582 group (symbol-name symbol)
2583 reads nil) 2515 reads nil)
2584 (if (eolp) 2516 (if (eolp)
2585 ;; If the line ends here, this is clearly a buggy line, so 2517 ;; If the line ends here, this is clearly a buggy line, so
2586 ;; we put point a the beginning of line and let the cond 2518 ;; we put point at the beginning of line and let the cond
2587 ;; below do the error handling. 2519 ;; below do the error handling.
2588 (beginning-of-line) 2520 (beginning-of-line)
2589 ;; We skip to the beginning of the ranges. 2521 ;; We skip to the beginning of the ranges.
@@ -2622,7 +2554,7 @@ If FORCE is non-nil, the .newsrc file is read."
2622 ;; It was just a simple number, so we add it to the 2554 ;; It was just a simple number, so we add it to the
2623 ;; list of ranges. 2555 ;; list of ranges.
2624 (push num1 reads)) 2556 (push num1 reads))
2625 ;; If the next char in ?\n, then we have reached the end 2557 ;; If the next char is ?\n, then we have reached the end
2626 ;; of the line and return nil. 2558 ;; of the line and return nil.
2627 (not (eq (char-after) ?\n))) 2559 (not (eq (char-after) ?\n)))
2628 ((eq (char-after) ?\n) 2560 ((eq (char-after) ?\n)
@@ -2651,7 +2583,8 @@ If FORCE is non-nil, the .newsrc file is read."
2651 (let ((info (gnus-get-info group)) 2583 (let ((info (gnus-get-info group))
2652 level) 2584 level)
2653 (if info 2585 (if info
2654 ;; There is an entry for this file in the alist. 2586 ;; There is an entry for this file in
2587 ;; `gnus-newsrc-hashtb'.
2655 (progn 2588 (progn
2656 (gnus-info-set-read info (nreverse reads)) 2589 (gnus-info-set-read info (nreverse reads))
2657 ;; We update the level very gently. In fact, we 2590 ;; We update the level very gently. In fact, we
@@ -2679,8 +2612,7 @@ If FORCE is non-nil, the .newsrc file is read."
2679 2612
2680 (setq newsrc (nreverse newsrc)) 2613 (setq newsrc (nreverse newsrc))
2681 2614
2682 (if (not already-read) 2615 (unless already-read
2683 ()
2684 ;; We now have two newsrc lists - `newsrc', which is what we 2616 ;; We now have two newsrc lists - `newsrc', which is what we
2685 ;; have read from .newsrc, and `gnus-newsrc-alist', which is 2617 ;; have read from .newsrc, and `gnus-newsrc-alist', which is
2686 ;; what we've read from .newsrc.eld. We have to merge these 2618 ;; 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."
2777 2709
2778(defvar gnus-save-newsrc-file-last-timestamp nil) 2710(defvar gnus-save-newsrc-file-last-timestamp nil)
2779(defun gnus-save-newsrc-file (&optional force) 2711(defun gnus-save-newsrc-file (&optional force)
2780 "Save .newsrc file." 2712 "Save .newsrc file.
2781 ;; Note: We cannot save .newsrc file if all newsgroups are removed 2713Use the group string names in `gnus-group-list' to pull info
2782 ;; from the variable gnus-newsrc-alist. 2714values from `gnus-newsrc-hashtb', and write a new value of
2715`gnus-newsrc-alist'."
2783 (when (and (or gnus-newsrc-alist gnus-killed-list) 2716 (when (and (or gnus-newsrc-alist gnus-killed-list)
2784 gnus-current-startup-file) 2717 gnus-current-startup-file)
2785 ;; Save agent range limits for the currently active method. 2718 ;; Save agent range limits for the currently active method.
@@ -2895,7 +2828,13 @@ If FORCE is non-nil, the .newsrc file is read."
2895 (gnus-group-set-mode-line))))) 2828 (gnus-group-set-mode-line)))))
2896 2829
2897(defun gnus-gnus-to-quick-newsrc-format (&optional minimal name &rest specific-variables) 2830(defun gnus-gnus-to-quick-newsrc-format (&optional minimal name &rest specific-variables)
2898 "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format." 2831 "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format.
2832Unless optional argument MINIMAL is non-nil, print human-readable
2833information in the header of the file, including the file
2834version. If NAME is present, print that as part of the header.
2835
2836Variables printed are either the variables specified in
2837SPECIFIC-VARIABLES, or those in `gnus-variable-list'."
2899 (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n" 2838 (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n"
2900 gnus-ding-file-coding-system)) 2839 gnus-ding-file-coding-system))
2901 (if name 2840 (if name
@@ -2929,9 +2868,18 @@ If FORCE is non-nil, the .newsrc file is read."
2929 ;; Remove the `gnus-killed-list' from the list of variables 2868 ;; Remove the `gnus-killed-list' from the list of variables
2930 ;; to be saved, if required. 2869 ;; to be saved, if required.
2931 (delq 'gnus-killed-list (copy-sequence gnus-variable-list))))) 2870 (delq 'gnus-killed-list (copy-sequence gnus-variable-list)))))
2932 ;; Peel off the "dummy" group.
2933 (gnus-newsrc-alist (cdr gnus-newsrc-alist))
2934 variable) 2871 variable)
2872 ;; A bit of a fake-out here: the original value of
2873 ;; `gnus-newsrc-alist' isn't written to file, instead it is
2874 ;; constructed at the last minute by combining the group
2875 ;; ordering in `gnus-group-list' with the group infos from
2876 ;; `gnus-newsrc-hashtb'.
2877 (set (nth (seq-position gnus-variable-list 'gnus-newsrc-alist)
2878 gnus-variable-list)
2879 (mapcar (lambda (g)
2880 (nth 1 (gethash g gnus-newsrc-hashtb)))
2881 gnus-group-list))
2882
2935 ;; Insert the variables into the file. 2883 ;; Insert the variables into the file.
2936 (while variables 2884 (while variables
2937 (when (and (boundp (setq variable (pop variables))) 2885 (when (and (boundp (setq variable (pop variables)))
@@ -2956,8 +2904,8 @@ If FORCE is non-nil, the .newsrc file is read."
2956 (interactive (list (gnus-y-or-n-p "write foreign groups too? "))) 2904 (interactive (list (gnus-y-or-n-p "write foreign groups too? ")))
2957 ;; Generate and save the .newsrc file. 2905 ;; Generate and save the .newsrc file.
2958 (with-current-buffer (create-file-buffer gnus-current-startup-file) 2906 (with-current-buffer (create-file-buffer gnus-current-startup-file)
2959 (let ((newsrc (cdr gnus-newsrc-alist)) 2907 (let ((standard-output (current-buffer))
2960 (standard-output (current-buffer)) 2908 (groups (delete "dummy.group" (copy-sequence gnus-group-list)))
2961 info ranges range method) 2909 info ranges range method)
2962 (setq buffer-file-name gnus-current-startup-file) 2910 (setq buffer-file-name gnus-current-startup-file)
2963 (setq default-directory (file-name-directory buffer-file-name)) 2911 (setq default-directory (file-name-directory buffer-file-name))
@@ -2971,13 +2919,14 @@ If FORCE is non-nil, the .newsrc file is read."
2971 (when gnus-newsrc-options 2919 (when gnus-newsrc-options
2972 (insert gnus-newsrc-options)) 2920 (insert gnus-newsrc-options))
2973 ;; Write subscribed and unsubscribed. 2921 ;; Write subscribed and unsubscribed.
2974 (while (setq info (pop newsrc)) 2922 (dolist (g-name groups)
2975 ;; Don't write foreign groups to .newsrc. 2923 (setq info (nth 1 (gnus-group-entry g-name)))
2924 ;; Maybe don't write foreign groups to .newsrc.
2976 (when (or (null (setq method (gnus-info-method info))) 2925 (when (or (null (setq method (gnus-info-method info)))
2977 (equal method "native") 2926 (equal method "native")
2978 (inline (gnus-server-equal method gnus-select-method)) 2927 (inline (gnus-server-equal method gnus-select-method))
2979 foreign-ok) 2928 foreign-ok)
2980 (insert (gnus-info-group info) 2929 (insert g-name
2981 (if (> (gnus-info-level info) gnus-level-subscribed) 2930 (if (> (gnus-info-level info) gnus-level-subscribed)
2982 "!" ":")) 2931 "!" ":"))
2983 (when (setq ranges (gnus-info-read info)) 2932 (when (setq ranges (gnus-info-read info))
@@ -3105,10 +3054,10 @@ If FORCE is non-nil, the .newsrc file is read."
3105 ;; to avoid trying to re-read after a failed read. 3054 ;; to avoid trying to re-read after a failed read.
3106 (unless gnus-description-hashtb 3055 (unless gnus-description-hashtb
3107 (setq gnus-description-hashtb 3056 (setq gnus-description-hashtb
3108 (gnus-make-hashtable (length gnus-active-hashtb)))) 3057 (gnus-make-hashtable (hash-table-size gnus-active-hashtb))))
3109 ;; Mark this method's desc file as read. 3058 ;; Mark this method's desc file as read.
3110 (gnus-sethash (gnus-group-prefixed-name "" method) "Has read" 3059 (puthash (gnus-group-prefixed-name "" method) "Has read"
3111 gnus-description-hashtb) 3060 gnus-description-hashtb)
3112 3061
3113 (gnus-message 5 "Reading descriptions file via %s..." (car method)) 3062 (gnus-message 5 "Reading descriptions file via %s..." (car method))
3114 (cond 3063 (cond
@@ -3144,29 +3093,26 @@ If FORCE is non-nil, the .newsrc file is read."
3144 (zerop (forward-line 1))))))) 3093 (zerop (forward-line 1)))))))
3145 (goto-char (point-min)) 3094 (goto-char (point-min))
3146 (while (not (eobp)) 3095 (while (not (eobp))
3147 ;; If we get an error, we set group to 0, which is not a
3148 ;; symbol...
3149 (setq group 3096 (setq group
3150 (condition-case () 3097 (condition-case ()
3151 (let ((obarray gnus-description-hashtb)) 3098 (read nntp-server-buffer)
3152 ;; Group is set to a symbol interned in this 3099 (error nil)))
3153 ;; hash table.
3154 (read nntp-server-buffer))
3155 (error 0)))
3156 (skip-chars-forward " \t") 3100 (skip-chars-forward " \t")
3157 ;; ... which leads to this line being effectively ignored. 3101 (when group
3158 (when (symbolp group) 3102 (setq group (if (numberp group)
3103 (number-to-string group)
3104 (symbol-name group)))
3159 (let* ((str (buffer-substring 3105 (let* ((str (buffer-substring
3160 (point) (progn (end-of-line) (point)))) 3106 (point) (progn (end-of-line) (point))))
3161 (name (symbol-name group))
3162 (charset 3107 (charset
3163 (or (gnus-group-name-charset method name) 3108 (or (gnus-group-name-charset method group)
3164 (gnus-parameter-charset name) 3109 (gnus-parameter-charset group)
3165 gnus-default-charset))) 3110 gnus-default-charset)))
3166 ;; Fixme: Don't decode in unibyte mode. 3111 ;; Fixme: Don't decode in unibyte mode.
3112 ;; Double fixme: We're not in unibyte mode, are we?
3167 (when (and str charset) 3113 (when (and str charset)
3168 (setq str (decode-coding-string str charset))) 3114 (setq str (decode-coding-string str charset)))
3169 (set group str))) 3115 (puthash group str gnus-description-hashtb)))
3170 (forward-line 1)))) 3116 (forward-line 1))))
3171 (gnus-message 5 "Reading descriptions file...done") 3117 (gnus-message 5 "Reading descriptions file...done")
3172 t)))) 3118 t))))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index efb3e4f1a66..85c902a5e43 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -39,6 +39,8 @@
39(require 'gmm-utils) 39(require 'gmm-utils)
40(require 'mm-decode) 40(require 'mm-decode)
41(require 'nnoo) 41(require 'nnoo)
42(eval-when-compile
43 (require 'subr-x))
42 44
43(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) 45(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t)
44(autoload 'gnus-cache-write-active "gnus-cache") 46(autoload 'gnus-cache-write-active "gnus-cache")
@@ -1361,7 +1363,15 @@ the normal Gnus MIME machinery."
1361(defvar gnus-current-crosspost-group nil) 1363(defvar gnus-current-crosspost-group nil)
1362(defvar gnus-newsgroup-display nil) 1364(defvar gnus-newsgroup-display nil)
1363 1365
1364(defvar gnus-newsgroup-dependencies nil) 1366(defvar gnus-newsgroup-dependencies nil
1367 "A hash table holding dependencies between messages.")
1368;; Dependencies are held in a tree structure: a list with the root
1369;; message as car, and each immediate child a sublist (perhaps
1370;; containing further sublists). Each message is represented as a
1371;; vector of headers. Each message's list can be looked up in the
1372;; dependency table using the message's Message-ID as the key. The
1373;; root key is the string "none".
1374
1365(defvar gnus-newsgroup-adaptive nil) 1375(defvar gnus-newsgroup-adaptive nil)
1366(defvar gnus-summary-display-article-function nil) 1376(defvar gnus-summary-display-article-function nil)
1367(defvar gnus-summary-highlight-line-function nil 1377(defvar gnus-summary-highlight-line-function nil
@@ -3937,7 +3947,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
3937 3947
3938 ;; Killed foreign groups can't be entered. 3948 ;; Killed foreign groups can't be entered.
3939 ;; (when (and (not (gnus-group-native-p group)) 3949 ;; (when (and (not (gnus-group-native-p group))
3940 ;; (not (gnus-gethash group gnus-newsrc-hashtb))) 3950 ;; (not (gethash group gnus-newsrc-hashtb)))
3941 ;; (error "Dead non-native groups can't be entered")) 3951 ;; (error "Dead non-native groups can't be entered"))
3942 (gnus-message 7 "Retrieving newsgroup: %s..." 3952 (gnus-message 7 "Retrieving newsgroup: %s..."
3943 (gnus-group-decoded-name group)) 3953 (gnus-group-decoded-name group))
@@ -4167,7 +4177,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4167 "Gather threads by looking at Subject headers." 4177 "Gather threads by looking at Subject headers."
4168 (if (not gnus-summary-make-false-root) 4178 (if (not gnus-summary-make-false-root)
4169 threads 4179 threads
4170 (let ((hashtb (gnus-make-hashtable 1024)) 4180 (let ((hashtb (gnus-make-hashtable 1000))
4171 (prev threads) 4181 (prev threads)
4172 (result threads) 4182 (result threads)
4173 subject hthread whole-subject) 4183 subject hthread whole-subject)
@@ -4176,7 +4186,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4176 (setq whole-subject (mail-header-subject 4186 (setq whole-subject (mail-header-subject
4177 (caar threads))))) 4187 (caar threads)))))
4178 (when subject 4188 (when subject
4179 (if (setq hthread (gnus-gethash subject hashtb)) 4189 (if (setq hthread (gethash subject hashtb))
4180 (progn 4190 (progn
4181 ;; We enter a dummy root into the thread, if we 4191 ;; We enter a dummy root into the thread, if we
4182 ;; haven't done that already. 4192 ;; haven't done that already.
@@ -4190,24 +4200,24 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4190 (setcdr prev (cdr threads)) 4200 (setcdr prev (cdr threads))
4191 (setq threads prev)) 4201 (setq threads prev))
4192 ;; Enter this thread into the hash table. 4202 ;; Enter this thread into the hash table.
4193 (gnus-sethash subject 4203 (puthash subject
4194 (if gnus-summary-make-false-root-always 4204 (if gnus-summary-make-false-root-always
4195 (progn 4205 (progn
4196 ;; If you want a dummy root above all 4206 ;; If you want a dummy root above all
4197 ;; threads... 4207 ;; threads...
4198 (setcar threads (list whole-subject 4208 (setcar threads (list whole-subject
4199 (car threads))) 4209 (car threads)))
4200 threads) 4210 threads)
4201 threads) 4211 threads)
4202 hashtb))) 4212 hashtb)))
4203 (setq prev threads) 4213 (setq prev threads)
4204 (setq threads (cdr threads))) 4214 (setq threads (cdr threads)))
4205 result))) 4215 result)))
4206 4216
4207(defun gnus-gather-threads-by-references (threads) 4217(defun gnus-gather-threads-by-references (threads)
4208 "Gather threads by looking at References headers." 4218 "Gather threads by looking at References headers."
4209 (let ((idhashtb (gnus-make-hashtable 1024)) 4219 (let ((idhashtb (gnus-make-hashtable 1000))
4210 (thhashtb (gnus-make-hashtable 1024)) 4220 (thhashtb (gnus-make-hashtable 1000))
4211 (prev threads) 4221 (prev threads)
4212 (result threads) 4222 (result threads)
4213 ids references id gthread gid entered ref) 4223 ids references id gthread gid entered ref)
@@ -4218,11 +4228,11 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4218 entered nil) 4228 entered nil)
4219 (while (setq ref (pop ids)) 4229 (while (setq ref (pop ids))
4220 (setq ids (delete ref ids)) 4230 (setq ids (delete ref ids))
4221 (if (not (setq gid (gnus-gethash ref idhashtb))) 4231 (if (not (setq gid (gethash ref idhashtb)))
4222 (progn 4232 (progn
4223 (gnus-sethash ref id idhashtb) 4233 (puthash ref id idhashtb)
4224 (gnus-sethash id threads thhashtb)) 4234 (puthash id threads thhashtb))
4225 (setq gthread (gnus-gethash gid thhashtb)) 4235 (setq gthread (gethash gid thhashtb))
4226 (unless entered 4236 (unless entered
4227 ;; We enter a dummy root into the thread, if we 4237 ;; We enter a dummy root into the thread, if we
4228 ;; haven't done that already. 4238 ;; haven't done that already.
@@ -4234,7 +4244,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4234 (setcdr (car gthread) 4244 (setcdr (car gthread)
4235 (nconc (cdar gthread) (list (car threads))))) 4245 (nconc (cdar gthread) (list (car threads)))))
4236 ;; Add it into the thread hash table. 4246 ;; Add it into the thread hash table.
4237 (gnus-sethash id gthread thhashtb) 4247 (puthash id gthread thhashtb)
4238 (setq entered t) 4248 (setq entered t)
4239 ;; Remove it from the list of threads. 4249 ;; Remove it from the list of threads.
4240 (setcdr prev (cdr threads)) 4250 (setcdr prev (cdr threads))
@@ -4267,12 +4277,12 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4267 ;; We have found a loop. 4277 ;; We have found a loop.
4268 (let (ref-dep) 4278 (let (ref-dep)
4269 (setcdr thread (delq (car th) (cdr thread))) 4279 (setcdr thread (delq (car th) (cdr thread)))
4270 (if (boundp (setq ref-dep (intern "none" 4280 (if (setq ref-dep (gethash "none"
4271 gnus-newsgroup-dependencies))) 4281 gnus-newsgroup-dependencies))
4272 (setcdr (symbol-value ref-dep) 4282 (setcdr ref-dep
4273 (nconc (cdr (symbol-value ref-dep)) 4283 (nconc (cdr ref-dep)
4274 (list (car th)))) 4284 (list (car th))))
4275 (set ref-dep (list nil (car th)))) 4285 (puthash ref-dep (list nil (car th)) gnus-newsgroup-dependencies))
4276 (setq infloop 1 4286 (setq infloop 1
4277 stack nil)) 4287 stack nil))
4278 ;; Push all the subthreads onto the stack. 4288 ;; Push all the subthreads onto the stack.
@@ -4283,31 +4293,30 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4283 "Go through the dependency hashtb and find the roots. Return all threads." 4293 "Go through the dependency hashtb and find the roots. Return all threads."
4284 (let (threads) 4294 (let (threads)
4285 (while (catch 'infloop 4295 (while (catch 'infloop
4286 (mapatoms 4296 (maphash
4287 (lambda (refs) 4297 (lambda (_id refs)
4288 ;; Deal with self-referencing References loops. 4298 ;; Deal with self-referencing References loops.
4289 (when (and (car (symbol-value refs)) 4299 (when (and (car refs)
4290 (not (zerop 4300 (not (zerop
4291 (apply 4301 (apply
4292 '+ 4302 '+
4293 (mapcar 4303 (mapcar
4294 (lambda (thread) 4304 (lambda (thread)
4295 (gnus-thread-loop-p 4305 (gnus-thread-loop-p
4296 (car (symbol-value refs)) thread)) 4306 (car refs) thread))
4297 (cdr (symbol-value refs))))))) 4307 (cdr refs))))))
4298 (setq threads nil) 4308 (setq threads nil)
4299 (throw 'infloop t)) 4309 (throw 'infloop t))
4300 (unless (car (symbol-value refs)) 4310 (unless (car refs)
4301 ;; These threads do not refer back to any other 4311 ;; These threads do not refer back to any other
4302 ;; articles, so they're roots. 4312 ;; articles, so they're roots.
4303 (setq threads (append (cdr (symbol-value refs)) threads)))) 4313 (setq threads (append (cdr refs) threads))))
4304 gnus-newsgroup-dependencies))) 4314 gnus-newsgroup-dependencies)))
4305 threads)) 4315 threads))
4306 4316
4307;; Build the thread tree. 4317;; Build the thread tree.
4308(defsubst gnus-dependencies-add-header (header dependencies force-new) 4318(defsubst gnus-dependencies-add-header (header dependencies force-new)
4309 "Enter HEADER into the DEPENDENCIES table if it is not already there. 4319 "Enter HEADER into the DEPENDENCIES table if it is not already there.
4310
4311If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even 4320If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even
4312if it was already present. 4321if it was already present.
4313 4322
@@ -4318,33 +4327,38 @@ Message-ID before being entered.
4318 4327
4319Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." 4328Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
4320 (let* ((id (mail-header-id header)) 4329 (let* ((id (mail-header-id header))
4321 (id-dep (and id (intern id dependencies))) 4330 ;; An "id-dep" is a list holding the vector headers of this
4331 ;; message, plus equivalent "id-deps" for each immediate
4332 ;; child message.
4333 (id-dep (and id (gethash id dependencies)))
4322 parent-id ref ref-dep ref-header replaced) 4334 parent-id ref ref-dep ref-header replaced)
4323 ;; Enter this `header' in the `dependencies' table. 4335 ;; Enter this `header' in the `dependencies' table.
4324 (cond 4336 (cond
4325 ((not id-dep) 4337 ((null id)
4338 ;; Omit this article altogether if there is no Message-ID.
4326 (setq header nil)) 4339 (setq header nil))
4327 ;; The first two cases do the normal part: enter a new `header' 4340 ;; Enter a new id and `header' in the `dependencies' table.
4328 ;; in the `dependencies' table. 4341 ((null id-dep)
4329 ((not (boundp id-dep)) 4342 (setq id-dep (puthash id (list header) dependencies)))
4330 (set id-dep (list header))) 4343 ;; A child message has already added this id, just insert the header.
4331 ((null (car (symbol-value id-dep))) 4344 ((null (car id-dep))
4332 (setcar (symbol-value id-dep) header)) 4345 (setcar (gethash id dependencies) header)
4333 4346 (setq id-dep (gethash id dependencies)))
4334 ;; From here the `header' was already present in the 4347 ;; From here the `header' was already present in the
4335 ;; `dependencies' table. 4348 ;; `dependencies' table.
4336 (force-new 4349 (force-new
4337 ;; Overrides an existing entry; 4350 ;; Overrides an existing entry;
4338 ;; just set the header part of the entry. 4351 ;; just set the header part of the entry.
4339 (setcar (symbol-value id-dep) header) 4352 (setcar (gethash id dependencies) header)
4340 (setq replaced t)) 4353 (setq replaced t))
4341 4354
4342 ;; Renames the existing `header' to a unique Message-ID. 4355 ;; Renames the existing `header' to a unique Message-ID.
4343 ((not gnus-summary-ignore-duplicates) 4356 ((not gnus-summary-ignore-duplicates)
4344 ;; An article with this Message-ID has already been seen. 4357 ;; An article with this Message-ID has already been seen.
4345 ;; We rename the Message-ID. 4358 ;; We rename the Message-ID.
4346 (set (setq id-dep (intern (setq id (nnmail-message-id)) dependencies)) 4359 (setq id-dep (puthash (setq id (nnmail-message-id))
4347 (list header)) 4360 (list header)
4361 dependencies))
4348 (mail-header-set-id header id)) 4362 (mail-header-set-id header id))
4349 4363
4350 ;; The last case ignores an existing entry, except it adds any 4364 ;; 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."
4354 ;; table was *not* modified. 4368 ;; table was *not* modified.
4355 (t 4369 (t
4356 (mail-header-set-xref 4370 (mail-header-set-xref
4357 (car (symbol-value id-dep)) 4371 (car id-dep)
4358 (concat (or (mail-header-xref (car (symbol-value id-dep))) 4372 (concat (or (mail-header-xref (car id-dep))
4359 "") 4373 "")
4360 (or (mail-header-xref header) ""))) 4374 (or (mail-header-xref header) "")))
4361 (setq header nil))) 4375 (setq header nil)))
@@ -4365,23 +4379,27 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
4365 (setq parent-id (gnus-parent-id (mail-header-references header))) 4379 (setq parent-id (gnus-parent-id (mail-header-references header)))
4366 (setq ref parent-id) 4380 (setq ref parent-id)
4367 (while (and ref 4381 (while (and ref
4368 (setq ref-dep (intern-soft ref dependencies)) 4382 (setq ref-dep (gethash ref dependencies))
4369 (boundp ref-dep) 4383 (setq ref-header (car-safe ref-dep)))
4370 (setq ref-header (car (symbol-value ref-dep))))
4371 (if (string= id ref) 4384 (if (string= id ref)
4372 ;; Yuk! This is a reference loop. Make the article be a 4385 ;; Yuk! This is a reference loop. Make the article be a
4373 ;; root article. 4386 ;; root article.
4374 (progn 4387 (progn
4375 (mail-header-set-references (car (symbol-value id-dep)) "none") 4388 (mail-header-set-references (car id-dep) "none")
4376 (setq ref nil) 4389 (setq ref nil)
4377 (setq parent-id nil)) 4390 (setq parent-id nil))
4378 (setq ref (gnus-parent-id (mail-header-references ref-header))))) 4391 (setq ref (gnus-parent-id (mail-header-references ref-header)))))
4379 (setq ref-dep (intern (or parent-id "none") dependencies)) 4392 (setq ref (or parent-id "none")
4380 (if (boundp ref-dep) 4393 ref-dep (gethash ref dependencies))
4381 (setcdr (symbol-value ref-dep) 4394 ;; Add `header' to its parent's list of children, creating that
4382 (nconc (cdr (symbol-value ref-dep)) 4395 ;; list if the parent isn't yet registered in the dependency
4383 (list (symbol-value id-dep)))) 4396 ;; table.
4384 (set ref-dep (list nil (symbol-value id-dep))))) 4397 (if ref-dep
4398 (setcdr (gethash ref dependencies)
4399 (nconc (cdr ref-dep)
4400 (list id-dep)))
4401 (puthash ref (list nil id-dep)
4402 dependencies)))
4385 header)) 4403 header))
4386 4404
4387(defun gnus-extract-message-id-from-in-reply-to (string) 4405(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."
4444 ;; server, that is. 4462 ;; server, that is.
4445 (let ((mail-parse-charset gnus-newsgroup-charset) 4463 (let ((mail-parse-charset gnus-newsgroup-charset)
4446 id heads) 4464 id heads)
4447 (mapatoms 4465 (maphash
4448 (lambda (refs) 4466 (lambda (id refs)
4449 (when (not (car (symbol-value refs))) 4467 (when (not (car refs))
4450 (setq heads (cdr (symbol-value refs))) 4468 (setq heads (cdr refs))
4451 (while heads 4469 (while heads
4452 (if (memq (mail-header-number (caar heads)) 4470 (if (memq (mail-header-number (caar heads))
4453 gnus-newsgroup-dormant) 4471 gnus-newsgroup-dormant)
4454 (setq heads (cdr heads)) 4472 (setq heads (cdr heads))
4455 (setq id (symbol-name refs))
4456 (while (and (setq id (gnus-build-get-header id)) 4473 (while (and (setq id (gnus-build-get-header id))
4457 (not (car (gnus-id-to-thread id))))) 4474 (not (car (gnus-id-to-thread id)))))
4458 (setq heads nil))))) 4475 (setq heads nil)))))
@@ -4733,7 +4750,7 @@ If LINE, insert the rebuilt thread starting on line LINE."
4733 4750
4734(defun gnus-id-to-thread (id) 4751(defun gnus-id-to-thread (id)
4735 "Return the (sub-)thread where ID appears." 4752 "Return the (sub-)thread where ID appears."
4736 (gnus-gethash id gnus-newsgroup-dependencies)) 4753 (gethash id gnus-newsgroup-dependencies))
4737 4754
4738(defun gnus-id-to-article (id) 4755(defun gnus-id-to-article (id)
4739 "Return the article number of ID." 4756 "Return the article number of ID."
@@ -5586,7 +5603,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5586 (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) 5603 (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual)
5587 t 5604 t
5588 gnus-summary-ignore-duplicates)) 5605 gnus-summary-ignore-duplicates))
5589 (info (nth 2 entry)) 5606 (info (nth 1 entry))
5590 charset articles fetched-articles cached) 5607 charset articles fetched-articles cached)
5591 5608
5592 (unless (gnus-check-server 5609 (unless (gnus-check-server
@@ -5605,7 +5622,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5605 (decode-coding-string group charset) 5622 (decode-coding-string group charset)
5606 (decode-coding-string (gnus-status-message group) charset)))) 5623 (decode-coding-string (gnus-status-message group) charset))))
5607 5624
5608 (unless (gnus-request-group group t nil (gnus-get-info group)) 5625 (unless (gnus-request-group group t nil info)
5609 (when (derived-mode-p 'gnus-summary-mode) 5626 (when (derived-mode-p 'gnus-summary-mode)
5610 (gnus-kill-buffer (current-buffer))) 5627 (gnus-kill-buffer (current-buffer)))
5611 (error "Couldn't request group %s: %s" 5628 (error "Couldn't request group %s: %s"
@@ -6208,9 +6225,9 @@ The resulting hash table is returned, or nil if no Xrefs were found."
6208 (setq number 6225 (setq number
6209 (string-to-number (substring xrefs (match-beginning 2) 6226 (string-to-number (substring xrefs (match-beginning 2)
6210 (match-end 2)))) 6227 (match-end 2))))
6211 (if (setq entry (gnus-gethash group xref-hashtb)) 6228 (if (setq entry (gethash group xref-hashtb))
6212 (setcdr entry (cons number (cdr entry))) 6229 (setcdr entry (cons number (cdr entry)))
6213 (gnus-sethash group (cons number nil) xref-hashtb))))) 6230 (puthash group (cons number nil) xref-hashtb)))))
6214 (and start xref-hashtb))) 6231 (and start xref-hashtb)))
6215 6232
6216(defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads) 6233(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."
6220 (with-current-buffer gnus-group-buffer 6237 (with-current-buffer gnus-group-buffer
6221 (when (setq xref-hashtb 6238 (when (setq xref-hashtb
6222 (gnus-create-xref-hashtb from-newsgroup headers unreads)) 6239 (gnus-create-xref-hashtb from-newsgroup headers unreads))
6223 (mapatoms 6240 (maphash
6224 (lambda (group) 6241 (lambda (group idlist)
6225 (unless (string= from-newsgroup (setq name (symbol-name group))) 6242 (unless (string= from-newsgroup group)
6226 (setq idlist (symbol-value group))
6227 ;; Dead groups are not updated. 6243 ;; Dead groups are not updated.
6228 (and (prog1 6244 (and (prog1
6229 (setq info (gnus-get-info name)) 6245 (setq info (gnus-get-info name))
@@ -6249,7 +6265,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
6249 6265
6250(defun gnus-compute-read-articles (group articles) 6266(defun gnus-compute-read-articles (group articles)
6251 (let* ((entry (gnus-group-entry group)) 6267 (let* ((entry (gnus-group-entry group))
6252 (info (nth 2 entry)) 6268 (info (nth 1 entry))
6253 (active (gnus-active group)) 6269 (active (gnus-active group))
6254 ninfo) 6270 ninfo)
6255 (when entry 6271 (when entry
@@ -6286,7 +6302,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
6286 "Update the info of GROUP to say that ARTICLES are read." 6302 "Update the info of GROUP to say that ARTICLES are read."
6287 (let* ((num 0) 6303 (let* ((num 0)
6288 (entry (gnus-group-entry group)) 6304 (entry (gnus-group-entry group))
6289 (info (nth 2 entry)) 6305 (info (nth 1 entry))
6290 (active (gnus-active group)) 6306 (active (gnus-active group))
6291 (set-marks 6307 (set-marks
6292 (gnus-method-option-p 6308 (gnus-method-option-p
@@ -8848,11 +8864,11 @@ fetch-old-headers verbiage, and so on."
8848 (null gnus-thread-expunge-below))) 8864 (null gnus-thread-expunge-below)))
8849 (push gnus-newsgroup-limit gnus-newsgroup-limits) 8865 (push gnus-newsgroup-limit gnus-newsgroup-limits)
8850 (setq gnus-newsgroup-limit nil) 8866 (setq gnus-newsgroup-limit nil)
8851 (mapatoms 8867 (maphash
8852 (lambda (node) 8868 (lambda (id deps)
8853 (unless (car (symbol-value node)) 8869 (unless (car deps)
8854 ;; These threads have no parents -- they are roots. 8870 ;; These threads have no parents -- they are roots.
8855 (let ((nodes (cdr (symbol-value node))) 8871 (let ((nodes (cdr deps))
8856 thread) 8872 thread)
8857 (while nodes 8873 (while nodes
8858 (if (and gnus-thread-expunge-below 8874 (if (and gnus-thread-expunge-below
@@ -12288,12 +12304,11 @@ save those articles instead."
12288 (nreverse split-name))) 12304 (nreverse split-name)))
12289 12305
12290(defun gnus-valid-move-group-p (group) 12306(defun gnus-valid-move-group-p (group)
12291 (and (symbolp group) 12307 (when (and (stringp group)
12292 (boundp group) 12308 (null (string-empty-p group)))
12293 (symbol-name group) 12309 (gnus-get-function (gnus-find-method-for-group
12294 (symbol-value group) 12310 group)
12295 (gnus-get-function (gnus-find-method-for-group 12311 'request-accept-article t)))
12296 (symbol-name group)) 'request-accept-article t)))
12297 12312
12298(defun gnus-read-move-group-name (prompt default articles prefix) 12313(defun gnus-read-move-group-name (prompt default articles prefix)
12299 "Read a group name." 12314 "Read a group name."
@@ -12304,27 +12319,24 @@ save those articles instead."
12304 (if (> (length articles) 1) 12319 (if (> (length articles) 1)
12305 (format "these %d articles" (length articles)) 12320 (format "these %d articles" (length articles))
12306 "this article"))) 12321 "this article")))
12307 valid-names 12322 (valid-names
12323 (seq-filter #'gnus-valid-move-group-p
12324 (hash-table-keys gnus-active-hashtb)))
12308 (to-newsgroup 12325 (to-newsgroup
12309 (progn 12326 (cond
12310 (mapatoms (lambda (g) 12327 ((null split-name)
12311 (when (gnus-valid-move-group-p g) 12328 (gnus-group-completing-read
12312 (push g valid-names))) 12329 prom
12313 gnus-active-hashtb) 12330 valid-names
12314 (cond 12331 nil prefix nil default))
12315 ((null split-name) 12332 ((= 1 (length split-name))
12316 (gnus-group-completing-read 12333 (gnus-group-completing-read
12317 prom 12334 prom
12318 valid-names 12335 valid-names
12319 nil prefix nil default)) 12336 nil prefix 'gnus-group-history (car split-name)))
12320 ((= 1 (length split-name)) 12337 (t
12321 (gnus-group-completing-read 12338 (gnus-completing-read
12322 prom 12339 prom (nreverse split-name) nil nil 'gnus-group-history))))
12323 valid-names
12324 nil prefix 'gnus-group-history (car split-name)))
12325 (t
12326 (gnus-completing-read
12327 prom (nreverse split-name) nil nil 'gnus-group-history)))))
12328 (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) 12340 (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))
12329 encoded) 12341 encoded)
12330 (when to-newsgroup 12342 (when to-newsgroup
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index 1a7524f9de9..e2c728df8f4 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -31,6 +31,8 @@
31(require 'gnus-group) 31(require 'gnus-group)
32(require 'gnus-start) 32(require 'gnus-start)
33(require 'gnus-util) 33(require 'gnus-util)
34(eval-when-compile
35 (require 'subr-x))
34 36
35(defgroup gnus-topic nil 37(defgroup gnus-topic nil
36 "Group topics." 38 "Group topics."
@@ -99,8 +101,7 @@ See Info node `(gnus)Formatting Variables'."
99 101
100(defun gnus-group-topic-name () 102(defun gnus-group-topic-name ()
101 "The name of the topic on the current line." 103 "The name of the topic on the current line."
102 (let ((topic (get-text-property (point-at-bol) 'gnus-topic))) 104 (get-text-property (point-at-bol) 'gnus-topic))
103 (and topic (symbol-name topic))))
104 105
105(defun gnus-group-topic-level () 106(defun gnus-group-topic-level ()
106 "The level of the topic on the current line." 107 "The level of the topic on the current line."
@@ -144,8 +145,7 @@ See Info node `(gnus)Formatting Variables'."
144 145
145(defun gnus-topic-goto-topic (topic) 146(defun gnus-topic-goto-topic (topic)
146 (when topic 147 (when topic
147 (gnus-goto-char (text-property-any (point-min) (point-max) 148 (gnus-text-property-search 'gnus-topic topic nil 'goto)))
148 'gnus-topic (intern topic)))))
149 149
150(defun gnus-topic-jump-to-topic (topic) 150(defun gnus-topic-jump-to-topic (topic)
151 "Go to TOPIC." 151 "Go to TOPIC."
@@ -167,8 +167,7 @@ See Info node `(gnus)Formatting Variables'."
167 (point) 'gnus-topic)) 167 (point) 'gnus-topic))
168 (get-text-property (max (1- (point)) (point-min)) 168 (get-text-property (max (1- (point)) (point-min))
169 'gnus-topic)))))) 169 'gnus-topic))))))
170 (when result 170 result))
171 (symbol-name result))))
172 171
173(defun gnus-current-topics (&optional topic) 172(defun gnus-current-topics (&optional topic)
174 "Return a list of all current topics, lowest in hierarchy first. 173 "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."
195 (while groups 194 (while groups
196 (when (setq group (pop groups)) 195 (when (setq group (pop groups))
197 (setq entry (gnus-group-entry group) 196 (setq entry (gnus-group-entry group)
198 info (nth 2 entry) 197 info (nth 1 entry)
199 params (gnus-info-params info) 198 params (gnus-info-params info)
200 active (gnus-active group) 199 active (gnus-active group)
201 unread (or (car entry) 200 unread (or (car entry)
@@ -462,7 +461,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
462 (gnus-group-prepare-flat-list-dead 461 (gnus-group-prepare-flat-list-dead
463 (seq-remove (lambda (group) 462 (seq-remove (lambda (group)
464 (or (gnus-group-entry group) 463 (or (gnus-group-entry group)
465 (gnus-gethash group gnus-killed-hashtb))) 464 (gethash group gnus-killed-hashtb)))
466 not-in-list) 465 not-in-list)
467 gnus-level-killed ?K regexp))) 466 gnus-level-killed ?K regexp)))
468 467
@@ -536,7 +535,7 @@ articles in the topic and its subtopics."
536 (funcall regexp entry)) 535 (funcall regexp entry))
537 ((null regexp) t) 536 ((null regexp) t)
538 (t nil)))) 537 (t nil))))
539 (setq info (nth 2 entry)) 538 (setq info (nth 1 entry))
540 (gnus-group-prepare-logic 539 (gnus-group-prepare-logic
541 (gnus-info-group info) 540 (gnus-info-group info)
542 (and (or (not gnus-group-listed-groups) 541 (and (or (not gnus-group-listed-groups)
@@ -557,7 +556,7 @@ articles in the topic and its subtopics."
557 (car active)) 556 (car active))
558 nil) 557 nil)
559 ;; Living groups. 558 ;; Living groups.
560 (when (setq info (nth 2 entry)) 559 (when (setq info (nth 1 entry))
561 (gnus-group-insert-group-line 560 (gnus-group-insert-group-line
562 (gnus-info-group info) 561 (gnus-info-group info)
563 (gnus-info-level info) (gnus-info-marks info) 562 (gnus-info-level info) (gnus-info-marks info)
@@ -646,7 +645,7 @@ articles in the topic and its subtopics."
646 (point) 645 (point)
647 (prog1 (1+ (point)) 646 (prog1 (1+ (point))
648 (eval gnus-topic-line-format-spec)) 647 (eval gnus-topic-line-format-spec))
649 (list 'gnus-topic (intern name) 648 (list 'gnus-topic name
650 'gnus-topic-level level 649 'gnus-topic-level level
651 'gnus-topic-unread unread 650 'gnus-topic-unread unread
652 'gnus-active active-topic 651 'gnus-active active-topic
@@ -844,10 +843,9 @@ articles in the topic and its subtopics."
844 ;; they belong to some topic. 843 ;; they belong to some topic.
845 (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist))) 844 (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist)))
846 (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) 845 (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
847 (newsrc (cdr gnus-newsrc-alist)) 846 (groups (cdr gnus-group-list)))
848 group) 847 (dolist (group groups)
849 (while newsrc 848 (unless (member group tgroups)
850 (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
851 (setcdr entry (list group)) 849 (setcdr entry (list group))
852 (setq entry (cdr entry))))) 850 (setq entry (cdr entry)))))
853 ;; Go through all topics and make sure they contain only living groups. 851 ;; Go through all topics and make sure they contain only living groups.
@@ -888,7 +886,7 @@ articles in the topic and its subtopics."
888 (while (setq group (pop topic)) 886 (while (setq group (pop topic))
889 (when (and (or (gnus-active group) 887 (when (and (or (gnus-active group)
890 (gnus-info-method (gnus-get-info group))) 888 (gnus-info-method (gnus-get-info group)))
891 (not (gnus-gethash group gnus-killed-hashtb))) 889 (not (gethash group gnus-killed-hashtb)))
892 (push group filtered-topic))) 890 (push group filtered-topic)))
893 (push (cons topic-name (nreverse filtered-topic)) result))) 891 (push (cons topic-name (nreverse filtered-topic)) result)))
894 (setq gnus-topic-alist (nreverse result)))) 892 (setq gnus-topic-alist (nreverse result))))
@@ -898,7 +896,7 @@ articles in the topic and its subtopics."
898 (with-current-buffer gnus-group-buffer 896 (with-current-buffer gnus-group-buffer
899 (let ((inhibit-read-only t)) 897 (let ((inhibit-read-only t))
900 (unless gnus-topic-inhibit-change-level 898 (unless gnus-topic-inhibit-change-level
901 (gnus-group-goto-group (or (car (nth 2 previous)) group)) 899 (gnus-group-goto-group (or (car (nth 1 previous)) group))
902 (when (and gnus-topic-mode 900 (when (and gnus-topic-mode
903 gnus-topic-alist 901 gnus-topic-alist
904 (not gnus-topic-inhibit-change-level)) 902 (not gnus-topic-inhibit-change-level))
@@ -956,7 +954,7 @@ articles in the topic and its subtopics."
956 (if (not group) 954 (if (not group)
957 (if (not (memq 'gnus-topic props)) 955 (if (not (memq 'gnus-topic props))
958 (goto-char (point-max)) 956 (goto-char (point-max))
959 (let ((topic (symbol-name (cadr (memq 'gnus-topic props))))) 957 (let ((topic (cadr (memq 'gnus-topic props))))
960 (or (gnus-topic-goto-topic topic) 958 (or (gnus-topic-goto-topic topic)
961 (gnus-topic-goto-topic (gnus-topic-next-topic topic))))) 959 (gnus-topic-goto-topic (gnus-topic-next-topic topic)))))
962 (if (gnus-group-goto-group group) 960 (if (gnus-group-goto-group group)
@@ -992,12 +990,8 @@ articles in the topic and its subtopics."
992 ;; First we make sure that we have really read the active file. 990 ;; First we make sure that we have really read the active file.
993 (when (or force 991 (when (or force
994 (not gnus-topic-active-alist)) 992 (not gnus-topic-active-alist))
995 (let (groups) 993 ;; Get a list of all groups available.
996 ;; Get a list of all groups available. 994 (let ((groups (sort (hash-table-keys gnus-active-hashtb) #'string<)))
997 (mapatoms (lambda (g) (when (symbol-value g)
998 (push (symbol-name g) groups)))
999 gnus-active-hashtb)
1000 (setq groups (sort groups 'string<))
1001 ;; Init the variables. 995 ;; Init the variables.
1002 (setq gnus-topic-active-topology (list (list "" 'visible))) 996 (setq gnus-topic-active-topology (list (list "" 'visible)))
1003 (setq gnus-topic-active-alist nil) 997 (setq gnus-topic-active-alist nil)
@@ -1202,7 +1196,7 @@ If performed over a topic line, toggle folding the topic."
1202 (save-excursion 1196 (save-excursion
1203 (gnus-message 5 "Expiring groups in %s..." topic) 1197 (gnus-message 5 "Expiring groups in %s..." topic)
1204 (let ((gnus-group-marked 1198 (let ((gnus-group-marked
1205 (mapcar (lambda (entry) (car (nth 2 entry))) 1199 (mapcar (lambda (entry) (car (nth 1 entry)))
1206 (gnus-topic-find-groups topic gnus-level-killed t 1200 (gnus-topic-find-groups topic gnus-level-killed t
1207 nil t)))) 1201 nil t))))
1208 (gnus-group-expire-articles nil)) 1202 (gnus-group-expire-articles nil))
@@ -1216,7 +1210,7 @@ Also see `gnus-group-catchup'."
1216 (call-interactively 'gnus-group-catchup-current) 1210 (call-interactively 'gnus-group-catchup-current)
1217 (save-excursion 1211 (save-excursion
1218 (let* ((groups 1212 (let* ((groups
1219 (mapcar (lambda (entry) (car (nth 2 entry))) 1213 (mapcar (lambda (entry) (car (nth 1 entry)))
1220 (gnus-topic-find-groups topic gnus-level-killed t 1214 (gnus-topic-find-groups topic gnus-level-killed t
1221 nil t))) 1215 nil t)))
1222 (inhibit-read-only t) 1216 (inhibit-read-only t)
@@ -1449,7 +1443,7 @@ If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics."
1449 (not non-recursive)))) 1443 (not non-recursive))))
1450 (while groups 1444 (while groups
1451 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) 1445 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
1452 (gnus-info-group (nth 2 (pop groups))))))))) 1446 (gnus-info-group (nth 1 (pop groups)))))))))
1453 1447
1454(defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive) 1448(defun gnus-topic-unmark-topic (topic &optional _dummy non-recursive)
1455 "Remove the process mark from all groups in the TOPIC. 1449 "Remove the process mark from all groups in the TOPIC.
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index d570f78347b..6b0f29b0afb 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -35,6 +35,7 @@
35(eval-when-compile (require 'cl-lib)) 35(eval-when-compile (require 'cl-lib))
36 36
37(require 'time-date) 37(require 'time-date)
38(require 'text-property-search)
38 39
39(defcustom gnus-completing-read-function 'gnus-emacs-completing-read 40(defcustom gnus-completing-read-function 'gnus-emacs-completing-read
40 "Function use to do completing read." 41 "Function use to do completing read."
@@ -104,13 +105,6 @@ This is a compatibility function for different Emacsen."
104(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) 105(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
105(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) 106(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
106 107
107(defmacro gnus-intern-safe (string hashtable)
108 "Get hash value. Arguments are STRING and HASHTABLE."
109 `(let ((symbol (intern ,string ,hashtable)))
110 (or (boundp symbol)
111 (set symbol nil))
112 symbol))
113
114(defsubst gnus-goto-char (point) 108(defsubst gnus-goto-char (point)
115 (and point (goto-char point))) 109 (and point (goto-char point)))
116 110
@@ -199,6 +193,36 @@ is slower."
199 (search-forward ":" eol t) 193 (search-forward ":" eol t)
200 (point))))) 194 (point)))))
201 195
196(defun gnus-text-property-search (prop value &optional forward-only goto end)
197 "Search current buffer for text property PROP with VALUE.
198Behaves like a combination of `text-property-any' and
199`text-property-search-forward'. Searches for the beginning of a
200text property `equal' to VALUE. Returns the value of point at
201the beginning of the matching text property span.
202
203If FORWARD-ONLY is non-nil, only search forward from point.
204
205If GOTO is non-nil, move point to the beginning of that span
206instead.
207
208If END is non-nil, use the end of the span instead."
209 (let* ((start (point))
210 (found (progn
211 (unless forward-only
212 (goto-char (point-min)))
213 (text-property-search-forward
214 prop value #'equal)))
215 (target (when found
216 (if end
217 (prop-match-end found)
218 (prop-match-beginning found)))))
219 (when target
220 (if goto
221 (goto-char target)
222 (prog1
223 target
224 (goto-char start))))))
225
202(declare-function gnus-find-method-for-group "gnus" (group &optional info)) 226(declare-function gnus-find-method-for-group "gnus" (group &optional info))
203(declare-function gnus-group-name-decode "gnus-group" (string charset)) 227(declare-function gnus-group-name-decode "gnus-group" (string charset))
204(declare-function gnus-group-name-charset "gnus-group" (method group)) 228(declare-function gnus-group-name-charset "gnus-group" (method group))
@@ -390,22 +414,9 @@ Cache the result as a text property stored in DATE."
390 "Quote all \"%\"'s in STRING." 414 "Quote all \"%\"'s in STRING."
391 (replace-regexp-in-string "%" "%%" string)) 415 (replace-regexp-in-string "%" "%%" string))
392 416
393;; Make a hash table (default and minimum size is 256). 417(defsubst gnus-make-hashtable (&optional size)
394;; Optional argument HASHSIZE specifies the table size. 418 "Make a hash table of SIZE, testing on `equal'."
395(defun gnus-make-hashtable (&optional hashsize) 419 (make-hash-table :size (or size 300) :test #'equal))
396 (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0))
397
398;; Make a number that is suitable for hashing; bigger than MIN and
399;; equal to some 2^x. Many machines (such as sparcs) do not have a
400;; hardware modulo operation, so they implement it in software. On
401;; many sparcs over 50% of the time to intern is spent in the modulo.
402;; Yes, it's slower than actually computing the hash from the string!
403;; So we use powers of 2 so people can optimize the modulo to a mask.
404(defun gnus-create-hash-size (min)
405 (let ((i 1))
406 (while (< i min)
407 (setq i (* 2 i)))
408 i))
409 420
410(defcustom gnus-verbose 6 421(defcustom gnus-verbose 6
411 "Integer that says how verbose Gnus should be. 422 "Integer that says how verbose Gnus should be.
@@ -1174,18 +1185,16 @@ ARG is passed to the first function."
1174 ;; The buffer should be in the unibyte mode because group names 1185 ;; The buffer should be in the unibyte mode because group names
1175 ;; are ASCII text or encoded non-ASCII text (i.e., unibyte). 1186 ;; are ASCII text or encoded non-ASCII text (i.e., unibyte).
1176 (mm-disable-multibyte) 1187 (mm-disable-multibyte)
1177 (mapatoms 1188 (maphash
1178 (lambda (sym) 1189 (lambda (group active)
1179 (when (and sym 1190 (when active
1180 (boundp sym) 1191 (insert (format "%s %d %d y\n"
1181 (symbol-value sym))
1182 (insert (format "%S %d %d y\n"
1183 (if full-names 1192 (if full-names
1184 sym 1193 group
1185 (intern (gnus-group-real-name (symbol-name sym)))) 1194 (gnus-group-real-name group))
1186 (or (cdr (symbol-value sym)) 1195 (or (cdr active)
1187 (car (symbol-value sym))) 1196 (car active))
1188 (car (symbol-value sym)))))) 1197 (car active)))))
1189 hashtb) 1198 hashtb)
1190 (goto-char (point-max)) 1199 (goto-char (point-max))
1191 (while (search-backward "\\." nil t) 1200 (while (search-backward "\\." nil t)
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 0bd15f3e392..989347c9fd1 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -29,7 +29,8 @@
29 29
30(run-hooks 'gnus-load-hook) 30(run-hooks 'gnus-load-hook)
31 31
32(eval-when-compile (require 'cl-lib)) 32(eval-when-compile (require 'cl-lib)
33 (require 'subr-x))
33(require 'wid-edit) 34(require 'wid-edit)
34(require 'mm-util) 35(require 'mm-util)
35(require 'nnheader) 36(require 'nnheader)
@@ -2453,28 +2454,37 @@ such as a mark that says whether an article is stored in the cache
2453gnus-registry.el will populate this if it's loaded.") 2454gnus-registry.el will populate this if it's loaded.")
2454 2455
2455(defvar gnus-newsrc-hashtb nil 2456(defvar gnus-newsrc-hashtb nil
2456 "Hashtable of `gnus-newsrc-alist'.") 2457 "Hash table of `gnus-newsrc-alist'.")
2458
2459(defvar gnus-group-list nil
2460 "Ordered list of group names as strings.
2461This variable only exists to provide easy access to the ordering
2462of `gnus-newsrc-alist'.")
2457 2463
2458(defvar gnus-killed-list nil 2464(defvar gnus-killed-list nil
2459 "List of killed newsgroups.") 2465 "List of killed newsgroups.")
2460 2466
2461(defvar gnus-killed-hashtb nil 2467(defvar gnus-killed-hashtb nil
2462 "Hash table equivalent of `gnus-killed-list'.") 2468 "Hash table equivalent of `gnus-killed-list'.
2469This is a hash table purely for the fast membership test: values
2470are always t.")
2463 2471
2464(defvar gnus-zombie-list nil 2472(defvar gnus-zombie-list nil
2465 "List of almost dead newsgroups.") 2473 "List of almost dead newsgroups.")
2466 2474
2467(defvar gnus-description-hashtb nil 2475(defvar gnus-description-hashtb nil
2468 "Descriptions of newsgroups.") 2476 "Hash table mapping group names to their descriptions.")
2469 2477
2470(defvar gnus-list-of-killed-groups nil 2478(defvar gnus-list-of-killed-groups nil
2471 "List of newsgroups that have recently been killed by the user.") 2479 "List of newsgroups that have recently been killed by the user.")
2472 2480
2473(defvar gnus-active-hashtb nil 2481(defvar gnus-active-hashtb nil
2474 "Hashtable of active articles.") 2482 "Hash table mapping group names to their active entry.")
2475 2483
2476(defvar gnus-moderated-hashtb nil 2484(defvar gnus-moderated-hashtb nil
2477 "Hashtable of moderated newsgroups.") 2485 "Hash table of moderated groups.
2486This is a hash table purely for the fast membership test: values
2487are always t.")
2478 2488
2479;; Save window configuration. 2489;; Save window configuration.
2480(defvar gnus-prev-winconf nil) 2490(defvar gnus-prev-winconf nil)
@@ -2800,36 +2810,21 @@ See Info node `(gnus)Formatting Variables'."
2800(defun gnus-header-from (header) 2810(defun gnus-header-from (header)
2801 (mail-header-from header)) 2811 (mail-header-from header))
2802 2812
2803(defmacro gnus-gethash (string hashtable)
2804 "Get hash value of STRING in HASHTABLE."
2805 `(symbol-value (intern-soft ,string ,hashtable)))
2806
2807(defmacro gnus-gethash-safe (string hashtable)
2808 "Get hash value of STRING in HASHTABLE.
2809Return nil if not defined."
2810 `(let ((sym (intern-soft ,string ,hashtable)))
2811 (and (boundp sym) (symbol-value sym))))
2812
2813(defmacro gnus-sethash (string value hashtable)
2814 "Set hash value. Arguments are STRING, VALUE, and HASHTABLE."
2815 `(set (intern ,string ,hashtable) ,value))
2816(put 'gnus-sethash 'edebug-form-spec '(form form form))
2817
2818(defmacro gnus-group-unread (group) 2813(defmacro gnus-group-unread (group)
2819 "Get the currently computed number of unread articles in GROUP." 2814 "Get the currently computed number of unread articles in GROUP."
2820 `(car (gnus-gethash ,group gnus-newsrc-hashtb))) 2815 `(car (gethash ,group gnus-newsrc-hashtb)))
2821 2816
2822(defmacro gnus-group-entry (group) 2817(defmacro gnus-group-entry (group)
2823 "Get the newsrc entry for GROUP." 2818 "Get the newsrc entry for GROUP."
2824 `(gnus-gethash ,group gnus-newsrc-hashtb)) 2819 `(gethash ,group gnus-newsrc-hashtb))
2825 2820
2826(defmacro gnus-active (group) 2821(defmacro gnus-active (group)
2827 "Get active info on GROUP." 2822 "Get active info on GROUP."
2828 `(gnus-gethash ,group gnus-active-hashtb)) 2823 `(gethash ,group gnus-active-hashtb))
2829 2824
2830(defmacro gnus-set-active (group active) 2825(defmacro gnus-set-active (group active)
2831 "Set GROUP's active info." 2826 "Set GROUP's active info."
2832 `(gnus-sethash ,group ,active gnus-active-hashtb)) 2827 `(puthash ,group ,active gnus-active-hashtb))
2833 2828
2834;; Info access macros. 2829;; Info access macros.
2835 2830
@@ -2893,10 +2888,10 @@ Return nil if not defined."
2893 (setcar rank (cons (car rank) ,score))))) 2888 (setcar rank (cons (car rank) ,score)))))
2894 2889
2895(defmacro gnus-get-info (group) 2890(defmacro gnus-get-info (group)
2896 `(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb))) 2891 `(nth 1 (gethash ,group gnus-newsrc-hashtb)))
2897 2892
2898(defun gnus-set-info (group info) 2893(defun gnus-set-info (group info)
2899 (setcar (nthcdr 2 (gnus-gethash group gnus-newsrc-hashtb)) 2894 (setcdr (gethash group gnus-newsrc-hashtb)
2900 info)) 2895 info))
2901 2896
2902 2897
@@ -3185,7 +3180,7 @@ that that variable is buffer-local to the summary buffers."
3185 3180
3186(defun gnus-kill-ephemeral-group (group) 3181(defun gnus-kill-ephemeral-group (group)
3187 "Remove ephemeral GROUP from relevant structures." 3182 "Remove ephemeral GROUP from relevant structures."
3188 (gnus-sethash group nil gnus-newsrc-hashtb)) 3183 (remhash group gnus-newsrc-hashtb))
3189 3184
3190(defun gnus-simplify-mode-line () 3185(defun gnus-simplify-mode-line ()
3191 "Make mode lines a bit simpler." 3186 "Make mode lines a bit simpler."
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index c491f16dd86..dae4b0dced6 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -8024,18 +8024,11 @@ regular text mode tabbing command."
8024 (skip-chars-backward "^, \t\n") (point)))) 8024 (skip-chars-backward "^, \t\n") (point))))
8025 (completion-ignore-case t) 8025 (completion-ignore-case t)
8026 (e (progn (skip-chars-forward "^,\t\n ") (point))) 8026 (e (progn (skip-chars-forward "^,\t\n ") (point)))
8027 group collection) 8027 (collection (when (and (boundp 'gnus-active-hashtb)
8028 (when (and (boundp 'gnus-active-hashtb) 8028 gnus-active-hashtb)
8029 gnus-active-hashtb) 8029 (hash-table-keys gnus-active-hashtb))))
8030 (mapatoms 8030 (when collection
8031 (lambda (symbol) 8031 (completion-in-region b e collection))))
8032 (setq group (symbol-name symbol))
8033 (push (if (string-match "[^\000-\177]" group)
8034 (gnus-group-decoded-name group)
8035 group)
8036 collection))
8037 gnus-active-hashtb))
8038 (completion-in-region b e collection)))
8039 8032
8040(defun message-expand-name () 8033(defun message-expand-name ()
8041 (cond ((and (memq 'eudc message-expand-name-databases) 8034 (cond ((and (memq 'eudc message-expand-name-databases)
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index be626858358..f6d358dfc09 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -29,6 +29,7 @@
29(require 'mml-sec) 29(require 'mml-sec)
30(eval-when-compile (require 'cl-lib)) 30(eval-when-compile (require 'cl-lib))
31(eval-when-compile (require 'url)) 31(eval-when-compile (require 'url))
32(eval-when-compile (require 'gnus-util))
32 33
33(autoload 'message-make-message-id "message") 34(autoload 'message-make-message-id "message")
34(declare-function gnus-setup-posting-charset "gnus-msg" (group)) 35(declare-function gnus-setup-posting-charset "gnus-msg" (group))
@@ -1547,7 +1548,6 @@ Should be adopted if code in `message-send-mail' is changed."
1547 1548
1548(defvar mml-preview-buffer nil) 1549(defvar mml-preview-buffer nil)
1549 1550
1550(autoload 'gnus-make-hashtable "gnus-util")
1551(autoload 'widget-button-press "wid-edit" nil t) 1551(autoload 'widget-button-press "wid-edit" nil t)
1552(declare-function widget-event-point "wid-edit" (event)) 1552(declare-function widget-event-point "wid-edit" (event))
1553;; If gnus-buffer-configuration is bound this is loaded. 1553;; If gnus-buffer-configuration is bound this is loaded.
diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el
index a90b6d554fe..3b316454107 100644
--- a/lisp/gnus/nnbabyl.el
+++ b/lisp/gnus/nnbabyl.el
@@ -624,7 +624,7 @@
624(defun nnbabyl-check-mbox () 624(defun nnbabyl-check-mbox ()
625 "Go through the nnbabyl mbox and make sure that no article numbers are reused." 625 "Go through the nnbabyl mbox and make sure that no article numbers are reused."
626 (interactive) 626 (interactive)
627 (let ((idents (make-vector 1000 0)) 627 (let ((idents (gnus-make-hashtable 1000))
628 id) 628 id)
629 (save-excursion 629 (save-excursion
630 (when (or (not nnbabyl-mbox-buffer) 630 (when (or (not nnbabyl-mbox-buffer)
@@ -633,13 +633,13 @@
633 (set-buffer nnbabyl-mbox-buffer) 633 (set-buffer nnbabyl-mbox-buffer)
634 (goto-char (point-min)) 634 (goto-char (point-min))
635 (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t) 635 (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t)
636 (if (intern-soft (setq id (match-string 1)) idents) 636 (if (gethash (setq id (match-string 1)) idents)
637 (progn 637 (progn
638 (delete-region (point-at-bol) (progn (forward-line 1) (point))) 638 (delete-region (point-at-bol) (progn (forward-line 1) (point)))
639 (nnheader-message 7 "Moving %s..." id) 639 (nnheader-message 7 "Moving %s..." id)
640 (nnbabyl-save-mail 640 (nnbabyl-save-mail
641 (nnmail-article-group 'nnbabyl-active-number))) 641 (nnmail-article-group 'nnbabyl-active-number)))
642 (intern id idents))) 642 (puthash id t idents)))
643 (when (buffer-modified-p (current-buffer)) 643 (when (buffer-modified-p (current-buffer))
644 (save-buffer)) 644 (save-buffer))
645 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) 645 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el
index 5fabeac7e39..9d02773d6f2 100644
--- a/lisp/gnus/nnmaildir.el
+++ b/lisp/gnus/nnmaildir.el
@@ -68,7 +68,9 @@
68(require 'message) 68(require 'message)
69(require 'nnmail) 69(require 'nnmail)
70 70
71(eval-when-compile (require 'cl-lib)) 71(eval-when-compile
72 (require 'cl-lib)
73 (require 'subr-x))
72 74
73(defconst nnmaildir-version "Gnus") 75(defconst nnmaildir-version "Gnus")
74 76
@@ -135,11 +137,10 @@ This variable is set by `nnmaildir-request-article'.")
135(defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid)))) 137(defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
136(defvar nnmaildir--delivery-count nil) 138(defvar nnmaildir--delivery-count nil)
137 139
138;; An obarry containing symbols whose names are server names and whose values 140(defvar nnmaildir--servers nil
139;; are servers: 141 "Alist mapping server name strings to servers.")
140(defvar nnmaildir--servers (make-vector 3 0)) 142(defvar nnmaildir--cur-server nil
141;; The current server: 143 "The current server.")
142(defvar nnmaildir--cur-server nil)
143 144
144;; A copy of nnmail-extra-headers 145;; A copy of nnmail-extra-headers
145(defvar nnmaildir--extra nil) 146(defvar nnmaildir--extra nil)
@@ -172,17 +173,17 @@ This variable is set by `nnmaildir-request-article'.")
172 (nov nil :type vector)) ;; cached nov structure, or nil 173 (nov nil :type vector)) ;; cached nov structure, or nil
173 174
174(cl-defstruct nnmaildir--grp 175(cl-defstruct nnmaildir--grp
175 (name nil :type string) ;; "group.name" 176 (name nil :type string) ;; "group.name"
176 (new nil :type list) ;; new/ modtime 177 (new nil :type list) ;; new/ modtime
177 (cur nil :type list) ;; cur/ modtime 178 (cur nil :type list) ;; cur/ modtime
178 (min 1 :type natnum) ;; minimum article number 179 (min 1 :type natnum) ;; minimum article number
179 (count 0 :type natnum) ;; count of articles 180 (count 0 :type natnum) ;; count of articles
180 (nlist nil :type list) ;; list of articles, ordered descending by number 181 (nlist nil :type list) ;; list of articles, ordered descending by number
181 (flist nil :type vector) ;; obarray mapping filename prefix->article 182 (flist nil :type hash-table) ;; hash table mapping filename prefix->article
182 (mlist nil :type vector) ;; obarray mapping message-id->article 183 (mlist nil :type hash-table) ;; hash table mapping message-id->article
183 (cache nil :type vector) ;; nov cache 184 (cache nil :type vector) ;; nov cache
184 (index nil :type natnum) ;; index of next cache entry to replace 185 (index nil :type natnum) ;; index of next cache entry to replace
185 (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime 186 (mmth nil :type hash-table)) ;; hash table mapping mark name->dir modtime
186 ; ("Mark Mod Time Hash") 187 ; ("Mark Mod Time Hash")
187 188
188(cl-defstruct nnmaildir--srv 189(cl-defstruct nnmaildir--srv
@@ -191,7 +192,7 @@ This variable is set by `nnmaildir-request-article'.")
191 (prefix nil :type string) ;; "nnmaildir+address:" 192 (prefix nil :type string) ;; "nnmaildir+address:"
192 (dir nil :type string) ;; "/expanded/path/to/server/dir/" 193 (dir nil :type string) ;; "/expanded/path/to/server/dir/"
193 (ls nil :type function) ;; directory-files function 194 (ls nil :type function) ;; directory-files function
194 (groups nil :type vector) ;; obarray mapping group name->group 195 (groups nil :type hash-table) ;; hash table mapping group name->group
195 (curgrp nil :type nnmaildir--grp) ;; current group, or nil 196 (curgrp nil :type nnmaildir--grp) ;; current group, or nil
196 (error nil :type string) ;; last error message, or nil 197 (error nil :type string) ;; last error message, or nil
197 (mtime nil :type list) ;; modtime of dir 198 (mtime nil :type list) ;; modtime of dir
@@ -238,17 +239,17 @@ This variable is set by `nnmaildir-request-article'.")
238 (setf (nnmaildir--grp-count group) count) 239 (setf (nnmaildir--grp-count group) count)
239 (setf (nnmaildir--grp-nlist group) new-nlist) 240 (setf (nnmaildir--grp-nlist group) new-nlist)
240 (setcdr nlist-pre nlist-post) 241 (setcdr nlist-pre nlist-post)
241 (unintern prefix flist) 242 (remhash prefix flist)
242 (unintern msgid mlist)))) 243 (remhash msgid mlist))))
243 244
244(defun nnmaildir--nlist-art (group num) 245(defun nnmaildir--nlist-art (group num)
245 (let ((entry (assq num (nnmaildir--grp-nlist group)))) 246 (let ((entry (assq num (nnmaildir--grp-nlist group))))
246 (if entry 247 (if entry
247 (cdr entry)))) 248 (cdr entry))))
248(defmacro nnmaildir--flist-art (list file) 249(defmacro nnmaildir--flist-art (list file)
249 `(symbol-value (intern-soft ,file ,list))) 250 `(gethash ,file ,list))
250(defmacro nnmaildir--mlist-art (list msgid) 251(defmacro nnmaildir--mlist-art (list msgid)
251 `(symbol-value (intern-soft ,msgid ,list))) 252 `(gethash ,msgid ,list))
252 253
253(defun nnmaildir--pgname (server gname) 254(defun nnmaildir--pgname (server gname)
254 (let ((prefix (nnmaildir--srv-prefix server))) 255 (let ((prefix (nnmaildir--srv-prefix server)))
@@ -337,12 +338,12 @@ This variable is set by `nnmaildir-request-article'.")
337 (if (null server) 338 (if (null server)
338 (unless (setq server nnmaildir--cur-server) 339 (unless (setq server nnmaildir--cur-server)
339 (throw 'return nil)) 340 (throw 'return nil))
340 (unless (setq server (intern-soft server nnmaildir--servers)) 341 (unless (setq server (alist-get server nnmaildir--servers
342 nil nil #'equal))
341 (throw 'return nil)) 343 (throw 'return nil))
342 (setq server (symbol-value server) 344 (setq nnmaildir--cur-server server))
343 nnmaildir--cur-server server))
344 (let ((groups (nnmaildir--srv-groups server))) 345 (let ((groups (nnmaildir--srv-groups server)))
345 (when groups 346 (when (and groups (null (hash-table-empty-p groups)))
346 (unless (nnmaildir--srv-method server) 347 (unless (nnmaildir--srv-method server)
347 (setf (nnmaildir--srv-method server) 348 (setf (nnmaildir--srv-method server)
348 (or (gnus-server-to-method 349 (or (gnus-server-to-method
@@ -350,7 +351,7 @@ This variable is set by `nnmaildir-request-article'.")
350 (throw 'return nil)))) 351 (throw 'return nil))))
351 (if (null group) 352 (if (null group)
352 (nnmaildir--srv-curgrp server) 353 (nnmaildir--srv-curgrp server)
353 (symbol-value (intern-soft group groups))))))) 354 (gethash group groups))))))
354 355
355(defun nnmaildir--tab-to-space (string) 356(defun nnmaildir--tab-to-space (string)
356 (let ((pos 0)) 357 (let ((pos 0))
@@ -574,15 +575,15 @@ This variable is set by `nnmaildir-request-article'.")
574 (if insert-nlist 575 (if insert-nlist
575 (setcdr nlist (cons (cons num article) nlist-cdr)) 576 (setcdr nlist (cons (cons num article) nlist-cdr))
576 (setf (nnmaildir--grp-nlist group) nlist)) 577 (setf (nnmaildir--grp-nlist group) nlist))
577 (set (intern (nnmaildir--art-prefix article) 578 (puthash (nnmaildir--art-prefix article)
578 (nnmaildir--grp-flist group)) 579 article
579 article) 580 (nnmaildir--grp-flist group))
580 (set (intern (nnmaildir--art-msgid article) 581 (puthash (nnmaildir--art-msgid article)
581 (nnmaildir--grp-mlist group)) 582 article
582 article) 583 (nnmaildir--grp-mlist group))
583 (set (intern (nnmaildir--grp-name group) 584 (puthash (nnmaildir--grp-name group)
584 (nnmaildir--srv-groups server)) 585 group
585 group)) 586 (nnmaildir--srv-groups server)))
586 (nnmaildir--cache-nov group article nov) 587 (nnmaildir--cache-nov group article nov)
587 t))) 588 t)))
588 589
@@ -650,9 +651,6 @@ This variable is set by `nnmaildir-request-article'.")
650 (if (< (car entry) low) (throw 'iterate-loop nil)) 651 (if (< (car entry) low) (throw 'iterate-loop nil))
651 (funcall func (cdr entry))))))) 652 (funcall func (cdr entry)))))))
652 653
653(defun nnmaildir--up2-1 (n)
654 (if (zerop n) 1 (1- (ash 1 (1+ (logb n))))))
655
656(defun nnmaildir--system-name () 654(defun nnmaildir--system-name ()
657 (replace-regexp-in-string 655 (replace-regexp-in-string
658 ":" "\\072" 656 ":" "\\072"
@@ -677,19 +675,20 @@ This variable is set by `nnmaildir-request-article'.")
677 (nnmaildir--srv-groups nnmaildir--cur-server) 675 (nnmaildir--srv-groups nnmaildir--cur-server)
678 t)) 676 t))
679 677
680(defun nnmaildir-open-server (server &optional defs) 678(defun nnmaildir-open-server (server-string &optional defs)
681 (let ((x server) 679 (let ((server (alist-get server-string nnmaildir--servers
682 dir size) 680 nil nil #'equal))
681 dir size x)
683 (catch 'return 682 (catch 'return
684 (setq server (intern-soft x nnmaildir--servers))
685 (if server 683 (if server
686 (and (setq server (symbol-value server)) 684 (and (nnmaildir--srv-groups server)
687 (nnmaildir--srv-groups server)
688 (setq nnmaildir--cur-server server) 685 (setq nnmaildir--cur-server server)
689 (throw 'return t)) 686 (throw 'return t))
690 (setq server (make-nnmaildir--srv :address x)) 687 (setq server (make-nnmaildir--srv :address server-string))
691 (let ((inhibit-quit t)) 688 (let ((inhibit-quit t))
692 (set (intern x nnmaildir--servers) server))) 689 (setf (alist-get server-string nnmaildir--servers
690 nil nil #'equal)
691 server)))
693 (setq dir (assq 'directory defs)) 692 (setq dir (assq 'directory defs))
694 (unless dir 693 (unless dir
695 (setf (nnmaildir--srv-error server) 694 (setf (nnmaildir--srv-error server)
@@ -713,8 +712,7 @@ This variable is set by `nnmaildir-request-article'.")
713 (concat "Not a function: " (prin1-to-string x))) 712 (concat "Not a function: " (prin1-to-string x)))
714 (throw 'return nil))) 713 (throw 'return nil)))
715 (setf (nnmaildir--srv-ls server) x) 714 (setf (nnmaildir--srv-ls server) x)
716 (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)) 715 (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)))
717 size (nnmaildir--up2-1 size))
718 (and (setq x (assq 'get-new-mail defs)) 716 (and (setq x (assq 'get-new-mail defs))
719 (setq x (cdr x)) 717 (setq x (cdr x))
720 (car x) 718 (car x)
@@ -734,7 +732,8 @@ This variable is set by `nnmaildir-request-article'.")
734 x (file-name-as-directory x)) 732 x (file-name-as-directory x))
735 (setf (nnmaildir--srv-target-prefix server) x)) 733 (setf (nnmaildir--srv-target-prefix server) x))
736 (setf (nnmaildir--srv-target-prefix server) ""))) 734 (setf (nnmaildir--srv-target-prefix server) "")))
737 (setf (nnmaildir--srv-groups server) (make-vector size 0)) 735 (setf (nnmaildir--srv-groups server)
736 (gnus-make-hashtable size))
738 (setq nnmaildir--cur-server server) 737 (setq nnmaildir--cur-server server)
739 t))) 738 t)))
740 739
@@ -833,10 +832,10 @@ This variable is set by `nnmaildir-request-article'.")
833 (cons (match-string 1 f) (match-string 2 f))) 832 (cons (match-string 1 f) (match-string 2 f)))
834 files))) 833 files)))
835 (when isnew 834 (when isnew
836 (setq num (nnmaildir--up2-1 (length files))) 835 (setq num (length files))
837 (setf (nnmaildir--grp-flist group) (make-vector num 0)) 836 (setf (nnmaildir--grp-flist group) (gnus-make-hashtable num))
838 (setf (nnmaildir--grp-mlist group) (make-vector num 0)) 837 (setf (nnmaildir--grp-mlist group) (gnus-make-hashtable num))
839 (setf (nnmaildir--grp-mmth group) (make-vector 1 0)) 838 (setf (nnmaildir--grp-mmth group) (gnus-make-hashtable 1))
840 (setq num (nnmaildir--param pgname 'nov-cache-size)) 839 (setq num (nnmaildir--param pgname 'nov-cache-size))
841 (if (numberp num) (if (< num 1) (setq num 1)) 840 (if (numberp num) (if (< num 1) (setq num 1))
842 (setq num 16 841 (setq num 16
@@ -862,7 +861,7 @@ This variable is set by `nnmaildir-request-article'.")
862 (cl-incf num))))) 861 (cl-incf num)))))
863 (setf (nnmaildir--grp-cache group) (make-vector num nil)) 862 (setf (nnmaildir--grp-cache group) (make-vector num nil))
864 (let ((inhibit-quit t)) 863 (let ((inhibit-quit t))
865 (set (intern gname groups) group)) 864 (puthash gname group groups))
866 (or scan-msgs (throw 'return t))) 865 (or scan-msgs (throw 'return t)))
867 (setq flist (nnmaildir--grp-flist group) 866 (setq flist (nnmaildir--grp-flist group)
868 files (mapcar 867 files (mapcar
@@ -901,49 +900,46 @@ This variable is set by `nnmaildir-request-article'.")
901 groups (nnmaildir--srv-groups nnmaildir--cur-server) 900 groups (nnmaildir--srv-groups nnmaildir--cur-server)
902 target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) 901 target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
903 (nnmaildir--with-work-buffer 902 (nnmaildir--with-work-buffer
904 (save-match-data 903 (save-match-data
905 (if (stringp scan-group) 904 (if (stringp scan-group)
906 (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls) 905 (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
907 (if (nnmaildir--srv-gnm nnmaildir--cur-server) 906 (when (nnmaildir--srv-gnm nnmaildir--cur-server)
908 (nnmail-get-new-mail 'nnmaildir nil nil scan-group)) 907 (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
909 (unintern scan-group groups)) 908 (remhash scan-group groups))
910 (setq x (file-attribute-modification-time (file-attributes srv-dir)) 909 (setq x (file-attribute-modification-time (file-attributes srv-dir))
911 scan-group (null scan-group)) 910 scan-group (null scan-group))
912 (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server)) 911 (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
913 (if scan-group 912 (when scan-group
914 (mapatoms (lambda (sym) 913 (maphash (lambda (group-name _group)
915 (nnmaildir--scan (symbol-name sym) t groups 914 (nnmaildir--scan group-name t groups
916 method srv-dir srv-ls)) 915 method srv-dir srv-ls))
917 groups)) 916 groups))
918 (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) 917 (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
919 dirs (if (zerop (length target-prefix)) 918 dirs (if (zerop (length target-prefix))
920 dirs 919 dirs
921 (seq-remove 920 (seq-remove
922 (lambda (dir) 921 (lambda (dir)
923 (and (>= (length dir) (length target-prefix)) 922 (and (>= (length dir) (length target-prefix))
924 (string= (substring dir 0 923 (string= (substring dir 0
925 (length target-prefix)) 924 (length target-prefix))
926 target-prefix))) 925 target-prefix)))
927 dirs)) 926 dirs)))
928 seen (nnmaildir--up2-1 (length dirs)) 927 (dolist (grp-dir dirs)
929 seen (make-vector seen 0)) 928 (when (nnmaildir--scan grp-dir scan-group groups
930 (dolist (grp-dir dirs) 929 method srv-dir srv-ls)
931 (if (nnmaildir--scan grp-dir scan-group groups method srv-dir 930 (push grp-dir seen)))
932 srv-ls) 931 (setq x nil)
933 (intern grp-dir seen))) 932 (maphash (lambda (gname _group)
934 (setq x nil) 933 (unless (member gname seen)
935 (mapatoms (lambda (group) 934 (push gname x)))
936 (setq group (symbol-name group)) 935 groups)
937 (unless (intern-soft group seen) 936 (dolist (grp x)
938 (setq x (cons group x)))) 937 (remhash grp groups))
939 groups) 938 (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
940 (dolist (grp x) 939 (file-attribute-modification-time (file-attributes srv-dir))))
941 (unintern grp groups)) 940 (and scan-group
942 (setf (nnmaildir--srv-mtime nnmaildir--cur-server) 941 (nnmaildir--srv-gnm nnmaildir--cur-server)
943 (file-attribute-modification-time (file-attributes srv-dir)))) 942 (nnmail-get-new-mail 'nnmaildir nil nil))))))
944 (and scan-group
945 (nnmaildir--srv-gnm nnmaildir--cur-server)
946 (nnmail-get-new-mail 'nnmaildir nil nil))))))
947 t) 943 t)
948 944
949(defun nnmaildir-request-list (&optional server) 945(defun nnmaildir-request-list (&optional server)
@@ -952,10 +948,9 @@ This variable is set by `nnmaildir-request-article'.")
952 (nnmaildir--prepare server nil) 948 (nnmaildir--prepare server nil)
953 (nnmaildir--with-nntp-buffer 949 (nnmaildir--with-nntp-buffer
954 (erase-buffer) 950 (erase-buffer)
955 (mapatoms (lambda (group) 951 (maphash (lambda (gname group)
956 (setq pgname (symbol-name group) 952 (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
957 pgname (nnmaildir--pgname nnmaildir--cur-server pgname) 953
958 group (symbol-value group)
959 ro (nnmaildir--param pgname 'read-only)) 954 ro (nnmaildir--param pgname 'read-only))
960 (insert (replace-regexp-in-string 955 (insert (replace-regexp-in-string
961 " " "\\ " 956 " " "\\ "
@@ -1035,8 +1030,7 @@ This variable is set by `nnmaildir-request-article'.")
1035 (append 1030 (append
1036 (mapcar 'cdr nnmaildir-flag-mark-mapping) 1031 (mapcar 'cdr nnmaildir-flag-mark-mapping)
1037 (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort)))) 1032 (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort))))
1038 new-mmth (nnmaildir--up2-1 (length all-marks)) 1033 new-mmth (make-hash-table :size (length all-marks))
1039 new-mmth (make-vector new-mmth 0)
1040 old-mmth (nnmaildir--grp-mmth group)) 1034 old-mmth (nnmaildir--grp-mmth group))
1041 (dolist (mark all-marks) 1035 (dolist (mark all-marks)
1042 (setq markdir (nnmaildir--subdir dir (symbol-name mark)) 1036 (setq markdir (nnmaildir--subdir dir (symbol-name mark))
@@ -1063,8 +1057,8 @@ This variable is set by `nnmaildir-request-article'.")
1063 curdir-mtime) 1057 curdir-mtime)
1064 (t 1058 (t
1065 markdir-mtime)))) 1059 markdir-mtime))))
1066 (set (intern (symbol-name mark) new-mmth) mtime) 1060 (puthash mark mtime new-mmth)
1067 (when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth))) 1061 (when (equal mtime (gethash mark old-mmth))
1068 (setq ranges (assq mark old-marks)) 1062 (setq ranges (assq mark old-marks))
1069 (if ranges (setq ranges (cdr ranges))) 1063 (if ranges (setq ranges (cdr ranges)))
1070 (throw 'got-ranges nil)) 1064 (throw 'got-ranges nil))
@@ -1126,7 +1120,7 @@ This variable is set by `nnmaildir-request-article'.")
1126 (nnmaildir--prepare server nil) 1120 (nnmaildir--prepare server nil)
1127 (catch 'return 1121 (catch 'return
1128 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) 1122 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
1129 srv-dir dir groups) 1123 srv-dir dir)
1130 (when (zerop (length gname)) 1124 (when (zerop (length gname))
1131 (setf (nnmaildir--srv-error nnmaildir--cur-server) 1125 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1132 "Invalid (empty) group name") 1126 "Invalid (empty) group name")
@@ -1140,8 +1134,8 @@ This variable is set by `nnmaildir-request-article'.")
1140 (concat "Invalid characters (null, tab, or /) in group name: " 1134 (concat "Invalid characters (null, tab, or /) in group name: "
1141 gname)) 1135 gname))
1142 (throw 'return nil)) 1136 (throw 'return nil))
1143 (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)) 1137 (when (gethash
1144 (when (intern-soft gname groups) 1138 gname (nnmaildir--srv-groups nnmaildir--cur-server))
1145 (setf (nnmaildir--srv-error nnmaildir--cur-server) 1139 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1146 (concat "Group already exists: " gname)) 1140 (concat "Group already exists: " gname))
1147 (throw 'return nil)) 1141 (throw 'return nil))
@@ -1186,7 +1180,7 @@ This variable is set by `nnmaildir-request-article'.")
1186 new-name)) 1180 new-name))
1187 (throw 'return nil)) 1181 (throw 'return nil))
1188 (if (string-equal gname new-name) (throw 'return t)) 1182 (if (string-equal gname new-name) (throw 'return t))
1189 (when (intern-soft new-name 1183 (when (gethash new-name
1190 (nnmaildir--srv-groups nnmaildir--cur-server)) 1184 (nnmaildir--srv-groups nnmaildir--cur-server))
1191 (setf (nnmaildir--srv-error nnmaildir--cur-server) 1185 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1192 (concat "Group already exists: " new-name)) 1186 (concat "Group already exists: " new-name))
@@ -1199,16 +1193,18 @@ This variable is set by `nnmaildir-request-article'.")
1199 (setf (nnmaildir--srv-error nnmaildir--cur-server) 1193 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1200 (concat "Error renaming link: " (prin1-to-string err))) 1194 (concat "Error renaming link: " (prin1-to-string err)))
1201 (throw 'return nil))) 1195 (throw 'return nil)))
1196 ;; FIXME: Why are we making copies of the group and the groups
1197 ;; hashtable? Why not just set the group's new name, and puthash the
1198 ;; group under that new name?
1202 (setq x (nnmaildir--srv-groups nnmaildir--cur-server) 1199 (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
1203 groups (make-vector (length x) 0)) 1200 groups (gnus-make-hashtable (hash-table-size x)))
1204 (mapatoms (lambda (sym) 1201 (maphash (lambda (gname g)
1205 (unless (eq (symbol-value sym) group) 1202 (unless (eq g group)
1206 (set (intern (symbol-name sym) groups) 1203 (puthash gname g groups)))
1207 (symbol-value sym))))
1208 x) 1204 x)
1209 (setq group (copy-sequence group)) 1205 (setq group (copy-sequence group))
1210 (setf (nnmaildir--grp-name group) new-name) 1206 (setf (nnmaildir--grp-name group) new-name)
1211 (set (intern new-name groups) group) 1207 (puthash new-name group groups)
1212 (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups) 1208 (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
1213 t))) 1209 t)))
1214 1210
@@ -1231,7 +1227,7 @@ This variable is set by `nnmaildir-request-article'.")
1231 (throw 'return nil)) 1227 (throw 'return nil))
1232 (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server)) 1228 (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
1233 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil)) 1229 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
1234 (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server)) 1230 (remhash gname (nnmaildir--srv-groups nnmaildir--cur-server))
1235 (if (not force) 1231 (if (not force)
1236 (progn 1232 (progn
1237 (setq grp-dir (directory-file-name grp-dir)) 1233 (setq grp-dir (directory-file-name grp-dir))
@@ -1332,10 +1328,9 @@ This variable is set by `nnmaildir-request-article'.")
1332 article (nnmaildir--mlist-art list num-msgid)) 1328 article (nnmaildir--mlist-art list num-msgid))
1333 (if article (setq num-msgid (nnmaildir--art-num article)) 1329 (if article (setq num-msgid (nnmaildir--art-num article))
1334 (catch 'found 1330 (catch 'found
1335 (mapatoms 1331 (maphash
1336 (lambda (group-sym) 1332 (lambda (_gname group)
1337 (setq group (symbol-value group-sym) 1333 (setq list (nnmaildir--grp-mlist group)
1338 list (nnmaildir--grp-mlist group)
1339 article (nnmaildir--mlist-art list num-msgid)) 1334 article (nnmaildir--mlist-art list num-msgid))
1340 (when article 1335 (when article
1341 (setq num-msgid (nnmaildir--art-num article)) 1336 (setq num-msgid (nnmaildir--art-num article))
@@ -1522,7 +1517,7 @@ This variable is set by `nnmaildir-request-article'.")
1522 (setq groups (nnmaildir--srv-groups nnmaildir--cur-server) 1517 (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1523 ga (car group-art) group-art (cdr group-art) 1518 ga (car group-art) group-art (cdr group-art)
1524 gname (car ga)) 1519 gname (car ga))
1525 (or (intern-soft gname groups) 1520 (or (gethash gname groups)
1526 (nnmaildir-request-create-group gname) 1521 (nnmaildir-request-create-group gname)
1527 (throw 'return nil)) ;; not that nnmail bothers to check :( 1522 (throw 'return nil)) ;; not that nnmail bothers to check :(
1528 (unless (nnmaildir-request-accept-article gname) 1523 (unless (nnmaildir-request-accept-article gname)
@@ -1539,7 +1534,7 @@ This variable is set by `nnmaildir-request-article'.")
1539 (mapcar 1534 (mapcar
1540 (lambda (ga) 1535 (lambda (ga)
1541 (setq gname (car ga)) 1536 (setq gname (car ga))
1542 (and (or (intern-soft gname groups) 1537 (and (or (gethash gname groups)
1543 (nnmaildir-request-create-group gname)) 1538 (nnmaildir-request-create-group gname))
1544 (nnmaildir-request-accept-article gname) 1539 (nnmaildir-request-accept-article gname)
1545 ga)) 1540 ga))
@@ -1749,36 +1744,38 @@ This variable is set by `nnmaildir-request-article'.")
1749 (lambda (dir) 1744 (lambda (dir)
1750 (cons dir (funcall ls dir nil "\\`[^.]" 'nosort))) 1745 (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
1751 dirs) 1746 dirs)
1752 files (funcall ls msgdir nil "\\`[^.]" 'nosort) 1747 files (funcall ls msgdir nil "\\`[^.]" 'nosort))
1753 flist (nnmaildir--up2-1 (length files))
1754 flist (make-vector flist 0))
1755 (save-match-data 1748 (save-match-data
1756 (dolist (file files) 1749 (dolist (file files)
1757 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) 1750 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1758 (intern (match-string 1 file) flist))) 1751 (push (match-string 1 file) flist)))
1759 (dolist (dir dirs) 1752 (dolist (dir dirs)
1760 (setq files (cdr dir) 1753 (setq files (cdr dir)
1761 dir (file-name-as-directory (car dir))) 1754 dir (file-name-as-directory (car dir)))
1762 (dolist (file files) 1755 (dolist (file files)
1763 (unless (or (intern-soft file flist) (string= file ":")) 1756 (unless (or (member file flist) (string= file ":"))
1764 (setq file (concat dir file)) 1757 (setq file (concat dir file))
1765 (delete-file file)))) 1758 (delete-file file))))
1766 t))) 1759 t)))
1767 1760
1768(defun nnmaildir-close-server (&optional server) 1761(defun nnmaildir-close-server (&optional server)
1769 (nnmaildir--prepare server nil) 1762 "Close SERVER, or the current maildir server."
1770 (when nnmaildir--cur-server 1763 (when (nnmaildir--prepare server nil)
1771 (setq server nnmaildir--cur-server 1764 (setq server nnmaildir--cur-server
1772 nnmaildir--cur-server nil) 1765 nnmaildir--cur-server nil)
1773 (unintern (nnmaildir--srv-address server) nnmaildir--servers)) 1766
1767 ;; This slightly obscure invocation of `alist-get' removes SERVER from
1768 ;; `nnmaildir-servers'.
1769 (setf (alist-get (nnmaildir--srv-address server)
1770 nnmaildir--servers server 'remove #'equal)
1771 server))
1774 t) 1772 t)
1775 1773
1776(defun nnmaildir-request-close () 1774(defun nnmaildir-request-close ()
1777 (let (servers buffer) 1775 (let ((servers
1778 (mapatoms (lambda (server) 1776 (mapcar #'car nnmaildir--servers))
1779 (setq servers (cons (symbol-name server) servers))) 1777 buffer)
1780 nnmaildir--servers) 1778 (mapc #'nnmaildir-close-server servers)
1781 (mapc 'nnmaildir-close-server servers)
1782 (setq buffer (get-buffer " *nnmaildir work*")) 1779 (setq buffer (get-buffer " *nnmaildir work*"))
1783 (if buffer (kill-buffer buffer)) 1780 (if buffer (kill-buffer buffer))
1784 (setq buffer (get-buffer " *nnmaildir nov*")) 1781 (setq buffer (get-buffer " *nnmaildir nov*"))
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index ee04b87dfe8..c80bbf61875 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -234,14 +234,12 @@ component group will show up when you enter the virtual group.")
234 nnvirtual-mapping-marks nil 234 nnvirtual-mapping-marks nil
235 nnvirtual-info-installed nil) 235 nnvirtual-info-installed nil)
236 (when nnvirtual-component-regexp 236 (when nnvirtual-component-regexp
237 ;; Go through the newsrc alist and find all component groups. 237 ;; Go through the list of groups and find all component groups.
238 (let ((newsrc (cdr gnus-newsrc-alist)) 238 (dolist (group (cdr gnus-group-list))
239 group) 239 (when (string-match nnvirtual-component-regexp group) ; Match
240 (while (setq group (car (pop newsrc))) 240 ;; Add this group to the list of component groups.
241 (when (string-match nnvirtual-component-regexp group) ; Match 241 (setq nnvirtual-component-groups
242 ;; Add this group to the list of component groups. 242 (cons group (delete group nnvirtual-component-groups))))))
243 (setq nnvirtual-component-groups
244 (cons group (delete group nnvirtual-component-groups)))))))
245 (if (not nnvirtual-component-groups) 243 (if (not nnvirtual-component-groups)
246 (nnheader-report 'nnvirtual "No component groups: %s" server) 244 (nnheader-report 'nnvirtual "No component groups: %s" server)
247 t))) 245 t)))
@@ -372,7 +370,7 @@ component group will show up when you enter the virtual group.")
372(defun nnvirtual-convert-headers () 370(defun nnvirtual-convert-headers ()
373 "Convert HEAD headers into NOV headers." 371 "Convert HEAD headers into NOV headers."
374 (with-current-buffer nntp-server-buffer 372 (with-current-buffer nntp-server-buffer
375 (let* ((dependencies (make-vector 100 0)) 373 (let* ((dependencies (make-hash-table :test #'equal))
376 (headers (gnus-get-newsgroup-headers dependencies))) 374 (headers (gnus-get-newsgroup-headers dependencies)))
377 (erase-buffer) 375 (erase-buffer)
378 (mapc 'nnheader-insert-nov headers)))) 376 (mapc 'nnheader-insert-nov headers))))
diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el
index 357af103da7..7b87502d0e0 100644
--- a/lisp/gnus/nnweb.el
+++ b/lisp/gnus/nnweb.el
@@ -109,7 +109,7 @@ Valid types include `google', `dejanews', and `gmane'.")
109(deffoo nnweb-request-scan (&optional group server) 109(deffoo nnweb-request-scan (&optional group server)
110 (nnweb-possibly-change-server group server) 110 (nnweb-possibly-change-server group server)
111 (if nnweb-ephemeral-p 111 (if nnweb-ephemeral-p
112 (setq nnweb-hashtb (gnus-make-hashtable 4095)) 112 (setq nnweb-hashtb (gnus-make-hashtable 4000))
113 (unless nnweb-articles 113 (unless nnweb-articles
114 (nnweb-read-overview group))) 114 (nnweb-read-overview group)))
115 (funcall (nnweb-definition 'map)) 115 (funcall (nnweb-definition 'map))
@@ -229,11 +229,11 @@ Valid types include `google', `dejanews', and `gmane'.")
229 (nnheader-insert-nov (cadr (pop articles))))))) 229 (nnheader-insert-nov (cadr (pop articles)))))))
230 230
231(defun nnweb-set-hashtb (header data) 231(defun nnweb-set-hashtb (header data)
232 (gnus-sethash (nnweb-identifier (mail-header-xref header)) 232 (puthash (nnweb-identifier (mail-header-xref header))
233 data nnweb-hashtb)) 233 data nnweb-hashtb))
234 234
235(defun nnweb-get-hashtb (url) 235(defun nnweb-get-hashtb (url)
236 (gnus-gethash (nnweb-identifier url) nnweb-hashtb)) 236 (gethash (nnweb-identifier url) nnweb-hashtb))
237 237
238(defun nnweb-identifier (ident) 238(defun nnweb-identifier (ident)
239 (funcall (nnweb-definition 'identifier) ident)) 239 (funcall (nnweb-definition 'identifier) ident))
@@ -268,7 +268,7 @@ Valid types include `google', `dejanews', and `gmane'.")
268 (unless nnweb-group-alist 268 (unless nnweb-group-alist
269 (nnweb-read-active)) 269 (nnweb-read-active))
270 (unless nnweb-hashtb 270 (unless nnweb-hashtb
271 (setq nnweb-hashtb (gnus-make-hashtable 4095))) 271 (setq nnweb-hashtb (make-hash-table :size 4000 :test #'equal)))
272 (when group 272 (when group
273 (setq nnweb-group group))) 273 (setq nnweb-group group)))
274 274
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 2b9ec6fece6..26e084320bd 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -466,11 +466,14 @@ looks like an email address, \"ftp://\" if it starts with
466 (while htbs 466 (while htbs
467 (setq htb (car htbs) htbs (cdr htbs)) 467 (setq htb (car htbs) htbs (cdr htbs))
468 (ignore-errors 468 (ignore-errors
469 ;; errs: htb symbol may be unbound, or not a hash-table. 469 (setq htb (symbol-value htb))
470 ;; gnus-gethash is just a macro for intern-soft. 470 (when (cond ((obarrayp htb)
471 (and (symbol-value htb) 471 (intern-soft string htb))
472 (intern-soft string (symbol-value htb)) 472 ((listp htb)
473 (setq ret string htbs nil)) 473 (member string htb))
474 ((hash-table-p htb)
475 (gethash string htb)))
476 (setq ret string htbs nil))
474 ;; If we made it this far, gnus is running, so ignore "heads": 477 ;; If we made it this far, gnus is running, so ignore "heads":
475 (setq heads nil))) 478 (setq heads nil)))
476 (or ret (not heads) 479 (or ret (not heads)
diff --git a/test/lisp/gnus/gnus-test-headers.el b/test/lisp/gnus/gnus-test-headers.el
new file mode 100644
index 00000000000..805a3003331
--- /dev/null
+++ b/test/lisp/gnus/gnus-test-headers.el
@@ -0,0 +1,176 @@
1;;; gnus-test-headers.el --- Tests for Gnus header-related functions -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2018 Free Software Foundation, Inc.
4
5;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>
6
7;; This program is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;; The tests her are for
23
24;;; Code:
25
26(require 'ert)
27(require 'gnus-sum)
28
29(defconst gnus-headers-test-data
30 '([2 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>"
31 "Thu, 14 Sep 2000 11:10:46 +0100"
32 "<200009141010.LAA26351@djlvig.dl.ac.uk>"
33 "<20000913175943.A26093@sparky.nisa.net>"
34 1882 16 "nnmaildir mails:2"
35 ((To . "Jeff Bailey <jbailey@nisa.net>")
36 (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
37 [3 "Re: [Emacs-devel] Emacs move" "Sam Steingold <sds@gnu.org>"
38 "14 Sep 2000 10:21:56 -0400" "<upum7xddn.fsf@xchange.com>"
39 "<20000913175943.A26093@sparky.nisa.net>"
40 2991 50 "nnmaildir mails:3"
41 ((To . "Jeff Bailey <jbailey@nisa.net>")
42 (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
43 [4 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
44 "Thu, 14 Sep 2000 09:14:47 -0700"
45 "<20000914091447.G4827@sparky.nisa.net>"
46 "<20000913175943.A26093@sparky.nisa.net> <upum7xddn.fsf@xchange.com>"
47 1780 15 "nnmaildir mails:4"
48 ((To . "sds@gnu.org, Jeff Bailey <jbailey@nisa.net>")
49 (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
50 [5 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>"
51 "Thu, 14 Sep 2000 18:24:36 +0100"
52 "<200009141724.SAA26807@djlvig.dl.ac.uk>"
53 "<20000913175943.A26093@sparky.nisa.net>"
54 1343 9 "nnmaildir mails:5"
55 ((To . "Jeff Bailey <jbailey@nisa.net>")
56 (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
57 [6 "Re: [Emacs-devel] Emacs move" "Karl Fogel <kfogel@galois.collab.net>"
58 "14 Sep 2000 10:37:35 -0500" "<87em2nyog0.fsf@galois.collab.net>"
59 "<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk>"
60 3740 124 "nnmaildir mails:6"
61 ((To . "Dave Love <d.love@dl.ac.uk>")
62 (Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
63 [7 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
64 "Thu, 14 Sep 2000 10:55:12 -0700"
65 "<20000914105512.A29291@sparky.nisa.net>"
66 "<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk> <87em2nyog0.fsf@galois.collab.net>"
67 1687 16 "nnmaildir mails:7"
68 ((To . "kfogel@red-bean.com, Dave Love <d.love@dl.ac.uk>")
69 (Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
70 [8 "Re: [Emacs-devel] Emacs move" "John Wiegley <johnw@gnu.org>"
71 "Thu, 14 Sep 2000 12:19:01 -0700"
72 "<200009141919.MAA05085@localhost.localdomain>"
73 "<20000913175943.A26093@sparky.nisa.net>"
74 1978 27 "nnmaildir mails:8"
75 ((To . "emacs-devel@gnu.org"))]
76 [9 "Re: [Emacs-devel] Emacs move"
77 "\"Robert J. Chassell\" <bob@rattlesnake.com>"
78 "Thu, 14 Sep 2000 07:33:15 -0400 (EDT)"
79 "<m13ZXGV-000BCgC@megalith.rattlesnake.com>"
80 "<20000913175943.A26093@sparky.nisa.net>"
81 3046 72 "nnmaildir mails:9"
82 ((To . "jbailey@nisa.net")
83 (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
84 [10 "Re: [Emacs-devel] Emacs move"
85 "wmperry@aventail.com (William M. Perry)"
86 "14 Sep 2000 09:10:25 -0500"
87 "<86g0n3f4j2.fsf@megalith.bp.aventail.com>"
88 "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
89 3104 44 "nnmaildir mails:10"
90 ((To . "bob@rattlesnake.com")
91 (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
92 [11 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>"
93 "Thu, 14 Sep 2000 21:51:05 +0200 (CEST)"
94 "<200009141951.VAA06005@gerd.segv.de>"
95 "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <86g0n3f4j2.fsf@megalith.bp.aventail.com>"
96 1884 6 "nnmaildir mails:11"
97 ((To . "wmvperry@aventail.com")
98 (Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
99 [12 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>"
100 "Thu, 14 Sep 2000 21:49:03 +0200 (CEST)"
101 "<200009141949.VAA05998@gerd.segv.de>"
102 "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
103 2408 24 "nnmaildir mails:12"
104 ((To . "bob@rattlesnake.com")
105 (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
106 [13 "Re: [Emacs-devel] Emacs move"
107 "\"Robert J. Chassell\" <bob@rattlesnake.com>"
108 "Thu, 14 Sep 2000 17:50:01 -0400 (EDT)"
109 "<m13ZgtN-000BD3C@megalith.rattlesnake.com>"
110 "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de>"
111 1968 23 "nnmaildir mails:13"
112 ((To . "gerd@gnu.org")
113 (Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
114 [14 "Re: [Emacs-devel] Emacs move" "Richard Stallman <rms@gnu.org>"
115 "Fri, 15 Sep 2000 16:28:12 -0600 (MDT)"
116 "<200009152228.QAA20526@wijiji.santafe.edu>"
117 "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>"
118 1288 2 "nnmaildir mails:14"
119 ((To . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]
120 [15 "[Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
121 "Wed, 13 Sep 2000 17:59:43 -0700"
122 "<20000913175943.A26093@sparky.nisa.net>" ""
123 1661 26 "nnmaildir mails:15"
124 ((To . "emacs-devel@gnu.org")
125 (Cc . "cvs-hackers@gnu.org"))]
126 [16 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>"
127 "Fri, 15 Sep 2000 22:00:12 -0700"
128 "<20000915220012.A3923@sparky.nisa.net>"
129 "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de> <m13ZgtN-000BD3C@megalith.rattlesnake.com>"
130 2857 51 "nnmaildir mails:16"
131 ((To . "bob@rattlesnake.com, gerd@gnu.org")
132 (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))])
133 "A pile of headers with potential interdependencies.")
134
135(ert-deftest gnus-headers-make-dependency-table ()
136 (let ((table (gnus-make-hashtable 20))
137 (data (copy-sequence gnus-headers-test-data))
138 ret)
139 (dolist (h data)
140 ;; `gnus-dependencies-add-header' returns nil if it fails to add
141 ;; the header.
142 (should (gnus-dependencies-add-header h table nil)))
143 ;; Pick a value to test.
144 (setq ret (gethash "<m13ZXGV-000BCgC@megalith.rattlesnake.com>"
145 table))
146 ;; The message has three children.
147 (should (= 3 (length (cdr ret))))
148 ;; The first of those children has one child.
149 (should (= 1 (length (cdr (nth 1 ret)))))))
150
151(ert-deftest gnus-headers-loop-dependencies ()
152 "Intentionally create a reference loop."
153 (let ((table (gnus-make-hashtable 20))
154 (data (copy-sequence gnus-headers-test-data))
155 (parent-id "<200009141724.SAA26807@djlvig.dl.ac.uk>")
156 (child-id "<87em2nyog0.fsf@galois.collab.net>")
157 parent)
158 (dolist (h data)
159 (gnus-dependencies-add-header h table nil))
160
161 (setq parent (gethash parent-id table))
162
163 ;; Put the parent header in the child references of one of its own
164 ;; children. `gnus-thread-loop-p' only checks if there's a loop
165 ;; between parent and immediate child, not parent and random
166 ;; descendant. At least, near as I can tell that's the case.
167
168 (push (list (car parent)) (cdr (gethash child-id table)))
169
170 (let ((gnus-newsgroup-dependencies table))
171 (should
172 (= 1 ; 1 indicates an infloop.
173 (gnus-thread-loop-p (car parent) (cadr parent)))))))
174
175(provide 'gnus-test-headers)
176;;; gnus-test-headers.el ends here