X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=5934a19ae2dcba7e0a82c2fc3a6dd711867373a2;hb=daae30b5b3e1592f628dd74543820de9282cac3a;hp=843c6ad551e332420ad80d771bbd7fec56217ebe;hpb=1eeb5665015062c1087d17cc01e4433f75b86c9a;p=gnus diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 843c6ad55..5934a19ae 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -169,7 +169,7 @@ list." (function-item gnus-group-sort-by-rank) (function :tag "other" nil)))) -(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%O\n" +(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)\n" "*Format of group lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -292,13 +292,14 @@ If you want to modify the group buffer, you can use this hook." :group 'gnus-exit :type 'hook) -(defcustom gnus-group-update-hook '(gnus-group-highlight-line) +(defcustom gnus-group-update-hook '(gnus-group-highlight-line gnus-group-add-icon) "Hook called when a group line is changed. The hook will not be called if `gnus-visual' is nil. -The default function `gnus-group-highlight-line' will -highlight the line according to the `gnus-group-highlight' -variable." +The default functions `gnus-group-highlight-line' will highlight +the line according to the `gnus-group-highlight' variable, and +`gnus-group-add-icon' will add an icon according to +`gnus-group-icon-list'" :group 'gnus-group-visual :type 'hook) @@ -509,7 +510,10 @@ simple manner.") (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) (t number)) ?s) (?R gnus-tmp-number-of-read ?s) - (?U (gnus-number-of-unseen-articles-in-group gnus-tmp-group) ?d) + (?U (if (gnus-active gnus-tmp-group) + (gnus-number-of-unseen-articles-in-group gnus-tmp-group) + "*") + ?s) (?t gnus-tmp-number-total ?d) (?y gnus-tmp-number-of-unread ?s) (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) @@ -675,7 +679,7 @@ simple manner.") "R" gnus-group-make-rss-group "c" gnus-group-customize "z" gnus-group-compact-group - "x" gnus-group-nnimap-expunge + "x" gnus-group-expunge-group "\177" gnus-group-delete-group [delete] gnus-group-delete-group) @@ -1273,7 +1277,7 @@ Also see the `gnus-group-use-permanent-levels' variable." (zerop number)) (zerop (buffer-size))) ;; No groups in the buffer. - (gnus-message 5 gnus-no-groups-message)) + (gnus-message 5 "%s" gnus-no-groups-message)) ;; We have some groups displayed. (goto-char (point-max)) (when (or (not gnus-group-goto-next-group-function) @@ -1575,7 +1579,7 @@ if it is a string, only list groups matching REGEXP." ?m ? )) (gnus-tmp-moderated-string (if (eq gnus-tmp-moderated ?m) "(m)" "")) - (gnus-tmp-group-icon "==&&==") + (gnus-tmp-group-icon (propertize " " 'gnus-group-icon t)) (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) (gnus-tmp-news-method (or (car gnus-tmp-method) "")) (gnus-tmp-news-method-string @@ -1684,76 +1688,111 @@ if it is a string, only list groups matching REGEXP." (gnus-extent-start-open beg))) (goto-char p))) +(defun gnus-group-add-icon () + "Add an icon to the current line according to `gnus-group-icon-list'." + (save-excursion + (let* ((end (line-end-position)) + ;; now find out where the line starts and leave point there. + (beg (line-beginning-position))) + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (let ((mystart (text-property-any beg end 'gnus-group-icon t))) + (when mystart + (let* ((group (gnus-group-group-name)) + (entry (gnus-group-entry group)) + (unread (if (numberp (car entry)) (car entry) 0)) + (active (gnus-active group)) + (total (if active (1+ (- (cdr active) (car active))) 0)) + (info (nth 2 entry)) + (method (gnus-server-get-method group (gnus-info-method info))) + (marked (gnus-info-marks info)) + (mailp (memq 'mail (assoc (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + (level (or (gnus-info-level info) gnus-level-killed)) + (score (or (gnus-info-score info) 0)) + (ticked (gnus-range-length (cdr (assq 'tick marked)))) + (group-age (gnus-group-timestamp-delta group)) + (inhibit-read-only t) + (list gnus-group-icon-list) + (myend (next-single-property-change + mystart 'gnus-group-icon))) + (while (and list + (not (eval (caar list)))) + (setq list (cdr list))) + (when list + (put-text-property + mystart myend + 'display + (append + (gnus-create-image (expand-file-name (cdar list))) + '(:ascent center))))))))))) + (defun gnus-group-update-group (group &optional visible-only) "Update all lines where GROUP appear. If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't already." - ;; Can't use `save-excursion' here, so we do it manually. - (let ((buf (current-buffer)) - mark) - (set-buffer gnus-group-buffer) - (setq mark (point-marker)) - ;; The buffer may be narrowed. - (save-restriction - (widen) - (let ((ident (gnus-intern-safe group gnus-active-hashtb)) - (loc (point-min)) - found buffer-read-only) - ;; Enter the current status into the dribble buffer. - (let ((entry (gnus-group-entry 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)) - ")")))) - ;; Find all group instances. If topics are in use, each group - ;; may be listed in more than once. - (while (setq loc (text-property-any - loc (point-max) 'gnus-group ident)) - (setq found t) - (goto-char loc) - (let ((gnus-group-indentation (gnus-group-group-indentation))) - (gnus-delete-line) - (gnus-group-insert-group-line-info group) - (save-excursion - (forward-line -1) - (gnus-run-hooks 'gnus-group-update-group-hook))) - (setq loc (1+ loc))) - (unless (or found visible-only) - ;; No such line in the buffer, find out where it's supposed to - ;; go, and insert it there (or at the end of the buffer). - (if gnus-goto-missing-group-function - (funcall gnus-goto-missing-group-function group) - (let ((entry (cddr (gnus-group-entry group)))) - (while (and entry (car entry) - (not - (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe - (caar entry) gnus-active-hashtb))))) - (setq entry (cdr entry))) - (or entry (goto-char (point-max))))) - ;; Finally insert the line. - (let ((gnus-group-indentation (gnus-group-group-indentation))) - (gnus-group-insert-group-line-info group) - (save-excursion - (forward-line -1) - (gnus-run-hooks 'gnus-group-update-group-hook)))) - (when gnus-group-update-group-function - (funcall gnus-group-update-group-function group)) - (gnus-group-set-mode-line))) - (goto-char mark) - (set-marker mark nil) - (set-buffer buf))) + (with-current-buffer gnus-group-buffer + (save-excursion + ;; The buffer may be narrowed. + (save-restriction + (widen) + (let ((ident (gnus-intern-safe group gnus-active-hashtb)) + (loc (point-min)) + found buffer-read-only) + ;; Enter the current status into the dribble buffer. + (let ((entry (gnus-group-entry 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)) + ")")))) + ;; Find all group instances. If topics are in use, each group + ;; may be listed in more than once. + (while (setq loc (text-property-any + loc (point-max) 'gnus-group ident)) + (setq found t) + (goto-char loc) + (let ((gnus-group-indentation (gnus-group-group-indentation))) + (gnus-delete-line) + (gnus-group-insert-group-line-info group) + (save-excursion + (forward-line -1) + (gnus-run-hooks 'gnus-group-update-group-hook))) + (setq loc (1+ loc))) + (unless (or found visible-only) + ;; No such line in the buffer, find out where it's supposed to + ;; go, and insert it there (or at the end of the buffer). + (if gnus-goto-missing-group-function + (funcall gnus-goto-missing-group-function group) + (let ((entry (cddr (gnus-group-entry group)))) + (while (and entry (car entry) + (not + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe + (caar entry) + gnus-active-hashtb))))) + (setq entry (cdr entry))) + (or entry (goto-char (point-max))))) + ;; Finally insert the line. + (let ((gnus-group-indentation (gnus-group-group-indentation))) + (gnus-group-insert-group-line-info group) + (save-excursion + (forward-line -1) + (gnus-run-hooks 'gnus-group-update-group-hook)))) + (when gnus-group-update-group-function + (funcall gnus-group-update-group-function group)) + (gnus-group-set-mode-line)))))) (defun gnus-group-set-mode-line () "Update the mode line in the group buffer." (when (memq 'group gnus-updated-mode-lines) ;; Yes, we want to keep this mode line updated. - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (let* ((gformat (or gnus-group-mode-line-format-spec (gnus-set-format 'group-mode))) (gnus-tmp-news-server (cadr gnus-select-method)) @@ -1766,8 +1805,7 @@ already." (and gnus-dribble-buffer (buffer-name gnus-dribble-buffer) (buffer-modified-p gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (not (zerop (buffer-size)))))) (mode-string (eval gformat))) ;; Say whether the dribble buffer has been modified. @@ -3170,21 +3208,17 @@ mail messages or news articles in files that have numeric names." 'summary 'group))) (error "Couldn't enter %s" dir)))) -(autoload 'nnimap-expunge "nnimap") -(autoload 'nnimap-acl-get "nnimap") -(autoload 'nnimap-acl-edit "nnimap") - -(defun gnus-group-nnimap-expunge (group) +(defun gnus-group-expunge-group (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)))) + (let ((method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-expunge-group (car method))) + (error "%s does not support expunging" (car method)) + (gnus-request-expunge-group group method)))) + +(autoload 'nnimap-acl-get "nnimap") +(autoload 'nnimap-acl-edit "nnimap") (defun gnus-group-nnimap-edit-acl (group) "Edit the Access Control List of current nnimap GROUP." @@ -3989,23 +4023,13 @@ re-scanning. If ARG is non-nil and not a number, this will force (>= arg gnus-use-nocem)) (not arg))) (gnus-nocem-scan-groups)) - ;; If ARG is not a number, then we read the active file. - (when (and arg (not (numberp arg))) - (let ((gnus-read-active-file t)) - (gnus-read-active-file)) - (setq arg nil) - - ;; If the user wants it, we scan for new groups. - (when (eq gnus-check-new-newsgroups 'always) - (gnus-find-new-newsgroups))) - - (setq arg (gnus-group-default-level arg t)) - (if (and gnus-read-active-file (not arg)) - (progn - (gnus-read-active-file) - (gnus-get-unread-articles arg)) - (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) - (gnus-get-unread-articles arg))) + + (gnus-get-unread-articles arg) + + ;; If the user wants it, we scan for new groups. + (when (eq gnus-check-new-newsgroups 'always) + (gnus-find-new-newsgroups)) + (gnus-check-reasonable-setup) (gnus-run-hooks 'gnus-after-getting-new-news-hook) (gnus-group-list-groups (and (numberp arg) @@ -4153,7 +4177,7 @@ If given a prefix argument, prompt for a group." (gnus-gethash mname gnus-description-hashtb)) (setq desc (gnus-group-get-description group)) (gnus-read-descriptions-file method)) - (gnus-message 1 + (gnus-message 1 "%s" (or desc (gnus-gethash group gnus-description-hashtb) "No description available"))))) @@ -4314,11 +4338,9 @@ If GROUP, edit that local kill file instead." (interactive "P") (setq gnus-current-kill-article article) (gnus-kill-file-edit-file group) - (gnus-message - 6 - (substitute-command-keys - (format "Editing a %s kill file (Type \\[gnus-kill-file-exit] to exit)" - (if group "local" "global"))))) + (gnus-message 6 "Editing a %s kill file (Type %s to exit)" + (if group "local" "global") + (substitute-command-keys "\\[gnus-kill-file-exit]"))) (defun gnus-group-edit-local-kill (article group) "Edit a local kill file." @@ -4395,8 +4417,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (gnus-run-hooks 'gnus-exit-gnus-hook) (gnus-configure-windows 'group t) (when (and (gnus-buffer-live-p gnus-dribble-buffer) - (not (zerop (save-excursion - (set-buffer gnus-dribble-buffer) + (not (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-dribble-enter ";;; Gnus was exited on purpose without saving the .newsrc files.")) @@ -4410,7 +4431,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (defun gnus-group-describe-briefly () "Give a one line description of the group mode commands." (interactive) - (gnus-message 7 (substitute-command-keys "\\\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help"))) + (gnus-message 7 "%s" (substitute-command-keys "\\\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help"))) (defun gnus-group-browse-foreign-server (method) "Browse a foreign news server. @@ -4457,13 +4478,11 @@ and the second element is the address." (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) + (with-current-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) + (with-current-buffer gnus-group-buffer (if method ;; It's a foreign group... (gnus-group-make-group @@ -4527,8 +4546,7 @@ and the second element is the address." "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not." (let ((buffer (gnus-summary-buffer-name group))) (if (gnus-buffer-live-p buffer) - (save-excursion - (set-buffer (get-buffer buffer)) + (with-current-buffer (get-buffer buffer) (gnus-summary-add-mark article mark)) (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists)) (list article))))) @@ -4728,5 +4746,4 @@ Compacting group %s... (this may take a long time)" (provide 'gnus-group) -;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6 ;;; gnus-group.el ends here