cgit.sxemacs.org Git - gnus/blob - lisp/gnus-int.el

   1 ;;; gnus-int.el --- backend interface functions for Gnus
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'gnus)
  32 (require 'message)
  33 (require 'gnus-range)
  34
  35 (autoload 'gnus-agent-expire "gnus-agent")
  36 (autoload 'gnus-agent-regenerate-group "gnus-agent")
  37 (autoload 'gnus-agent-read-servers-validate-native "gnus-agent")
  38
  39 (defcustom gnus-open-server-hook nil
  40   "Hook called just before opening connection to the news server."
  41   :group 'gnus-start
  42   :type 'hook)
  43
  44 (defcustom gnus-server-unopen-status nil
  45   "The default status if the server is not able to open.
  46 If the server is covered by Gnus agent, the possible values are
  47 `denied', set the server denied; `offline', set the server offline;
  48 nil, ask user.  If the server is not covered by Gnus agent, set the
  49 server denied."
  50   :group 'gnus-start
  51   :type '(choice (const :tag "Ask" nil)
  52                  (const :tag "Deny server" denied)
  53                  (const :tag "Unplug Agent" offline)))
  54
  55 (defvar gnus-internal-registry-spool-current-method nil
  56   "The current method, for the registry.")
  57
  58 ;;;
  59 ;;; Server Communication
  60 ;;;
  61
  62 (defun gnus-start-news-server (&optional confirm)
  63   "Open a method for getting news.
  64 If CONFIRM is non-nil, the user will be asked for an NNTP server."
  65   (let (how)
  66     (if gnus-current-select-method
  67         ;; Stream is already opened.
  68         nil
  69       ;; Open NNTP server.
  70       (unless gnus-nntp-service
  71         (setq gnus-nntp-server nil))
  72       (when confirm
  73         ;; Read server name with completion.
  74         (setq gnus-nntp-server
  75               (completing-read "NNTP server: "
  76                                (mapcar (lambda (server) (list server))
  77                                        (cons (list gnus-nntp-server)
  78                                              gnus-secondary-servers))
  79                                nil nil gnus-nntp-server)))
  80
  81       (when (and gnus-nntp-server
  82                  (stringp gnus-nntp-server)
  83                  (not (string= gnus-nntp-server "")))
  84         (setq gnus-select-method
  85               (cond ((or (string= gnus-nntp-server "")
  86                          (string= gnus-nntp-server "::"))
  87                      (list 'nnspool (system-name)))
  88                     ((string-match "^:" gnus-nntp-server)
  89                      (list 'nnmh gnus-nntp-server
  90                            (list 'nnmh-directory
  91                                  (file-name-as-directory
  92                                   (expand-file-name
  93                                    (substring gnus-nntp-server 1) "~/")))
  94                            (list 'nnmh-get-new-mail nil)))
  95                     (t
  96                      (list 'nntp gnus-nntp-server)))))
  97
  98       (setq how (car gnus-select-method))
  99       (cond
 100        ((eq how 'nnspool)
 101         (require 'nnspool)
 102         (gnus-message 5 "Looking up local news spool..."))
 103        ((eq how 'nnmh)
 104         (require 'nnmh)
 105         (gnus-message 5 "Looking up mh spool..."))
 106        (t
 107         (require 'nntp)))
 108       (setq gnus-current-select-method gnus-select-method)
 109       (gnus-run-hooks 'gnus-open-server-hook)
 110
 111       ;; Partially validate agent covered methods now that the
 112       ;; gnus-select-method is known.
 113
 114       (if gnus-agent
 115           ;; NOTE: This is here for one purpose only.  By validating
 116           ;; the current select method, it converts the old 5.10.3,
 117           ;; and earlier, format to the current format.  That enables
 118           ;; the agent code within gnus-open-server to function
 119           ;; correctly.
 120           (gnus-agent-read-servers-validate-native gnus-select-method))
 121
 122       (or
 123        ;; gnus-open-server-hook might have opened it
 124        (gnus-server-opened gnus-select-method)
 125        (gnus-open-server gnus-select-method)
 126        gnus-batch-mode
 127        (gnus-y-or-n-p
 128         (format
 129          "%s (%s) open error: '%s'.  Continue? "
 130          (car gnus-select-method) (cadr gnus-select-method)
 131          (gnus-status-message gnus-select-method)))
 132        (gnus-error 1 "Couldn't open server on %s"
 133                    (nth 1 gnus-select-method))))))
 134
 135 (defun gnus-check-group (group)
 136   "Try to make sure that the server where GROUP exists is alive."
 137   (let ((method (gnus-find-method-for-group group)))
 138     (or (gnus-server-opened method)
 139         (gnus-open-server method))))
 140
 141 (defun gnus-check-server (&optional method silent)
 142   "Check whether the connection to METHOD is down.
 143 If METHOD is nil, use `gnus-select-method'.
 144 If it is down, start it up (again)."
 145   (let ((method (or method gnus-select-method))
 146         result)
 147     ;; Transform virtual server names into select methods.
 148     (when (stringp method)
 149       (setq method (gnus-server-to-method method)))
 150     (if (gnus-server-opened method)
 151         ;; The stream is already opened.
 152         t
 153       ;; Open the server.
 154       (unless silent
 155         (gnus-message 5 "Opening %s server%s..." (car method)
 156                       (if (equal (nth 1 method) "") ""
 157                         (format " on %s" (nth 1 method)))))
 158       (gnus-run-hooks 'gnus-open-server-hook)
 159       (prog1
 160           (condition-case ()
 161               (setq result (gnus-open-server method))
 162             (quit (message "Quit gnus-check-server")
 163                   nil))
 164         (unless silent
 165           (gnus-message 5 "Opening %s server%s...%s" (car method)
 166                         (if (equal (nth 1 method) "") ""
 167                           (format " on %s" (nth 1 method)))
 168                         (if result "done" "failed")))))))
 169
 170 (defun gnus-get-function (method function &optional noerror)
 171   "Return a function symbol based on METHOD and FUNCTION."
 172   ;; Translate server names into methods.
 173   (unless method
 174     (error "Attempted use of a nil select method"))
 175   (when (stringp method)
 176     (setq method (gnus-server-to-method method)))
 177   ;; Check cache of constructed names.
 178   (let* ((method-sym (if gnus-agent
 179                          (gnus-agent-get-function method)
 180                        (car method)))
 181          (method-fns (get method-sym 'gnus-method-functions))
 182          (func (let ((method-fnlist-elt (assq function method-fns)))
 183                  (unless method-fnlist-elt
 184                    (setq method-fnlist-elt
 185                          (cons function
 186                                (intern (format "%s-%s" method-sym function))))
 187                    (put method-sym 'gnus-method-functions
 188                         (cons method-fnlist-elt method-fns)))
 189                  (cdr method-fnlist-elt))))
 190     ;; Maybe complain if there is no function.
 191     (unless (fboundp func)
 192       (unless (car method)
 193         (error "Trying to require a method that doesn't exist"))
 194       (require (car method))
 195       (when (not (fboundp func))
 196         (if noerror
 197             (setq func nil)
 198           (error "No such function: %s" func))))
 199     func))
 200
 201 \f
 202 ;;;
 203 ;;; Interface functions to the backends.
 204 ;;;
 205
 206 (defun gnus-open-server (gnus-command-method)
 207   "Open a connection to GNUS-COMMAND-METHOD."
 208   (when (stringp gnus-command-method)
 209     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 210   (let ((elem (assoc gnus-command-method gnus-opened-servers)))
 211     ;; If this method was previously denied, we just return nil.
 212     (if (eq (nth 1 elem) 'denied)
 213         (progn
 214           (gnus-message 1 "Denied server")
 215           nil)
 216       ;; Open the server.
 217       (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server))
 218              (result
 219              (condition-case err
 220                  (funcall open-server-function
 221                           (nth 1 gnus-command-method)
 222                           (nthcdr 2 gnus-command-method))
 223                (error
 224                 (gnu