;;; gnus-start.el --- startup functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2012 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
: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
(gnus-group-change-level
newsgroup gnus-level-default-subscribed
gnus-level-killed (gnus-group-entry (or next "dummy.group")))
+ (gnus-request-update-group-status newsgroup 'subscribe)
(gnus-message 5 "Subscribe newsgroup: %s" newsgroup)
(run-hook-with-args 'gnus-subscribe-newsgroup-hooks newsgroup)
t))
;; 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))
+ (add-to-list 'gnus-predefined-server-alist
+ (cons "native" gnus-select-method)))
(if gnus-agent
(gnus-agentize))
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 <huber@alum.wpi.edu>
(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)
;; Find the number of unread articles in each non-dead group.
(let ((gnus-read-active-file (and (not level) gnus-read-active-file)))
- (gnus-get-unread-articles level))))
+ (gnus-get-unread-articles level dont-connect))))
(defun gnus-call-subscribe-functions (method group)
"Call METHOD to subscribe GROUP.
((>= 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
(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)))))
(defun gnus-activate-group (group &optional scan dont-check method
dont-sub-check)
"Check whether a group has been activated or not.
-If SCAN, request a scan of that group as well."
+If SCAN, request a scan of that group as well. If METHOD, use
+that select method instead of determining the method based on the
+group name. If DONT-CHECK, don't check check whether the group
+actually exists. If DONT-SUB-CHECK or DONT-CHECK, don't let the
+backend check whether the group actually exists."
(let ((method (or method (inline (gnus-find-method-for-group group))))
active)
(and (inline (gnus-check-server method))
(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))
(gnus-info-group info)))))
(gnus-activate-group (gnus-info-group info) nil t))
- ;; Allow backends to update marks,
- (when gnus-use-backend-marks
- (let ((method (inline (gnus-find-method-for-group
- (gnus-info-group info)))))
- (when (gnus-check-backend-function 'request-marks (car method))
- (gnus-request-marks info method))))
-
(let* ((range (gnus-info-read info))
(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)
;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb'
;; and compute how many unread articles there are in each group.
-(defun gnus-get-unread-articles (&optional level)
+(defun gnus-get-unread-articles (&optional level dont-connect one-level)
(setq gnus-server-method-cache nil)
(require 'gnus-agent)
(let* ((newsrc (cdr gnus-newsrc-alist))
(push (setq method-group-list (list method method-type nil nil))
type-cache))
;; Only add groups that need updating.
- (if (<= (gnus-info-level info)
+ (if (funcall (if one-level #'= #'<=) (gnus-info-level info)
(if (eq (cadr method-group-list) 'foreign)
foreign-level
alevel))
;; Sort the methods based so that the primary and secondary
;; methods come first. This is done for legacy reasons to try to
- ;; ensure that side-effect behaviour doesn't change from previous
+ ;; ensure that side-effect behavior doesn't change from previous
;; Gnus versions.
(setq type-cache
(sort (nreverse type-cache)
(lambda (c1 c2)
(< (gnus-method-rank (cadr c1) (car c1))
(gnus-method-rank (cadr c2) (car c2))))))
-
- ;; Start early async retrieval of data.
+ ;; 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.
+ (unless dont-connect
+ (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)))))
+
+ ;; Clear out all the early methods.
(dolist (elem type-cache)
(destructuring-bind (method method-type infos dummy) elem
- (when (and method infos
+ (when (and method
+ infos
+ (gnus-check-backend-function
+ 'retrieve-group-data-early (car method))
(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))
+ (when (ignore-errors (gnus-get-function method 'open-server))
(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))
- (setcar (nthcdr 3 elem)
- (gnus-retrieve-group-data-early method infos)))))))
+ (when (gnus-server-opened method)
+ ;; Just mark this server as "cleared".
+ (gnus-retrieve-group-data-early method nil))))))
+
+ ;; Start early async retrieval of data.
+ (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.
(defun gnus-read-active-for-groups (method infos early-data)
(with-current-buffer nntp-server-buffer
(cond
+ ;; 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)))
(gnus-finish-retrieve-group-infos method infos early-data)
(gnus-agent-save-active method))
+ ;; Most backends have -retrieve-groups.
((gnus-check-backend-function 'retrieve-groups (car method))
(when (gnus-check-backend-function 'request-scan (car method))
(gnus-request-scan nil method))
(dolist (info infos (nreverse groups))
(push (gnus-group-real-name (gnus-info-group info)) groups))
method)))
+ ;; Virtually all backends have -request-list.
((gnus-check-backend-function 'request-list (car method))
- (gnus-read-active-file-1 method nil infos))
+ (gnus-read-active-file-1 method nil))
+ ;; Except nnvirtual and friends, where we request each group, one
+ ;; by one.
(t
(dolist (info infos)
(gnus-activate-group (gnus-info-group info) nil nil method t))))))
;; 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)
(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
;; 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 &optional infos)
+(defun gnus-read-active-file-1 (method force)
(let (where mesg)
(setq where (nth 1 method)
mesg (format "Reading active file%s via %s..."
(gnus-message 5 "Reading %s...done" newsrc-file)))
;; Convert old to new.
- (gnus-convert-old-newsrc))))
+ (gnus-convert-old-newsrc)
+ (gnus-clean-old-newsrc))))
+
+(defun gnus-clean-old-newsrc (&optional force)
+ (when gnus-newsrc-file-version
+ (when (or force
+ (< (gnus-continuum-version gnus-newsrc-file-version)
+ (gnus-continuum-version "Ma Gnus v0.03")))
+ ;; Remove old `exist' marks from old nnimap groups.
+ (dolist (info (cdr gnus-newsrc-alist))
+ (let ((exist (assoc 'unexist (gnus-info-marks info))))
+ (when exist
+ (gnus-info-set-marks
+ info (delete exist (gnus-info-marks info)))))))))
(defun gnus-convert-old-newsrc ()
"Convert old newsrc formats into the current format, if needed."
((or (eq symbol options-symbol)
(eq symbol Options-symbol))
(setq gnus-newsrc-options
- ;; This concating is quite inefficient, but since our
+ ;; This concatting is quite inefficient, but since our
;; thorough studies show that approx 99.37% of all
;; .newsrc files only contain a single options line, we
;; don't give a damn, frankly, my dear.
(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))
;; 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)
"!" ":"))
projects / gnus / blobdiff