X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-int.el;h=33d020f2a1a849e15378ed3d46af560f9d449b0e;hb=8339220cc25db3fbdab4367d6252e596bddd9cb1;hp=2a3837dbb828bfc0a47f9327780bc85b9a0be2d6;hpb=6c58b85f7f48e52a123a3f6ac3437703b9d6a3cc;p=gnus diff --git a/lisp/gnus-int.el b/lisp/gnus-int.el index 2a3837dbb..33d020f2a 100644 --- a/lisp/gnus-int.el +++ b/lisp/gnus-int.el @@ -1,26 +1,25 @@ ;;; gnus-int.el --- backend interface functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 +;; 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 -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -32,8 +31,10 @@ (require 'message) (require 'gnus-range) -(eval-when-compile - (defun gnus-agent-expire (a b c))) +(autoload 'gnus-agent-expire "gnus-agent") +(autoload 'gnus-agent-regenerate-group "gnus-agent") +(autoload 'gnus-agent-read-servers-validate-native "gnus-agent") +(autoload 'gnus-agent-possibly-synchronize-flags-server "gnus-agent") (defcustom gnus-open-server-hook nil "Hook called just before opening connection to the news server." @@ -46,6 +47,7 @@ If the server is covered by Gnus agent, the possible values are `denied', set the server denied; `offline', set the server offline; nil, ask user. If the server is not covered by Gnus agent, set the server denied." + :version "22.1" :group 'gnus-start :type '(choice (const :tag "Ask" nil) (const :tag "Deny server" denied) @@ -54,6 +56,27 @@ server denied." (defvar gnus-internal-registry-spool-current-method nil "The current method, for the registry.") + +(defun gnus-server-opened (gnus-command-method) + "Check whether a connection to GNUS-COMMAND-METHOD has been opened." + (unless (eq (gnus-server-status gnus-command-method) + 'denied) + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (inline (gnus-get-function gnus-command-method 'server-opened)) + (nth 1 gnus-command-method)))) + +(defun gnus-status-message (gnus-command-method) + "Return the status message from GNUS-COMMAND-METHOD. +If GNUS-COMMAND-METHOD is a string, it is interpreted as a group +name. The method this group uses will be queried." + (let ((gnus-command-method + (if (stringp gnus-command-method) + (gnus-find-method-for-group gnus-command-method) + gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'status-message) + (nth 1 gnus-command-method)))) + ;;; ;;; Server Communication ;;; @@ -71,11 +94,10 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." (when confirm ;; Read server name with completion. (setq gnus-nntp-server - (completing-read "NNTP server: " - (mapcar (lambda (server) (list server)) - (cons (list gnus-nntp-server) - gnus-secondary-servers)) - nil nil gnus-nntp-server))) + (gnus-completing-read "NNTP server" + (cons gnus-nntp-server + gnus-secondary-servers) + nil gnus-nntp-server))) (when (and gnus-nntp-server (stringp gnus-nntp-server) @@ -106,6 +128,18 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." (require 'nntp))) (setq gnus-current-select-method gnus-select-method) (gnus-run-hooks 'gnus-open-server-hook) + + ;; Partially validate agent covered methods now that the + ;; gnus-select-method is known. + + (if gnus-agent + ;; NOTE: This is here for one purpose only. By validating + ;; the current select method, it converts the old 5.10.3, + ;; and earlier, format to the current format. That enables + ;; the agent code within gnus-open-server to function + ;; correctly. + (gnus-agent-read-servers-validate-native gnus-select-method)) + (or ;; gnus-open-server-hook might have opened it (gnus-server-opened gnus-select-method) @@ -144,15 +178,17 @@ If it is down, start it up (again)." (format " on %s" (nth 1 method))))) (gnus-run-hooks 'gnus-open-server-hook) (prog1 - (condition-case () - (setq result (gnus-open-server method)) - (quit (message "Quit gnus-check-server") - nil)) + (setq result (gnus-open-server method)) (unless silent - (gnus-message 5 "Opening %s server%s...%s" (car method) - (if (equal (nth 1 method) "") "" - (format " on %s" (nth 1 method))) - (if result "done" "failed"))))))) + (gnus-message + (if result 5 3) + "Opening %s server%s...%s" (car method) + (if (equal (nth 1 method) "") "" + (format " on %s" (nth 1 method))) + (if result + "done" + (format "failed: %s" + (nnheader-get-report-string (car method)))))))))) (defun gnus-get-function (method function &optional noerror) "Return a function symbol based on METHOD and FUNCTION." @@ -163,7 +199,7 @@ If it is down, start it up (again)." (setq method (gnus-server-to-method method))) ;; Check cache of constructed names. (let* ((method-sym (if gnus-agent - (gnus-agent-get-function method) + (inline (gnus-agent-get-function method)) (car method))) (method-fns (get method-sym 'gnus-method-functions)) (func (let ((method-fnlist-elt (assq function method-fns))) @@ -190,74 +226,93 @@ If it is down, start it up (again)." ;;; Interface functions to the backends. ;;; +(defun gnus-method-denied-p (method) + (eq (nth 1 (assoc method gnus-opened-servers)) + 'denied)) + +(defvar gnus-backend-trace t) + (defun gnus-open-server (gnus-command-method) "Open a connection to GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) - - (let ((state (or (assoc gnus-command-method gnus-opened-servers) - (car (setq gnus-opened-servers - (cons (list gnus-command-method nil) - gnus-opened-servers)))))) - (cond ((eq (nth 1 state) 'denied) - ;; If this method was previously denied, we just return nil. - - (gnus-message 1 "Denied server") - nil) - ((eq (nth 1 state) 'offline) - ;; If this method was previously opened offline, we just return t. - t) - ((not gnus-plugged) - ;; I'm opening servers while unplugged. Set the status to - ;; either 'offline or 'denied without asking (I'm assuming - ;; that the user wants to go 'offline on every agentized - ;; server when opening while unplugged.) - (setcar (cdr state) (if (and gnus-agent - (gnus-agent-method-p gnus-command-method)) - (or gnus-server-unopen-status - 'offline) - 'denied)) - - (if (eq (nth 1 state) 'offline) - ;; Invoke the agent's backend to open the offline server. - (funcall (gnus-get-function gnus-command-method 'open-server) - (nth 1 gnus-command-method) - (nthcdr 2 gnus-command-method)))) - ((condition-case err - ;; Open the server. - (funcall (gnus-get-function gnus-command-method 'open-server) - (nth 1 gnus-command-method) - (nthcdr 2 gnus-command-method)) - (error - (gnus-message 1 (format - "Unable to open server due to: %s" - (error-message-string err))) + (when gnus-backend-trace + (with-current-buffer (get-buffer-create "*gnus trace*") + (buffer-disable-undo) + (goto-char (point-max)) + (insert (format-time-string "%H:%M:%S") + (format " %S\n" gnus-command-method)))) + (let ((elem (assoc gnus-command-method gnus-opened-servers)) + (server (gnus-method-to-server-name gnus-command-method))) + ;; If this method was previously denied, we just return nil. + (if (eq (nth 1 elem) 'denied) + (progn + (gnus-message 1 "Denied server %s" server) + nil) + ;; Open the server. + (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server)) + (result + (condition-case err + (funcall open-server-function + (nth 1 gnus-command-method) + (nthcdr 2 gnus-command-method)) + (error + (gnus-message 1 "Unable to open server %s due to: %s" + server (error-message-string err)) nil) - (quit - (gnus-message 1 "Quit trying to open server") - nil)) - ;; I successfully opened the server. - (setcar (cdr state) 'ok)) - (t - ;; I couldn't open the server so decide whether to mark it - ;; 'denied or to open it 'offline. - (setcar (cdr state) - (if (and gnus-agent - (not (eq (cadr state) 'offline)) - (gnus-agent-method-p gnus-command-method)) - (or gnus-server-unopen-status - (if (gnus-y-or-n-p - (format "Unable to open %s:%s, go offline? " - (car gnus-command-method) - (cadr gnus-command-method))) - 'offline - 'denied)) - 'denied)) - (if (eq (nth 1 state) 'offline) - ;; Invoke the agent's backend to open the offline server. - (funcall (gnus-get-function gnus-command-method 'open-server) - (nth 1 gnus-command-method) - (nthcdr 2 gnus-command-method))))))) + (quit + (gnus-message 1 "Quit trying to open server %s" server) + nil))) + open-offline) + ;; If this hasn't been opened before, we add it to the list. + (unless elem + (setq elem (list gnus-command-method nil) + gnus-opened-servers (cons elem gnus-opened-servers))) + ;; Set the status of this server. + (setcar + (cdr elem) + (cond (result + (if (eq open-server-function #'nnagent-open-server) + ;; The agent's backend has a "special" status + 'offline + 'ok)) + ((and gnus-agent + (gnus-agent-method-p gnus-command-method)) + (cond + (gnus-server-unopen-status + ;; Set the server's status to the unopen + ;; status. If that status is offline, + ;; recurse to open the agent's backend. + (setq open-offline (eq gnus-server-unopen-status 'offline)) + gnus-server-unopen-status) + ((not gnus-batch-mode) + (setq open-offline t) + 'offline) + (t + ;; This agentized server was still denied + 'denied))) + (t + ;; This unagentized server must be denied + 'denied))) + + ;; NOTE: I MUST set the server's status to offline before this + ;; recursive call as this status will drive the + ;; gnus-get-function (called above) to return the agent's + ;; backend. + (if open-offline + ;; Recursively open this offline server to perform the + ;; open-server function of the agent's backend. + (let ((gnus-server-unopen-status 'denied)) + ;; Bind gnus-server-unopen-status to avoid recursively + ;; prompting with "go offline?". This is only a concern + ;; when the agent's backend fails to open the server. + (gnus-open-server gnus-command-method)) + (when (and (eq (cadr elem) 'ok) gnus-agent + (gnus-agent-method-p gnus-command-method)) + (save-excursion + (gnus-agent-possibly-synchronize-flags-server + gnus-command-method))) + result))))) (defun gnus-close-server (gnus-command-method) "Close the connection to GNUS-COMMAND-METHOD." @@ -273,6 +328,22 @@ If it is down, start it up (again)." (funcall (gnus-get-function gnus-command-method 'request-list) (nth 1 gnus-command-method))) +(defun gnus-finish-retrieve-group-infos (gnus-command-method infos data) + "Read and update infos from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'finish-retrieve-group-infos) + (nth 1 gnus-command-method) + infos data)) + +(defun gnus-retrieve-group-data-early (gnus-command-method infos) + "Start early async retrival of data from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'retrieve-group-data-early) + (nth 1 gnus-command-method) + infos)) + (defun gnus-request-list-newsgroups (gnus-command-method) "Request the newsgroups file from GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) @@ -288,26 +359,6 @@ If it is down, start it up (again)." (when func (funcall func date (nth 1 gnus-command-method))))) -(defun gnus-server-opened (gnus-command-method) - "Check whether a connection to GNUS-COMMAND-METHOD has been opened." - (unless (eq (gnus-server-status gnus-command-method) - 'denied) - (when (stringp gnus-command-method) - (setq gnus-command-method (gnus-server-to-method gnus-command-method))) - (funcall (inline (gnus-get-function gnus-command-method 'server-opened)) - (nth 1 gnus-command-method)))) - -(defun gnus-status-message (gnus-command-method) - "Return the status message from GNUS-COMMAND-METHOD. -If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method -this group uses will be queried." - (let ((gnus-command-method - (if (stringp gnus-command-method) - (gnus-find-method-for-group gnus-command-method) - gnus-command-method))) - (funcall (gnus-get-function gnus-command-method 'status-message) - (nth 1 gnus-command-method)))) - (defun gnus-request-regenerate (gnus-command-method) "Request a data generation from GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) @@ -315,7 +366,24 @@ this group uses will be queried." (funcall (gnus-get-function gnus-command-method 'request-regenerate) (nth 1 gnus-command-method))) -(defun gnus-request-group (group &optional dont-check gnus-command-method) +(defun gnus-request-compact-group (group) + (let* ((method (gnus-find-method-for-group group)) + (gnus-command-method method) + (result + (funcall (gnus-get-function gnus-command-method + 'request-compact-group) + (gnus-group-real-name group) + (nth 1 gnus-command-method) t))) + result)) + +(defun gnus-request-compact (gnus-command-method) + "Request groups compaction from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-compact) + (nth 1 gnus-command-method))) + +(defun gnus-request-group (group &optional dont-check gnus-command-method info) "Request GROUP. If DONT-CHECK, no information is required." (let ((gnus-command-method (or gnus-command-method (inline (gnus-find-method-for-group group))))) @@ -324,7 +392,8 @@ this group uses will be queried." (inline (gnus-server-to-method gnus-command-method)))) (funcall (inline (gnus-get-function gnus-command-method 'request-group)) (gnus-group-real-name group) (nth 1 gnus-command-method) - dont-check))) + dont-check + info))) (defun gnus-list-active-group (group) "Request active information on GROUP." @@ -395,7 +464,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (gnus-group-real-name group) article)))) (defun gnus-request-set-mark (group action) - "Set marks on articles in the backend." + "Set marks on articles in the back end." (let ((gnus-command-method (gnus-find-method-for-group group))) (if (not (gnus-check-backend-function 'request-set-mark (car gnus-command-method))) @@ -405,7 +474,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (nth 1 gnus-command-method))))) (defun gnus-request-update-mark (group article mark) - "Allow the backend to change the mark the user tries to put on an article." + "Allow the back end to change the mark the user tries to put on an article." (let ((gnus-command-method (gnus-find-method-for-group group))) (if (not (gnus-check-backend-function 'request-update-mark (car gnus-command-method))) @@ -447,8 +516,7 @@ If BUFFER, insert the article in that group." (setq res (gnus-request-article article group) clean-up t))) (when clean-up - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (1- (point)) (point-max))) @@ -480,8 +548,7 @@ If BUFFER, insert the article in that group." (setq res (gnus-request-article article group) clean-up t))) (when clean-up - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (point-min) (1- (point)))))) @@ -494,6 +561,14 @@ If BUFFER, insert the article in that group." (funcall (gnus-get-function gnus-command-method 'request-post) (nth 1 gnus-command-method))) +(defun gnus-request-expunge-group (group gnus-command-method) + "Expunge GROUP, which is removing articles that have been marked as deleted." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-expunge-group) + (gnus-group-real-name group) + (nth 1 gnus-command-method))) + (defun gnus-request-scan (group gnus-command-method) "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD. If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." @@ -501,19 +576,28 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (if group (gnus-find-method-for-group group) gnus-command-method)) (gnus-inhibit-demon t) (mail-source-plugged gnus-plugged)) - (if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) - (progn - (setq gnus-internal-registry-spool-current-method gnus-command-method) - (funcall (gnus-get-function gnus-command-method 'request-scan) - (and group (gnus-group-real-name group)) - (nth 1 gnus-command-method)))))) + (when (or gnus-plugged + (not (gnus-agent-method-p gnus-command-method))) + (setq gnus-internal-registry-spool-current-method gnus-command-method) + (funcall (gnus-get-function gnus-command-method 'request-scan) + (and group (gnus-group-real-name group)) + (nth 1 gnus-command-method))))) + +(defun gnus-request-update-info (info gnus-command-method) + (when (gnus-check-backend-function + 'request-update-info (car gnus-command-method)) + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-update-info) + (gnus-group-real-name (gnus-info-group info)) info + (nth 1 gnus-command-method)))) -(defsubst gnus-request-update-info (info gnus-command-method) +(defsubst gnus-request-marks (info gnus-command-method) "Request that GNUS-COMMAND-METHOD update INFO." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) (when (gnus-check-backend-function - 'request-update-info (car gnus-command-method)) + 'request-marks (car gnus-command-method)) (let ((group (gnus-info-group info))) (and (funcall (gnus-get-function gnus-command-method 'request-update-info) @@ -533,8 +617,9 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (defun gnus-request-expire-articles (articles group &optional force) (let* ((gnus-command-method (gnus-find-method-for-group group)) - (not-deleted - (funcall + (gnus-inhibit-demon t) + (not-deleted + (funcall (gnus-get-function gnus-command-method 'request-expire-articles) articles (gnus-group-real-name group) (nth 1 gnus-command-method) force))) @@ -546,17 +631,17 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." not-deleted)) (defun gnus-request-move-article (article group server accept-function - &optional last) + &optional last move-is-internal) (let* ((gnus-command-method (gnus-find-method-for-group group)) (result (funcall (gnus-get-function gnus-command-method 'request-move-article) article (gnus-group-real-name group) - (nth 1 gnus-command-method) accept-function last))) + (nth 1 gnus-command-method) accept-function last move-is-internal))) (when (and result gnus-agent (gnus-agent-method-p gnus-command-method)) - (gnus-agent-expire (list article) group 'force)) + (gnus-agent-unfetch-articles group (list article))) result)) - + (defun gnus-request-accept-article (group &optional gnus-command-method last no-encode) ;; Make sure there's a newline at the end of the article. @@ -564,7 +649,8 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (setq gnus-command-method (gnus-server-to-method gnus-command-method))) (when (and (not gnus-command-method) (stringp group)) - (setq gnus-command-method (gnus-group-name-to-method group))) + (setq gnus-command-method (or (gnus-find-method-for-group group) + (gnus-group-name-to-method group)))) (goto-char (point-max)) (unless (bolp) (insert "\n")) @@ -577,11 +663,16 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (mail-encode-encoded-word-buffer))) (message-encode-message-body))) (let ((gnus-command-method (or gnus-command-method - (gnus-find-method-for-group group)))) - (funcall (gnus-get-function gnus-command-method 'request-accept-article) - (if (stringp group) (gnus-group-real-name group) group) - (cadr gnus-command-method) - last))) + (gnus-find-method-for-group group))) + (result + (funcall + (gnus-get-function gnus-command-method 'request-accept-article) + (if (stringp group) (gnus-group-real-name group) group) + (cadr gnus-command-method) + last))) + (when (and gnus-agent (gnus-agent-method-p gnus-command-method)) + (gnus-agent-regenerate-group group (list (cdr result)))) + result)) (defun gnus-request-replace-article (article group buffer &optional no-encode) (unless no-encode @@ -592,9 +683,12 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer))) (message-encode-message-body))) - (let ((func (car (gnus-group-name-to-method group)))) - (funcall (intern (format "%s-request-replace-article" func)) - article (gnus-group-real-name group) buffer))) + (let* ((func (car (gnus-group-name-to-method group))) + (result (funcall (intern (format "%s-request-replace-article" func)) + article (gnus-group-real-name group) buffer))) + (when (and gnus-agent (gnus-agent-method-p gnus-command-method)) + (gnus-agent-regenerate-group group (list article))) + result)) (defun gnus-request-associate-buffer (group) (let ((gnus-command-method (gnus-find-method-for-group group))) @@ -617,15 +711,25 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (gnus-group-real-name group) (nth 1 gnus-command-method) args))) (defun gnus-request-delete-group (group &optional force) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (funcall (gnus-get-function gnus-command-method 'request-delete-group) - (gnus-group-real-name group) force (nth 1 gnus-command-method)))) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (result + (funcall (gnus-get-function gnus-command-method 'request-delete-group) + (gnus-group-real-name group) force (nth 1 gnus-command-method)))) + (when result + (gnus-cache-delete-group group) + (gnus-agent-delete-group group)) + result)) (defun gnus-request-rename-group (group new-name) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (funcall (gnus-get-function gnus-command-method 'request-rename-group) - (gnus-group-real-name group) - (gnus-group-real-name new-name) (nth 1 gnus-command-method)))) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (result + (funcall (gnus-get-function gnus-command-method 'request-rename-group) + (gnus-group-real-name group) + (gnus-group-real-name new-name) (nth 1 gnus-command-method)))) + (when result + (gnus-cache-rename-group group new-name) + (gnus-agent-rename-group group new-name)) + result)) (defun gnus-close-backends () ;; Send a close request to all backends that support such a request.