X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=377c606ba7fbeacd1b454951142414f08d95087d;hb=b19ab0bcf7b463d4b14b41bd23f2a5d62d03795a;hp=f3989a634531f5982af7ac19544fa7f01f7264fb;hpb=fb45cd5bf025bcd45acf6339cd08d04b79a6841c;p=gnus diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index f3989a634..377c606ba 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -32,6 +32,7 @@ (require 'gnus-int) (require 'gnus-range) (require 'gnus-win) +(require 'gnus-undo) (defvar gnus-group-archive-directory "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" @@ -84,9 +85,10 @@ Ignored if `gnus-group-use-permanent-levels' is non-nil.") "*Function used for sorting the group buffer. This function will be called with group info entries as the arguments for the groups to be sorted. Pre-made functions include -`gnus-group-sort-by-alphabet', `gnus-group-sort-by-unread', -`gnus-group-sort-by-level', `gnus-group-sort-by-score', -`gnus-group-sort-by-method', and `gnus-group-sort-by-rank'. +`gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name', +`gnus-group-sort-by-unread', `gnus-group-sort-by-level', +`gnus-group-sort-by-score', `gnus-group-sort-by-method', and +`gnus-group-sort-by-rank'. This variable can also be a list of sorting functions. In that case, the most significant sort function should be the last function in the @@ -152,6 +154,9 @@ with some simple extensions: (defvar gnus-group-mode-hook nil "*A hook for Gnus group mode.") +(defvar gnus-group-menu-hook nil + "*Hook run after the creation of the group mode menu.") + (defvar gnus-group-catchup-group-hook nil "*A hook run when catching up a group from the group buffer.") @@ -193,6 +198,7 @@ variable.") (defvar gnus-group-indentation-function nil) (defvar gnus-goto-missing-group-function nil) +(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) (defvar gnus-group-goto-next-group-function nil "Function to override finding the next group after listing groups.") @@ -273,6 +279,7 @@ variable.") "U" gnus-group-unsubscribe-group "c" gnus-group-catchup-current "C" gnus-group-catchup-current-all + "\M-c" gnus-group-clear-data "l" gnus-group-list-groups "L" gnus-group-list-all-groups "m" gnus-group-mail @@ -339,6 +346,7 @@ variable.") "V" gnus-group-make-empty-virtual "D" gnus-group-enter-directory "f" gnus-group-make-doc-group + "n" gnus-group-make-web-group "r" gnus-group-rename-group "\177" gnus-group-delete-group [delete] gnus-group-delete-group) @@ -387,6 +395,169 @@ variable.") "\C-k" gnus-group-kill-level "z" gnus-group-kill-all-zombies)) + +(defun gnus-group-make-menu-bar () + (gnus-turn-off-edit-menu 'group) + (unless (boundp 'gnus-group-reading-menu) + + (easy-menu-define + gnus-group-reading-menu gnus-group-mode-map "" + '("Group" + ["Read" gnus-group-read-group (gnus-group-group-name)] + ["Select" gnus-group-select-group (gnus-group-group-name)] + ["See old articles" (gnus-group-select-group 'all) + :keys "C-u SPC" :active (gnus-group-group-name)] + ["Catch up" gnus-group-catchup-current (gnus-group-group-name)] + ["Catch up all articles" gnus-group-catchup-current-all + (gnus-group-group-name)] + ["Check for new articles" gnus-group-get-new-news-this-group + (gnus-group-group-name)] + ["Toggle subscription" gnus-group-unsubscribe-current-group + (gnus-group-group-name)] + ["Kill" gnus-group-kill-group (gnus-group-group-name)] + ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] + ["Describe" gnus-group-describe-group (gnus-group-group-name)] + ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] + ["Edit kill file" gnus-group-edit-local-kill + (gnus-group-group-name)] + ;; Actually one should check, if any of the marked groups gives t for + ;; (gnus-check-backend-function 'request-expire-articles ...) + ["Expire articles" gnus-group-expire-articles + (or (and (gnus-group-group-name) + (gnus-check-backend-function + 'request-expire-articles + (gnus-group-group-name))) gnus-group-marked)] + ["Set group level" gnus-group-set-current-level + (gnus-group-group-name)] + ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)] + )) + + (easy-menu-define + gnus-group-group-menu gnus-group-mode-map "" + '("Groups" + ("Listing" + ["List unread subscribed groups" gnus-group-list-groups t] + ["List (un)subscribed groups" gnus-group-list-all-groups t] + ["List killed groups" gnus-group-list-killed gnus-killed-list] + ["List zombie groups" gnus-group-list-zombies gnus-zombie-list] + ["List level..." gnus-group-list-level t] + ["Describe all groups" gnus-group-describe-all-groups t] + ["Group apropos..." gnus-group-apropos t] + ["Group and description apropos..." gnus-group-description-apropos t] + ["List groups matching..." gnus-group-list-matching t] + ["List all groups matching..." gnus-group-list-all-matching t] + ["List active file" gnus-group-list-active t]) + ("Sort" + ["Default sort" gnus-group-sort-groups + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by method" gnus-group-sort-groups-by-method + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by rank" gnus-group-sort-groups-by-rank + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by score" gnus-group-sort-groups-by-score + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by level" gnus-group-sort-groups-by-level + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by unread" gnus-group-sort-groups-by-unread + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by name" gnus-group-sort-groups-by-alphabet + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]) + ("Mark" + ["Mark group" gnus-group-mark-group + (and (gnus-group-group-name) + (not (memq (gnus-group-group-name) gnus-group-marked)))] + ["Unmark group" gnus-group-unmark-group + (and (gnus-group-group-name) + (memq (gnus-group-group-name) gnus-group-marked))] + ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked] + ["Mark regexp..." gnus-group-mark-regexp t] + ["Mark region" gnus-group-mark-region t] + ["Mark buffer" gnus-group-mark-buffer t] + ["Execute command" gnus-group-universal-argument + (or gnus-group-marked (gnus-group-group-name))]) + ("Subscribe" + ["Subscribe to a group" gnus-group-unsubscribe-group t] + ["Kill all newsgroups in region" gnus-group-kill-region t] + ["Kill all zombie groups" gnus-group-kill-all-zombies + gnus-zombie-list] + ["Kill all groups on level..." gnus-group-kill-level t]) + ("Foreign groups" + ["Make a foreign group" gnus-group-make-group t] + ["Add a directory group" gnus-group-make-directory-group t] + ["Add the help group" gnus-group-make-help-group t] + ["Add the archive group" gnus-group-make-archive-group t] + ["Make a doc group" gnus-group-make-doc-group t] + ["Make a kiboze group" gnus-group-make-kiboze-group t] + ["Make a virtual group" gnus-group-make-empty-virtual t] + ["Add a group to a virtual" gnus-group-add-to-virtual t] + ["Rename group" gnus-group-rename-group + (gnus-check-backend-function + 'request-rename-group (gnus-group-group-name))] + ["Delete group" gnus-group-delete-group + (gnus-check-backend-function + 'request-delete-group (gnus-group-group-name))]) + ("Editing groups" + ["Parameters" gnus-group-edit-group-parameters + (gnus-group-group-name)] + ["Select method" gnus-group-edit-group-method + (gnus-group-group-name)] + ["Info" gnus-group-edit-group (gnus-group-group-name)]) + ("Score file" + ["Flush cache" gnus-score-flush-cache t]) + ("Move" + ["Next" gnus-group-next-group t] + ["Previous" gnus-group-prev-group t] + ["Next unread" gnus-group-next-unread-group t] + ["Previous unread" gnus-group-prev-unread-group t] + ["Next unread same level" gnus-group-next-unread-group-same-level t] + ["Previous unread same level" + gnus-group-previous-unread-group-same-level t] + ["Jump to group" gnus-group-jump-to-group t] + ["First unread group" gnus-group-first-unread-group t] + ["Best unread group" gnus-group-best-unread-group t]) + ["Transpose" gnus-group-transpose-groups + (gnus-group-group-name)] + ["Read a directory as a group..." gnus-group-enter-directory t] + )) + + (easy-menu-define + gnus-group-misc-menu gnus-group-mode-map "" + '("Misc" + ["Send a bug report" gnus-bug t] + ["Send a mail" gnus-group-mail t] + ["Post an article..." gnus-group-post-news t] + ["Customize score file" gnus-score-customize t] + ["Check for new news" gnus-group-get-new-news t] + ["Activate all groups" gnus-activate-all-groups t] + ["Delete bogus groups" gnus-group-check-bogus-groups t] + ["Find new newsgroups" gnus-find-new-newsgroups t] + ["Restart Gnus" gnus-group-restart t] + ["Read init file" gnus-group-read-init-file t] + ["Browse foreign server" gnus-group-browse-foreign-server t] + ["Enter server buffer" gnus-group-enter-server-mode t] + ["Expire all expirable articles" gnus-group-expire-all-groups t] + ["Generate any kiboze groups" nnkiboze-generate-groups t] + ["Gnus version" gnus-version t] + ["Save .newsrc files" gnus-group-save-newsrc t] + ["Suspend Gnus" gnus-group-suspend t] + ["Clear dribble buffer" gnus-group-clear-dribble t] + ["Edit global kill file" gnus-group-edit-global-kill t] + ["Read manual" gnus-info-find-node t] + ["Toggle topics" gnus-topic-mode t] + ("SOUP" + ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)] + ["Send replies" gnus-soup-send-replies + (fboundp 'gnus-soup-pack-packet)] + ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] + ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] + ["Brew SOUP" gnus-soup-brew-soup (fboundp 'gnus-soup-pack-packet)]) + ["Exit from Gnus" gnus-group-exit t] + ["Exit without saving" gnus-group-quit t] + )) + + (run-hooks 'gnus-group-menu-hook) + )) + (defun gnus-group-mode () "Major mode for reading news. @@ -418,6 +589,7 @@ The following commands are available: (buffer-disable-undo (current-buffer)) (setq truncate-lines t) (setq buffer-read-only t) + (gnus-set-default-directory) (gnus-update-format-specifications nil 'group 'group-mode) (gnus-update-group-mark-positions) (gnus-make-local-hook 'post-command-hook) @@ -478,15 +650,16 @@ The following commands are available: Default is all subscribed groups. If argument UNREAD is non-nil, groups with no unread articles are also listed." - (interactive (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - (or - (gnus-group-default-level nil t) - gnus-group-default-list-level - gnus-level-subscribed)))) - (or level - (setq level (car gnus-group-list-mode) - unread (cdr gnus-group-list-mode))) + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (or + (gnus-group-default-level nil t) + gnus-group-default-list-level + gnus-level-subscribed)))) + (unless level + (setq level (car gnus-group-list-mode) + unread (cdr gnus-group-list-mode))) (setq level (gnus-group-default-level level)) (gnus-group-setup-buffer) ;May call from out of group buffer (gnus-update-format-specifications) @@ -508,20 +681,22 @@ listed." ;; 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. - (if (not (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))) - (let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb)))) - (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))) - (or newsrc (progn (goto-char (point-max)) - (forward-line -1))))))) + (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-gethash group gnus-newsrc-hashtb)))) + (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 + (goto-char (point-max)) + (forward-line -1)))))) ;; Adjust cursor point. (gnus-group-position-point)))) @@ -625,7 +800,7 @@ If REGEXP, only list groups matching REGEXP." (not (gnus-ephemeral-group-p group)) (gnus-dribble-enter (concat "(gnus-group-set-info '" - (prin1-to-string (nth 2 entry)) ")"))) + (gnus-prin1-to-string (nth 2 entry)) ")"))) (setq gnus-group-indentation (gnus-group-group-indentation)) (gnus-delete-line) (gnus-group-insert-group-line-info group) @@ -724,6 +899,40 @@ If REGEXP, only list groups matching REGEXP." ;; Allow XEmacs to remove front-sticky text properties. (gnus-group-remove-excess-properties))) +(defun gnus-group-highlight-line () + "Highlight the current line according to `gnus-group-highlight'." + (let* ((list gnus-group-highlight) + (p (point)) + (end (progn (end-of-line) (point))) + ;; now find out where the line starts and leave point there. + (beg (progn (beginning-of-line) (point))) + (group (gnus-group-group-name)) + (entry (gnus-group-entry group)) + (unread (if (numberp (car entry)) (car entry) 0)) + (active (gnus-active group)) + (total (if active (1+ (- (cdr active) (car active))) 0)) + (info (nth 2 entry)) + (method (gnus-server-get-method group (gnus-info-method info))) + (marked (gnus-info-marks info)) + (mailp (memq 'mail (assoc (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + (level (or (gnus-info-level info) 9)) + (score (or (gnus-info-score info) 0)) + (ticked (gnus-range-length (cdr (assq 'tick marked)))) + (inhibit-read-only t)) + ;; Eval the cars of the lists until we find a match. + (while (and list + (not (eval (caar list)))) + (setq list (cdr list))) + (let ((face (cdar list))) + (unless (eq face (get-text-property beg 'face)) + (gnus-put-text-property + beg end 'face + (setq face (if (boundp face) (symbol-value face) face))) + (gnus-extent-start-open beg))) + (goto-char p))) + (defun gnus-group-update-group (group &optional visible-only) "Update all lines where GROUP appear. If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't @@ -740,7 +949,8 @@ already." (let ((entry (gnus-gethash group gnus-newsrc-hashtb))) (if (and entry (not (gnus-ephemeral-group-p group))) (gnus-dribble-enter - (concat "(gnus-group-set-info '" (prin1-to-string (nth 2 entry)) + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (nth 2 entry)) ")")))) ;; Find all group instances. If topics are in use, each group ;; may be listed in more than once. @@ -889,19 +1099,20 @@ If FIRST-TOO, the current line is also eligible as a target." (while (and (> n 0) (not (eobp))) (when (setq group (gnus-group-group-name)) - ;; Update the mark. + ;; Go to the mark position. (beginning-of-line) - (forward-char - (or (cdr (assq 'process gnus-group-mark-positions)) 2)) - (delete-char 1) - (if unmark - (progn - (insert " ") - (setq gnus-group-marked (delete group gnus-group-marked))) - (insert "#") - (setq gnus-group-marked - (cons group (delete group gnus-group-marked))))) - (or no-advance (gnus-group-next-group 1)) + (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) + (subst-char-in-region + (point) (1+ (point)) (following-char) + (if unmark + (progn + (setq gnus-group-marked (delete group gnus-group-marked)) + ? ) + (setq gnus-group-marked + (cons group (delete group gnus-group-marked))) + gnus-process-mark))) + (unless no-advance + (gnus-group-next-group 1)) (decf n)) (gnus-summary-position-point) n)) @@ -1088,8 +1299,15 @@ Returns whether the fetching was successful or not." ;; Enter a group that is not in the group buffer. Non-nil is returned ;; if selection was successful. -(defun gnus-group-read-ephemeral-group - (group method &optional activate quit-config) +(defun gnus-group-read-ephemeral-group (group method &optional activate + quit-config request-only) + "Read GROUP from METHOD as an ephemeral group. +If ACTIVATE, request the group first. +If QUIT-CONFIG, use that window configuration when exiting from the +ephemeral group. +If REQUEST-ONLY, don't actually read the group; just request it. + +Return the name of the group is selection was successful." (let ((group (if (gnus-group-foreign-p group) group (gnus-group-prefixed-name group method)))) (gnus-sethash @@ -1101,12 +1319,17 @@ Returns whether the fetching was successful or not." (set-buffer gnus-group-buffer) (unless (gnus-check-server method) (error "Unable to contact server: %s" (gnus-status-message method))) - (if activate (or (gnus-request-group group) - (error "Couldn't request group"))) - (condition-case () - (gnus-group-read-group t t group) - ;(error nil) - (quit nil)))) + (when activate + (unless (gnus-request-group group) + (error "Couldn't request group: %s" + (nnheader-get-report (car method))))) + (if request-only + group + (condition-case () + (when (gnus-group-read-group t t group) + group) + ;;(error nil) + (quit nil))))) (defun gnus-group-jump-to-group (group) "Jump to newsgroup GROUP." @@ -1144,35 +1367,41 @@ Returns whether the fetching was successful or not." ;; Adjust cursor point. (gnus-group-position-point))) -(defun gnus-group-goto-group (group) - "Goto to newsgroup GROUP." +(defun gnus-group-goto-group (group &optional far) + "Goto to newsgroup GROUP. +If FAR, it is likely that the group is not on the current line." (when group - (beginning-of-line) - (cond - ;; It's quite likely that we are on the right line, so - ;; we check the current line first. - ((eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb)) - (point)) - ;; Previous and next line are also likely, so we check them as well. - ((save-excursion + (if far + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe group gnus-active-hashtb))) + (beginning-of-line) + (cond + ;; It's quite likely that we are on the right line, so + ;; we check the current line first. + ((eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb)) + (point)) + ;; Previous and next line are also likely, so we check them as well. + ((save-excursion + (forward-line -1) + (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb))) (forward-line -1) - (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb))) - (forward-line -1) - (point)) - ((save-excursion + (point)) + ((save-excursion + (forward-line 1) + (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb))) (forward-line 1) - (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb))) - (forward-line 1) - (point)) - (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))))))) + (point)) + (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)))))))) (defun gnus-group-next-group (n &optional silent) "Go to next N'th newsgroup. @@ -1286,7 +1515,7 @@ ADDRESS." (interactive (list (read-string "Group name: ") - (gnus-read-server "From method: "))) + (gnus-read-method "From method: "))) (let* ((meth (when (and method (not (gnus-server-equal method gnus-select-method))) @@ -1308,7 +1537,8 @@ ADDRESS." (gnus-set-active nname (cons 1 0)) (or (gnus-ephemeral-group-p name) (gnus-dribble-enter - (concat "(gnus-group-set-info '" (prin1-to-string (cdr info)) ")"))) + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (cdr info)) ")"))) ;; Insert the line. (gnus-group-insert-group-line-info nname) (forward-line -1) @@ -1525,10 +1755,44 @@ and NEW-NAME will be prompted for." (file-name-nondirectory file) '(nndoc ""))))) (gnus-group-make-group (gnus-group-real-name name) - (list 'nndoc (file-name-nondirectory file) + (list 'nndoc file (list 'nndoc-address file) (list 'nndoc-article-type (or type 'guess)))))) +(defvar nnweb-type-definition) +(defvar gnus-group-web-type-history nil) +(defvar gnus-group-web-search-history nil) +(defun gnus-group-make-web-group (&optional solid) + "Create an ephemeral nnweb group. +If SOLID (the prefix), create a solid group." + (interactive "P") + (require 'nnweb) + (let* ((group + (if solid (read-string "Group name: ") (message-unique-id))) + (type + (completing-read + "Search engine type: " + (mapcar (lambda (elem) (list (symbol-name (car elem)))) + nnweb-type-definition) + nil t (cons (or (car gnus-group-web-type-history) + (symbol-name (caar nnweb-type-definition))) + 0) + 'gnus-group-web-type-history)) + (search + (read-string + "Search string: " + (cons (or (car gnus-group-web-search-history) "") 0) + 'gnus-group-web-search-history)) + (method + `(nnweb ,group (nnweb-search ,search) + (nnweb-type ,(intern type))))) + (if solid + (gnus-group-make-group group method) + (gnus-group-read-ephemeral-group + group method t + (cons (current-buffer) + (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) + (defun gnus-group-make-archive-group (&optional all) "Create the (ding) Gnus archive group of the most recent articles. Given a prefix, create a full group." @@ -1632,17 +1896,17 @@ score file entries for articles to include in the group." (defun gnus-group-enter-directory (dir) "Enter an ephemeral nneething group." (interactive "DDirectory to read: ") - (let* ((method (list 'nneething dir)) + (let* ((method (list 'nneething dir '(nneething-read-only t))) (leaf (gnus-group-prefixed-name (file-name-nondirectory (directory-file-name dir)) method)) (name (gnus-generate-new-group-name leaf))) - (let ((nneething-read-only t)) - (or (gnus-group-read-ephemeral-group - name method t - (cons (current-buffer) (if (eq major-mode 'gnus-summary-mode) - 'summary 'group))) - (error "Couldn't enter %s" dir))))) + (unless (gnus-group-read-ephemeral-group + name method t + (cons (current-buffer) + (if (eq major-mode 'gnus-summary-mode) + 'summary 'group))) + (error "Couldn't enter %s" dir)))) ;; Group sorting commands ;; Suggested by Joe Hildebrand . @@ -1712,6 +1976,11 @@ If REVERSE, sort in reverse order." "Sort alphabetically." (string< (gnus-info-group info1) (gnus-info-group info2))) +(defun gnus-group-sort-by-real-name (info1 info2) + "Sort alphabetically on real (unprefixed) names." + (string< (gnus-group-real-name (gnus-info-group info1)) + (gnus-group-real-name (gnus-info-group info2)))) + (defun gnus-group-sort-by-unread (info1 info2) "Sort by number of unread articles." (let ((n1 (car (gnus-gethash (gnus-info-group info1) gnus-newsrc-hashtb))) @@ -1742,7 +2011,7 @@ If REVERSE, sort in reverse order." (and (= level1 level2) (> (gnus-info-score info1) (gnus-info-score info2)))))) -;; Group catching up. +;;; Clearing data (defun gnus-group-clear-data (n) "Clear all marks and read ranges from the current group." @@ -1750,15 +2019,37 @@ If REVERSE, sort in reverse order." (let ((groups (gnus-group-process-prefix n)) group info) (while (setq group (pop groups)) - (setq info (gnus-get-info group)) - (gnus-info-set-read info nil) - (when (gnus-info-marks info) - (gnus-info-set-marks info nil)) + (gnus-info-clear-data (setq info (gnus-get-info group))) (gnus-get-unread-articles-in-group info (gnus-active group) t) (when (gnus-group-goto-group group) (gnus-group-remove-mark group) (gnus-group-update-group-line))))) +(defun gnus-group-clear-data-on-native-groups () + "Clear all marks and read ranges from all native groups." + (interactive) + (when (gnus-yes-or-no-p "Really clear all data from almost all groups? ") + (let ((alist (cdr gnus-newsrc-alist)) + info) + (while (setq info (pop alist)) + (gnus-info-clear-data info)) + (gnus-get-unread-articles)))) + +(defun gnus-info-clear-data (info) + "Clear all marks and read ranges from INFO." + (let ((group (gnus-info-group info))) + (gnus-undo-register + `(progn + (gnus-info-set-marks ,info ,(gnus-info-marks info)) + (gnus-info-set-read ,info ,(gnus-info-read info)) + (when (gnus-group-goto-group ,group) + (gnus-group-update-group-line)))) + (gnus-info-set-read info nil) + (when (gnus-info-marks info) + (gnus-info-set-marks info nil)))) + +;; Group catching up. + (defun gnus-group-catchup-current (&optional n all) "Mark all articles not marked as unread in current newsgroup as read. If prefix argument N is numeric, the ARG next newsgroups will be @@ -1846,7 +2137,7 @@ or nil if no action could be taken." (expirable (if (gnus-group-total-expirable-p group) (cons nil (gnus-list-of-read-articles group)) (assq 'expire (gnus-info-marks info)))) - (expiry-wait (gnus-group-get-parameter group 'expiry-wait))) + (expiry-wait (gnus-group-find-parameter group 'expiry-wait))) (when expirable (setcdr expirable @@ -2021,6 +2312,10 @@ of groups killed." (gnus-delete-line) (when (and (not discard) (setq entry (gnus-gethash group gnus-newsrc-hashtb))) + (gnus-undo-register + `(progn + (gnus-group-goto-group ,(gnus-group-group-name)) + (gnus-group-yank-group))) (push (cons (car entry) (nth 2 entry)) gnus-list-of-killed-groups)) (gnus-group-change-level @@ -2072,7 +2367,10 @@ is returned." info (gnus-info-level (cdr info)) gnus-level-killed (and prev (gnus-gethash prev gnus-newsrc-hashtb)) t) - (gnus-group-insert-group-line-info group)) + (gnus-group-insert-group-line-info group) + (gnus-undo-register + `(when (gnus-group-goto-group ,group) + (gnus-group-kill-group 1)))) (forward-line -1) (gnus-group-position-point) (if (< (length out) 2) (car out) (nreverse out)))) @@ -2212,6 +2510,8 @@ If N is negative, this group and the N-1 previous groups will be checked." group) (while (setq group (pop groups)) (gnus-group-remove-mark group) + ;; Bypass any previous denials from the server. + (gnus-remove-denial (gnus-find-method-for-group group)) (if (gnus-activate-group group 'scan) (progn (gnus-get-unread-articles-in-group @@ -2221,7 +2521,7 @@ If N is negative, this group and the N-1 previous groups will be checked." (gnus-group-update-group group)) (if (eq (gnus-server-status (gnus-find-method-for-group group)) 'denied) - (gnus-error "Server denied access") + (gnus-error 3 "Server denied access") (gnus-error 3 "%s error: %s" group (gnus-status-message group))))) (when beg (goto-char beg)) (when gnus-goto-next-group-when-activating @@ -2230,26 +2530,31 @@ If N is negative, this group and the N-1 previous groups will be checked." ret)) (defun gnus-group-fetch-faq (group &optional faq-dir) - "Fetch the FAQ for the current group." + "Fetch the FAQ for the current group. +If given a prefix argument, prompt for the FAQ dir +to use." (interactive (list - (and (gnus-group-group-name) - (gnus-group-real-name (gnus-group-group-name))) + (gnus-group-group-name) (cond (current-prefix-arg (completing-read "Faq dir: " (and (listp gnus-group-faq-directory) (mapcar (lambda (file) (list file)) gnus-group-faq-directory))))))) - (or faq-dir - (setq faq-dir (if (listp gnus-group-faq-directory) - (car gnus-group-faq-directory) - gnus-group-faq-directory))) - (or group (error "No group name given")) - (let ((file (concat (file-name-as-directory faq-dir) - (gnus-group-real-name group)))) - (if (not (file-exists-p file)) - (error "No such file: %s" file) - (find-file file)))) + (unless group + (error "No group name given")) + (let ((dirs (or faq-dir gnus-group-faq-directory)) + dir found file) + (unless (listp dirs) + (setq dirs (list dirs))) + (while (and (not found) + (setq dir (pop dirs))) + (setq file (concat (file-name-as-directory dir) + (gnus-group-real-name group))) + (if (not (file-exists-p file)) + (gnus-message 1 "No such file: %s" file) + (find-file file) + (setq found t))))) (defun gnus-group-describe-group (force &optional group) "Display a description of the current newsgroup." @@ -2384,8 +2689,7 @@ If FORCE, force saving whether it is necessary or not." "Force Gnus to read the .newsrc file." (interactive "P") (when (gnus-yes-or-no-p - (format "Are you sure you want to read %s? " - gnus-current-startup-file)) + (format "Are you sure you want to restart Gnus? ")) (gnus-save-newsrc-file) (gnus-setup-news 'force) (gnus-group-list-groups arg))) @@ -2611,10 +2915,7 @@ and the second element is the address." (copy-sequence articles)) '<) t)))))) (defun gnus-update-read-articles (group unread) - "Update the list of read and ticked articles in GROUP using the -UNREAD and TICKED lists. -Note: UNSELECTED has to be sorted over `<'. -Returns whether the updating was successful." + "Update the list of read articles in GROUP." (let* ((active (or gnus-newsgroup-active (gnus-active group))) (entry (gnus-gethash group gnus-newsrc-hashtb)) (info (nth 2 entry)) @@ -2644,6 +2945,11 @@ Returns whether the updating was successful." (setq unread (cdr unread))) (when (<= prev (cdr active)) (setq read (cons (cons prev (cdr active)) read))) + (gnus-undo-register + `(progn + (gnus-info-set-marks ,info ,(gnus-info-marks info)) + (gnus-info-set-read ,info ,(gnus-info-read info)) + (gnus-get-unread-articles-in-group ,info (gnus-active ,group)))) ;; Enter this list into the group info. (gnus-info-set-read info (if (> (length read) 1) (nreverse read) read))