;;; Code:
(eval-when-compile (require 'cl))
-
(require 'gnus)
(require 'gnus-start)
(require 'nnmail)
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
(?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)))
"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)
["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]
(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
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)))
(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)
((= 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."
'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>.
(gnus-group-yank-group)
(gnus-group-position-point)))
-(defun gnus-group-kill-all-zombies ()
- "Kill all zombie newsgroups."
- (interactive)
- (when (gnus-yes-or-no-p "Really kill all zombies? ")
+(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)
(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)
(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
(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))
projects / elisp / gnus.git- / blobdiff