X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-start.el;h=aa9af012a1c26bb7437460af52befeed8e3ac362;hb=ae00ae88f84af9b21708cbb2ac32e2d2498d193c;hp=d2f6c985c01d1d310277f5178aec531c8c8564d7;hpb=fe4a9204a7a3799d63b30753ac705af8538a591e;p=gnus diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index d2f6c985c..aa9af012a 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -380,13 +380,6 @@ disc." :group 'gnus-newsrc :type 'boolean) -(defcustom gnus-use-backend-marks nil - "If non-nil, Gnus will store and retrieve marks from the backends. -This means that marks will be stored both in .newsrc.eld and in -the backend, and will slow operation down somewhat." - :group 'gnus-newsrc - :type 'boolean) - (defcustom gnus-check-bogus-groups-hook nil "A hook run after removing bogus groups." :group 'gnus-start-server @@ -839,13 +832,22 @@ prompt the user for the name of an NNTP server to use." gnus-current-startup-file) "-dribble")) -(defun gnus-dribble-enter (string) - "Enter STRING into the dribble buffer." +(defun gnus-dribble-enter (string &optional regexp) + "Enter STRING into the dribble buffer. +If REGEXP is given, lines that match it will be deleted." (when (and (not gnus-dribble-ignore) gnus-dribble-buffer (buffer-name gnus-dribble-buffer)) (let ((obuf (current-buffer))) (set-buffer gnus-dribble-buffer) + (when regexp + (goto-char (point-min)) + (let (end) + (while (re-search-forward regexp nil t) + (unless (bolp) (forward-line 1)) + (setq end (point)) + (goto-char (match-beginning 0)) + (delete-region (point-at-bol) end)))) (goto-char (point-max)) (insert string "\n") ;; This has been commented by Josh Huber @@ -871,6 +873,7 @@ prompt the user for the name of an NNTP server to use." (gnus-get-buffer-create (file-name-nondirectory dribble-file))) (set (make-local-variable 'file-precious-flag) t) + (setq buffer-save-without-query t) (erase-buffer) (setq buffer-file-name dribble-file) (auto-save-mode t) @@ -1312,16 +1315,13 @@ for new groups, and subscribe the new groups as zombies." ((>= level gnus-level-zombie) ;; Remove from the hash table. (gnus-sethash group nil gnus-newsrc-hashtb) - ;; We do not enter foreign groups into the list of dead - ;; groups. - (unless (gnus-group-foreign-p group) - (if (= level gnus-level-zombie) - (push group gnus-zombie-list) - (if (= oldlevel gnus-level-killed) - ;; Remove from active hashtb. - (unintern group gnus-active-hashtb) - ;; Don't add it into killed-list if it was killed. - (push group gnus-killed-list))))) + (if (= level gnus-level-zombie) + (push group gnus-zombie-list) + (if (= oldlevel gnus-level-killed) + ;; Remove from active hashtb. + (unintern group gnus-active-hashtb) + ;; Don't add it into killed-list if it was killed. + (push group gnus-killed-list)))) (t ;; If the list is to be entered into the newsrc assoc, and ;; it was killed, we have to create an entry in the newsrc @@ -1363,8 +1363,8 @@ for new groups, and subscribe the new groups as zombies." (when (cdr entry) (setcdr (gnus-group-entry (caadr entry)) entry)) (gnus-dribble-enter - (format - "(gnus-group-set-info '%S)" info))))) + (format "(gnus-group-set-info '%S)" info) + (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))))) (when gnus-group-change-level-function (funcall gnus-group-change-level-function group level oldlevel previous))))) @@ -1471,9 +1471,10 @@ If SCAN, request a scan of that group as well." (inline (gnus-request-group group (or dont-sub-check dont-check) method (gnus-get-info group))) - ;;(error nil) (quit - (message "Quit activating %s" group) + (if debug-on-quit + (debug "Quit") + (message "Quit activating %s" group)) nil))) (unless dont-check (setq active (gnus-parse-active)) @@ -1499,6 +1500,8 @@ If SCAN, request a scan of that group as well." ;; Return the new active info. active))))) +(defvar gnus-propagate-marks) ; gnus-sum + (defun gnus-get-unread-articles-in-group (info active &optional update) (when (and info active) ;; Allow the backend to update the info in the group. @@ -1509,7 +1512,7 @@ If SCAN, request a scan of that group as well." (gnus-activate-group (gnus-info-group info) nil t)) ;; Allow backends to update marks, - (when gnus-use-backend-marks + (when gnus-propagate-marks (let ((method (inline (gnus-find-method-for-group (gnus-info-group info))))) (when (gnus-check-backend-function 'request-marks (car method)) @@ -1519,7 +1522,7 @@ If SCAN, request a scan of that group as well." (num 0)) ;; These checks are present in gnus-activate-group but skipped - ;; due to setting dont-check in the preceeding call. + ;; due to setting dont-check in the preceding call. ;; If a cache is present, we may have to alter the active info. (when (and gnus-use-cache info) @@ -1682,33 +1685,68 @@ If SCAN, request a scan of that group as well." (lambda (c1 c2) (< (gnus-method-rank (cadr c1) (car c1)) (gnus-method-rank (cadr c2) (car c2)))))) + ;; Go through the list of servers and possibly extend methods that + ;; aren't equal (and that need extension; i.e., they are async). + (let ((methods nil)) + (dolist (elem type-cache) + (destructuring-bind (method method-type infos dummy) elem + (let ((gnus-opened-servers methods)) + (when (and (gnus-similar-server-opened method) + (gnus-check-backend-function + 'retrieve-group-data-early (car method))) + (setq method (gnus-server-extend-method + (gnus-info-group (car infos)) + method)) + (setcar elem method)) + (push (list method 'ok) methods))))) + + ;; If we have primary/secondary select methods, but no groups from + ;; them, we still want to issue a retrieval request from them. + (dolist (method (cons gnus-select-method + gnus-secondary-select-methods)) + (when (and (not (assoc method type-cache)) + (gnus-check-backend-function 'request-list (car method))) + (with-current-buffer nntp-server-buffer + (gnus-read-active-file-1 method nil)))) ;; Start early async retrieval of data. - (dolist (elem type-cache) - (destructuring-bind (method method-type infos dummy) elem - (when (and method infos - (not (gnus-method-denied-p method))) - ;; If the open-server method doesn't exist, then the method - ;; itself doesn't exist, so we ignore it. - (if (not (ignore-errors (gnus-get-function method 'open-server))) - (setq type-cache (delq elem type-cache)) - (unless (gnus-server-opened method) - (gnus-open-server method)) - (when (and - (gnus-server-opened method) - (gnus-check-backend-function - 'retrieve-group-data-early (car method))) - (when (gnus-check-backend-function 'request-scan (car method)) - (gnus-request-scan nil method)) - ;; Store the token we get back from -early so that we - ;; can pass it to -finish later. - (setcar (nthcdr 3 elem) - (gnus-retrieve-group-data-early method infos))))))) + (let ((done-methods nil) + sanity-spec) + (dolist (elem type-cache) + (destructuring-bind (method method-type infos dummy) elem + (setq sanity-spec (list (car method) (cadr method))) + (when (and method infos + (not (gnus-method-denied-p method))) + ;; If the open-server method doesn't exist, then the method + ;; itself doesn't exist, so we ignore it. + (if (not (ignore-errors (gnus-get-function method 'open-server))) + (setq type-cache (delq elem type-cache)) + (unless (gnus-server-opened method) + (gnus-open-server method)) + (when (and + ;; This is a sanity check, so that we never + ;; attempt to start two async requests to the + ;; same server, because that will fail. This + ;; should never happen, since the methods should + ;; be unique at this point, but apparently it + ;; does happen in the wild with some setups. + (not (member sanity-spec done-methods)) + (gnus-server-opened method) + (gnus-check-backend-function + 'retrieve-group-data-early (car method))) + (push sanity-spec done-methods) + (when (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan nil method)) + ;; Store the token we get back from -early so that we + ;; can pass it to -finish later. + (setcar (nthcdr 3 elem) + (gnus-retrieve-group-data-early method infos)))))))) ;; Do the rest of the retrieval. (dolist (elem type-cache) (destructuring-bind (method method-type infos early-data) elem - (when (and method infos) + (when (and method infos + (not (gnus-method-denied-p method))) (let ((updatep (gnus-check-backend-function 'request-update-info (car method)))) ;; See if any of the groups from this method require updating. @@ -1746,6 +1784,7 @@ If SCAN, request a scan of that group as well." ;; Finish up getting the data from the methods that have -early ;; methods. ((and + early-data (gnus-check-backend-function 'finish-retrieve-group-infos (car method)) (or (not (gnus-agent-method-p method)) (gnus-online method))) @@ -1870,7 +1909,7 @@ If SCAN, request a scan of that group as well." ;; OK - I'm done (setq articles nil)) ((< range article) - ;; this range preceeds the article. Leave the range unmodified. + ;; this range precedes the article. Leave the range unmodified. (pop ranges) ranges) ((= range article) @@ -1893,11 +1932,11 @@ If SCAN, request a scan of that group as well." (setcar ranges min) ranges) ((< max article) - ;; this range preceeds the article. Leave the range unmodified. + ;; this range precedes the article. Leave the range unmodified. (pop ranges) ranges) ((< article min) - ;; this article preceeds the range. Return null to move to the + ;; this article precedes the range. Return null to move to the ;; next article nil) (t @@ -1990,7 +2029,9 @@ If SCAN, request a scan of that group as well." ;; We catch C-g so that we can continue past servers ;; that do not respond. (quit - (message "Quit reading the active file") + (if debug-on-quit + (debug "Quit") + (message "Quit reading the active file")) nil)))))))) (defun gnus-read-active-file-1 (method force) @@ -2854,7 +2895,8 @@ If FORCE is non-nil, the .newsrc file is read." (pop list)) (nreverse olist))) -(defun gnus-gnus-to-newsrc-format () +(defun gnus-gnus-to-newsrc-format (&optional foreign-ok) + (interactive (list (gnus-y-or-n-p "write foreign groups too? "))) ;; Generate and save the .newsrc file. (with-current-buffer (create-file-buffer gnus-current-startup-file) (let ((newsrc (cdr gnus-newsrc-alist)) @@ -2876,7 +2918,8 @@ If FORCE is non-nil, the .newsrc file is read." ;; Don't write foreign groups to .newsrc. (when (or (null (setq method (gnus-info-method info))) (equal method "native") - (inline (gnus-server-equal method gnus-select-method))) + (inline (gnus-server-equal method gnus-select-method)) + foreign-ok) (insert (gnus-info-group info) (if (> (gnus-info-level info) gnus-level-subscribed) "!" ":"))