Commit c1b63af4 authored by Eric Abrahamsen's avatar Eric Abrahamsen

Change Gnus hash tables into real hash tables

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

* lisp/gnus/gnus-util.el (gnus-intern-safe, gnus-create-hash-size):
  Remove functions.
  (gnus-make-hashtable): Change to return a real hash table.
  (gnus-text-property-search): Utility similar to `text-property-any',
  but compares on `equal'. Needed because the 'gnus-group text
  property is now a string.
* lisp/gnus/gnus.el (gnus-gethash, gnus-gethash-safe, gnus-sethash):
  Remove macros.
  (gnus-group-list): New variable holding all group names as an
  ordered list. Used because `gnus-newsrc-hashtb' used to preserve
  `gnus-newsrc-alist' ordering, but now doesn't.
* lisp/gnus/nnmaildir.el (nnmaildir--servers): Change from obarray to
  alist.
  (nnmaildir--up2-1): Remove function.
* lisp/thingatpt.el (thing-at-point-newsgroup-p): This was making use
  of Gnus obarrays, replace with a cond that can handle many different
  possibilities.
* lisp/gnus/gnus-bcklg.el (gnus-backlog-articles): Remove
  gnus-backlog-hashtb, which wasn't doing anything. Just keep a list
  of ident strings in gnus-backlog-articles.
  (gnus-backlog-setup): Delete unnecessary function.
  (gnus-backlog-enter-article, gnus-backlog-remove-oldest-article,
  gnus-backlog-remove-article, gnus-backlog-request-article): Alter
  calls accordingly.
* lisp/gnus/gnus-dup.el (gnus-duplicate-list-max-length): Rename from
  `gnus-duplicate-list-length', for accuracy.
* lisp/gnus/gnus-start.el (gnus-active-to-gnus-format,
  gnus-groups-to-gnus-format, gnus-newsrc-to-gnus-format): Read group
  names as strings.
  (gnus-gnus-to-quick-newsrc-format): Write `gnus-newsrc-alist' using
  the ordering in `gnus-group-list'.
* lisp/gnus/gnus-agent.el:
* lisp/gnus/gnus-async.el:
* lisp/gnus/gnus-cache.el:
* lisp/gnus/gnus-group.el:
* lisp/gnus/gnus-score.el:
* lisp/gnus/gnus-sum.el:
* lisp/gnus/gnus-topic.el:
* lisp/gnus/message.el:
* lisp/gnus/mml.el:
* lisp/gnus/nnagent.el:
* lisp/gnus/nnbabyl.el:
* lisp/gnus/nnvirtual.el:
* lisp/gnus/nnweb.el: In all files, change obarrays to hash-tables,
  and swap `gnus-sethash' for `puthash', `gnus-gethash' for `gethash',
  `mapatoms' for `maphash', etc.
* test/lisp/gnus/gnus-test-headers.el (gnus-headers-make-dependency-table,
  gnus-headers-loop-dependencies): New tests to make sure we're
  building `gnus-newsgroup-dependencies' correctly.
parent 3375d082
Pipeline #1056 passed with stage
in 51 minutes and 12 seconds
This diff is collapsed.
......@@ -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)))
......
......@@ -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
......
......@@ -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)))
......
......@@ -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)
......
This diff is collapsed.
......@@ -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 ()
......
This diff is collapsed.
This diff is collapsed.
......@@ -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.
......
......@@ -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)