diff options
| author | Eric Abrahamsen | 2018-04-26 16:26:27 -0700 |
|---|---|---|
| committer | Eric Abrahamsen | 2019-03-22 10:23:30 -0700 |
| commit | c1b63af4458e92bad33da0def2b15c206656e2fa (patch) | |
| tree | 267503989ec0475b76800bb309f6cdc1da53e74e | |
| parent | 3375d08299bbc1e224d19a871012cdbbf5d787ee (diff) | |
| download | emacs-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.el | 278 | ||||
| -rw-r--r-- | lisp/gnus/gnus-async.el | 29 | ||||
| -rw-r--r-- | lisp/gnus/gnus-bcklg.el | 114 | ||||
| -rw-r--r-- | lisp/gnus/gnus-cache.el | 60 | ||||
| -rw-r--r-- | lisp/gnus/gnus-dup.el | 22 | ||||
| -rw-r--r-- | lisp/gnus/gnus-group.el | 297 | ||||
| -rw-r--r-- | lisp/gnus/gnus-score.el | 27 | ||||
| -rw-r--r-- | lisp/gnus/gnus-start.el | 500 | ||||
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 220 | ||||
| -rw-r--r-- | lisp/gnus/gnus-topic.el | 48 | ||||
| -rw-r--r-- | lisp/gnus/gnus-util.el | 77 | ||||
| -rw-r--r-- | lisp/gnus/gnus.el | 51 | ||||
| -rw-r--r-- | lisp/gnus/message.el | 17 | ||||
| -rw-r--r-- | lisp/gnus/mml.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/nnbabyl.el | 6 | ||||
| -rw-r--r-- | lisp/gnus/nnmaildir.el | 269 | ||||
| -rw-r--r-- | lisp/gnus/nnvirtual.el | 16 | ||||
| -rw-r--r-- | lisp/gnus/nnweb.el | 8 | ||||
| -rw-r--r-- | lisp/thingatpt.el | 13 | ||||
| -rw-r--r-- | test/lisp/gnus/gnus-test-headers.el | 176 |
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. | ||
| 230 | Actually 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. |
| 644 | Optional arg GROUP-NAME allows another group to be specified." | 646 | Optional 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." | |||
| 2188 | gnus-agent-article-local. If that variable had `dirty' (also known as | 2193 | gnus-agent-article-local. If that variable had `dirty' (also known as |
| 2189 | modified) original contents, they are first saved to their own file." | 2194 | modified) 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 |
| 4134 | modified." | 4133 | modified." |
| @@ -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. |
| 671 | The update is performed if ACTIVE contains a higher or lower bound | 674 | The update is performed if ACTIVE contains a higher or lower bound |
| 672 | than the current." | 675 | than 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. |
| 689 | If LOW, update the lower bound instead." | 692 | If 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; | |||
| 1313 | if it is a string, only list groups matching REGEXP." | 1311 | if 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. |
| 2179 | The arguments are the same as `completing-read' except that COLLECTION | 2170 | Non-ASCII group names are allowed. The arguments are the same as |
| 2180 | and HIST default to `gnus-active-hashtb' and `gnus-group-history' | 2171 | `completing-read' except that COLLECTION and HIST default to |
| 2181 | respectively if they are omitted. Regards COLLECTION as a hash table | 2172 | `gnus-active-hashtb' and `gnus-group-history' respectively if |
| 2182 | if it is not a list." | 2173 | they are omitted. Can handle COLLECTION as a list, hash table, |
| 2174 | or 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 | |||
| 2562 | If FAR, it is likely that the group is not on the current line. | 2565 | If FAR, it is likely that the group is not on the current line. |
| 2563 | If TEST-MARKED, the line must be marked." | 2566 | If 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 | |||
| 2837 | be deleted. This is \"deleted\" as in \"removed forever from the face | 2832 | be deleted. This is \"deleted\" as in \"removed forever from the face |
| 2838 | of the Earth\". There is no undo. The user will be prompted before | 2833 | of the Earth\". There is no undo. The user will be prompted before |
| 2839 | doing the deletion. | 2834 | doing the deletion. |
| 2835 | |||
| 2840 | Note that you also have to specify FORCE if you want the group to | 2836 | Note that you also have to specify FORCE if you want the group to |
| 2841 | be removed from the server, even when it's empty." | 2837 | be 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, | |||
| 3627 | or nil if no action could be taken." | 3622 | or 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. | ||
| 1253 | This is the fundamental function for changing subscription levels | ||
| 1254 | of newsgroups. This might mean just changing from level 1 to 2, | ||
| 1255 | which is pretty trivial, from 2 to 6 or back again, which | ||
| 1256 | subscribes/unsubscribes a group, which is equally trivial. | ||
| 1257 | Changing from 1-7 to 8-9 means that you kill a group, and from | ||
| 1258 | 8-9 to 1-7 means that you remove the group from the list of | ||
| 1259 | killed (or zombie) groups and add them to the (kinda) subscribed | ||
| 1260 | groups. And last but not least, moving from 8 to 9 and 9 to 8, | ||
| 1261 | which is trivial. ENTRY can either be a string (newsgroup name) | ||
| 1262 | or a list (if FROMKILLED is t, it's a list on the format (NUM | ||
| 1263 | INFO-LIST), otherwise it's a list in the format of the | ||
| 1264 | `gnus-newsrc-hashtb' entries. LEVEL is the new level of the | ||
| 1265 | group, OLDLEVEL is the old level and PREVIOUS is the group (a | ||
| 1266 | string 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'. | ||
| 1813 | The keys are group names, and values are a cons of (unread info), | ||
| 1814 | where unread is an integer count of calculated unread | ||
| 1815 | messages (or nil), and info is a regular gnus info entry. | ||
| 1816 | |||
| 1817 | The 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 | 2713 | Use the group string names in `gnus-group-list' to pull info |
| 2782 | ;; from the variable gnus-newsrc-alist. | 2714 | values 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. |
| 2832 | Unless optional argument MINIMAL is non-nil, print human-readable | ||
| 2833 | information in the header of the file, including the file | ||
| 2834 | version. If NAME is present, print that as part of the header. | ||
| 2835 | |||
| 2836 | Variables printed are either the variables specified in | ||
| 2837 | SPECIFIC-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 | |||
| 4311 | If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even | 4320 | If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even |
| 4312 | if it was already present. | 4321 | if it was already present. |
| 4313 | 4322 | ||
| @@ -4318,33 +4327,38 @@ Message-ID before being entered. | |||
| 4318 | 4327 | ||
| 4319 | Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." | 4328 | Returns 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. | ||
| 198 | Behaves like a combination of `text-property-any' and | ||
| 199 | `text-property-search-forward'. Searches for the beginning of a | ||
| 200 | text property `equal' to VALUE. Returns the value of point at | ||
| 201 | the beginning of the matching text property span. | ||
| 202 | |||
| 203 | If FORWARD-ONLY is non-nil, only search forward from point. | ||
| 204 | |||
| 205 | If GOTO is non-nil, move point to the beginning of that span | ||
| 206 | instead. | ||
| 207 | |||
| 208 | If 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 | |||
| 2453 | gnus-registry.el will populate this if it's loaded.") | 2454 | gnus-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. | ||
| 2461 | This variable only exists to provide easy access to the ordering | ||
| 2462 | of `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'. |
| 2469 | This is a hash table purely for the fast membership test: values | ||
| 2470 | are 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. |
| 2486 | This is a hash table purely for the fast membership test: values | ||
| 2487 | are 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. | ||
| 2809 | Return 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 | ||