X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=17b58feb74392ba9262fd2b522280431332f1213;hb=7e38337607c1f9b091002eb6c5661dfe8826fda0;hp=30fc67c044c1c950a54b88ea97051cd3210ac52d;hpb=7554e4249c821770633b5aea99298d92bf1e5b5d;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 30fc67c..17b58fe 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -26,7 +26,6 @@ ;;; Code: (eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-start) (require 'nnmail) @@ -90,7 +89,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. @@ -157,6 +156,7 @@ with some simple extensions. %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 @@ -407,6 +407,13 @@ ticked: The number of ticked articles." (?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))) @@ -514,6 +521,7 @@ ticked: The number of ticked articles." "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 @@ -525,6 +533,7 @@ ticked: The number of ticked articles." "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) @@ -725,7 +734,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] @@ -1474,7 +1482,9 @@ and with point over the group in question." (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 @@ -1601,7 +1611,7 @@ ephemeral group. 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))) @@ -1809,10 +1819,11 @@ ADDRESS." (when (stringp 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) - 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) @@ -2047,6 +2058,7 @@ 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))) @@ -2097,6 +2109,42 @@ If SOLID (the prefix), create a solid group." (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." @@ -2215,6 +2263,62 @@ score file entries for articles to include in the group." '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 . @@ -2524,32 +2628,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) @@ -2677,13 +2784,15 @@ N and the number of steps taken is returned." (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). @@ -2732,7 +2841,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) @@ -2861,7 +2971,8 @@ entail asking the server for the groups." (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 @@ -3283,59 +3394,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 (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))