X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=5cd3cd8b782dc47bc958c8a1c7cb6f51a65ddb25;hb=3aca09c100b6c60da9524bebf9c9eed6ad3e0174;hp=fcbcea55da4f6d24c5b980a0ca3fe11276ae1a7b;hpb=5c85eb9dd8a85edecf9b9da5bfeb5ca5d754aa1b;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index fcbcea5..5cd3cd8 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -1,5 +1,5 @@ ;;; gnus-group.el --- group mode commands for Gnus -;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -49,7 +49,7 @@ :group 'gnus-group-foreign :type 'directory) -(defcustom gnus-no-groups-message "No news is no news" +(defcustom gnus-no-groups-message "No gnus is bad news" "*Message displayed by Gnus when no groups are available." :group 'gnus-start :type 'string) @@ -90,7 +90,7 @@ unread articles in the groups. If nil, no groups are permanently visible." :group 'gnus-group-listing - :type 'regexp) + :type '(choice regexp (const nil))) (defcustom gnus-list-groups-with-ticked-articles t "*If non-nil, list groups that have only ticked articles. @@ -725,7 +725,6 @@ ticked: The number of ticked articles." ["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-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) - ["Send a bug report" gnus-bug t] ["Send a mail" gnus-group-mail t] ["Post an article..." gnus-group-post-news t] ["Check for new news" gnus-group-get-new-news t] @@ -782,8 +781,6 @@ The following commands are available: (gnus-set-default-directory) (gnus-update-format-specifications nil 'group 'group-mode) (gnus-update-group-mark-positions) - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) (when gnus-use-undo (gnus-undo-mode 1)) (when gnus-slave @@ -804,9 +801,6 @@ The following commands are available: (list (cons 'process (and (search-forward "\200" nil t) (- (point) 2)))))))) -(defun gnus-clear-inboxes-moved () - (setq nnmail-moved-inboxes nil)) - (defun gnus-mouse-pick-group (e) "Enter the group under the mouse pointer." (interactive "e") @@ -851,8 +845,6 @@ Also see the `gnus-group-use-permanent-levels' variable." (gnus-group-default-level nil t) gnus-group-default-list-level gnus-level-subscribed)))) - ;; Just do this here, for no particular good reason. - (gnus-clear-inboxes-moved) (unless level (setq level (car gnus-group-list-mode) unread (cdr gnus-group-list-mode))) @@ -2453,7 +2445,8 @@ The number of newsgroups that this function was unable to catch up is returned." (interactive "P") (let ((groups (gnus-group-process-prefix n)) - (ret 0)) + (ret 0) + group) (unless groups (error "No groups selected")) (if (not (or (not gnus-interactive-catchup) ;Without confirmation? @@ -2467,21 +2460,21 @@ up is returned." (car groups) (format "these %d groups" (length groups))))))) n - (while groups + (while (setq group (pop groups)) + (gnus-group-remove-mark group) ;; Virtual groups have to be given special treatment. - (let ((method (gnus-find-method-for-group (car groups)))) + (let ((method (gnus-find-method-for-group group))) (when (eq 'nnvirtual (car method)) (nnvirtual-catchup-group - (gnus-group-real-name (car groups)) (nth 1 method) all))) - (gnus-group-remove-mark (car groups)) - (if (>= (gnus-group-group-level) gnus-level-zombie) + (gnus-group-real-name group) (nth 1 method) all))) + (if (>= (gnus-info-level (gnus-get-info group)) + gnus-level-zombie) (gnus-message 2 "Dead groups can't be caught up") (if (prog1 - (gnus-group-goto-group (car groups)) - (gnus-group-catchup (car groups) all)) + (gnus-group-goto-group group) + (gnus-group-catchup group all)) (gnus-group-update-group-line) - (setq ret (1+ ret)))) - (setq groups (cdr groups))) + (setq ret (1+ ret))))) (gnus-group-next-unread-group 1) ret))) @@ -2530,32 +2523,35 @@ or nil if no action could be taken." (error "No groups to expire")) (while (setq group (pop groups)) (gnus-group-remove-mark group) - (when (gnus-check-backend-function 'request-expire-articles group) - (gnus-message 6 "Expiring articles in %s..." group) - (let* ((info (gnus-get-info group)) - (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-find-parameter group 'expiry-wait))) - (when expirable - (setcdr - expirable - (gnus-compress-sequence - (if expiry-wait - ;; We set the expiry variables to the group - ;; parameter. - (let ((nnmail-expiry-wait-function nil) - (nnmail-expiry-wait expiry-wait)) - (gnus-request-expire-articles - (gnus-uncompress-sequence (cdr expirable)) group)) - ;; Just expire using the normal expiry values. - (gnus-request-expire-articles - (gnus-uncompress-sequence (cdr expirable)) group)))) - (gnus-close-group group)) - (gnus-message 6 "Expiring articles in %s...done" group))) + (gnus-group-expire-articles-1 group) (gnus-dribble-touch) (gnus-group-position-point)))) +(defun gnus-group-expire-articles-1 (group) + (when (gnus-check-backend-function 'request-expire-articles group) + (gnus-message 6 "Expiring articles in %s..." group) + (let* ((info (gnus-get-info group)) + (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-find-parameter group 'expiry-wait))) + (when expirable + (setcdr + expirable + (gnus-compress-sequence + (if expiry-wait + ;; We set the expiry variables to the group + ;; parameter. + (let ((nnmail-expiry-wait-function nil) + (nnmail-expiry-wait expiry-wait)) + (gnus-request-expire-articles + (gnus-uncompress-sequence (cdr expirable)) group)) + ;; Just expire using the normal expiry values. + (gnus-request-expire-articles + (gnus-uncompress-sequence (cdr expirable)) group)))) + (gnus-close-group group)) + (gnus-message 6 "Expiring articles in %s...done" group)))) + (defun gnus-group-expire-all-groups () "Expire all expirable articles in all newsgroups." (interactive) @@ -2582,7 +2578,7 @@ or nil if no action could be taken." gnus-level-default-subscribed)) s))))) (unless (and (>= level 1) (<= level gnus-level-killed)) - (error "Illegal level: %d" level)) + (error "Invalid level: %d" level)) (let ((groups (gnus-group-process-prefix n)) group) (while (setq group (pop groups)) @@ -2686,10 +2682,11 @@ N and the number of steps taken is returned." (defun gnus-group-kill-all-zombies () "Kill all zombie newsgroups." (interactive) - (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) - (setq gnus-zombie-list nil) - (gnus-dribble-touch) - (gnus-group-list-groups)) + (when (gnus-yes-or-no-p "Really kill all zombies? ") + (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) + (setq gnus-zombie-list nil) + (gnus-dribble-touch) + (gnus-group-list-groups))) (defun gnus-group-kill-region (begin end) "Kill newsgroups in current region (excluding current point). @@ -2738,7 +2735,8 @@ of groups killed." (push (cons (car entry) (nth 2 entry)) gnus-list-of-killed-groups)) (gnus-group-change-level - (if entry entry group) gnus-level-killed (if entry nil level))) + (if entry entry group) gnus-level-killed (if entry nil level)) + (message "Killed group %s" group)) ;; If there are lots and lots of groups to be killed, we use ;; this thing instead. (let (entry) @@ -2824,7 +2822,7 @@ yanked) a list of yanked groups is returned." (gnus-make-hashtable-from-newsrc-alist) (gnus-group-list-groups))) (t - (error "Can't kill; illegal level: %d" level)))) + (error "Can't kill; invalid level: %d" level)))) (defun gnus-group-list-all-groups (&optional arg) "List all newsgroups with level ARG or lower. @@ -2907,7 +2905,11 @@ If ARG is a number, it specifies which levels you are interested in re-scanning. If ARG is non-nil and not a number, this will force \"hard\" re-reading of the active files from all servers." (interactive "P") - (let ((gnus-inhibit-demon t)) + (require 'nnmail) + (let ((gnus-inhibit-demon t) + ;; Binding this variable will inhibit multiple fetchings + ;; of the same mail source. + (nnmail-fetched-sources (list t))) (gnus-run-hooks 'gnus-get-new-news-hook) ;; Read any slave files. @@ -3068,7 +3070,6 @@ to use." (mapatoms (lambda (group) (and (string-match regexp (symbol-value group)) - (gnus-active (symbol-name group)) (push (symbol-name group) groups))) gnus-description-hashtb)) (if (not groups) @@ -3286,59 +3287,60 @@ and the second element is the address." (gnus-browse-foreign-server method)) (defun gnus-group-set-info (info &optional method-only-group part) - (let* ((entry (gnus-gethash - (or method-only-group (gnus-info-group info)) - gnus-newsrc-hashtb)) - (part-info info) - (info (if method-only-group (nth 2 entry) info)) - method) - (when method-only-group + (when info + (let* ((entry (gnus-gethash + (or method-only-group (gnus-info-group info)) + gnus-newsrc-hashtb)) + (part-info info) + (info (if method-only-group (nth 2 entry) info)) + method) + (when method-only-group + (unless entry + (error "Trying to change non-existent group %s" method-only-group)) + ;; We have received parts of the actual group info - either the + ;; select method or the group parameters. We first check + ;; whether we have to extend the info, and if so, do that. + (let ((len (length info)) + (total (if (eq part 'method) 5 6))) + (when (< len total) + (setcdr (nthcdr (1- len) info) + (make-list (- total len) nil))) + ;; Then we enter the new info. + (setcar (nthcdr (1- total) info) part-info))) (unless entry - (error "Trying to change non-existent group %s" method-only-group)) - ;; We have received parts of the actual group info - either the - ;; select method or the group parameters. We first check - ;; whether we have to extend the info, and if so, do that. - (let ((len (length info)) - (total (if (eq part 'method) 5 6))) - (when (< len total) - (setcdr (nthcdr (1- len) info) - (make-list (- total len) nil))) - ;; Then we enter the new info. - (setcar (nthcdr (1- total) info) part-info))) - (unless entry - ;; This is a new group, so we just create it. - (save-excursion - (set-buffer gnus-group-buffer) - (setq method (gnus-info-method info)) - (when (gnus-server-equal method "native") - (setq method nil)) + ;; This is a new group, so we just create it. (save-excursion (set-buffer gnus-group-buffer) - (if method - ;; It's a foreign group... - (gnus-group-make-group - (gnus-group-real-name (gnus-info-group info)) - (if (stringp method) method - (prin1-to-string (car method))) - (and (consp method) - (nth 1 (gnus-info-method info)))) - ;; It's a native group. - (gnus-group-make-group (gnus-info-group info)))) - (gnus-message 6 "Note: New group created") - (setq entry - (gnus-gethash (gnus-group-prefixed-name - (gnus-group-real-name (gnus-info-group info)) - (or (gnus-info-method info) gnus-select-method)) - gnus-newsrc-hashtb)))) - ;; Whether it was a new group or not, we now have the entry, so we - ;; can do the update. - (if entry - (progn - (setcar (nthcdr 2 entry) info) - (when (and (not (eq (car entry) t)) - (gnus-active (gnus-info-group info))) - (setcar entry (length (gnus-list-of-unread-articles (car info)))))) - (error "No such group: %s" (gnus-info-group info))))) + (setq method (gnus-info-method info)) + (when (gnus-server-equal method "native") + (setq method nil)) + (save-excursion + (set-buffer gnus-group-buffer) + (if method + ;; It's a foreign group... + (gnus-group-make-group + (gnus-group-real-name (gnus-info-group info)) + (if (stringp method) method + (prin1-to-string (car method))) + (and (consp method) + (nth 1 (gnus-info-method info)))) + ;; It's a native group. + (gnus-group-make-group (gnus-info-group info)))) + (gnus-message 6 "Note: New group created") + (setq entry + (gnus-gethash (gnus-group-prefixed-name + (gnus-group-real-name (gnus-info-group info)) + (or (gnus-info-method info) gnus-select-method)) + gnus-newsrc-hashtb)))) + ;; Whether it was a new group or not, we now have the entry, so we + ;; can do the update. + (if entry + (progn + (setcar (nthcdr 2 entry) info) + (when (and (not (eq (car entry) t)) + (gnus-active (gnus-info-group info))) + (setcar entry (length (gnus-list-of-unread-articles (car info)))))) + (error "No such group: %s" (gnus-info-group info)))))) (defun gnus-group-set-method-info (group select-method) (gnus-group-set-info select-method group 'method))