X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=d56f5ce3982ebeef53bf93f158a322de4cd311d1;hb=04aa4d466b5e1d5906632c748818fed207fd0c32;hp=54239628d00556e96248237fb2b9307f401e1c56;hpb=625b891fc07e1e5fc5f2658176b6c0e3cb244ee0;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 5423962..d56f5ce 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,99 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -35,7 +35,6 @@ (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/" @@ -49,7 +48,7 @@ :group 'gnus-group-foreign :type 'directory) -(defcustom gnus-no-groups-message "No gnus is bad news" +(defcustom gnus-no-groups-message "No news is no news" "*Message displayed by Gnus when no groups are available." :group 'gnus-start :type 'string) @@ -90,7 +89,7 @@ unread articles in the groups. If nil, no groups are permanently visible." :group 'gnus-group-listing - :type '(choice regexp (const nil))) + :type 'regexp) (defcustom gnus-list-groups-with-ticked-articles t "*If non-nil, list groups that have only ticked articles. @@ -299,18 +298,6 @@ 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)) . @@ -725,6 +712,7 @@ 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] @@ -775,12 +763,14 @@ 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) + (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) + (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 @@ -801,6 +791,9 @@ 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") @@ -845,6 +838,8 @@ 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))) @@ -1332,7 +1327,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)) (char-after) + (point) (1+ (point)) (following-char) (if unmark (progn (setq gnus-group-marked (delete group gnus-group-marked)) @@ -1807,7 +1802,7 @@ ADDRESS." (gnus-read-method "From method: "))) (when (stringp method) - (setq method (or (gnus-server-to-method method) method))) + (setq method (gnus-server-to-method method))) (let* ((meth (when (and method (not (gnus-server-equal method gnus-select-method))) (if address (list (intern method) address) @@ -2046,7 +2041,6 @@ and NEW-NAME will be prompted for." ((= char ?d) 'digest) ((= char ?f) 'forward) ((= char ?a) 'mmfd) - ((= char ?g) 'guess) (t (setq err (format "%c unknown. " char)) nil)))) (setq type found))) @@ -2161,7 +2155,7 @@ score file entries for articles to include in the group." (push (cons header regexps) scores)) scores))) (gnus-group-make-group group "nnkiboze" address) - (with-temp-file (gnus-score-file-name (concat "nnkiboze:" group)) + (nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group)) (let (emacs-lisp-mode-hook) (pp scores (current-buffer))))) @@ -2306,52 +2300,46 @@ If REVERSE, sort in reverse order." ;; Go through all the infos and replace the old entries ;; with the new infos. (while infos - (setcar (car entries) (pop infos)) + (setcar entries (pop infos)) (pop entries)) ;; Update the hashtable. (gnus-make-hashtable-from-newsrc-alist))) -(defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse) +(defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse) "Sort the group buffer alphabetically by group name. -Obeys the process/prefix convention. If REVERSE (the symbolic prefix), -sort in reverse order." - (interactive (gnus-interactive "P\ny")) - (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse)) +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse)) -(defun gnus-group-sort-selected-groups-by-unread (&optional n reverse) +(defun gnus-group-sort-selected-groups-by-unread (&optional reverse) "Sort the group buffer by number of unread articles. -Obeys the process/prefix convention. If REVERSE (the symbolic prefix), -sort in reverse order." - (interactive (gnus-interactive "P\ny")) - (gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse)) +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse)) -(defun gnus-group-sort-selected-groups-by-level (&optional n reverse) +(defun gnus-group-sort-selected-groups-by-level (&optional reverse) "Sort the group buffer by group level. -Obeys the process/prefix convention. If REVERSE (the symbolic prefix), -sort in reverse order." - (interactive (gnus-interactive "P\ny")) - (gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse)) +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse)) -(defun gnus-group-sort-selected-groups-by-score (&optional n reverse) +(defun gnus-group-sort-selected-groups-by-score (&optional reverse) "Sort the group buffer by group score. -Obeys the process/prefix convention. If REVERSE (the symbolic prefix), -sort in reverse order." - (interactive (gnus-interactive "P\ny")) - (gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse)) +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse)) -(defun gnus-group-sort-selected-groups-by-rank (&optional n reverse) +(defun gnus-group-sort-selected-groups-by-rank (&optional reverse) "Sort the group buffer by group rank. -Obeys the process/prefix convention. If REVERSE (the symbolic prefix), -sort in reverse order." - (interactive (gnus-interactive "P\ny")) - (gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse)) +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse)) -(defun gnus-group-sort-selected-groups-by-method (&optional n reverse) +(defun gnus-group-sort-selected-groups-by-method (&optional reverse) "Sort the group buffer alphabetically by backend name. -Obeys the process/prefix convention. If REVERSE (the symbolic prefix), -sort in reverse order." - (interactive (gnus-interactive "P\ny")) - (gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse)) +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse)) ;;; Sorting predicates. @@ -2446,8 +2434,7 @@ 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) - group) + (ret 0)) (unless groups (error "No groups selected")) (if (not (or (not gnus-interactive-catchup) ;Without confirmation? @@ -2461,21 +2448,21 @@ up is returned." (car groups) (format "these %d groups" (length groups))))))) n - (while (setq group (pop groups)) - (gnus-group-remove-mark group) + (while groups ;; Virtual groups have to be given special treatment. - (let ((method (gnus-find-method-for-group group))) + (let ((method (gnus-find-method-for-group (car groups)))) (when (eq 'nnvirtual (car method)) (nnvirtual-catchup-group - (gnus-group-real-name group) (nth 1 method) all))) - (if (>= (gnus-info-level (gnus-get-info group)) - gnus-level-zombie) + (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-message 2 "Dead groups can't be caught up") (if (prog1 - (gnus-group-goto-group group) - (gnus-group-catchup group all)) + (gnus-group-goto-group (car groups)) + (gnus-group-catchup (car groups) all)) (gnus-group-update-group-line) - (setq ret (1+ ret))))) + (setq ret (1+ ret)))) + (setq groups (cdr groups))) (gnus-group-next-unread-group 1) ret))) @@ -2524,35 +2511,32 @@ or nil if no action could be taken." (error "No groups to expire")) (while (setq group (pop groups)) (gnus-group-remove-mark group) - (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))) (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) @@ -2579,7 +2563,7 @@ or nil if no action could be taken." gnus-level-default-subscribed)) s))))) (unless (and (>= level 1) (<= level gnus-level-killed)) - (error "Invalid level: %d" level)) + (error "Illegal level: %d" level)) (let ((groups (gnus-group-process-prefix n)) group) (while (setq group (pop groups)) @@ -2680,15 +2664,13 @@ N and the number of steps taken is returned." (gnus-group-yank-group) (gnus-group-position-point))) -(defun gnus-group-kill-all-zombies (&optional dummy) - "Kill all zombie newsgroups. -The optional DUMMY should always be nil." - (interactive (list (not (gnus-yes-or-no-p "Really kill all zombies? ")))) - (unless dummy - (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-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)) (defun gnus-group-kill-region (begin end) "Kill newsgroups in current region (excluding current point). @@ -2737,8 +2719,7 @@ 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)) - (message "Killed group %s" group)) + (if entry entry group) gnus-level-killed (if entry nil level))) ;; If there are lots and lots of groups to be killed, we use ;; this thing instead. (let (entry) @@ -2824,7 +2805,7 @@ yanked) a list of yanked groups is returned." (gnus-make-hashtable-from-newsrc-alist) (gnus-group-list-groups))) (t - (error "Can't kill; invalid level: %d" level)))) + (error "Can't kill; illegal level: %d" level)))) (defun gnus-group-list-all-groups (&optional arg) "List all newsgroups with level ARG or lower. @@ -2907,11 +2888,7 @@ 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") - (require 'nnmail) - (let ((gnus-inhibit-demon t) - ;; Binding this variable will inhibit multiple fetchings - ;; of the same mail source. - (nnmail-fetched-sources (list t))) + (let ((gnus-inhibit-demon t)) (gnus-run-hooks 'gnus-get-new-news-hook) ;; Read any slave files. @@ -2963,9 +2940,8 @@ 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)) - (when gnus-agent - (gnus-agent-save-group-info - method (gnus-group-real-name group) (gnus-active group))) + (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) @@ -3079,7 +3055,7 @@ to use." ;; Print out all the groups. (save-excursion (pop-to-buffer "*Gnus Help*") - (buffer-disable-undo) + (buffer-disable-undo (current-buffer)) (erase-buffer) (setq groups (sort groups 'string<)) (while groups @@ -3289,60 +3265,59 @@ and the second element is the address." (gnus-browse-foreign-server method)) (defun gnus-group-set-info (info &optional method-only-group part) - (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))) + (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 - ;; This is a new group, so we just create it. + (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)) (save-excursion (set-buffer gnus-group-buffer) - (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)))))) + (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)) @@ -3352,26 +3327,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)))))) @@ -3397,7 +3372,7 @@ or `gnus-group-catchup-group-hook'." "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 (subtract-time (current-time) time))) + (delta (gnus-time-minus (current-time) time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta))))