X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fgnus-group.el;h=9f272f4258785d7275cc337840e4d0a72af42eff;hb=829fe7e073a13eaf991e04e90b1e731b1ccce0c2;hp=7f8cc4788115fff7f3fd4770318750e1b50fff1b;hpb=8f7476d4cfadb358d635238ae62c48a89efc6db2;p=gnus diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 7f8cc4788..9f272f425 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -1,6 +1,6 @@ ;;; gnus-group.el --- group mode commands for Gnus -;; Copyright (C) 1996-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (defvar tool-bar-mode) @@ -159,7 +155,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%)\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. @@ -217,7 +213,7 @@ See Info node `(gnus)Formatting Variables'." :group 'gnus-group-visual :type 'string) -(defcustom gnus-group-mode-line-format "Gnus: %%b {%M\%:%S}" +(defcustom gnus-group-mode-line-format "Gnus: %%b {%M\ %:%S}" "*The format specification for the group mode line. It works along the same lines as a normal formatting string, with some simple extensions: @@ -449,7 +445,7 @@ If non-nil, the value should be a string or an alist. If it is a string, e.g. \"nnml:\", in which case `gnus-group-jump-to-group' offers \"Group: nnml:\" in the minibuffer prompt. -If it is an alist, it must consist of \(NUMBER . PROMPT\) pairs, for example: +If it is an alist, it must consist of \(NUMBER . PROMPT) pairs, for example: \((1 . \"\") (2 . \"nnfolder+archive:\")). The element with number 0 is used when no prefix argument is given to `gnus-group-jump-to-group'." :version "22.1" @@ -482,6 +478,26 @@ simple manner.") (defvar gnus-group-edit-buffer nil) +(defvar gnus-tmp-news-method) +(defvar gnus-tmp-colon) +(defvar gnus-tmp-news-server) +(defvar gnus-tmp-decoded-group) +(defvar gnus-tmp-header) +(defvar gnus-tmp-process-marked) +(defvar gnus-tmp-summary-live) +(defvar gnus-tmp-news-method-string) +(defvar gnus-tmp-group-icon) +(defvar gnus-tmp-moderated-string) +(defvar gnus-tmp-newsgroup-description) +(defvar gnus-tmp-comment) +(defvar gnus-tmp-qualified-group) +(defvar gnus-tmp-subscribed) +(defvar gnus-tmp-number-of-read) +(defvar gnus-inhibit-demon) +(defvar gnus-pick-mode) +(defvar gnus-tmp-marked-mark) +(defvar gnus-tmp-number-of-unread) + (defvar gnus-group-line-format-alist `((?M gnus-tmp-marked-mark ?c) (?S gnus-tmp-subscribed ?c) @@ -571,7 +587,6 @@ simple manner.") "p" gnus-group-prev-unread-group "\177" gnus-group-prev-unread-group [delete] gnus-group-prev-unread-group - [backspace] gnus-group-prev-unread-group "N" gnus-group-next-group "P" gnus-group-prev-group "\M-n" gnus-group-next-unread-group-same-level @@ -1105,7 +1120,7 @@ When FORCE, rebuild the tool bar." (set (make-local-variable 'tool-bar-map) map)))) gnus-group-tool-bar-map) -(defun gnus-group-mode () +(define-derived-mode gnus-group-mode fundamental-mode "Group" "Major mode for reading news. All normal editing commands are switched off. @@ -1122,17 +1137,12 @@ For more in-depth information on this mode, read the manual (`\\[gnus-info-find- The following commands are available: \\{gnus-group-mode-map}" - (interactive) - (kill-all-local-variables) (when (gnus-visual-p 'group-menu 'menu) (gnus-group-make-menu-bar) (gnus-group-make-tool-bar)) (gnus-simplify-mode-line) - (setq major-mode 'gnus-group-mode) - (setq mode-name "Group") (gnus-group-set-mode-line) (setq mode-line-process nil) - (use-local-map gnus-group-mode-map) (buffer-disable-undo) (setq truncate-lines t) (setq buffer-read-only t @@ -1143,16 +1153,14 @@ The following commands are available: (when gnus-use-undo (gnus-undo-mode 1)) (when gnus-slave - (gnus-slave-mode)) - (gnus-run-mode-hooks 'gnus-group-mode-hook)) + (gnus-slave-mode))) (defun gnus-update-group-mark-positions () (save-excursion (let ((gnus-process-mark ?\200) (gnus-group-update-hook nil) (gnus-group-marked '("dummy.group")) - (gnus-active-hashtb (make-vector 10 0)) - (topic "")) + (gnus-active-hashtb (make-vector 10 0))) (gnus-set-active "dummy.group" '(0 . 0)) (gnus-set-work-buffer) (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) @@ -1193,7 +1201,7 @@ The following commands are available: (defun gnus-group-setup-buffer () (set-buffer (gnus-get-buffer-create gnus-group-buffer)) - (unless (eq major-mode 'gnus-group-mode) + (unless (derived-mode-p 'gnus-group-mode) (gnus-group-mode))) (defun gnus-group-name-charset (method group) @@ -1388,7 +1396,8 @@ if it is a string, only list groups matching REGEXP." (gnus-group-prepare-flat-list-dead (gnus-union not-in-list - (setq gnus-killed-list (sort gnus-killed-list 'string<))) + (setq gnus-killed-list (sort gnus-killed-list 'string<)) + :test 'equal) gnus-level-killed ?K regexp)) (gnus-group-set-mode-line) @@ -1585,7 +1594,7 @@ if it is a string, only list groups matching REGEXP." gnus-process-mark ? )) (buffer-read-only nil) beg end - header gnus-tmp-header) ; passed as parameter to user-funcs. + gnus-tmp-header) ; passed as parameter to user-funcs. (beginning-of-line) (setq beg (point)) (gnus-add-text-properties @@ -1603,20 +1612,31 @@ if it is a string, only list groups matching REGEXP." gnus-indentation ,gnus-group-indentation gnus-level ,gnus-tmp-level)) (setq end (point)) - (when gnus-group-update-tool-bar - (gnus-put-text-property beg end 'point-entered - 'gnus-tool-bar-update) - (gnus-put-text-property beg end 'point-left - 'gnus-tool-bar-update)) + (gnus-group--setup-tool-bar-update beg end) (forward-line -1) (when (inline (gnus-visual-p 'group-highlight 'highlight)) (gnus-group-highlight-line gnus-tmp-group beg end)) (gnus-run-hooks 'gnus-group-update-hook) (forward-line))) +(defun gnus-group--setup-tool-bar-update (beg end) + (when gnus-group-update-tool-bar + (if (fboundp 'cursor-sensor-mode) + (progn + (unless (bound-and-true-p cursor-sensor-mode) + (cursor-sensor-mode 1)) + (gnus-put-text-property beg end 'cursor-sensor-functions + '(gnus-tool-bar-update))) + (gnus-put-text-property beg end 'point-entered + #'gnus-tool-bar-update) + (gnus-put-text-property beg end 'point-left + #'gnus-tool-bar-update)))) + (defun gnus-group-update-eval-form (group list) "Eval `car' of each element of LIST, and return the first that return t. Some value are bound so the form can use them." + (defvar group-age) (defvar ticked) (defvar score) (defvar level) + (defvar mailp) (defvar total) (defvar unread) (when list (let* ((entry (gnus-group-entry group)) (unread (if (numberp (car entry)) (car entry) 0)) @@ -1795,7 +1815,9 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." "Get the name of the newsgroup on the current line." (let ((group (get-text-property (point-at-bol) 'gnus-group))) (when group - (symbol-name group)))) + (if (stringp group) + group + (symbol-name group))))) (defun gnus-group-group-level () "Get the level of the newsgroup on the current line." @@ -2147,13 +2169,13 @@ be permanent." (defun gnus-group-name-at-point () "Return a group name from around point if it exists, or nil." - (if (eq major-mode 'gnus-group-mode) + (if (derived-mode-p 'gnus-group-mode) (let ((group (gnus-group-group-name))) (when group (gnus-group-decoded-name group))) (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\ \\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\ -\[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\ +[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\ \\|[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)+\\)") (start (point)) (case-fold-search nil)) @@ -2414,7 +2436,7 @@ Valid input formats include: ;; URLs providing `group', `start' and `range': ((string-match ;; http://thread.gmane.org/gmane.emacs.devel/86326/focus=86525 - "^http://thread\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)/focus=\\([0-9]+\\)$" + "^http://thread\\.gmane\\.org/\\([^/]+\\)/\\([0-9]+\\)/focus=\\([0-9]+\\)$" url) (setq group (match-string 1 url) start (string-to-number (match-string 2 url)) @@ -2425,15 +2447,15 @@ Valid input formats include: ;; URLs providing `group' and `start': ((or (string-match ;; http://article.gmane.org/gmane.comp.gnu.make.bugs/3584 - "^http://\\(?:thread\\|article\\|permalink\\)\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)" + "^http://\\(?:thread\\|article\\|permalink\\)\\.gmane\\.org/\\([^/]+\\)/\\([0-9]+\\)" url) (string-match ;; Don't advertise these in the doc string yet: - "^\\(?:nntp\\|news\\)://news\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)" + "^\\(?:nntp\\|news\\)://news\\.gmane\\.org/\\([^/]+\\)/\\([0-9]+\\)" url) (string-match ;; http://news.gmane.org/group/gmane.emacs.gnus.general/thread=65099/force_load=t - "^http://news\.gmane\.org/group/\\([^/]+\\)/thread=\\([0-9]+\\)" + "^http://news\\.gmane\\.org/group/\\([^/]+\\)/thread=\\([0-9]+\\)" url)) (setq group (match-string 1 url) start (string-to-number (match-string 2 url)))) @@ -2466,27 +2488,27 @@ the bug number, and browsing the URL must return mbox output." (setq ids (string-to-number ids))) (unless (listp ids) (setq ids (list ids))) - (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")) - (coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (with-temp-file tmpfile - (dolist (id ids) - (url-insert-file-contents (format mbox-url id))) - (goto-char (point-min)) - ;; Add the debbugs address so that we can respond to reports easily. - (while (re-search-forward "^To: " nil t) - (end-of-line) - (insert (format ", %s@%s" (car ids) - (gnus-replace-in-string - (gnus-replace-in-string mbox-url "^http://" "") - "/.*$" "")))) - (write-region (point-min) (point-max) tmpfile) - (gnus-group-read-ephemeral-group - (format "nndoc+ephemeral:bug#%s" - (mapconcat 'number-to-string ids ",")) - `(nndoc ,tmpfile - (nndoc-article-type mbox)) - nil window-conf)) + (let ((tmpfile (mm-make-temp-file "gnus-temp-group-"))) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (with-temp-file tmpfile + (mm-disable-multibyte) + (dolist (id ids) + (url-insert-file-contents (format mbox-url id))) + (goto-char (point-min)) + ;; Add the debbugs address so that we can respond to reports easily. + (while (re-search-forward "^To: " nil t) + (end-of-line) + (insert (format ", %s@%s" (car ids) + (gnus-replace-in-string + (gnus-replace-in-string mbox-url "^http://" "") + "/.*$" "")))))) + (gnus-group-read-ephemeral-group + (format "nndoc+ephemeral:bug#%s" + (mapconcat 'number-to-string ids ",")) + `(nndoc ,tmpfile + (nndoc-article-type mbox)) + nil window-conf) (delete-file tmpfile))) (defun gnus-read-ephemeral-debian-bug-group (number) @@ -2735,7 +2757,7 @@ server." (interactive (list (gnus-read-group "Group name: ") - (gnus-read-method "From method"))) + (gnus-read-method "Select method for new group (use tab for completion)"))) (when (stringp method) (setq method (or (gnus-server-to-method method) method))) @@ -2796,14 +2818,21 @@ server." (lambda (group) (gnus-group-delete-group group nil t)))))) -(defun gnus-group-delete-articles (group) - "Delete all articles in the current group." - (interactive (list (gnus-group-group-name))) +(defun gnus-group-delete-articles (group &optional oldp) + "Delete all articles in the current group. +If OLDP (the prefix), only delete articles that are \"old\", +according to the expiry settings. Note that this will delete old +not-expirable articles, too." + (interactive (list (gnus-group-group-name) + current-prefix-arg)) (let ((articles (gnus-uncompress-range (gnus-active group)))) (when (gnus-yes-or-no-p (format "Do you really want to delete these %d articles forever? " (length articles))) - (gnus-request-expire-articles articles group 'force)))) + (gnus-request-expire-articles articles group + (if current-prefix-arg + nil + 'force))))) (defun gnus-group-delete-group (group &optional force no-prompt) "Delete the current group. Only meaningful with editable groups. @@ -2922,7 +2951,7 @@ and NEW-NAME will be prompted for." (gnus-info-params info)) (t info)) ;; The proper documentation. - (format + (gnus-format-message "Editing the %s for `%s'." (cond ((eq part 'method) "select method") @@ -3107,12 +3136,12 @@ If SOLID (the prefix), create a solid group." (gnus-group-read-ephemeral-group group method t (cons (current-buffer) - (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) + (if (derived-mode-p 'gnus-summary-mode) 'summary 'group)))))) (defvar nnrss-group-alist) (eval-when-compile - (defun nnrss-discover-feed (arg)) - (defun nnrss-save-server-data (arg))) + (defun nnrss-discover-feed (_arg)) + (defun nnrss-save-server-data (_arg))) (defun gnus-group-make-rss-group (&optional url) "Given a URL, discover if there is an RSS feed. If there is, use Gnus to create an nnrss group" @@ -3222,7 +3251,7 @@ mail messages or news articles in files that have numeric names." (unless (gnus-group-read-ephemeral-group name method t (cons (current-buffer) - (if (eq major-mode 'gnus-summary-mode) + (if (derived-mode-p 'gnus-summary-mode) 'summary 'group))) (error "Couldn't enter %s" dir)))) @@ -3250,7 +3279,8 @@ mail messages or news articles in files that have numeric names." (error "%s is not an nnimap group" group)) (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'. + (gnus-edit-form acl (gnus-format-message "\ +Editing the access control list for `%s'. An access control list is a list of (identifier . rights) elements. @@ -3259,7 +3289,7 @@ mail messages or news articles in files that have numeric names." 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 + 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) @@ -3591,6 +3621,8 @@ Cross references (Xref: header) of articles are ignored." (interactive "P") (gnus-group-catchup-current n 'all)) +(declare-function gnus-sequence-of-unread-articles "gnus-sum" (group)) + (defun gnus-group-catchup (group &optional all) "Mark all articles in GROUP as read. If ALL is non-nil, all articles are marked as read. @@ -3759,7 +3791,7 @@ group line." nil nil (gnus-read-active-file-p)))) (let ((newsrc (gnus-group-entry group))) (cond - ((string-match "^[ \t]*$" group) + ((string-match "\\`[ \t]*\\'" group) (error "Empty group name")) (newsrc ;; Toggle subscription flag. @@ -4077,7 +4109,9 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (gnus-group-remove-mark group) ;; Bypass any previous denials from the server. (gnus-remove-denial (setq method (gnus-find-method-for-group group))) - (if (gnus-activate-group group (if dont-scan nil 'scan) nil method) + (if (or (and (not dont-scan) + (gnus-request-group-scan group (gnus-get-info group))) + (gnus-activate-group group (if dont-scan nil 'scan) nil method)) (let ((info (gnus-get-info group)) (active (gnus-active group))) (when info @@ -4310,10 +4344,15 @@ The hook `gnus-suspend-gnus-hook' is called before actually suspending." (unless (or (eq buf group-buf) (eq buf gnus-dribble-buffer) (with-current-buffer buf - (eq major-mode 'message-mode))) + (derived-mode-p 'message-mode))) (gnus-kill-buffer buf))) (setq gnus-backlog-articles nil) (gnus-kill-gnus-frames) + ;; Closing all the backends is useful (for instance) when when the + ;; IP addresses have changed and you need to reconnect. + (dolist (elem gnus-opened-servers) + (gnus-close-server (car elem)) + (setcar (cdr elem) 'closed)) (when group-buf (bury-buffer group-buf) (delete-windows-on group-buf t)))) @@ -4379,7 +4418,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (defun gnus-group-browse-foreign-server (method) "Browse a foreign news server. If called interactively, this function will ask for a select method - (nntp, nnspool, etc.) and a server address (eg. nntp.some.where). + (nntp, nnspool, etc.) and a server address (e.g., nntp.some.where). If not, METHOD should be a list where the first element is the method and the second element is the address." (interactive @@ -4395,7 +4434,12 @@ and the second element is the address." ;; Suggested by mapjph@bath.ac.uk. (gnus-completing-read "Address" - gnus-secondary-servers)) + ;; FIXME? gnus-secondary-servers is obsolete, + ;; and it is not obvious that there is anything + ;; sensible to use instead in this particular case. + (if (boundp 'gnus-secondary-servers) + gnus-secondary-servers + (cdr gnus-select-method)))) ;; We got a server name. how)))) (gnus-browse-foreign-server method)) @@ -4495,6 +4539,8 @@ and the second element is the address." (sort (nconc (gnus-uncompress-range (cdr m)) (copy-sequence articles)) '<) t)))))) +(declare-function gnus-summary-add-mark "gnus-sum" (article type)) + (defun gnus-add-mark (group mark article) "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not." (let ((buffer (gnus-summary-buffer-name group))) @@ -4659,6 +4705,9 @@ you the groups that have both dormant articles and cached articles." (let ((gnus-group-list-option 'limit)) (gnus-group-list-plus args))) +(declare-function gnus-mark-article-as-read "gnus-sum" (article &optional mark)) +(declare-function gnus-group-make-articles-read "gnus-sum" (group articles)) + (defun gnus-group-mark-article-read (group article) "Mark ARTICLE read." (let ((buffer (gnus-summary-buffer-name group))