X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=0e6f1b1535b14cfa960b6185c8693fc7a83fd3a4;hb=cddb4672a1b8d0b3fb03dd1c5cad4b01f9fab219;hp=736ad5361b7b58bf9ad6d93902d5b1d7c828c1e9;hpb=9dc12b9ca22173804a9fe992e95f0feb774bf828;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 736ad53..0e6f1b1 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 @@ -35,6 +35,7 @@ (require 'gnus-range) (require 'gnus-win) (require 'gnus-undo) +(require 'time-date) (defcustom gnus-group-archive-directory "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" @@ -48,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) @@ -298,6 +299,18 @@ variable." gnus-group-news-3-empty-face) ((and (not mailp) (eq level 3)) . gnus-group-news-3-face) + ((and (= unread 0) (not mailp) (eq level 4)) . + gnus-group-news-4-empty-face) + ((and (not mailp) (eq level 4)) . + gnus-group-news-4-face) + ((and (= unread 0) (not mailp) (eq level 5)) . + gnus-group-news-5-empty-face) + ((and (not mailp) (eq level 5)) . + gnus-group-news-5-face) + ((and (= unread 0) (not mailp) (eq level 6)) . + gnus-group-news-6-empty-face) + ((and (not mailp) (eq level 6)) . + gnus-group-news-6-face) ((and (= unread 0) (not mailp)) . gnus-group-news-low-empty-face) ((and (not mailp)) . @@ -763,14 +776,12 @@ The following commands are available: (gnus-group-set-mode-line) (setq mode-line-process nil) (use-local-map gnus-group-mode-map) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (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) - (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 @@ -791,9 +802,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") @@ -838,8 +846,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))) @@ -1327,7 +1333,7 @@ If FIRST-TOO, the current line is also eligible as a target." (beginning-of-line) (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) (subst-char-in-region - (point) (1+ (point)) (following-char) + (point) (1+ (point)) (char-after) (if unmark (progn (setq gnus-group-marked (delete group gnus-group-marked)) @@ -1802,7 +1808,7 @@ ADDRESS." (gnus-read-method "From method: "))) (when (stringp method) - (setq method (gnus-server-to-method method))) + (setq method (or (gnus-server-to-method method) method))) (let* ((meth (when (and method (not (gnus-server-equal method gnus-select-method))) (if address (list (intern method) address) @@ -2440,7 +2446,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? @@ -2454,21 +2461,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))) @@ -2517,32 +2524,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) @@ -2569,7 +2579,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)) @@ -2673,10 +2683,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). @@ -2811,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. @@ -2894,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. @@ -2946,8 +2961,9 @@ If N is negative, this group and the N-1 previous groups will be checked." (gnus-get-info group) (gnus-active group) t) (unless (gnus-virtual-group-p group) (gnus-close-group group)) - (gnus-agent-save-group-info - method (gnus-group-real-name group) (gnus-active group)) + (when gnus-agent + (gnus-agent-save-group-info + method (gnus-group-real-name group) (gnus-active group))) (gnus-group-update-group group)) (if (eq (gnus-server-status (gnus-find-method-for-group group)) 'denied) @@ -3054,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) @@ -3062,7 +3077,7 @@ to use." ;; Print out all the groups. (save-excursion (pop-to-buffer "*Gnus Help*") - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (erase-buffer) (setq groups (sort groups 'string<)) (while groups @@ -3334,26 +3349,26 @@ and the second element is the address." (defun gnus-add-marked-articles (group type articles &optional info force) ;; Add ARTICLES of TYPE to the info of GROUP. - ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't + ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't ;; add, but replace marked articles of TYPE with ARTICLES. (let ((info (or info (gnus-get-info group))) marked m) (or (not info) (and (not (setq marked (nthcdr 3 info))) (or (null articles) - (setcdr (nthcdr 2 info) - (list (list (cons type (gnus-compress-sequence - articles t))))))) + (setcdr (nthcdr 2 info) + (list (list (cons type (gnus-compress-sequence + articles t))))))) (and (not (setq m (assq type (car marked)))) (or (null articles) - (setcar marked - (cons (cons type (gnus-compress-sequence articles t) ) - (car marked))))) + (setcar marked + (cons (cons type (gnus-compress-sequence articles t) ) + (car marked))))) (if force (if (null articles) - (setcar (nthcdr 3 info) - (gnus-delete-alist type (car marked))) - (setcdr m (gnus-compress-sequence articles t))) + (setcar (nthcdr 3 info) + (gnus-delete-alist type (car marked))) + (setcdr m (gnus-compress-sequence articles t))) (setcdr m (gnus-compress-sequence (sort (nconc (gnus-uncompress-range (cdr m)) (copy-sequence articles)) '<) t))))))