;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(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/"
: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)
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.
%O Moderated group (string, \"(m)\" or \"\")
%P Topic indentation (string)
%m Whether there is new(ish) mail in the group (char, \"%\")
+%w Number of new(ish) mails in the group (integer)
%l Whether there are GroupLens predictions for this group (string)
%n Select from where (string)
%z A string that look like `<%s:%n>' if a foreign select method is used
%d The date the group was last entered.
+%E Icon as defined by `gnus-group-icon-list'.
%u User defined specifier. The next character in the format string should
be a letter. Gnus will call the function gnus-user-format-function-X,
where X is the letter following %u. The function will be passed the
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)) .
((= unread 0) .
gnus-group-mail-low-empty-face)
(t .
- gnus-group-mail-low-face))
+ gnus-group-mail-low-face))
"*Controls the highlighting of group buffer lines.
Below is a list of `Form'/`Face' pairs. When deciding how a a
:group 'gnus-group-visual
:type 'character)
+(defgroup gnus-group-icons nil
+ "Add Icons to your group buffer. "
+ :group 'gnus-group-visual)
+
+(defcustom gnus-group-icon-list
+ nil
+ "*Controls the insertion of icons into group buffer lines.
+
+Below is a list of `Form'/`File' pairs. When deciding how a
+particular group line should be displayed, each form is evaluated.
+The icon from the file field after the first true form is used. You
+can change how those group lines are displayed by editing the file
+field. The File will either be found in the
+`gnus-group-glyph-directory' or by designating absolute path to the
+file.
+
+It is also possible to change and add form fields, but currently that
+requires an understanding of Lisp expressions. Hopefully this will
+change in a future release. For now, you can use the following
+variables in the Lisp expression:
+
+group: The name of the group.
+unread: The number of unread articles in the group.
+method: The select method used.
+mailp: Whether it's a mail group or not.
+newsp: Whether it's a news group or not
+level: The level of the group.
+score: The score of the group.
+ticked: The number of ticked articles."
+ :group 'gnus-group-icons
+ :type '(repeat (cons (sexp :tag "Form") file)))
+
;;; Internal variables
(defvar gnus-group-sort-alist-function 'gnus-group-sort-flat
(?s gnus-tmp-news-server ?s)
(?n gnus-tmp-news-method ?s)
(?P gnus-group-indentation ?s)
+ (?E gnus-tmp-group-icon ?s)
(?l gnus-tmp-grouplens ?s)
(?z gnus-tmp-news-method-string ?s)
(?m (gnus-group-new-mail gnus-tmp-group) ?c)
+ (?w (if (gnus-news-group-p gnus-tmp-group)
+ ""
+ (int-to-string
+ (length
+ (nnmail-new-mail-numbers (gnus-group-real-name gnus-tmp-group))
+ )))
+ ?s)
(?d (gnus-group-timestamp-string gnus-tmp-group) ?s)
(?u gnus-tmp-user-defined ?s)))
(defvar gnus-group-list-mode nil)
+
+(defvar gnus-group-icon-cache nil)
+(defvar gnus-group-running-xemacs (string-match "XEmacs" emacs-version))
+
;;;
;;; Gnus group mode
;;;
"u" gnus-group-make-useful-group
"a" gnus-group-make-archive-group
"k" gnus-group-make-kiboze-group
+ "l" gnus-group-nnimap-edit-acl
"m" gnus-group-make-group
"E" gnus-group-edit-group
"e" gnus-group-edit-group-method
"w" gnus-group-make-web-group
"r" gnus-group-rename-group
"c" gnus-group-customize
+ "x" gnus-group-nnimap-expunge
"\177" gnus-group-delete-group
[delete] gnus-group-delete-group)
"d" gnus-group-description-apropos
"m" gnus-group-list-matching
"M" gnus-group-list-all-matching
- "l" gnus-group-list-level)
+ "l" gnus-group-list-level
+ "c" gnus-group-list-cached)
(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
"f" gnus-score-flush-cache)
["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])
+ ["List active file" gnus-group-list-active t]
+ ["List groups with cached" gnus-group-list-cached t])
("Sort"
["Default sort" gnus-group-sort-groups t]
["Sort by method" gnus-group-sort-groups-by-method t]
["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]
(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
+ (gnus-slave-mode))
(gnus-run-hooks 'gnus-group-mode-hook))
(defun gnus-update-group-mark-positions ()
(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")
(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)))
params (gnus-info-params info)
newsrc (cdr newsrc)
unread (car (gnus-gethash group gnus-newsrc-hashtb)))
- (and unread ; This group might be bogus
+ (and unread ; This group might be unchecked
(or (not regexp)
(string-match regexp group))
(<= (setq clevel (gnus-info-level info)) level)
?m ? ))
(gnus-tmp-moderated-string
(if (eq gnus-tmp-moderated ?m) "(m)" ""))
+ (gnus-tmp-group-icon "==&&==")
(gnus-tmp-method
(gnus-server-get-method gnus-tmp-group gnus-tmp-method)) ;
(gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
gnus-marked ,gnus-tmp-marked-mark
gnus-indentation ,gnus-group-indentation
gnus-level ,gnus-tmp-level))
+ (forward-line -1)
(when (inline (gnus-visual-p 'group-highlight 'highlight))
- (forward-line -1)
(gnus-run-hooks 'gnus-group-update-hook)
(forward-line))
;; Allow XEmacs to remove front-sticky text properties.
found buffer-read-only)
;; Enter the current status into the dribble buffer.
(let ((entry (gnus-gethash group gnus-newsrc-hashtb)))
- (when (and entry (not (gnus-ephemeral-group-p group)))
+ (when (and entry
+ (not (gnus-ephemeral-group-p group)))
(gnus-dribble-enter
(concat "(gnus-group-set-info '"
(gnus-prin1-to-string (nth 2 entry))
(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))
(let ((,groups (gnus-group-process-prefix arg))
(,window (selected-window))
,group)
- (while (setq ,group (pop ,groups))
+ (while ,groups
+ (setq ,group (car ,groups)
+ ,groups (cdr ,groups))
(select-window ,window)
(gnus-group-remove-mark ,group)
(save-selected-window
(defun gnus-fetch-group (group)
"Start Gnus if necessary and enter GROUP.
Returns whether the fetching was successful or not."
- (interactive "sGroup name: ")
+ (interactive (list (completing-read "Group name: " gnus-active-hashtb)))
(unless (get-buffer gnus-group-buffer)
(gnus-no-server))
(gnus-group-read-group nil nil group))
+;;;###autoload
+(defun gnus-fetch-group-other-frame (group)
+ "Pop up a frame and enter GROUP."
+ (interactive "P")
+ (let ((window (get-buffer-window gnus-group-buffer)))
+ (cond (window
+ (select-frame (window-frame window)))
+ ((= (length (frame-list)) 1)
+ (select-frame (make-frame)))
+ (t
+ (other-frame 1))))
+ (gnus-fetch-group group))
+
(defvar gnus-ephemeral-group-server 0)
;; Enter a group that is not in the group buffer. Non-nil is returned
If REQUEST-ONLY, don't actually read the group; just request it.
If SELECT-ARTICLES, only select those articles.
-Return the name of the group is selection was successful."
+Return the name of the group if selection was successful."
;; Transform the select method into a unique server.
(when (stringp method)
(setq method (gnus-server-to-method method)))
(gnus-read-method "From method: ")))
(when (stringp 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)
- method)))
+ (setq method (or (gnus-server-to-method method) method)))
+ (let* ((meth (gnus-method-simplify
+ (when (and method
+ (not (gnus-server-equal method gnus-select-method)))
+ (if address (list (intern method) address)
+ method))))
(nname (if method (gnus-group-prefixed-name name meth) name))
backend info)
(when (gnus-gethash nname gnus-newsrc-hashtb)
(gnus-request-create-group nname nil args))
t))
-(defun gnus-group-delete-group (group &optional force)
- "Delete the current group. Only meaningful with mail groups.
+(defun gnus-group-delete-groups (&optional arg)
+ "Delete the current group. Only meaningful with editable groups."
+ (interactive "P")
+ (let ((n (length (gnus-group-process-prefix arg))))
+ (when (gnus-yes-or-no-p
+ (if (= n 1)
+ "Delete this 1 group? "
+ (format "Delete these %d groups? " n)))
+ (gnus-group-iterate arg
+ (lambda (group)
+ (gnus-group-delete-group group nil t))))))
+
+(defun gnus-group-delete-group (group &optional force no-prompt)
+ "Delete the current group. Only meaningful with editable groups.
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
(unless (gnus-check-backend-function 'request-delete-group group)
(error "This backend does not support group deletion"))
(prog1
- (if (not (gnus-yes-or-no-p
- (format
- "Do you really want to delete %s%s? "
- group (if force " and all its contents" ""))))
+ (if (and (not no-prompt)
+ (not (gnus-yes-or-no-p
+ (format
+ "Do you really want to delete %s%s? "
+ group (if force " and all its contents" "")))))
() ; Whew!
(gnus-message 6 "Deleting group %s..." group)
(if (not (gnus-request-delete-group group force))
(gnus-group-position-point)))
(defun gnus-group-make-useful-group (group method)
+ "Create one of the groups described in `gnus-useful-groups'."
(interactive
(let ((entry (assoc (completing-read "Create group: " gnus-useful-groups
nil t)
"Create the Gnus documentation group."
(interactive)
(let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
- (file (nnheader-find-etc-directory "gnus-tut.txt" t))
- dir)
+ (file (nnheader-find-etc-directory "gnus-tut.txt" t)))
(when (gnus-gethash name gnus-newsrc-hashtb)
(error "Documentation group already exists"))
(if (not file)
((= char ?d) 'digest)
((= char ?f) 'forward)
((= char ?a) 'mmfd)
+ ((= char ?g) 'guess)
(t (setq err (format "%c unknown. " char))
nil))))
(setq type found)))
(cons (current-buffer)
(if (eq major-mode 'gnus-summary-mode) 'summary 'group))))))
+(defvar nnwarchive-type-definition)
+(defvar gnus-group-warchive-type-history nil)
+(defvar gnus-group-warchive-login-history nil)
+(defvar gnus-group-warchive-address-history nil)
+
+(defun gnus-group-make-warchive-group ()
+ "Create a nnwarchive group."
+ (interactive)
+ (require 'nnwarchive)
+ (let* ((group (gnus-read-group "Group name: "))
+ (default-type (or (car gnus-group-warchive-type-history)
+ (symbol-name (caar nnwarchive-type-definition))))
+ (type
+ (gnus-string-or
+ (completing-read
+ (format "Warchive type (default %s): " default-type)
+ (mapcar (lambda (elem) (list (symbol-name (car elem))))
+ nnwarchive-type-definition)
+ nil t nil 'gnus-group-warchive-type-history)
+ default-type))
+ (address (read-string "Warchive address: "
+ nil 'gnus-group-warchive-address-history))
+ (default-login (or (car gnus-group-warchive-login-history)
+ user-mail-address))
+ (login
+ (gnus-string-or
+ (read-string
+ (format "Warchive login (default %s): " user-mail-address)
+ default-login 'gnus-group-warchive-login-history)
+ user-mail-address))
+ (method
+ `(nnwarchive ,address
+ (nnwarchive-type ,(intern type))
+ (nnwarchive-login ,login))))
+ (gnus-group-make-group group method)))
+
(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."
(push (cons header regexps) scores))
scores)))
(gnus-group-make-group group "nnkiboze" address)
- (nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group))
+ (with-temp-file (gnus-score-file-name (concat "nnkiboze:" group))
(let (emacs-lisp-mode-hook)
(pp scores (current-buffer)))))
'summary 'group)))
(error "Couldn't enter %s" dir))))
+(eval-and-compile
+ (autoload 'nnimap-expunge "nnimap")
+ (autoload 'nnimap-acl-get "nnimap")
+ (autoload 'nnimap-acl-edit "nnimap"))
+
+(defun gnus-group-nnimap-expunge (group)
+ "Expunge deleted articles in current nnimap GROUP."
+ (interactive (list (gnus-group-group-name)))
+ (let ((mailbox (gnus-group-real-name group)) method)
+ (unless group
+ (error "No group on current line"))
+ (unless (gnus-get-info group)
+ (error "Killed group; can't be edited"))
+ (unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group))))
+ (error "%s is not an nnimap group" group))
+ (nnimap-expunge mailbox (cadr method))))
+
+(defun gnus-group-nnimap-edit-acl (group)
+ "Edit the Access Control List of current nnimap GROUP."
+ (interactive (list (gnus-group-group-name)))
+ (let ((mailbox (gnus-group-real-name group)) method acl)
+ (unless group
+ (error "No group on current line"))
+ (unless (gnus-get-info group)
+ (error "Killed group; can't be edited"))
+ (unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap)
+ (error "%s is not an nnimap group" group))
+ (gnus-edit-form (setq acl (nnimap-acl-get mailbox (cadr method)))
+ (format "Editing the access control list for `%s'.
+
+ An access control list is a list of (identifier . rights) elements.
+
+ The identifier string specifies the corresponding user. The
+ identifier \"anyone\" is reserved to refer to the universal identity.
+
+ Rights is a string listing a (possibly empty) set of alphanumeric
+ characters, each character listing a set of operations which is being
+ controlled. Letters are reserved for ``standard'' rights, listed
+ below. Digits are reserved for implementation or site defined rights.
+
+ l - lookup (mailbox is visible to LIST/LSUB commands)
+ r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL,
+ SEARCH, COPY from mailbox)
+ s - keep seen/unseen information across sessions (STORE SEEN flag)
+ w - write (STORE flags other than SEEN and DELETED)
+ i - insert (perform APPEND, COPY into mailbox)
+ p - post (send mail to submission address for mailbox,
+ not enforced by IMAP4 itself)
+ c - create (CREATE new sub-mailboxes in any implementation-defined
+ hierarchy)
+ d - delete (STORE DELETED flag, perform EXPUNGE)
+ a - administer (perform SETACL)" group)
+ `(lambda (form)
+ (nnimap-acl-edit
+ ,mailbox ',method ',acl form)))))
+
;; Group sorting commands
;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
;; Go through all the infos and replace the old entries
;; with the new infos.
(while infos
- (setcar entries (pop infos))
+ (setcar (car entries) (pop infos))
(pop entries))
;; Update the hashtable.
(gnus-make-hashtable-from-newsrc-alist)))
-(defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse)
"Sort the group buffer alphabetically by group name.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse))
+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))
-(defun gnus-group-sort-selected-groups-by-unread (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
"Sort the group buffer by number of unread articles.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse))
+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))
-(defun gnus-group-sort-selected-groups-by-level (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
"Sort the group buffer by group level.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse))
+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))
-(defun gnus-group-sort-selected-groups-by-score (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
"Sort the group buffer by group score.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse))
+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))
-(defun gnus-group-sort-selected-groups-by-rank (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
"Sort the group buffer by group rank.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse))
+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))
-(defun gnus-group-sort-selected-groups-by-method (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
"Sort the group buffer alphabetically by backend name.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse))
+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))
;;; Sorting predicates.
(when (gnus-group-native-p (gnus-info-group info))
(gnus-info-clear-data info)))
(gnus-get-unread-articles)
- (gnus-dribble-enter "")
+ (gnus-dribble-touch)
(when (gnus-y-or-n-p
"Move the cache away to avoid problems in the future? ")
(call-interactively 'gnus-cache-move-cache)))))
;; Group catching up.
(defun gnus-group-catchup-current (&optional n all)
- "Mark all articles not marked as unread in current newsgroup as read.
+ "Mark all unread articles in the current newsgroup as read.
If prefix argument N is numeric, the next N newsgroups will be
caught up. If ALL is non-nil, marked articles will also be marked as
read. Cross references (Xref: header) of articles are ignored.
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?
(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-group-level 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)))
or nil if no action could be taken."
(let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
(num (car entry)))
+ ;; Remove entries for this group.
+ (nnmail-purge-split-history (gnus-group-real-name group))
;; Do the updating only if the newsgroup isn't killed.
(if (not (numberp (car entry)))
(gnus-message 1 "Can't catch up %s; non-active group" group)
(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))
+ (nnmail-expiry-target
+ (or (gnus-group-find-parameter group 'expiry-target)
+ nnmail-expiry-target)))
+ (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)
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))
(gnus-group-yank-group)
(gnus-group-position-point)))
-(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-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-region (begin end)
"Kill newsgroups in current region (excluding current point).
(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)
(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.
(interactive)
;; First we make sure that we have really read the active file.
(unless (gnus-read-active-file-p)
- (let ((gnus-read-active-file t))
+ (let ((gnus-read-active-file t)
+ (gnus-agent nil)) ; Trick the agent into ignoring the active file.
(gnus-read-active-file)))
;; Find all groups and sort them.
(let ((groups
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.
(ret (if (numberp n) (- n (length groups)) 0))
(beg (unless n
(point)))
- group)
+ group method
+ (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)
(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))
+ (gnus-remove-denial (setq method (gnus-find-method-for-group group)))
(if (gnus-activate-group group (if dont-scan nil 'scan))
(progn
(gnus-get-unread-articles-in-group
(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-group-update-group group))
(if (eq (gnus-server-status (gnus-find-method-for-group group))
'denied)
(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)
;; 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
(interactive)
(gnus-run-hooks 'gnus-suspend-gnus-hook)
;; Kill Gnus buffers except for group mode buffer.
- (let* ((group-buf (get-buffer gnus-group-buffer)))
- (apply (lambda (buf)
- (unless (equal buf group-buf)
- (kill-buffer buf)))
- (gnus-buffers))
+ (let ((group-buf (get-buffer gnus-group-buffer)))
+ (mapcar (lambda (buf)
+ (unless (member buf (list group-buf gnus-dribble-buffer))
+ (kill-buffer buf)))
+ (gnus-buffers))
(gnus-kill-gnus-frames)
(when group-buf
(bury-buffer group-buf)
(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 (or info 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
+ (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))
(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)))
- (uncompressed '(score bookmark killed))
marked m)
(or (not info)
(and (not (setq marked (nthcdr 3 info)))
(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 (gnus-time-minus (current-time) time)))
+ (list 0 0)))
+ (delta (subtract-time (current-time) time)))
(+ (* (nth 0 delta) 65536.0)
(nth 1 delta))))
""
(gnus-time-iso8601 time))))
+(defun gnus-group-prepare-flat-predicate (level predicate &optional lowest)
+ "List all newsgroups with unread articles of level LEVEL or lower.
+If LOWEST is non-nil, list all newsgroups of level LOWEST or higher.
+If PREDICATE, only list groups which PREDICATE returns non-nil."
+ (set-buffer gnus-group-buffer)
+ (let ((buffer-read-only nil)
+ (newsrc (cdr gnus-newsrc-alist))
+ (lowest (or lowest 1))
+ info clevel unread group params)
+ (erase-buffer)
+ ;; List living groups.
+ (while newsrc
+ (setq info (car newsrc)
+ group (gnus-info-group info)
+ params (gnus-info-params info)
+ newsrc (cdr newsrc)
+ unread (car (gnus-gethash group gnus-newsrc-hashtb)))
+ (and unread ; This group might be unchecked
+ (funcall predicate info)
+ (<= (setq clevel (gnus-info-level info)) level)
+ (>= clevel lowest)
+ (gnus-group-insert-group-line
+ group (gnus-info-level info)
+ (gnus-info-marks info) unread (gnus-info-method info))))
+
+ (gnus-group-set-mode-line)
+ (setq gnus-group-list-mode (cons level t))
+ (gnus-run-hooks 'gnus-group-prepare-hook)
+ t))
+
+(defun gnus-group-list-cached (level &optional lowest)
+ "List all groups with cached articles.
+If the prefix LEVEL is non-nil, it should be a number that says which
+level to cut off listing groups.
+If LOWEST, don't list groups with level lower than LOWEST.
+
+This command may read the active file."
+ (interactive "P")
+ (when level
+ (setq level (prefix-numeric-value level)))
+ (gnus-group-prepare-flat-predicate (or level gnus-level-killed)
+ #'(lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'cache marks)))
+ lowest)
+ (goto-char (point-min))
+ (gnus-group-position-point))
+
(provide 'gnus-group)
;;; gnus-group.el ends here
projects / elisp / gnus.git- / blobdiff