(defvar gnus-group-icon-cache nil)
-(defvar gnus-group-running-xemacs (string-match "XEmacs" emacs-version))
+
+(defvar gnus-group-listed-groups nil)
+(defvar gnus-group-list-option nil)
;;;
;;; Gnus group mode
"c" gnus-group-list-cached
"?" gnus-group-list-dormant)
+ (gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map)
+ "k" gnus-group-list-limit
+ "z" gnus-group-list-limit
+ "s" gnus-group-list-limit
+ "u" gnus-group-list-limit
+ "A" gnus-group-list-limit
+ "m" gnus-group-list-limit
+ "M" gnus-group-list-limit
+ "l" gnus-group-list-limit
+ "c" gnus-group-list-limit
+ "?" gnus-group-list-limit)
+
+ (gnus-define-keys (gnus-group-list-flush-map "f" gnus-group-list-map)
+ "k" gnus-group-list-flush
+ "z" gnus-group-list-flush
+ "s" gnus-group-list-flush
+ "u" gnus-group-list-flush
+ "A" gnus-group-list-flush
+ "m" gnus-group-list-flush
+ "M" gnus-group-list-flush
+ "l" gnus-group-list-flush
+ "c" gnus-group-list-flush
+ "?" gnus-group-list-flush)
+
+ (gnus-define-keys (gnus-group-list-plus-map "p" gnus-group-list-map)
+ "k" gnus-group-list-plus
+ "z" gnus-group-list-plus
+ "s" gnus-group-list-plus
+ "u" gnus-group-list-plus
+ "A" gnus-group-list-plus
+ "m" gnus-group-list-plus
+ "M" gnus-group-list-plus
+ "l" gnus-group-list-plus
+ "c" gnus-group-list-plus
+ "?" gnus-group-list-plus)
+
(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
"f" gnus-score-flush-cache)
(interactive "nList groups on level: \nP")
(gnus-group-list-groups level all level))
-(defun gnus-group-prepare-flat (level &optional all lowest regexp)
+(defun gnus-group-prepare-logic (group test)
+ (or (and gnus-group-listed-groups
+ (null gnus-group-list-option)
+ (member group gnus-group-listed-groups))
+ (cond
+ ((null gnus-group-listed-groups) test)
+ ((null gnus-group-list-option) test)
+ (t (and (member group gnus-group-listed-groups)
+ (if (eq gnus-group-list-option 'flush)
+ (not test)
+ test))))))
+
+(defun gnus-group-prepare-flat (level &optional predicate lowest regexp)
"List all newsgroups with unread articles of level LEVEL or lower.
-If ALL is non-nil, list groups that have no unread articles.
+If PREDICATE is a function, list groups that the function returns non-nil;
+if it is t, list groups that have no unread articles.
If LOWEST is non-nil, list all newsgroups of level LOWEST or higher.
-If REGEXP, only list groups matching REGEXP."
+If REGEXP is a function, list dead groups that the function returns non-nil;
+if it is a string, only list groups matching REGEXP."
(set-buffer gnus-group-buffer)
(let ((buffer-read-only nil)
(newsrc (cdr gnus-newsrc-alist))
(lowest (or lowest 1))
+ (not-in-list (and gnus-group-listed-groups
+ (not (eq gnus-group-list-option 'limit))
+ (copy-sequence gnus-group-listed-groups)))
info clevel unread group params)
(erase-buffer)
- (when (< lowest gnus-level-zombie)
+ (when (or (< lowest gnus-level-zombie)
+ gnus-group-listed-groups)
;; List living groups.
(while newsrc
(setq info (car newsrc)
params (gnus-info-params info)
newsrc (cdr newsrc)
unread (car (gnus-gethash group gnus-newsrc-hashtb)))
- (and unread ; This group might be unchecked
- (or (not regexp)
- (string-match regexp group))
- (<= (setq clevel (gnus-info-level info)) level)
- (>= clevel lowest)
- (or all ; We list all groups?
- (if (eq unread t) ; Unactivated?
- gnus-group-list-inactive-groups ; We list unactivated
- (> unread 0)) ; We list groups with unread articles
- (and gnus-list-groups-with-ticked-articles
- (cdr (assq 'tick (gnus-info-marks info))))
+ (if not-in-list
+ (setq not-in-list (delete group not-in-list)))
+ (and
+ (gnus-group-prepare-logic
+ group
+ (and unread ; This group might be unchecked
+ (or (not (stringp regexp))
+ (string-match regexp group))
+ (<= (setq clevel (gnus-info-level info)) level)
+ (>= clevel lowest)
+ (cond
+ ((functionp predicate)
+ (funcall predicate info))
+ (predicate t) ; We list all groups?
+ (t
+ (or
+ (if (eq unread t) ; Unactivated?
+ gnus-group-list-inactive-groups
+ ; We list unactivated
+ (> unread 0))
+ ; We list groups with unread articles
+ (and gnus-list-groups-with-ticked-articles
+ (cdr (assq 'tick (gnus-info-marks info))))
; And groups with tickeds
- ;; Check for permanent visibility.
- (and gnus-permanently-visible-groups
- (string-match gnus-permanently-visible-groups
- group))
- (memq 'visible params)
- (cdr (assq 'visible params)))
- (gnus-group-insert-group-line
- group (gnus-info-level info)
- (gnus-info-marks info) unread (gnus-info-method info)))))
-
+ ;; Check for permanent visibility.
+ (and gnus-permanently-visible-groups
+ (string-match gnus-permanently-visible-groups group))
+ (memq 'visible params)
+ (cdr (assq 'visible params)))))))
+ (gnus-group-insert-group-line
+ group (gnus-info-level info)
+ (gnus-info-marks info) unread (gnus-info-method info)))))
+
;; List dead groups.
- (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)
- (gnus-group-prepare-flat-list-dead
- (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
- gnus-level-zombie ?Z
- regexp))
- (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
- (gnus-group-prepare-flat-list-dead
- (setq gnus-killed-list (sort gnus-killed-list 'string<))
- gnus-level-killed ?K regexp))
+ (if (or gnus-group-listed-groups
+ (and (>= level gnus-level-zombie)
+ (<= lowest gnus-level-zombie)))
+ (gnus-group-prepare-flat-list-dead
+ (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
+ gnus-level-zombie ?Z
+ regexp))
+ (if not-in-list
+ (dolist (group gnus-zombie-list)
+ (setq not-in-list (delete group not-in-list))))
+ (if (or gnus-group-listed-groups
+ (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)))
+ (gnus-group-prepare-flat-list-dead
+ (or not-in-list
+ (setq gnus-killed-list (sort gnus-killed-list 'string<)))
+ gnus-level-killed ?K regexp))
(gnus-group-set-mode-line)
- (setq gnus-group-list-mode (cons level all))
+ (setq gnus-group-list-mode (cons level predicate))
(gnus-run-hooks 'gnus-group-prepare-hook)
t))
;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does
;; this by ignoring the group format specification altogether.
(let (group)
- (if regexp
- ;; This loop is used when listing groups that match some
- ;; regexp.
- (while groups
- (setq group (pop groups))
- (when (string-match regexp group)
- (gnus-add-text-properties
- (point) (prog1 (1+ (point))
- (insert " " mark " *: "
- (gnus-group-name-decode group
- (gnus-group-name-charset
- nil group))
- "\n"))
- (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
- 'gnus-unread t
- 'gnus-level level))))
- ;; This loop is used when listing all groups.
- (while groups
- (setq group (pop groups))
- (gnus-add-text-properties
- (point) (prog1 (1+ (point))
- (insert " " mark " *: "
- (gnus-group-name-decode group
- (gnus-group-name-charset
- nil group))
- "\n"))
- (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
- 'gnus-unread t
- 'gnus-level level))))))
+ (while groups
+ (setq group (pop groups))
+ (when (gnus-group-prepare-logic
+ group
+ (or (not regexp)
+ (and (stringp regexp) (string-match regexp group))
+ (and (functionp regexp) (funcall regexp group))))
+;;; (gnus-add-text-properties
+;;; (point) (prog1 (1+ (point))
+;;; (insert " " mark " *: "
+;;; (gnus-group-name-decode group
+;;; (gnus-group-name-charset
+;;; nil group))
+;;; "\n"))
+;;; (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
+;;; 'gnus-unread t
+;;; 'gnus-level level))
+ (gnus-group-insert-group-line
+ group level nil
+ (if gnus-server-browse-hashtb
+ (gnus-gethash group gnus-server-browse-hashtb) t)
+ (gnus-method-simplify (gnus-find-method-for-group group)))))))
(defun gnus-group-update-group-line ()
"Update the current line in the group buffer."
gnus-level ,gnus-tmp-level))
(forward-line -1)
(when (inline (gnus-visual-p 'group-highlight 'highlight))
- (gnus-run-hooks 'gnus-group-update-hook)
- (forward-line))
+ (gnus-run-hooks 'gnus-group-update-hook))
+ (forward-line)
;; Allow XEmacs to remove front-sticky text properties.
(gnus-group-remove-excess-properties)))
(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
(when (gnus-group-read-group t t group select-articles)
group)
;;(error nil)
- (quit nil)))))
+ (quit
+ (message "Quit reading the ephemeral group")
+ nil)))))
(defun gnus-group-jump-to-group (group)
"Jump to newsgroup GROUP."
(gnus-message 6 "Renaming group %s to %s..." group new-name)
(prog1
- (if (not (gnus-request-rename-group group new-name))
+ (if (progn
+ (gnus-group-goto-group group)
+ (not (when (< (gnus-group-group-level) gnus-level-zombie)
+ (gnus-request-rename-group group new-name))))
(gnus-error 3 "Couldn't rename group %s to %s" group new-name)
;; We rename the group internally by killing it...
- (gnus-group-goto-group group)
(gnus-group-kill-group)
;; ... changing its name ...
(setcar (cdar gnus-list-of-killed-groups) new-name)
"Match on header: " headers nil t))))
(setq regexps nil)
(while (not (equal "" (setq regexp (read-string
- (format "Match on %s (string): "
+ (format "Match on %s (regexp): "
header)))))
(push (list regexp nil nil 'r) regexps))
(push (cons header regexps) scores))
scores)))
(gnus-group-make-group group "nnkiboze" address)
- (with-temp-file (gnus-score-file-name (concat "nnkiboze:" group))
- (let (emacs-lisp-mode-hook)
- (pp scores (current-buffer)))))
+ (let* ((nnkiboze-current-group group)
+ (score-file (car (nnkiboze-score-file "")))
+ (score-dir (file-name-directory score-file)))
+ (unless (file-exists-p score-dir)
+ (make-directory score-dir))
+ (with-temp-file score-file
+ (let (emacs-lisp-mode-hook)
+ (pp scores (current-buffer))))))
(defun gnus-group-add-to-virtual (n vgroup)
"Add the current group to a virtual 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'.
+ (unless (setq acl (nnimap-acl-get mailbox (cadr method)))
+ (error "Server does not support ACL's"))
+ (gnus-edit-form acl (format "Editing the access control list for `%s'.
An access control list is a list of (identifier . rights) elements.
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)
+ 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)
+ c - create and delete mailbox (CREATE new sub-mailboxes in any
+ implementation-defined hierarchy, RENAME or DELETE mailbox)
+ d - delete messages (STORE \\DELETED flag, perform EXPUNGE)
a - administer (perform SETACL)" group)
`(lambda (form)
(nnimap-acl-edit
(or (gnus-group-find-parameter group 'expiry-target)
nnmail-expiry-target)))
(when expirable
+ (gnus-check-group group)
(setcdr
expirable
(gnus-compress-sequence
(gnus-request-expire-articles
(gnus-uncompress-sequence (cdr expirable)) group))))
(gnus-close-group group))
- (gnus-message 6 "Expiring articles in %s...done" group))))
+ (gnus-message 6 "Expiring articles in %s...done" group)
+ ;; Return the list of un-expired articles.
+ (cdr expirable))))
(defun gnus-group-expire-all-groups ()
"Expire all expirable articles in all newsgroups."
(when (and level
(> (prefix-numeric-value level) gnus-level-killed))
(gnus-get-killed-groups))
- (gnus-group-prepare-flat
- (or level gnus-level-subscribed) all (or lowest 1) regexp)
+ (funcall gnus-group-prepare-function
+ (or level gnus-level-subscribed) (and all t) (or lowest 1) regexp)
(goto-char (point-min))
(gnus-group-position-point))
(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)
""
(gnus-time-iso8601 time))))
-(defun gnus-group-prepare-flat-list-dead-predicate
- (groups level mark predicate)
- (let (group)
- (if predicate
- ;; This loop is used when listing groups that match some
- ;; regexp.
- (while (setq group (pop groups))
- (when (funcall predicate group)
- (gnus-add-text-properties
- (point) (prog1 (1+ (point))
- (insert " " mark " *: "
- (gnus-group-name-decode group
- (gnus-group-name-charset
- nil group))
- "\n"))
- (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
- 'gnus-unread t
- 'gnus-level level)))))))
-
-(defun gnus-group-prepare-flat-predicate (level predicate &optional lowest
- dead-predicate)
- "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.
-If DEAD-PREDICATE, list dead groups which DEAD-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))))
-
- ;; List dead groups.
- (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)
- (gnus-group-prepare-flat-list-dead-predicate
- (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
- gnus-level-zombie ?Z
- dead-predicate))
- (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
- (gnus-group-prepare-flat-list-dead-predicate
- (setq gnus-killed-list (sort gnus-killed-list 'string<))
- gnus-level-killed ?K dead-predicate))
-
- (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
(setq level (prefix-numeric-value level)))
(when (or (not level) (>= level gnus-level-zombie))
(gnus-cache-open))
- (gnus-group-prepare-flat-predicate (or level gnus-level-subscribed)
- #'(lambda (info)
- (let ((marks (gnus-info-marks info)))
- (assq 'cache marks)))
- lowest
- #'(lambda (group)
- (or (gnus-gethash group
- gnus-cache-active-hashtb)
- ;; Cache active file might use "."
- ;; instead of ":".
- (gnus-gethash
- (mapconcat 'identity
- (split-string group ":")
- ".")
- gnus-cache-active-hashtb))))
+ (funcall gnus-group-prepare-function
+ (or level gnus-level-subscribed)
+ #'(lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'cache marks)))
+ lowest
+ #'(lambda (group)
+ (or (gnus-gethash group
+ gnus-cache-active-hashtb)
+ ;; Cache active file might use "."
+ ;; instead of ":".
+ (gnus-gethash
+ (mapconcat 'identity
+ (split-string group ":")
+ ".")
+ gnus-cache-active-hashtb))))
(goto-char (point-min))
(gnus-group-position-point))
(setq level (prefix-numeric-value level)))
(when (or (not level) (>= level gnus-level-zombie))
(gnus-cache-open))
- (gnus-group-prepare-flat-predicate (or level gnus-level-subscribed)
- #'(lambda (info)
- (let ((marks (gnus-info-marks info)))
- (assq 'dormant marks)))
- lowest)
+ (funcall gnus-group-prepare-function
+ (or level gnus-level-subscribed)
+ #'(lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'dormant marks)))
+ lowest
+ 'ignore)
(goto-char (point-min))
(gnus-group-position-point))
+(defun gnus-group-listed-groups ()
+ "Return a list of listed groups."
+ (let (point groups)
+ (goto-char (point-min))
+ (while (setq point (text-property-not-all (point) (point-max)
+ 'gnus-group nil))
+ (goto-char point)
+ (push (symbol-name (get-text-property point 'gnus-group)) groups)
+ (forward-char 1))
+ groups))
+
+(defun gnus-group-list-plus (&optional args)
+ "List groups plus the current selection."
+ (interactive "P")
+ (let ((gnus-group-listed-groups (gnus-group-listed-groups))
+ (gnus-group-list-mode gnus-group-list-mode) ;; Save it.
+ func)
+ (push last-command-event unread-command-events)
+ (if (featurep 'xemacs)
+ (push (make-event 'key-press '(key ?A)) unread-command-events)
+ (push ?A unread-command-events))
+ (let (gnus-pick-mode keys)
+ (setq keys (if (featurep 'xemacs)
+ (events-to-keys (read-key-sequence nil))
+ (read-key-sequence nil)))
+ (setq func (lookup-key (current-local-map) keys)))
+ (if (or (not func)
+ (numberp func))
+ (ding)
+ (call-interactively func))))
+
+(defun gnus-group-list-flush (&optional args)
+ "Flush groups from the current selection."
+ (interactive "P")
+ (let ((gnus-group-list-option 'flush))
+ (gnus-group-list-plus args)))
+
+(defun gnus-group-list-limit (&optional args)
+ "List groups limited within the current selection."
+ (interactive "P")
+ (let ((gnus-group-list-option 'limit))
+ (gnus-group-list-plus args)))
+
(provide 'gnus-group)
;;; gnus-group.el ends here
projects / gnus / blobdiff