diff options
Diffstat (limited to 'lisp/gnus/gnus-group.el')
| -rw-r--r-- | lisp/gnus/gnus-group.el | 633 |
1 files changed, 311 insertions, 322 deletions
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index bcff8621925..f49ed164439 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -24,10 +24,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) -(defvar tool-bar-mode) - +(require 'cl-lib) (require 'gnus) (require 'gnus-start) (require 'nnmail) @@ -41,11 +38,14 @@ (eval-when-compile (require 'mm-url) + (require 'subr-x) (let ((features (cons 'gnus-group features))) (require 'gnus-sum)) (unless (boundp 'gnus-cache-active-hashtb) (defvar gnus-cache-active-hashtb nil))) +(defvar tool-bar-mode) + (autoload 'gnus-agent-total-fetched-for "gnus-agent") (autoload 'gnus-cache-total-fetched-for "gnus-cache") @@ -497,7 +497,7 @@ simple manner." (defvar gnus-tmp-number-of-unread) (defvar gnus-group-line-format-alist - `((?M gnus-tmp-marked-mark ?c) + '((?M gnus-tmp-marked-mark ?c) (?S gnus-tmp-subscribed ?c) (?L gnus-tmp-level ?d) (?N (cond ((eq number t) "*" ) @@ -545,7 +545,7 @@ simple manner." )) (defvar gnus-group-mode-line-format-alist - `((?S gnus-tmp-news-server ?s) + '((?S gnus-tmp-news-server ?s) (?M gnus-tmp-news-method ?s) (?u gnus-tmp-user-defined ?s) (?: gnus-tmp-colon ?s))) @@ -568,8 +568,6 @@ simple manner." ;;; Gnus group mode ;;; -(put 'gnus-group-mode 'mode-class 'special) - (gnus-define-keys gnus-group-mode-map " " gnus-group-read-group "=" gnus-group-select-group @@ -783,7 +781,7 @@ simple manner." (easy-menu-define gnus-group-reading-menu gnus-group-mode-map "" - `("Group" + '("Group" ["Read" gnus-group-read-group :included (not (gnus-topic-mode-p)) :active (gnus-group-group-name)] @@ -950,7 +948,7 @@ simple manner." (easy-menu-define gnus-group-misc-menu gnus-group-mode-map "" - `("Gnus" + '("Gnus" ["Send a mail" gnus-group-mail t] ["Send a message (mail or news)" gnus-group-post-news t] ["Create a local message" gnus-group-news t] @@ -1086,6 +1084,8 @@ See `gmm-tool-bar-from-list' for the format of the list." (defvar image-load-path) (defvar tool-bar-map) +(declare-function image-load-path-for-library "image" + (library image &optional path no-error)) (defun gnus-group-make-tool-bar (&optional force) "Make a group mode tool bar from `gnus-group-tool-bar'. @@ -1105,9 +1105,8 @@ When FORCE, rebuild the tool bar." (set (make-local-variable 'tool-bar-map) map)))) gnus-group-tool-bar-map) -(define-derived-mode gnus-group-mode fundamental-mode "Group" +(define-derived-mode gnus-group-mode gnus-mode "Group" "Major mode for reading news. - All normal editing commands are switched off. \\<gnus-group-mode-map> The group buffer lists (some of) the groups available. For instance, @@ -1130,8 +1129,7 @@ The following commands are available: (setq mode-line-process nil) (buffer-disable-undo) (setq truncate-lines t) - (setq buffer-read-only t - show-trailing-whitespace nil) + (setq show-trailing-whitespace nil) (gnus-set-default-directory) (gnus-update-format-specifications nil 'group 'group-mode) (gnus-update-group-mark-positions) @@ -1145,14 +1143,14 @@ 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) (goto-char (point-min)) (setq gnus-group-mark-positions (list (cons 'process (and (search-forward - (string-to-multibyte "\200") nil t) + (string gnus-process-mark) nil t) (- (point) (point-min) 1)))))))) (defun gnus-mouse-pick-group (e) @@ -1189,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))) @@ -1270,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. @@ -1316,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))) @@ -1324,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 (gnus-get-info g) 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))) @@ -1359,6 +1352,8 @@ if it is a string, only list groups matching REGEXP." (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) + ;; Marked groups are always visible. + (member group gnus-group-marked) (memq 'visible params) (cdr (assq 'visible params))))))) (gnus-group-insert-group-line @@ -1394,39 +1389,35 @@ if it is a string, only list groups matching REGEXP." ;; List zombies and killed lists somewhat faster, which was ;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does ;; this by ignoring the group format specification altogether. - (let (group) - (if (> (length groups) gnus-group-listing-limit) - (while groups - (setq group (pop groups)) - (when (gnus-group-prepare-logic - group - (or (not regexp) - (and (stringp regexp) (string-match regexp group)) - (and (functionp regexp) (funcall regexp group)))) - (add-text-properties - (point) (prog1 (1+ (point)) - (insert " " mark " *: " - (gnus-group-decoded-name group) - "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) - 'gnus-unread t - 'gnus-level level)))) - (while groups - (setq group (pop groups)) + (if (nthcdr gnus-group-listing-limit groups) + (dolist (group groups) (when (gnus-group-prepare-logic group - (or (not regexp) - (and (stringp regexp) (string-match regexp group)) - (and (functionp regexp) (funcall regexp group)))) - (gnus-group-insert-group-line - group level nil - (let ((active (gnus-active group))) - (if active - (if (zerop (cdr active)) - 0 - (- (1+ (cdr active)) (car active))) - nil)) - (gnus-method-simplify (gnus-find-method-for-group group)))))))) + (cond ((not regexp)) + ((stringp regexp) (string-match-p regexp group)) + ((functionp regexp) (funcall regexp group)))) + (add-text-properties + (point) (prog1 (1+ (point)) + (insert " " mark " *: " + (gnus-group-decoded-name group) + "\n")) + (list 'gnus-group group + 'gnus-unread t + 'gnus-level level)))) + (dolist (group groups) + (when (gnus-group-prepare-logic + group + (cond ((not regexp)) + ((stringp regexp) (string-match-p regexp group)) + ((functionp regexp) (funcall regexp group)))) + (gnus-group-insert-group-line + group level nil + (let ((active (gnus-active group))) + (and active + (if (zerop (cdr active)) + 0 + (- (cdr active) (car active) -1)))) + (gnus-method-simplify (gnus-find-method-for-group group))))))) (defun gnus-group-update-group-line () "Update the current line in the group buffer." @@ -1439,7 +1430,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)) @@ -1456,7 +1447,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))) @@ -1473,7 +1464,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))) @@ -1532,7 +1523,7 @@ if it is a string, only list groups matching REGEXP." (int-to-string (max 0 (- gnus-tmp-number-total number))) "*")) (gnus-tmp-subscribed - (cond ((<= gnus-tmp-level gnus-level-subscribed) ? ) + (cond ((<= gnus-tmp-level gnus-level-subscribed) ?\s) ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) ((= gnus-tmp-level gnus-level-zombie) ?Z) (t ?K))) @@ -1545,13 +1536,13 @@ 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)) - ?m ? )) + (gethash gnus-tmp-group gnus-moderated-hashtb)) + ?m ?\s)) (gnus-tmp-moderated-string (if (eq gnus-tmp-moderated ?m) "(m)" "")) (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group)) @@ -1565,18 +1556,18 @@ if it is a string, only list groups matching REGEXP." (if (and (numberp number) (zerop number) (cdr (assq 'tick gnus-tmp-marked))) - ?* ? )) + ?* ?\s)) (gnus-tmp-summary-live (if (and (not gnus-group-is-exiting-p) (gnus-buffer-live-p (gnus-summary-buffer-name gnus-tmp-group))) - ?* ? )) + ?* ?\s)) (gnus-tmp-process-marked (if (member gnus-tmp-group gnus-group-marked) - gnus-process-mark ? )) + gnus-process-mark ?\s)) (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 @@ -1586,7 +1577,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) @@ -1620,7 +1611,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)) @@ -1691,9 +1682,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))) @@ -1701,37 +1690,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. @@ -1758,8 +1743,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." gnus-tmp-header ;Dummy binding for user-defined formats ;; Get the resulting string. (modified - (and gnus-dribble-buffer - (buffer-name gnus-dribble-buffer) + (and (buffer-live-p gnus-dribble-buffer) (buffer-modified-p gnus-dribble-buffer) (with-current-buffer gnus-dribble-buffer (not (zerop (buffer-size)))))) @@ -1779,10 +1763,8 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (defun gnus-group-group-name () "Get the name of the newsgroup on the current line." (let ((group (get-text-property (point-at-bol) 'gnus-group))) - (when group - (if (stringp group) - group - (symbol-name group))))) + (cond ((stringp group) group) + (group (symbol-name group))))) (defun gnus-group-group-level () "Get the level of the newsgroup on the current line." @@ -1802,7 +1784,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (defun gnus-group-new-mail (group) (if (nnmail-new-mail-p (gnus-group-real-name group)) gnus-new-mail-mark - ? )) + ?\s)) (defun gnus-group-level (group) "Return the estimated level of GROUP." @@ -1892,13 +1874,13 @@ If FIRST-TOO, the current line is also eligible as a target." (if unmark (progn (setq gnus-group-marked (delete group gnus-group-marked)) - (insert-char ? 1 t)) + (insert-char ?\s 1 t)) (setq gnus-group-marked (cons group (delete group gnus-group-marked))) (insert-char gnus-process-mark 1 t))) (unless no-advance (gnus-group-next-group 1)) - (decf n)) + (cl-decf n)) (gnus-group-position-point) n)) @@ -2063,7 +2045,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 @@ -2138,6 +2120,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-?]+\\)*\ @@ -2176,34 +2159,39 @@ 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) - 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))) + (let* ((choices + (mapcar + (lambda (g) + (if (string-match "[^\000-\177]" g) + (gnus-group-decoded-name g) + g)) + (cond ((listp collection) + collection) + ((vectorp collection) + (mapatoms #'symbol-name collection)) + ((hash-table-p collection) + (hash-table-keys collection))))) + (group + (gnus-completing-read (or prompt "Group") (reverse choices) + require-match initial-input + (or hist 'gnus-group-history) + def))) + (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)))) @@ -2281,7 +2269,8 @@ 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) + gnus-active-hashtb (gnus-make-hashtable 100))) ;; Transform the select method into a unique server. (when (stringp method) (setq method (gnus-server-to-method method))) @@ -2298,23 +2287,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) @@ -2548,65 +2537,64 @@ If PROMPT (the prefix) is a number, use the prompt specified in (when (equal group "") (error "Empty group name")) - (unless (gnus-ephemeral-group-p group) - ;; Either go to the line in the group buffer... - (unless (gnus-group-goto-group group) - ;; ... or insert the line. - (gnus-group-update-group group) - (gnus-group-goto-group group))) - ;; Adjust cursor point. - (gnus-group-position-point)) + (prog1 + (unless (gnus-ephemeral-group-p group) + ;; Either go to the line in the group buffer... + (unless (gnus-group-goto-group group) + ;; ... or insert the line. + (gnus-group-update-group group) + (gnus-group-goto-group group))) + ;; Adjust cursor point. + (gnus-group-position-point))) (defun gnus-group-goto-group (group &optional far test-marked) - "Goto to newsgroup GROUP. + "Go to newsgroup GROUP. If FAR, it is likely that the group is not on the current line. -If TEST-MARKED, the line must be marked." +If TEST-MARKED, the line must be marked. + +Return nil if GROUP is not found." (when 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)) - (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)) - (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)) - (or (not test-marked) (gnus-group-mark-line-p))))) - (forward-line 1) - (point)) - (test-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)))) - (if (gnus-group-mark-line-p) - (setq found t) - (forward-line 1))) - found)) - (t - ;; Search through the entire buffer. - (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe group gnus-active-hashtb))))))) + (let ((start (point))) + (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) + (equal (get-text-property (point) 'gnus-group) group) + (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 (equal (get-text-property (point) 'gnus-group) group) + (or (not test-marked) (gnus-group-mark-line-p))))) + (forward-line -1) + (point)) + ((and (not far) + (save-excursion + (forward-line 1) + (and (equal (get-text-property (point) 'gnus-group) group) + (or (not test-marked) (gnus-group-mark-line-p))))) + (forward-line 1) + (point)) + (test-marked + (goto-char (point-min)) + (let (found) + (while (and (not found) + (gnus-text-property-search + 'gnus-group group 'forward 'goto)) + (if (gnus-group-mark-line-p) + (setq found t) + (forward-line 1))) + found)) + (t + ;; Search through the entire buffer. + (if (gnus-text-property-search + 'gnus-group group nil 'goto) + (point) + (goto-char start) + nil)))))) (defun gnus-group-next-group (n &optional silent) "Go to next N'th newsgroup. @@ -2771,9 +2759,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) @@ -2833,6 +2819,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 @@ -2844,12 +2831,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) @@ -2998,7 +2984,7 @@ and NEW-NAME will be prompted for." ;; Set the info. (if (not (and info new-group)) (gnus-group-set-info form (or new-group group) part) - (setq info (gnus-copy-sequence info)) + (setq info (copy-tree info)) (setcar info new-group) (unless (gnus-server-equal method "native") (unless (nthcdr 3 info) @@ -3021,7 +3007,7 @@ and NEW-NAME will be prompted for." ;; Don't use `caddr' here since macros within the `interactive' ;; form won't be expanded. (car (cddr entry))))) - (setq method (gnus-copy-sequence method)) + (setq method (copy-tree method)) (let (entry) (while (setq entry (memq (assq 'eval method) method)) (setcar entry (eval (cadar entry))))) @@ -3230,7 +3216,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) @@ -3313,21 +3299,31 @@ If REVERSE (the prefix), reverse the sorting order." (funcall gnus-group-sort-alist-function (gnus-make-sort-function func) reverse) (gnus-group-unmark-all-groups) + ;; Redisplay all groups according to the newly-sorted order of + ;; `gnus-group-list'. (gnus-group-list-groups) (gnus-dribble-touch)) (defun gnus-group-sort-flat (func reverse) - ;; We peel off the dummy group from the alist. + "Sort groups in a flat list using sorting function FUNC. +If REVERSE is non-nil, reverse the sort order. + +This function sets a new value for `gnus-group-list'; its return +value is disregarded." (when func - (when (equal (gnus-info-group (car gnus-newsrc-alist)) "dummy.group") - (pop gnus-newsrc-alist)) - ;; Do the sorting. - (setq gnus-newsrc-alist - (sort gnus-newsrc-alist func)) - (when reverse - (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist))) - ;; Regenerate the hash table. - (gnus-make-hashtable-from-newsrc-alist))) + (let* ((groups (remove "dummy.group" gnus-group-list)) + (sorted-infos + (sort (mapcar (lambda (g) + (gnus-get-info g)) + groups) + func))) + (setq gnus-group-list + (mapcar (lambda (i) + (gnus-info-group i)) + sorted-infos)) + (when reverse + (setq gnus-group-list (nreverse gnus-group-list))) + (setq gnus-group-list (cons "dummy.group" gnus-group-list))))) (defun gnus-group-sort-groups-by-alphabet (&optional reverse) "Sort the group buffer alphabetically by group name. @@ -3390,27 +3386,26 @@ If REVERSE, sort in reverse order." (gnus-dribble-touch))) (defun gnus-group-sort-selected-flat (groups func reverse) - (let (entries infos) - ;; First find all the group entries for these groups. - (while groups - (push (nthcdr 2 (gnus-group-entry (pop groups))) - entries)) - ;; Then sort the infos. - (setq infos - (sort - (mapcar - (lambda (entry) (car entry)) - (setq entries (nreverse entries))) - func)) + "Sort only the selected GROUPS, using FUNC. +If REVERSE is non-nil, reverse the sorting." + (let ((infos (sort + (mapcar (lambda (g) + (gnus-get-info g)) + groups) + func)) + sorted-groups) (when reverse (setq infos (nreverse infos))) - ;; Go through all the infos and replace the old entries - ;; with the new infos. - (while infos - (setcar (car entries) (pop infos)) - (pop entries)) - ;; Update the hashtable. - (gnus-make-hashtable-from-newsrc-alist))) + (setq sorted-groups (mapcar (lambda (i) (gnus-info-group i)) infos)) + + ;; Find the original locations of GROUPS in `gnus-group-list', and + ;; replace each one, in order, with a group from SORTED-GROUPS. + (dolist (i (sort (mapcar (lambda (g) + (seq-position gnus-group-list g)) + groups) + #'<)) + (setf (nth i gnus-group-list) + (pop sorted-groups))))) (defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse) "Sort the group buffer alphabetically by group name. @@ -3553,7 +3548,7 @@ Obeys the process/prefix convention." (gnus-request-set-mark ,group ',action) (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) - (when (gnus-group-goto-group ,group) + (when (gnus-group-jump-to-group ,group) (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t) (gnus-group-update-group-line)))) (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el))) @@ -3623,7 +3618,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)) @@ -3805,8 +3800,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))) @@ -3877,10 +3871,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))) @@ -3898,7 +3894,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) @@ -3921,7 +3917,7 @@ yanked) a list of yanked groups is returned." (interactive "p") (setq arg (or arg 1)) (let (info group prev out) - (while (>= (decf arg) 0) + (while (>= (cl-decf arg) 0) (when (not (setq info (pop gnus-list-of-killed-groups))) (error "No more newsgroups to yank")) (push (setq group (nth 1 info)) out) @@ -3931,9 +3927,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 @@ -4017,28 +4011,15 @@ entail asking the server for the groups." (gnus-agent gnus-plugged)); If we're actually plugged, store the active file in the agent. (gnus-read-active-file))) ;; 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) - 'string<)) - (buffer-read-only nil) - group) + (let ((buffer-read-only nil)) (erase-buffer) - (while groups - (setq group (pop groups)) + (dolist (group (sort (hash-table-keys gnus-active-hashtb) #'string<)) (add-text-properties (point) (prog1 (1+ (point)) (insert " *: " (gnus-group-decoded-name group) "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + (list 'gnus-group group 'gnus-unread t 'gnus-level (inline (gnus-group-level group))))) (goto-char (point-min)))) @@ -4102,9 +4083,14 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (gnus-group-remove-mark group) ;; Bypass any previous denials from the server. (gnus-remove-denial (setq method (gnus-find-method-for-group group))) - (if (or (and (not dont-scan) - (gnus-request-group-scan group (gnus-get-info group))) - (gnus-activate-group group (if dont-scan nil 'scan) nil method)) + (if (if (and (not dont-scan) + ;; Prefer request-group-scan if the backend supports it. + (gnus-check-backend-function 'request-group-scan group)) + (progn + ;; Ensure that the server is already open. + (gnus-activate-group group nil nil method) + (gnus-request-group-scan group (gnus-get-info group))) + (gnus-activate-group group (if dont-scan nil 'scan) nil method)) (let ((info (gnus-get-info group)) (active (gnus-active group))) (when info @@ -4117,6 +4103,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." method (gnus-group-real-name group) active)) (gnus-group-update-group group nil t)) (gnus-error 3 "%s error: %s" group (gnus-status-message group)))) + (gnus-run-hooks 'gnus-after-getting-new-news-hook) (when beg (goto-char beg)) (when gnus-goto-next-group-when-activating @@ -4132,17 +4119,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>. @@ -4154,24 +4141,19 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (when (not (or gnus-description-hashtb (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<)) + (let ((buffer-read-only nil)) (erase-buffer) - (dolist (group groups) - (setq b (point)) - (let ((charset (gnus-group-name-charset nil group))) + (dolist (group (sort (hash-table-keys gnus-description-hashtb) #'string<)) + (let ((b (point)) + (desc (gethash group gnus-description-hashtb)) + (charset (gnus-group-name-charset nil group))) (insert (format " *: %-20s %s\n" (gnus-group-name-decode group charset) - (gnus-group-name-decode group charset)))) - (add-text-properties - b (1+ b) (list 'gnus-group (intern group gnus-description-hashtb) - 'gnus-unread t 'gnus-marked nil - 'gnus-level (1+ gnus-level-subscribed)))) + (gnus-group-name-decode desc charset))) + (add-text-properties + b (1+ b) (list 'gnus-group group + 'gnus-unread t 'gnus-marked nil + 'gnus-level (1+ gnus-level-subscribed))))) (goto-char (point-min)) (gnus-group-position-point))) @@ -4183,20 +4165,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. @@ -4212,8 +4190,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)))) @@ -4367,6 +4345,9 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." gnus-expert-user (gnus-y-or-n-p "Are you sure you want to quit reading news? ")) (gnus-run-hooks 'gnus-exit-gnus-hook) + ;; Check whether we have any unsaved Message buffers and offer to + ;; save them. + (gnus--abort-on-unsaved-message-buffers) ;; Offer to save data from non-quitted summary buffers. (gnus-offer-save-summaries) ;; Save the newsrc file(s). @@ -4378,6 +4359,16 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." ;; Allow the user to do things after cleaning up. (gnus-run-hooks 'gnus-after-exiting-gnus-hook))) +(defun gnus--abort-on-unsaved-message-buffers () + (dolist (buffer (gnus-buffers)) + (with-current-buffer buffer + (when (and (derived-mode-p 'message-mode) + (buffer-modified-p) + (not (y-or-n-p + (format "Message buffer %s unsaved, continue exit? " + buffer)))) + (error "Gnus exit aborted due to unsaved buffer %s" buffer))))) + (defun gnus-group-quit () "Quit reading news without updating .newsrc.eld or .newsrc. The hook `gnus-exit-gnus-hook' is called before actually exiting." @@ -4443,7 +4434,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 @@ -4485,7 +4476,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 @@ -4553,8 +4544,7 @@ and the second element is the address." This function can be used in hooks like `gnus-select-group-hook' or `gnus-group-catchup-group-hook'." (when gnus-newsgroup-name - (let ((time (current-time))) - (setcdr (cdr time) nil) + (let ((time (encode-time nil 'integer))) (gnus-group-set-parameter gnus-newsgroup-name 'timestamp time)))) (defsubst gnus-group-timestamp (group) @@ -4563,11 +4553,11 @@ or `gnus-group-catchup-group-hook'." (defun gnus-group-timestamp-delta (group) "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." - (let* ((time (or (gnus-group-timestamp group) - (list 0 0))) - (delta (time-subtract (current-time) time))) - (+ (* (nth 0 delta) 65536.0) - (nth 1 delta)))) + ;; FIXME: This should return a Lisp integer, not a Lisp float, + ;; since it is always an integer. + (let* ((time (or (gnus-group-timestamp group) 0)) + (delta (time-since time))) + (float-time delta))) (defun gnus-group-timestamp-string (group) "Return a string of the timestamp for GROUP." @@ -4595,11 +4585,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 ":") ".") @@ -4761,8 +4751,7 @@ Compacting group %s... (this may take a long time)" ;; Invalidate the "original article" buffer which might be out of date. ;; #### NOTE: Yes, this might be a bit rude, but since compaction ;; #### will not happen very often, I think this is acceptable. - (let ((original (get-buffer gnus-original-article-buffer))) - (and original (gnus-kill-buffer original))) + (gnus-kill-buffer gnus-original-article-buffer) ;; Update the group line to reflect new information (art number etc). (gnus-group-update-group-line)))) |