X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fgnus-start.el;h=4098bc9f0c32192f80aeb1904763b1e56ae29df6;hb=6e78f2356811a237efe323789441d9c1da9d9bc3;hp=fa582c58aeec552427b4f4a850934bec73b00d39;hpb=853d81e87dcdc0a4367450d9ce0a3fc67e247137;p=gnus diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index fa582c58a..4098bc9f0 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -1,6 +1,6 @@ ;;; gnus-start.el --- startup functions for Gnus -;; Copyright (C) 1996-2011 Free Software Foundation, Inc. +;; Copyright (C) 1996-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -291,7 +291,9 @@ claim them." function (repeat function))) -(defcustom gnus-subscribe-newsgroup-hooks nil +(define-obsolete-variable-alias 'gnus-subscribe-newsgroup-hooks + 'gnus-subscribe-newsgroup-functions "24.3") +(defcustom gnus-subscribe-newsgroup-functions nil "*Hooks run after you subscribe to a new group. The hooks will be called with new group's name as argument." :version "22.1" @@ -393,7 +395,15 @@ This hook is called after Gnus is connected to the NNTP server." (defcustom gnus-before-startup-hook nil "A hook called before startup. -This hook is called as the first thing when Gnus is started." +This hook is called as the first thing when Gnus is started. +See also `gnus-before-resume-hook'." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-before-resume-hook nil + "A hook called before resuming Gnus after suspend. +This hook is called as the first thing when Gnus is resumed after a suspend. +See also `gnus-before-startup-hook'." :group 'gnus-start :type 'hook) @@ -639,7 +649,7 @@ the first newsgroup." 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) + (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) t)) (defun gnus-read-active-file-p () @@ -747,6 +757,7 @@ prompt the user for the name of an NNTP server to use." (if (gnus-alive-p) (progn + (gnus-run-hooks 'gnus-before-resume-hook) (switch-to-buffer gnus-group-buffer) (gnus-group-get-new-news (and (numberp arg) @@ -763,8 +774,8 @@ prompt the user for the name of an NNTP server to use." ;; 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)) @@ -832,13 +843,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 @@ -1034,7 +1054,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; 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. @@ -1354,17 +1374,12 @@ 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))))) -(defun gnus-kill-newsgroup (newsgroup) - "Obsolete function. Kills a newsgroup." - (gnus-group-change-level - (gnus-group-entry newsgroup) gnus-level-killed)) - (defun gnus-check-bogus-newsgroups (&optional confirm) "Remove bogus newsgroups. If CONFIRM is non-nil, the user has to confirm the deletion of every @@ -1442,7 +1457,11 @@ newsgroup." (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)) @@ -1500,13 +1519,6 @@ If SCAN, request a scan of that group as well." (gnus-info-group info))))) (gnus-activate-group (gnus-info-group info) nil t)) - ;; Allow backends to update 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)) - (gnus-request-marks info method)))) - (let* ((range (gnus-info-read info)) (num 0)) @@ -1595,7 +1607,7 @@ If SCAN, request a scan of that group as well." ;; 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)) @@ -1652,7 +1664,7 @@ If SCAN, request a scan of that group as well." (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)) @@ -1667,7 +1679,7 @@ If SCAN, request a scan of that group as well." ;; 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) @@ -1691,41 +1703,67 @@ If SCAN, request a scan of that group as well." ;; 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. + (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)) - ;; 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))))))) + (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 - (not (eq (gnus-server-status method) - 'denied))) + (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. @@ -1763,6 +1801,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))) @@ -2188,7 +2227,7 @@ If SCAN, request a scan of that group as well." (gnus-online method) (gnus-agent-method-p method)) (progn - (gnus-agent-save-active method) + (gnus-agent-save-active method t) (gnus-active-to-gnus-format method hashtb nil real-active)) (goto-char (point-min)) @@ -2261,7 +2300,27 @@ If FORCE is non-nil, the .newsrc file is read." (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 + ;; Remove totally bogus `unexists' entries. The name is + ;; `unexist'. + (dolist (info (cdr gnus-newsrc-alist)) + (let ((exist (assoc 'unexists (gnus-info-marks info)))) + (when exist + (gnus-info-set-marks + info (delete exist (gnus-info-marks info)))))) + (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." @@ -2400,7 +2459,9 @@ If FORCE is non-nil, the .newsrc file is read." (when gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))) (dolist (elem gnus-newsrc-alist) - (setcar elem (mm-string-as-unibyte (car elem)))) + ;; Protect against broken .newsrc.el files. + (when (car elem) + (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 @@ -2510,7 +2571,7 @@ If FORCE is non-nil, the .newsrc file is read." ((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. @@ -2873,7 +2934,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)) @@ -2895,7 +2957,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) "!" ":"))