X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-start.el;h=0e35a12cf7d0a0944445cd08b834f38d8979334e;hb=ec675c6a0ef92ebe4b883b3bf10f43b9910975a3;hp=69ecae3ebcf86f0533c3a55f50ec361f57623654;hpb=0779559e5111910244cb32817bb671d8a2d25174;p=gnus diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index 69ecae3eb..0e35a12cf 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -1,17 +1,17 @@ ;;; gnus-start.el --- startup functions for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -19,9 +19,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -39,11 +37,11 @@ (autoload 'gnus-agent-possibly-alter-active "gnus-agent") (eval-when-compile - (require 'cl) + (require 'cl)) - (defvar gnus-agent-covered-methods nil) - (defvar gnus-agent-file-loading-local nil) - (defvar gnus-agent-file-loading-cache nil)) +(defvar gnus-agent-covered-methods) +(defvar gnus-agent-file-loading-local) +(defvar gnus-agent-file-loading-cache) (defcustom gnus-startup-file (nnheader-concat gnus-home-directory ".newsrc") "Your `.newsrc' file. @@ -52,7 +50,7 @@ :type 'file) (defcustom gnus-backup-startup-file 'never - "Whether to create backup files. + "Control use of version numbers for backups of `gnus-startup-file'. This variable takes the same values as the `version-control' variable." :version "22.1" @@ -178,8 +176,13 @@ properly with all servers." (defconst gnus-level-unsubscribed 7 "Groups with levels less than or equal to this variable are unsubscribed. -Groups with levels less than `gnus-level-subscribed', which should be -less than this variable, are subscribed.") + +Groups with levels less than `gnus-level-subscribed', which +should be less than this variable, are subscribed. Groups with +levels from `gnus-level-subscribed' (exclusive) upto this +variable (inclusive) are unsubscribed. See also +`gnus-level-zombie', `gnus-level-killed' and the Info node `(gnus)Group +Levels' for details.") (defconst gnus-level-zombie 8 "Groups with this level are zombie groups.") @@ -389,7 +392,7 @@ This hook is called after Gnus is connected to the NNTP server." :type 'hook) (defcustom gnus-before-startup-hook nil - "A hook called at before startup. + "A hook called before startup. This hook is called as the first thing when Gnus is started." :group 'gnus-start :type 'hook) @@ -458,6 +461,8 @@ Can be used to turn version control on or off." ;;; Internal variables +;; Fixme: deal with old emacs-mule when mm-universal-coding-system is +;; utf-8-emacs. (defvar gnus-ding-file-coding-system mm-universal-coding-system "Coding system for ding file.") @@ -645,21 +650,20 @@ the first newsgroup." ;;; General various misc type functions. ;; Silence byte-compiler. -(eval-when-compile - (defvar gnus-current-headers) - (defvar gnus-thread-indent-array) - (defvar gnus-newsgroup-name) - (defvar gnus-newsgroup-headers) - (defvar gnus-group-list-mode) - (defvar gnus-group-mark-positions) - (defvar gnus-newsgroup-data) - (defvar gnus-newsgroup-unreads) - (defvar nnoo-state-alist) - (defvar gnus-current-select-method) - (defvar mail-sources) - (defvar nnmail-scan-directory-mail-source-once) - (defvar nnmail-split-history) - (defvar nnmail-spool-file)) +(defvar gnus-current-headers) +(defvar gnus-thread-indent-array) +(defvar gnus-newsgroup-name) +(defvar gnus-newsgroup-headers) +(defvar gnus-group-list-mode) +(defvar gnus-group-mark-positions) +(defvar gnus-newsgroup-data) +(defvar gnus-newsgroup-unreads) +(defvar nnoo-state-alist) +(defvar gnus-current-select-method) +(defvar mail-sources) +(defvar nnmail-scan-directory-mail-source-once) +(defvar nnmail-split-history) +(defvar nnmail-spool-file) (defun gnus-close-all-servers () "Close all servers." @@ -761,7 +765,7 @@ prompt the user for the name of an NNTP server to use." (when gnus-select-method (push (cons "native" gnus-select-method) gnus-predefined-server-alist)) - + (if gnus-agent (gnus-agentize)) @@ -770,8 +774,7 @@ prompt the user for the name of an NNTP server to use." (cond ((featurep 'xemacs) (gnus-xmas-splash)) - ((and window-system - (= (frame-height) (1+ (window-height)))) + (window-system (gnus-x-splash)))) (let ((level (and (numberp arg) (> arg 0) arg)) @@ -811,6 +814,7 @@ prompt the user for the name of an NNTP server to use." (defun gnus-start-draft-setup () "Make sure the draft group exists." + (interactive) (gnus-request-create-group "drafts" '(nndraft "")) (unless (gnus-group-entry "nndraft:drafts") (let ((gnus-level-default-subscribed 1)) @@ -865,6 +869,8 @@ prompt the user for the name of an NNTP server to use." (defun gnus-dribble-read-file () "Read the dribble file from disk." (let ((dribble-file (gnus-dribble-file-name))) + (unless (file-exists-p (file-name-directory dribble-file)) + (make-directory (file-name-directory dribble-file) t)) (save-excursion (set-buffer (setq gnus-dribble-buffer (gnus-get-buffer-create @@ -1508,8 +1514,8 @@ newsgroup." (setq killed (cdr killed))))) ;; We want to inline a function from gnus-cache, so we cheat here: +(defvar gnus-cache-active-hashtb) (eval-when-compile - (defvar gnus-cache-active-hashtb) (defun gnus-cache-possibly-alter-active (group active) "Alter the ACTIVE info for GROUP to reflect the articles in the cache." (when gnus-cache-active-hashtb @@ -1666,7 +1672,7 @@ If SCAN, request a scan of that group as well." (defun gnus-get-unread-articles (&optional level) (setq gnus-server-method-cache nil) (let* ((newsrc (cdr gnus-newsrc-alist)) - (level (or level gnus-activate-level (1+ gnus-level-subscribed))) + (alevel (or level gnus-activate-level (1+ gnus-level-subscribed))) (foreign-level (min (cond ((and gnus-activate-foreign-newsgroups @@ -1675,11 +1681,12 @@ If SCAN, request a scan of that group as well." ((numberp gnus-activate-foreign-newsgroups) gnus-activate-foreign-newsgroups) (t 0)) - level)) + alevel)) (methods-cache nil) (type-cache nil) - scanned-methods info group active method retrieve-groups cmethod - method-type ignore) + (gnus-agent-article-local-times 0) + infos info group active method cmethod + method-type method-group-list) (gnus-message 6 "Checking new news...") (while newsrc @@ -1698,14 +1705,19 @@ If SCAN, request a scan of that group as well." ;; nil for non-foreign groups that the user has requested not be checked ;; t for unchecked foreign groups or bogus groups, or groups that can't ;; be checked, for one reason or other. - (when (setq method (gnus-info-method info)) + + ;; First go through all the groups, see what select methods they + ;; belong to, and then collect them into lists per unique select + ;; method. + (if (not (setq method (gnus-info-method info))) + (setq method gnus-select-method) (if (setq cmethod (assoc method methods-cache)) (setq method (cdr cmethod)) (setq cmethod (inline (gnus-server-get-method nil method))) (push (cons method cmethod) methods-cache) (setq method cmethod))) - (when (and method - (not (setq method-type (cdr (assoc method type-cache))))) + (setq method-group-list (assoc method type-cache)) + (unless method-group-list (setq method-type (cond ((gnus-secondary-method-p method) @@ -1714,100 +1726,75 @@ If SCAN, request a scan of that group as well." '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. - (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. - (setq active 'ignore)) - ;; Activate groups. - ((not gnus-read-active-file) - (if (gnus-check-backend-function 'retrieve-groups group) - ;; if server support gnus-retrieve-groups we push - ;; the group onto retrievegroups for later checking - (if (assoc method retrieve-groups) - (setcdr (assoc method retrieve-groups) - (cons group (cdr (assoc method retrieve-groups)))) - (push (list method group) retrieve-groups)) - ;; hack: `nnmail-get-new-mail' changes the mail-source depending - ;; on the group, so we must perform a scan for every group - ;; if the users has any directory mail sources. - ;; hack: if `nnmail-scan-directory-mail-source-once' is non-nil, - ;; for it scan all spool files even when the groups are - ;; not required. - (if (and - (or nnmail-scan-directory-mail-source-once - (null (assq 'directory - (or mail-sources - (if (listp nnmail-spool-file) - nnmail-spool-file - (list nnmail-spool-file)))))) - (member method scanned-methods)) - (setq active (gnus-activate-group group)) - (setq active (gnus-activate-group group 'scan)) - (push method scanned-methods)) - (when active - (gnus-close-group group))))) - - ;; Get the number of unread articles in the group. - (cond - ((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-group-entry group))) - (when tmp - (setcar tmp t)))))) - - ;; iterate through groups on methods which support gnus-retrieve-groups - ;; and fetch a partial active file and use it to find new news. - (dolist (rg retrieve-groups) - (let ((method (or (car rg) gnus-select-method)) - (groups (cdr rg))) - (when (gnus-check-server method) - ;; Request that the backend scan its incoming messages. - (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) - (dolist (group groups) - (cond - ((setq active (gnus-active (gnus-info-group - (setq info (gnus-get-info group))))) - (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) - (setcar (gnus-group-entry group) t))))))) - + (push (setq method-group-list (list method method-type nil)) + type-cache)) + (setcar (nthcdr 2 method-group-list) + (cons info (nth 2 method-group-list)))) + + ;; 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 + ;; 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)))))) + + (while type-cache + (setq method (nth 0 (car type-cache)) + method-type (nth 1 (car type-cache)) + infos (nth 2 (car type-cache))) + (pop type-cache) + + (when method + ;; See if any of the groups from this method require updating. + (when (block nil + (dolist (info infos) + (when (<= (gnus-info-level info) + (if (eq method-type 'foreign) + foreign-level + alevel)) + (return t)))) + (gnus-read-active-for-groups method infos) + (dolist (info infos) + (inline (gnus-get-unread-articles-in-group + info (gnus-active (gnus-info-group info)))))))) (gnus-message 6 "Checking new news...done"))) +(defun gnus-method-rank (type method) + (cond + ((eq type 'primary) + 1) + ;; Compute the rank of the secondary methods based on where they + ;; are in the secondary select list. + ((eq type 'secondary) + (let ((i 2)) + (block nil + (dolist (smethod gnus-secondary-select-methods) + (when (equalp method smethod) + (return i)) + (incf i)) + i))) + ;; Just say that all foreign groups have the same rank. + (t + 100))) + +(defun gnus-read-active-for-groups (method infos) + (with-current-buffer nntp-server-buffer + (cond + ((gnus-check-backend-function 'retrieve-groups (car method)) + (gnus-read-active-file-2 + (mapcar (lambda (info) + (gnus-group-real-name (gnus-info-group info))) + infos) + method)) + ((gnus-check-backend-function 'request-list (car method)) + (gnus-read-active-file-1 method nil)) + (t + (dolist (info infos) + (gnus-activate-group (gnus-info-group info) nil nil method)))))) + ;; Create a hash table out of the newsrc alist. The `car's of the ;; alist elements are used as keys. (defun gnus-make-hashtable-from-newsrc-alist () @@ -1828,14 +1815,18 @@ If SCAN, request a scan of that group as well." (if (setq rest (member method methods)) (gnus-info-set-method info (car rest)) (push method methods))) - (gnus-sethash - (car info) - ;; Preserve number of unread articles in groups. - (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) - prev) - gnus-newsrc-hashtb) - (setq prev alist - alist (cdr alist))) + ;; Check for duplicates. + (if (gnus-gethash (car info) gnus-newsrc-hashtb) + ;; Remove this entry from the alist. + (setcdr prev (cddr prev)) + (gnus-sethash + (car info) + ;; Preserve number of unread articles in groups. + (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) + prev) + gnus-newsrc-hashtb) + (setq prev alist)) + (setq alist (cdr alist))) ;; Make the same select-methods in `gnus-server-alist' identical ;; as well. (while methods @@ -1963,7 +1954,7 @@ If SCAN, request a scan of that group as well." (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))))) @@ -2038,7 +2029,9 @@ If SCAN, request a scan of that group as well." (gnus-message 5 mesg) (when (gnus-check-server method) ;; Request that the backend scan its incoming messages. - (when (gnus-check-backend-function 'request-scan (car method)) + (when (and gnus-agent + (gnus-online method) + (gnus-check-backend-function 'request-scan (car method))) (gnus-request-scan nil method)) (cond ((and (eq gnus-read-active-file 'some) @@ -2100,7 +2093,8 @@ If SCAN, request a scan of that group as well." (if (equal method gnus-select-method) (gnus-make-hashtable (count-lines (point-min) (point-max))) - (gnus-make-hashtable 4096))))))) + (gnus-make-hashtable 4096)))))) + group max min) ;; Delete unnecessary lines. (goto-char (point-min)) (cond @@ -2135,8 +2129,12 @@ If SCAN, request a scan of that group as well." (insert prefix) (zerop (forward-line 1))))))) ;; Store the active file in a hash table. - (goto-char (point-min)) - (let (group max min) + ;; Use a unibyte buffer in order to make `read' read non-ASCII + ;; group names (which have been encoded) as unibyte strings. + (mm-with-unibyte-buffer + (insert-buffer-substring cur) + (setq cur (current-buffer)) + (goto-char (point-min)) (while (not (eobp)) (condition-case () (progn @@ -2385,11 +2383,11 @@ If FORCE is non-nil, the .newsrc file is read." (eval form)) (error (unless (eq (car type) 'end-of-file) - (let ((error (format "Error in %s line %d" file - (count-lines (point-min) (point))))) + (let ((errmsg (format "Error in %s line %d" file + (count-lines (point-min) (point))))) (ding) - (unless (gnus-yes-or-no-p (concat error "; continue? ")) - (error "%s" error))))))))) + (unless (gnus-yes-or-no-p (concat errmsg "; continue? ")) + (error "%s" errmsg))))))))) (defun gnus-read-newsrc-el-file (file) (let ((ding-file (concat file "d"))) @@ -2397,8 +2395,7 @@ If FORCE is non-nil, the .newsrc file is read." ;; We always, always read the .eld file. (gnus-message 5 "Reading %s..." ding-file) (let (gnus-newsrc-assoc) - (let ((coding-system-for-read gnus-ding-file-coding-system)) - (gnus-load ding-file)) + (gnus-load ding-file) ;; Older versions of `gnus-format-specs' are no longer valid ;; in Oort Gnus 0.01. (let ((version @@ -2409,6 +2406,8 @@ If FORCE is non-nil, the .newsrc file is read." (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 @@ -2791,9 +2790,7 @@ If FORCE is non-nil, the .newsrc file is read." (if (and (eq system-type 'ms-dos) (not (gnus-long-file-names))) "%s#%d.tm#" ; MSDOS limits files to 8+3 - (if (memq system-type '(vax-vms axp-vms)) - "%s$tmp$%d" - "%s#tmp#%d")) + "%s#tmp#%d") working-dir (setq i (1+ i)))) (file-exists-p working-file))) @@ -2828,7 +2825,8 @@ If FORCE is non-nil, the .newsrc file is read." (defun gnus-gnus-to-quick-newsrc-format (&optional minimal name &rest specific-variables) "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format." - (princ ";; -*- emacs-lisp -*-\n") + (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n" + gnus-ding-file-coding-system)) (if name (princ (format ";; %s\n" name)) (princ ";; Gnus startup file.\n")) @@ -2867,7 +2865,7 @@ If FORCE is non-nil, the .newsrc file is read." (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)) @@ -2894,6 +2892,10 @@ If FORCE is non-nil, the .newsrc file is read." (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)) @@ -2936,7 +2938,8 @@ If FORCE is non-nil, the .newsrc file is read." (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))))) @@ -2948,6 +2951,8 @@ If FORCE is non-nil, the .newsrc file is read." (defun gnus-slave-mode () "Minor mode for slave Gnusae." + ;; FIXME: gnus-slave-mode appears to never be set (i.e. it'll always be nil): + ;; Remove, or fix and use define-minor-mode. (add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) (gnus-run-hooks 'gnus-slave-mode-hook)) @@ -3046,6 +3051,7 @@ If FORCE is non-nil, the .newsrc file is read." nil) (t (save-excursion + ;; FIXME: Shouldn't save-restriction be done after set-buffer? (save-restriction (set-buffer nntp-server-buffer) (goto-char (point-min)) @@ -3177,7 +3183,6 @@ If this variable is nil, don't do anything." (provide 'gnus-start) -;; arch-tag: f4584a22-b7b7-4853-abfc-a637329af5d2 ;;; gnus-start.el ends here