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

Change Gnus hash tables into real hash tables

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

51
lisp/gnus/gnus.el
View file

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

17
lisp/gnus/message.el
View file

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

2
lisp/gnus/mml.el
View file

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

6
lisp/gnus/nnbabyl.el
View file

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

269
lisp/gnus/nnmaildir.el
View file

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

16
lisp/gnus/nnvirtual.el
View file

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

8
lisp/gnus/nnweb.el
View file

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

13
lisp/thingatpt.el
View file

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

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

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