X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-int.el;h=bcfff3479689c6a0c438e870e56192701301c654;hb=400a77ad86dccb7c5c4904162d18aa7716f9470f;hp=6e09e0c45583e63a648fc0a45b4198f337cb4de4;hpb=6d3039252bb175eba53a2028cbf3c0e90112388d;p=gnus diff --git a/lisp/gnus-int.el b/lisp/gnus-int.el index 6e09e0c45..bcfff3479 100644 --- a/lisp/gnus-int.el +++ b/lisp/gnus-int.el @@ -1,27 +1,25 @@ ;;; gnus-int.el --- backend interface functions for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; 2005, 2006, 2007, 2008 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 3, 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -33,6 +31,7 @@ (require 'message) (require 'gnus-range) +(autoload 'gnus-run-hook-with-args "gnus-util") (autoload 'gnus-agent-expire "gnus-agent") (autoload 'gnus-agent-regenerate-group "gnus-agent") (autoload 'gnus-agent-read-servers-validate-native "gnus-agent") @@ -43,6 +42,16 @@ :group 'gnus-start :type 'hook) +(defcustom gnus-after-set-mark-hook nil + "Hook called just after marks are set in a group." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-before-update-mark-hook nil + "Hook called just before marks are updated in a group." + :group 'gnus-start + :type 'hook) + (defcustom gnus-server-unopen-status nil "The default status if the server is not able to open. If the server is covered by Gnus agent, the possible values are @@ -91,16 +100,13 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." ;; Stream is already opened. nil ;; Open NNTP server. - (unless gnus-nntp-service - (setq gnus-nntp-server nil)) (when confirm ;; Read server name with completion. (setq gnus-nntp-server - (completing-read "NNTP server: " - (mapcar 'list - (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) @@ -181,15 +187,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." @@ -227,10 +235,22 @@ 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))) + (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. @@ -246,9 +266,8 @@ If it is down, start it up (again)." (nth 1 gnus-command-method) (nthcdr 2 gnus-command-method)) (error - (gnus-message 1 (format - "Unable to open server %s due to: %s" - server (error-message-string err))) + (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 %s" server) @@ -259,34 +278,31 @@ If it is down, start it up (again)." (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) - ((and - (not gnus-batch-mode) - (gnus-y-or-n-p - (format - "Unable to open server %s, go offline? " - server))) - (setq open-offline t) - 'offline) - (t - ;; This agentized server was still denied - 'denied))) - (t - ;; This unagentized server must be denied - 'denied))) + (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 @@ -321,6 +337,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) @@ -360,16 +392,17 @@ If it is down, start it up (again)." (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) +(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))))) (when (stringp gnus-command-method) (setq gnus-command-method (inline (gnus-server-to-method gnus-command-method)))) - (funcall (inline (gnus-get-function gnus-command-method 'request-group)) + (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." @@ -447,7 +480,8 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." action (funcall (gnus-get-function gnus-command-method 'request-set-mark) (gnus-group-real-name group) action - (nth 1 gnus-command-method))))) + (nth 1 gnus-command-method)) + (gnus-run-hook-with-args gnus-after-set-mark-hook group action)))) (defun gnus-request-update-mark (group article mark) "Allow the back end to change the mark the user tries to put on an article." @@ -455,6 +489,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (if (not (gnus-check-backend-function 'request-update-mark (car gnus-command-method))) mark + (gnus-run-hook-with-args gnus-before-update-mark-hook group article mark) (funcall (gnus-get-function gnus-command-method 'request-update-mark) (gnus-group-real-name group) article mark)))) @@ -467,6 +502,23 @@ If BUFFER, insert the article in that group." article (gnus-group-real-name group) (nth 1 gnus-command-method) buffer))) +(defun gnus-request-thread (id) + "Request the headers in the thread containing the article +specified by Message-ID id." + (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) + (funcall (gnus-get-function gnus-command-method 'request-thread) + id))) + +(defun gnus-warp-to-article () + "Warps from an article in a virtual group to the article in its +real group. Does nothing on a real group." + (interactive) + (let ((gnus-command-method + (gnus-find-method-for-group gnus-newsgroup-name))) + (when (gnus-check-backend-function + 'warp-to-article (car gnus-command-method)) + (funcall (gnus-get-function gnus-command-method 'warp-to-article))))) + (defun gnus-request-head (article group) "Request the head of ARTICLE in GROUP." (let* ((gnus-command-method (gnus-find-method-for-group group)) @@ -492,8 +544,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))) @@ -525,8 +576,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)))))) @@ -539,6 +589,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." @@ -546,18 +604,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)) - (when (or gnus-plugged (not (gnus-agent-method-p 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))))) -(defsubst gnus-request-update-info (info 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-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) @@ -577,6 +645,7 @@ 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)) + (gnus-inhibit-demon t) (not-deleted (funcall (gnus-get-function gnus-command-method 'request-expire-articles) @@ -595,7 +664,8 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (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 move-is-internal))) + (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-unfetch-articles group (list article))) @@ -718,5 +788,4 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (provide 'gnus-int) -;; arch-tag: bbc90087-9b7f-4017-a92c-3abf180ac86d ;;; gnus-int.el ends here