Mercurial > emacs
diff lisp/gnus/gnus-start.el @ 85712:a3c27999decb
Update Gnus to No Gnus 0.7 from the Gnus CVS trunk
Revision: emacs@sv.gnu.org/emacs--devo--0--patch-911
| author | Miles Bader <miles@gnu.org> |
|---|---|
| date | Sun, 28 Oct 2007 09:18:39 +0000 |
| parents | 24202b793a08 |
| children | 1cdfc94602cb 880960b70474 |
line wrap: on
line diff
--- a/lisp/gnus/gnus-start.el Sun Oct 28 04:58:17 2007 +0000 +++ b/lisp/gnus/gnus-start.el Sun Oct 28 09:18:39 2007 +0000 @@ -506,19 +506,23 @@ (defun gnus-subscribe-hierarchical-interactive (groups) (let ((groups (sort groups 'string<)) - prefixes prefix start ans group starts) + prefixes prefix start ans group starts real-group) (while groups (setq prefixes (list "^")) (while (and groups prefixes) - (while (not (string-match (car prefixes) (car groups))) + (while (not (string-match (car prefixes) + (gnus-group-real-name (car groups)))) (setq prefixes (cdr prefixes))) (setq prefix (car prefixes)) (setq start (1- (length prefix))) - (if (and (string-match "[^\\.]\\." (car groups) start) + (if (and (string-match "[^\\.]\\." (gnus-group-real-name (car groups)) + start) (cdr groups) (setq prefix - (concat "^" (substring (car groups) 0 (match-end 0)))) - (string-match prefix (cadr groups))) + (concat "^" (substring + (gnus-group-real-name (car groups)) + 0 (match-end 0)))) + (string-match prefix (gnus-group-real-name (cadr groups)))) (progn (push prefix prefixes) (message "Descend hierarchy %s? ([y]nsq): " @@ -530,16 +534,18 @@ (substring prefix 1 (1- (length prefix))))) (cond ((= ans ?n) (while (and groups - (string-match prefix - (setq group (car groups)))) + (setq group (car groups) + real-group (gnus-group-real-name group)) + (string-match prefix real-group)) (push group gnus-killed-list) (gnus-sethash group group gnus-killed-hashtb) (setq groups (cdr groups))) (setq starts (cdr starts))) ((= ans ?s) (while (and groups - (string-match prefix - (setq group (car groups)))) + (setq group (car groups) + real-group (gnus-group-real-name group)) + (string-match prefix real-group)) (gnus-sethash group group gnus-killed-hashtb) (gnus-subscribe-alphabetically (car groups)) (setq groups (cdr groups))) @@ -632,8 +638,7 @@ ;; We subscribe the group by changing its level to `subscribed'. (gnus-group-change-level newsgroup gnus-level-default-subscribed - gnus-level-killed (gnus-gethash (or next "dummy.group") - gnus-newsrc-hashtb)) + gnus-level-killed (gnus-group-entry (or next "dummy.group"))) (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) (run-hook-with-args 'gnus-subscribe-newsgroup-hooks newsgroup) t)) @@ -755,6 +760,13 @@ (nnheader-init-server-buffer) (setq gnus-slave slave) (gnus-read-init-file) + + ;; Add "native" to gnus-predefined-server-alist just to have a + ;; name for the native select method. + (when gnus-select-method + (push (cons "native" gnus-select-method) + gnus-predefined-server-alist)) + (if gnus-agent (gnus-agentize)) @@ -787,11 +799,6 @@ (when (or gnus-slave gnus-use-dribble-file) (gnus-dribble-read-file)) - ;; Allow using GroupLens predictions. - (when gnus-use-grouplens - (bbb-login) - (add-hook 'gnus-summary-mode-hook 'gnus-grouplens-mode)) - ;; Do the actual startup. (if gnus-agent (gnus-request-create-group "queue" '(nndraft ""))) @@ -809,8 +816,7 @@ (defun gnus-start-draft-setup () "Make sure the draft group exists." (gnus-request-create-group "drafts" '(nndraft "")) - (unless (gnus-gethash "nndraft:drafts" gnus-newsrc-hashtb) - (gnus-message 3 "Subscribing drafts group") + (unless (gnus-group-entry "nndraft:drafts") (let ((gnus-level-default-subscribed 1)) (gnus-subscribe-group "nndraft:drafts" nil '(nndraft "")))) (unless (equal (gnus-group-get-parameter "nndraft:drafts" 'gnus-dummy t) @@ -891,7 +897,7 @@ (when (and (file-exists-p gnus-current-startup-file) (file-exists-p dribble-file) (setq modes (file-modes gnus-current-startup-file))) - (set-file-modes dribble-file modes)) + (gnus-set-file-modes dribble-file modes)) (goto-char (point-min)) (when (search-forward "Gnus was exited on purpose" nil t) (setq purpose t)) @@ -961,30 +967,34 @@ (gnus-read-newsrc-file rawfile)) ;; Make sure the archive server is available to all and sundry. - (when gnus-message-archive-method - (unless (assoc "archive" gnus-server-alist) - (let ((method (or (and (stringp gnus-message-archive-method) - (gnus-server-to-method - gnus-message-archive-method)) - gnus-message-archive-method))) - ;; Check whether the archive method is writable. - (unless (or (stringp method) - (memq 'respool (assoc (format "%s" (car method)) - gnus-valid-select-methods))) - (setq method "archive")) ;; The default. - (push (if (stringp method) - `("archive" - nnfolder - ,method - (nnfolder-directory - ,(nnheader-concat message-directory method)) - (nnfolder-active-file - ,(nnheader-concat message-directory - (concat method "/active"))) - (nnfolder-get-new-mail nil) - (nnfolder-inhibit-expiry t)) - (cons "archive" method)) - gnus-server-alist)))) + (let ((method (or (and (stringp gnus-message-archive-method) + (gnus-server-to-method + gnus-message-archive-method)) + gnus-message-archive-method))) + ;; Check whether the archive method is writable. + (unless (or (not method) + (stringp method) + (memq 'respool (assoc (format "%s" (car method)) + gnus-valid-select-methods))) + (setq method "archive")) ;; The default. + (when (stringp method) + (setq method `(nnfolder + ,method + (nnfolder-directory + ,(nnheader-concat message-directory method)) + (nnfolder-active-file + ,(nnheader-concat message-directory + (concat method "/active"))) + (nnfolder-get-new-mail nil) + (nnfolder-inhibit-expiry t)))) + (if (assoc "archive" gnus-server-alist) + (when gnus-update-message-archive-method + (if method + (setcdr (assoc "archive" gnus-server-alist) method) + (setq gnus-server-alist (delq (assoc "archive" gnus-server-alist) + gnus-server-alist)))) + (when method + (push (cons "archive" method) gnus-server-alist)))) ;; If we don't read the complete active file, we fill in the ;; hashtb here. @@ -1334,16 +1344,16 @@ (when (and (stringp entry) oldlevel (< oldlevel gnus-level-zombie)) - (setq entry (gnus-gethash entry gnus-newsrc-hashtb))) + (setq entry (gnus-group-entry entry))) (if (and (not oldlevel) (consp entry)) (setq oldlevel (gnus-info-level (nth 2 entry))) (setq oldlevel (or oldlevel gnus-level-killed))) (when (stringp previous) - (setq previous (gnus-gethash previous gnus-newsrc-hashtb))) + (setq previous (gnus-group-entry previous))) (if (and (>= oldlevel gnus-level-zombie) - (gnus-gethash group gnus-newsrc-hashtb)) + (gnus-group-entry group)) ;; We are trying to subscribe a group that is already ;; subscribed. () ; Do nothing. @@ -1367,8 +1377,7 @@ entry) (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb) (when (nth 3 entry) - (setcdr (gnus-gethash (car (nth 3 entry)) - gnus-newsrc-hashtb) + (setcdr (gnus-group-entry (car (nth 3 entry))) (cdr entry))) (setcdr (cdr entry) (cdddr entry))))) @@ -1428,7 +1437,7 @@ (gnus-sethash group (cons num previous) gnus-newsrc-hashtb)) (when (cdr entry) - (setcdr (gnus-gethash (caadr entry) gnus-newsrc-hashtb) entry)) + (setcdr (gnus-group-entry (caadr entry)) entry)) (gnus-dribble-enter (format "(gnus-group-set-info '%S)" info))))) @@ -1439,7 +1448,7 @@ (defun gnus-kill-newsgroup (newsgroup) "Obsolete function. Kills a newsgroup." (gnus-group-change-level - (gnus-gethash newsgroup gnus-newsrc-hashtb) gnus-level-killed)) + (gnus-group-entry newsgroup) gnus-level-killed)) (defun gnus-check-bogus-newsgroups (&optional confirm) "Remove bogus newsgroups. @@ -1467,14 +1476,14 @@ (lambda (group) ;; Remove all bogus subscribed groups by first killing them, and ;; then removing them from the list of killed groups. - (when (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (when (setq entry (gnus-group-entry group)) (gnus-group-change-level entry gnus-level-killed) (setq gnus-killed-list (delete group gnus-killed-list)))) bogus '("group" "groups" "remove")) (while (setq group (pop bogus)) ;; Remove all bogus subscribed groups by first killing them, and ;; then removing them from the list of killed groups. - (when (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (when (setq entry (gnus-group-entry group)) (gnus-group-change-level entry gnus-level-killed) (setq gnus-killed-list (delete group gnus-killed-list))))) ;; Then we remove all bogus groups from the list of killed and @@ -1543,8 +1552,8 @@ ;; command may have responded with the `(0 . 0)'. We ;; ignore this if we already have an active entry ;; for the group. - (if (and (zerop (car active)) - (zerop (cdr active)) + (if (and (zerop (or (car active) 0)) + (zerop (or (cdr active) 0)) (gnus-active group)) (gnus-active group) @@ -1652,8 +1661,8 @@ (setq num (max 0 (- (cdr active) num))))) ;; Set the number of unread articles. (when (and info - (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb)) - (setcar (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb) num)) + (gnus-group-entry (gnus-info-group info))) + (setcar (gnus-group-entry (gnus-info-group info)) num)) num))) ;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' @@ -1674,12 +1683,12 @@ (methods-cache nil) (type-cache nil) scanned-methods info group active method retrieve-groups cmethod - method-type) + method-type ignore) (gnus-message 6 "Checking new news...") (while newsrc (setq active (gnus-active (setq group (gnus-info-group - (setq info (pop newsrc)))))) + (setq info (pop newsrc)))))) ;; Check newsgroups. If the user doesn't want to check them, or ;; they can't be checked (for instance, if the news server can't @@ -1702,28 +1711,30 @@ (when (and method (not (setq method-type (cdr (assoc method type-cache))))) (setq method-type - (cond - ((gnus-secondary-method-p method) - 'secondary) - ((inline (gnus-server-equal gnus-select-method method)) - 'primary) - (t - 'foreign))) + (cond + ((gnus-secondary-method-p method) + 'secondary) + ((inline (gnus-server-equal gnus-select-method method)) + 'primary) + (t + 'foreign))) (push (cons method method-type) type-cache)) + (setq ignore nil) (cond ((and method (eq method-type 'foreign)) ;; These groups are foreign. Check the level. - (when (and (<= (gnus-info-level info) foreign-level) - (setq active (gnus-activate-group group 'scan))) - ;; Let the Gnus agent save the active file. - (when (and gnus-agent active (gnus-online method)) - (gnus-agent-save-group-info - method (gnus-group-real-name group) active)) - (unless (inline (gnus-virtual-group-p group)) - (inline (gnus-close-group group))) - (when (fboundp (intern (concat (symbol-name (car method)) - "-request-update-info"))) - (inline (gnus-request-update-info info method))))) + (if (<= (gnus-info-level info) foreign-level) + (when (setq active (gnus-activate-group group 'scan)) + ;; Let the Gnus agent save the active file. + (when (and gnus-agent active (gnus-online method)) + (gnus-agent-save-group-info + method (gnus-group-real-name group) active)) + (unless (inline (gnus-virtual-group-p group)) + (inline (gnus-close-group group))) + (when (fboundp (intern (concat (symbol-name (car method)) + "-request-update-info"))) + (inline (gnus-request-update-info info method)))) + (setq ignore t))) ;; These groups are native or secondary. ((> (gnus-info-level info) level) ;; We don't want these groups. @@ -1762,13 +1773,17 @@ ((eq active 'ignore) ;; Don't do anything. ) + ((and active ignore) + ;; The level of the foreign group is higher than the specified + ;; value. + ) (active (inline (gnus-get-unread-articles-in-group info active t))) (t ;; The group couldn't be reached, so we nix out the number of ;; unread articles and stuff. (gnus-set-active group nil) - (let ((tmp (gnus-gethash group gnus-newsrc-hashtb))) + (let ((tmp (gnus-group-entry group))) (when tmp (setcar tmp t)))))) @@ -1782,8 +1797,8 @@ (when (gnus-check-backend-function 'request-scan (car method)) (gnus-request-scan nil method)) (gnus-read-active-file-2 - (mapcar (lambda (group) (gnus-group-real-name group)) groups) - method) + (mapcar (lambda (group) (gnus-group-real-name group)) groups) + method) (dolist (group groups) (cond ((setq active (gnus-active (gnus-info-group @@ -1793,7 +1808,7 @@ ;; The group couldn't be reached, so we nix out the number of ;; unread articles and stuff. (gnus-set-active group nil) - (setcar (gnus-gethash group gnus-newsrc-hashtb) t))))))) + (setcar (gnus-group-entry group) t))))))) (gnus-message 6 "Checking new news...done"))) @@ -1802,7 +1817,7 @@ (defun gnus-make-hashtable-from-newsrc-alist () (let ((alist gnus-newsrc-alist) (ohashtb gnus-newsrc-hashtb) - prev) + prev info method rest methods) (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) (setq alist (setq prev (setq gnus-newsrc-alist @@ -1811,14 +1826,26 @@ gnus-newsrc-alist (cons (list "dummy.group" 0 nil) alist))))) (while alist + (setq info (car alist)) + ;; Make the same select-methods identical Lisp objects. + (when (setq method (gnus-info-method info)) + (if (setq rest (member method methods)) + (gnus-info-set-method info (car rest)) + (push method methods))) (gnus-sethash - (caar alist) + (car info) ;; Preserve number of unread articles in groups. - (cons (and ohashtb (car (gnus-gethash (caar alist) ohashtb))) + (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) prev) gnus-newsrc-hashtb) (setq prev alist - alist (cdr alist))))) + alist (cdr alist))) + ;; Make the same select-methods in `gnus-server-alist' identical + ;; as well. + (while methods + (setq method (pop methods)) + (when (setq rest (rassoc method gnus-server-alist)) + (setcdr rest method))))) (defun gnus-make-hashtable-from-killed () "Create a hash table from the killed and zombie lists." @@ -1845,9 +1872,9 @@ (defun gnus-make-articles-unread (group articles) "Mark ARTICLES in GROUP as unread." - (let* ((info (nth 2 (or (gnus-gethash group gnus-newsrc-hashtb) - (gnus-gethash (gnus-group-real-name group) - gnus-newsrc-hashtb)))) + (let* ((info (nth 2 (or (gnus-group-entry group) + (gnus-group-entry + (gnus-group-real-name group))))) (ranges (gnus-info-read info)) news article) (while articles @@ -1867,9 +1894,8 @@ (defun gnus-make-ascending-articles-unread (group articles) "Mark ascending ARTICLES in GROUP as unread." - (let* ((entry (or (gnus-gethash group gnus-newsrc-hashtb) - (gnus-gethash (gnus-group-real-name group) - gnus-newsrc-hashtb))) + (let* ((entry (or (gnus-group-entry group) + (gnus-group-entry (gnus-group-real-name group)))) (info (nth 2 entry)) (ranges (gnus-info-read info)) (r ranges) @@ -1941,7 +1967,7 @@ (while lists (setq killed (car lists)) (while killed - (gnus-sethash (car killed) nil hashtb) + (gnus-sethash (mm-string-as-unibyte (car killed)) nil hashtb) (setq killed (cdr killed))) (setq lists (cdr lists))))) @@ -2118,7 +2144,7 @@ (while (not (eobp)) (condition-case () (progn - (narrow-to-region (point) (gnus-point-at-eol)) + (narrow-to-region (point) (point-at-eol)) ;; group gets set to a symbol interned in the hash table ;; (what a hack!!) - jwz (setq group (let ((obarray hashtb)) (read cur))) @@ -2150,7 +2176,7 @@ (unless ignore-errors (gnus-message 3 "Warning - invalid active: %s" (buffer-substring - (gnus-point-at-bol) (gnus-point-at-eol)))))) + (point-at-bol) (point-at-eol)))))) (widen) (forward-line 1))))) @@ -2387,6 +2413,8 @@ (setq gnus-format-specs gnus-default-format-specs))) (when gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))) + (dolist (elem gnus-newsrc-alist) + (setcar elem (mm-string-as-unibyte (car elem)))) (gnus-make-hashtable-from-newsrc-alist) (when (file-newer-than-file-p file ding-file) ;; Old format quick file @@ -2502,10 +2530,10 @@ ;; don't give a damn, frankly, my dear. (concat gnus-newsrc-options (buffer-substring - (gnus-point-at-bol) + (point-at-bol) ;; Options may continue on the next line. (or (and (re-search-forward "^[^ \t]" nil 'move) - (progn (beginning-of-line) (point))) + (point-at-bol)) (point))))) (forward-line -1)) (symbol @@ -2573,8 +2601,8 @@ ;; The line was buggy. (setq group nil) (gnus-error 3.1 "Mangled line: %s" - (buffer-substring (gnus-point-at-bol) - (gnus-point-at-eol)))) + (buffer-substring (point-at-bol) + (point-at-eol)))) nil)) ;; Skip past ", ". Spaces are invalid in these ranges, but ;; we allow them, because it's a common mistake to put a @@ -2683,9 +2711,9 @@ (while (re-search-forward "[ \t]-n" nil t) (setq eol (or (save-excursion - (and (re-search-forward "[ \t]-n" (gnus-point-at-eol) t) + (and (re-search-forward "[ \t]-n" (point-at-eol) t) (- (point) 2))) - (gnus-point-at-eol))) + (point-at-eol))) ;; Search for all "words"... (while (re-search-forward "[^ \t,\n]+" eol t) (if (eq (char-after (match-beginning 0)) ?!) @@ -2793,7 +2821,7 @@ ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) - (set-file-modes startup-file setmodes))) + (gnus-set-file-modes startup-file setmodes))) (condition-case nil (delete-file working-file) (file-error nil))))) @@ -2845,7 +2873,7 @@ (while variables (when (and (boundp (setq variable (pop variables))) (symbol-value variable)) - (princ "(setq ") + (princ "\n(setq ") (princ (symbol-name variable)) (princ " '") (prin1 (symbol-value variable)) @@ -2872,6 +2900,10 @@ (setq default-directory (file-name-directory buffer-file-name)) (buffer-disable-undo) (erase-buffer) + ;; Use a unibyte buffer since group names are unibyte strings; + ;; in particular, non-ASCII group names are the ones encoded by + ;; a certain coding system. + (mm-disable-multibyte) ;; Write options. (when gnus-newsrc-options (insert gnus-newsrc-options)) @@ -2914,7 +2946,8 @@ (delete-file gnus-startup-file) (clear-visited-file-modtime)) (gnus-run-hooks 'gnus-save-standard-newsrc-hook) - (save-buffer) + (let ((coding-system-for-write 'raw-text)) + (save-buffer)) (kill-buffer (current-buffer))))) @@ -2926,7 +2959,7 @@ (defun gnus-slave-mode () "Minor mode for slave Gnusae." - (gnus-add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) + (add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) (gnus-run-hooks 'gnus-slave-mode-hook)) (defun gnus-slave-save-newsrc () @@ -2939,7 +2972,7 @@ (let ((coding-system-for-write gnus-ding-file-coding-system)) (gnus-write-buffer slave-name)) (when modes - (set-file-modes slave-name modes))))) + (gnus-set-file-modes slave-name modes))))) (defun gnus-master-read-slave-newsrc () (let ((slave-files @@ -3117,6 +3150,41 @@ (symbol-value 'nnimap-mailbox-info) (make-vector 1 0))))) +(defun gnus-check-reasonable-setup () + ;; Check whether nnml and nnfolder share a directory. + (let ((display-warn + (if (fboundp 'display-warning) + 'display-warning + (lambda (type message) + (if noninteractive + (message "Warning (%s): %s" type message) + (let (window) + (with-current-buffer (get-buffer-create "*Warnings*") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert (format "Warning (%s): %s\n" type message)) + (setq window (display-buffer (current-buffer))) + (set-window-start + window + (prog2 + (forward-line (- 1 (window-height window))) + (point) + (goto-char (point-max)))))))))) + method active actives match) + (dolist (server gnus-server-alist) + (setq method (gnus-server-to-method server) + active (intern (format "%s-active-file" (car method)))) + (when (and (member (car method) '(nnml nnfolder)) + (gnus-server-opened method) + (boundp active)) + (when (setq match (assoc (symbol-value active) actives)) + (funcall display-warn 'gnus-server + (format "%s and %s share the same active file %s" + (car method) + (cadr match) + (car match)))) + (push (list (symbol-value active) method) actives))))) (provide 'gnus-start)