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

   1 ;;; gnus-int.el --- backend interface functions for Gnus
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'gnus)
  31 (require 'message)
  32 (require 'gnus-range)
  33
  34 (autoload 'gnus-run-hook-with-args "gnus-util")
  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 (autoload 'gnus-agent-possibly-synchronize-flags-server "gnus-agent")
  39
  40 (defcustom gnus-open-server-hook nil
  41   "Hook called just before opening connection to the news server."
  42   :group 'gnus-start
  43   :type 'hook)
  44
  45 (defcustom gnus-after-set-mark-hook nil
  46   "Hook called just after marks are set in a group."
  47   :group 'gnus-start
  48   :type 'hook)
  49
  50 (defcustom gnus-before-update-mark-hook nil
  51   "Hook called just before marks are updated in a group."
  52   :group 'gnus-start
  53   :type 'hook)
  54
  55 (defcustom gnus-server-unopen-status nil
  56   "The default status if the server is not able to open.
  57 If the server is covered by Gnus agent, the possible values are
  58 `denied', set the server denied; `offline', set the server offline;
  59 nil, ask user.  If the server is not covered by Gnus agent, set the
  60 server denied."
  61   :version "22.1"
  62   :group 'gnus-start
  63   :type '(choice (const :tag "Ask" nil)
  64                  (const :tag "Deny server" denied)
  65                  (const :tag "Unplug Agent" offline)))
  66
  67 (defvar gnus-internal-registry-spool-current-method nil
  68   "The current method, for the registry.")
  69
  70
  71 (defun gnus-server-opened (gnus-command-method)
  72   "Check whether a connection to GNUS-COMMAND-METHOD has been opened."
  73   (unless (eq (gnus-server-status gnus-command-method)
  74               'denied)
  75     (when (stringp gnus-command-method)
  76       (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
  77     (funcall (inline (gnus-get-function gnus-command-method 'server-opened))
  78              (nth 1 gnus-command-method))))
  79
  80 (defun gnus-status-message (gnus-command-method)
  81   "Return the status message from GNUS-COMMAND-METHOD.
  82 If GNUS-COMMAND-METHOD is a string, it is interpreted as a group
  83 name.  The method this group uses will be queried."
  84   (let ((gnus-command-method
  85          (if (stringp gnus-command-method)
  86              (gnus-find-method-for-group gnus-command-method)
  87            gnus-command-method)))
  88     (funcall (gnus-get-function gnus-command-method 'status-message)
  89              (nth 1 gnus-command-method))))
  90
  91 ;;;
  92 ;;; Server Communication
  93 ;;;
  94
  95 (defun gnus-start-news-server (&optional confirm)
  96   "Open a method for getting news.
  97 If CONFIRM is non-nil, the user will be asked for an NNTP server."
  98   (let (how)
  99     (if gnus-current-select-method
 100         ;; Stream is already opened.
 101         nil
 102       ;; Open NNTP server.
 103       (unless gnus-nntp-service
 104         (setq gnus-nntp-server nil))
 105       (when confirm
 106         ;; Read server name with completion.
 107         (setq gnus-nntp-server
 108               (gnus-completing-read "NNTP server"
 109                                     (cons gnus-nntp-server
 110                                           gnus-secondary-servers)
 111                                     nil gnus-nntp-server)))
 112
 113       (when (and gnus-nntp-server
 114                  (stringp gnus-nntp-server)
 115                  (not (string= gnus-nntp-server "")))
 116         (setq gnus-select-method
 117               (cond ((or (string= gnus-nntp-server "")
 118                          (string= gnus-nntp-server "::"))
 119                      (list 'nnspool (system-name)))
 120                     ((string-match "^:" gnus-nntp-server)
 121                      (list 'nnmh gnus-nntp-server
 122                            (list 'nnmh-directory
 123                                  (file-name-as-directory
 124                                   (expand-file-name
 125                                    (substring gnus-nntp-server 1) "~/")))
 126                            (list 'nnmh-get-new-mail nil)))
 127                     (t
 128                      (list 'nntp gnus-nntp-server)))))
 129
 130       (setq how (car gnus-select-method))
 131       (cond
 132        ((eq how 'nnspool)
 133         (require 'nnspool)
 134         (gnus-message 5 "Looking up local news spool..."))
 135        ((eq how 'nnmh)
 136         (require 'nnmh)
 137         (gnus-message 5 "Looking up mh spool..."))
 138        (t
 139         (require 'nntp)))
 140       (setq gnus-current-select-method gnus-select-method)
 141       (gnus-run-hooks 'gnus-open-server-hook)
 142
 143       ;; Partially validate agent covered methods now that the
 144       ;; gnus-select-method is known.
 145
 146       (if gnus-agent
 147           ;; NOTE: This is here for one purpose only.  By validating
 148           ;; the current select method, it converts the old 5.10.3,
 149           ;; and earlier, format to the current format.  That enables
 150           ;; the agent code within gnus-open-server to function
 151           ;; correctly.
 152           (gnus-agent-read-servers-validate-native gnus-select-method))
 153
 154       (or
 155        ;; gnus-open-server-hook might have opened it
 156        (gnus-server-opened gnus-select-method)
 157        (gnus-open-server gnus-select-method)
 158        gnus-batch-mode
 159        (gnus-y-or-n-p
 160         (format
 161          "%s (%s) open error: '%s'.  Continue? "
 162          (car gnus-select-method) (cadr gnus-select-method)
 163          (gnus-status-message gnus-select-method)))
 164        (gnus-error 1 "Couldn't open server on %s"
 165                    (nth 1 gnus-select-method))))))
 166
 167 (defun gnus-check-group (group)
 168   "Try to make sure that the server where GROUP exists is alive."
 169   (let ((method (gnus-find-method-for-group group)))
 170     (or (gnus-server-opened method)
 171         (gnus-open-server method))))
 172
 173 (defun gnus-check-server (&optional method silent)
 174   "Check whether the connection to METHOD is down.
 175 If METHOD is nil, use `gnus-select-method'.
 176 If it is down, start it up (again)."
 177   (let ((method (or method gnus-select-method))
 178         result)
 179     ;; Transform virtual server names into select methods.
 180     (when (stringp method)
 181       (setq method (gnus-server-to-method method)))
 182     (if (gnus-server-opened method)
 183         ;; The stream is already opened.
 184         t
 185       ;; Open the server.
 186       (unless silent
 187         (gnus-message 5 "Opening %s server%s..." (car method)
 188                       (if (equal (nth 1 method) "") ""
 189                         (format " on %s" (nth 1 method)))))
 190       (gnus-run-hooks 'gnus-open-server-hook)
 191       (prog1
 192           (setq result (gnus-open-server method))
 193         (unless silent
 194           (gnus-message
 195            (if result 5 3)
 196            "Opening %s server%s...%s" (car method)
 197            (if (equal (nth 1 method) "") ""
 198              (format " on %s" (nth 1 method)))
 199            (if result
 200                "done"
 201              (format "failed: %s"
 202                      (nnheader-get-report-string (car method))))))))))
 203
 204 (defun gnus-get-function (method function &optional noerror)
 205   "Return a function symbol based on METHOD and FUNCTION."
 206   ;; Translate server names into methods.
 207   (unless method
 208     (error "Attempted use of a nil select method"))
 209   (when (stringp method)
 210     (setq method (gnus-server-to-method method)))
 211   ;; Check cache of constructed names.
 212   (let* ((method-sym (if gnus-agent
 213                          (inline (gnus-agent-get-function method))
 214                        (car method)))
 215          (method-fns (get method-sym 'gnus-method-functions))
 216          (func (let ((method-fnlist-elt (assq function method-fns)))
 217                  (unless method-fnlist-elt
 218                    (setq method-fnlist-elt
 219                          (cons function
 220                                (intern (format "%s-%s" method-sym function))))
 221                    (put method-sym 'gnus-method-functions
 222                         (cons method-fnlist-elt method-fns)))
 223                  (cdr method-fnlist-elt))))
 224     ;; Maybe complain if there is no function.
 225     (unless (fboundp func)
 226       (unless (car method)
 227         (error "Trying to require a method that doesn't exist"))
 228       (require (car method))
 229       (when (not (fboundp func))
 230         (if noerror
 231             (setq func nil)
 232           (error "No such function: %s" func))))
 233     func))
 234
 235 \f
 236 ;;;
 237 ;;; Interface functions to the backends.
 238 ;;;
 239
 240 (defun gnus-method-denied-p (method)
 241   (eq (nth 1 (assoc method gnus-opened-servers))
 242       'denied))
 243
 244 (defvar gnus-backend-trace t)
 245
 246 (defun gnus-open-server (gnus-command-method)
 247   "Open a connection to GNUS-COMMAND-METHOD."
 248   (when (stringp gnus-command-method)
 249     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 250   (when gnus-backend-trace
 251     (with-current-buffer (get-buffer-create "*gnus trace*")
 252       (buffer-disable-undo)
 253       (goto-char (point-max))
 254       (insert (format-time-string "%H:%M:%S")
 255               (format " %S\n" gnus-command-method))))
 256   (let ((elem (assoc gnus-command-method gnus-opened-servers))
 257         (server (gnus-method-to-server-name gnus-command-method)))
 258     ;; If this method was previously denied, we just return nil.
 259     (if (eq (nth 1 elem) 'denied)
 260         (progn
 261           (gnus-message 1 "Denied server %s" server)
 262           nil)
 263       ;; Open the server.
 264       (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server))
 265              (result
 266              (condition-case err
 267                  (funcall open-server-function
 268                           (nth 1 gnus-command-method)
 269                           (nthcdr 2 gnus-command-method))
 270                (error
 271                 (gnus-message 1 "Unable to open server %s due to: %s"
 272                               server (error-message-string err))
 273                 nil)
 274                (quit
 275                 (gnus-message 1 "Quit trying to open server %s" server)
 276                 nil)))
 277             open-offline)
 278         ;; If this hasn't been opened before, we add it to the list.
 279         (unless elem
 280           (setq elem (list gnus-command-method nil)
 281                 gnus-opened-servers (cons elem gnus-opened-servers)))
 282         ;; Set the status of this server.
 283         (setcar
 284          (cdr elem)
 285          (cond (result
 286                 (if (eq open-server-function #'nnagent-open-server)
 287                     ;; The agent's backend has a "special" status
 288                     'offline
 289                   'ok))
 290                ((and gnus-agent
 291                      (gnus-agent-method-p gnus-command-method))
 292                 (cond
 293                  (gnus-server-unopen-status
 294                   ;; Set the server's status to the unopen
 295                   ;; status.  If that status is offline,
 296                   ;; recurse to open the agent's backend.
 297                   (setq open-offline (eq gnus-server-unopen-status 'offline))
 298                   gnus-server-unopen-status)
 299                  ((not gnus-batch-mode)
 300                   (setq open-offline t)
 301                   'offline)
 302                  (t
 303                   ;; This agentized server was still denied
 304                   'denied)))
 305                (t
 306                 ;; This unagentized server must be denied
 307                 'denied)))
 308
 309         ;; NOTE: I MUST set the server's status to offline before this
 310         ;; recursive call as this status will drive the
 311         ;; gnus-get-function (called above) to return the agent's
 312         ;; backend.
 313         (if open-offline
 314             ;; Recursively open this offline server to perform the
 315             ;; open-server function of the agent's backend.
 316             (let ((gnus-server-unopen-status 'denied))
 317               ;; Bind gnus-server-unopen-status to avoid recursively
 318               ;; prompting with "go offline?".  This is only a concern
 319               ;; when the agent's backend fails to open the server.
 320               (gnus-open-server gnus-command-method))
 321           (when (and (eq (cadr elem) 'ok) gnus-agent
 322                      (gnus-agent-method-p gnus-command-method))
 323             (save-excursion
 324               (gnus-agent-possibly-synchronize-flags-server
 325                gnus-command-method)))
 326           result)))))
 327
 328 (defun gnus-close-server (gnus-command-method)
 329   "Close the connection to GNUS-COMMAND-METHOD."
 330   (when (stringp gnus-command-method)
 331     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 332   (funcall (gnus-get-function gnus-command-method 'close-server)
 333            (nth 1 gnus-command-method)))
 334
 335 (defun gnus-request-list (gnus-command-method)
 336   "Request the active file from GNUS-COMMAND-METHOD."
 337   (when (stringp gnus-command-method)
 338     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 339   (funcall (gnus-get-function gnus-command-method 'request-list)
 340            (nth 1 gnus-command-method)))
 341
 342 (defun gnus-finish-retrieve-group-infos (gnus-command-method infos data)
 343   "Read and update infos from GNUS-COMMAND-METHOD."
 344   (when (stringp gnus-command-method)
 345     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 346   (funcall (gnus-get-function gnus-command-method 'finish-retrieve-group-infos)
 347            (nth 1 gnus-command-method)
 348            infos data))
 349
 350 (defun gnus-retrieve-group-data-early (gnus-command-method infos)
 351   "Start early async retrival of data from GNUS-COMMAND-METHOD."
 352   (when (stringp gnus-command-method)
 353     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 354   (funcall (gnus-get-function gnus-command-method 'retrieve-group-data-early)
 355            (nth 1 gnus-command-method)
 356            infos))
 357
 358 (defun gnus-request-list-newsgroups (gnus-command-method)
 359   "Request the newsgroups file from GNUS-COMMAND-METHOD."
 360   (when (stringp gnus-command-method)
 361     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 362   (funcall (gnus-get-function gnus-command-method 'request-list-newsgroups)
 363            (nth 1 gnus-command-method)))
 364
 365 (defun gnus-request-newgroups (date gnus-command-method)
 366   "Request all new groups since DATE from GNUS-COMMAND-METHOD."
 367   (when (stringp gnus-command-method)
 368     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 369   (let ((func (gnus-get-function gnus-command-method 'request-newgroups t)))
 370     (when func
 371       (funcall func date (nth 1 gnus-command-method)))))
 372
 373 (defun gnus-request-regenerate (gnus-command-method)
 374   "Request a data generation from GNUS-COMMAND-METHOD."
 375   (when (stringp gnus-command-method)
 376     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 377   (funcall (gnus-get-function gnus-command-method 'request-regenerate)
 378            (nth 1 gnus-command-method)))
 379
 380 (defun gnus-request-compact-group (group)
 381   (let* ((method (gnus-find-method-for-group group))
 382          (gnus-command-method method)
 383          (result
 384           (funcall (gnus-get-function gnus-command-method
 385                                       'request-compact-group)
 386                    (gnus-group-real-name group)
 387                    (nth 1 gnus-command-method) t)))
 388     result))
 389
 390 (defun gnus-request-compact (gnus-command-method)
 391   "Request groups compaction  from GNUS-COMMAND-METHOD."
 392   (when (stringp gnus-command-method)
 393     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 394   (funcall (gnus-get-function gnus-command-method 'request-compact)
 395            (nth 1 gnus-command-method)))
 396
 397 (defun gnus-request-group (group &optional dont-check gnus-command-method info)
 398   "Request GROUP.  If DONT-CHECK, no information is required."
 399   (let ((gnus-command-method
 400          (or gnus-command-method (inline (gnus-find-method-for-group group)))))
 401     (when (stringp gnus-command-method)
 402       (setq gnus-command-method
 403             (inline (gnus-server-to-method gnus-command-method))))
 404     (funcall (inline (gnus-get-function gnus-command-method 'request-group))
 405              (gnus-group-real-name group) (nth 1 gnus-command-method)
 406              dont-check
 407              info)))
 408
 409 (defun gnus-list-active-group (group)
 410   "Request active information on GROUP."
 411   (let ((gnus-command-method (gnus-find-method-for-group group))
 412         (func 'list-active-group))
 413     (when (gnus-check-backend-function func group)
 414       (funcall (gnus-get-function gnus-command-method func)
 415                (gnus-group-real-name group) (nth 1 gnus-command-method)))))
 416
 417 (defun gnus-request-group-description (group)
 418   "Request a description of GROUP."
 419   (let ((gnus-command-method (gnus-find-method-for-group group))
 420         (func 'request-group-description))
 421     (when (gnus-check-backend-function func group)
 422       (funcall (gnus-get-function gnus-command-method func)
 423                (gnus-group-real-name group) (nth 1 gnus-command-method)))))
 424
 425 (defun gnus-request-group-articles (group)
 426   "Request a list of existing articles in GROUP."
 427   (let ((gnus-command-method (gnus-find-method-for-group group))
 428         (func 'request-group-articles))
 429     (when (gnus-check-backend-function func group)
 430       (funcall (gnus-get-function gnus-command-method func)
 431                (gnus-group-real-name group) (nth 1 gnus-command-method)))))
 432
 433 (defun gnus-close-group (group)
 434   "Request the GROUP be closed."
 435   (let ((gnus-command-method (inline (gnus-find-method-for-group group))))
 436     (funcall (gnus-get-function gnus-command-method 'close-group)
 437              (gnus-group-real-name group) (nth 1 gnus-command-method))))
 438
 439 (defun gnus-retrieve-headers (articles group &optional fetch-old)
 440   "Request headers for ARTICLES in GROUP.
 441 If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
 442   (let ((gnus-command-method (gnus-find-method-for-group group)))
 443     (cond
 444      ((and gnus-use-cache (numberp (car articles)))
 445       (gnus-cache-retrieve-headers articles group fetch-old))
 446      ((and gnus-agent (gnus-online gnus-command-method)
 447            (gnus-agent-method-p gnus-command-method))
 448       (gnus-agent-retrieve-headers articles group fetch-old))
 449      (t
 450       (funcall (gnus-get-function gnus-command-method 'retrieve-headers)
 451                articles (gnus-group-real-name group)
 452                (nth 1 gnus-command-method) fetch-old)))))
 453
 454 (defun gnus-retrieve-articles (articles group)
 455   "Request ARTICLES in GROUP."
 456   (let ((gnus-command-method (gnus-find-method-for-group group)))
 457     (funcall (gnus-get-function gnus-command-method 'retrieve-articles)
 458              articles (gnus-group-real-name group)
 459              (nth 1 gnus-command-method))))
 460
 461 (defun gnus-retrieve-groups (groups gnus-command-method)
 462   "Request active information on GROUPS from GNUS-COMMAND-METHOD."
 463   (when (stringp gnus-command-method)
 464     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 465   (funcall (gnus-get-function gnus-command-method 'retrieve-groups)
 466            groups (nth 1 gnus-command-method)))
 467
 468 (defun gnus-request-type (group &optional article)
 469   "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
 470   (let ((gnus-command-method (gnus-find-method-for-group group)))
 471     (if (not (gnus-check-backend-function
 472               'request-type (car gnus-command-method)))
 473         'unknown
 474       (funcall (gnus-get-function gnus-command-method 'request-type)
 475                (gnus-group-real-name group) article))))
 476
 477 (defun gnus-request-set-mark (group action)
 478   "Set marks on articles in the back end."
 479   (let ((gnus-command-method (gnus-find-method-for-group group)))
 480     (if (not (gnus-check-backend-function
 481               'request-set-mark (car gnus-command-method)))
 482         action
 483       (funcall (gnus-get-function gnus-command-method 'request-set-mark)
 484                (gnus-group-real-name group) action
 485                (nth 1 gnus-command-method))
 486       (gnus-run-hook-with-args gnus-after-set-mark-hook group action))))
 487
 488 (defun gnus-request-update-mark (group article mark)
 489   "Allow the back end to change the mark the user tries to put on an article."
 490   (let ((gnus-command-method (gnus-find-method-for-group group)))
 491     (if (not (gnus-check-backend-function
 492               'request-update-mark (car gnus-command-method)))
 493         mark
 494       (gnus-run-hook-with-args gnus-before-update-mark-hook group article mark)
 495       (funcall (gnus-get-function gnus-command-method 'request-update-mark)
 496                (gnus-group-real-name group) article mark))))
 497
 498 (defun gnus-request-article (article group &optional buffer)
 499   "Request the ARTICLE in GROUP.
 500 ARTICLE can either be an article number or an article Message-ID.
 501 If BUFFER, insert the article in that group."
 502   (let ((gnus-command-method (gnus-find-method-for-group group)))
 503     (funcall (gnus-get-function gnus-command-method 'request-article)
 504              article (gnus-group-real-name group)
 505              (nth 1 gnus-command-method) buffer)))
 506
 507 (defun gnus-request-thread (id)
 508   "Request the thread containing the article specified by Message-ID id."
 509   (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
 510     (funcall (gnus-get-function gnus-command-method 'request-thread)
 511              id)))
 512
 513 (defun gnus-request-head (article group)
 514   "Request the head of ARTICLE in GROUP."
 515   (let* ((gnus-command-method (gnus-find-method-for-group group))
 516          (head (gnus-get-function gnus-command-method 'request-head t))
 517          res clean-up)
 518     (cond
 519      ;; Check the cache.
 520      ((and gnus-use-cache
 521            (numberp article)
 522            (gnus-cache-request-article article group))
 523       (setq res (cons group article)
 524             clean-up t))
 525      ;; Check the agent cache.
 526      ((gnus-agent-request-article article group)
 527       (setq res (cons group article)
 528             clean-up t))
 529      ;; Use `head' function.
 530      ((fboundp head)
 531       (setq res (funcall head article (gnus-group-real-name group)
 532                          (nth 1 gnus-command-method))))
 533      ;; Use `article' function.
 534      (t
 535       (setq res (gnus-request-article article group)
 536             clean-up t)))
 537     (when clean-up
 538       (with-current-buffer nntp-server-buffer
 539         (goto-char (point-min))
 540         (when (search-forward "\n\n" nil t)
 541           (delete-region (1- (point)) (point-max)))
 542         (nnheader-fold-continuation-lines)))
 543     res))
 544
 545 (defun gnus-request-body (article group)
 546   "Request the body of ARTICLE in GROUP."
 547   (let* ((gnus-command-method (gnus-find-method-for-group group))
 548          (head (gnus-get-function gnus-command-method 'request-body t))
 549          res clean-up)
 550     (cond
 551      ;; Check the cache.
 552      ((and gnus-use-cache
 553            (numberp article)
 554            (gnus-cache-request-article article group))
 555       (setq res (cons group article)
 556             clean-up t))
 557      ;; Check the agent cache.
 558      ((gnus-agent-request-article article group)
 559       (setq res (cons group article)
 560             clean-up t))
 561      ;; Use `head' function.
 562      ((fboundp head)
 563       (setq res (funcall head article (gnus-group-real-name group)
 564                          (nth 1 gnus-command-method))))
 565      ;; Use `article' function.
 566      (t
 567       (setq res (gnus-request-article article group)
 568             clean-up t)))
 569     (when clean-up
 570       (with-current-buffer nntp-server-buffer
 571         (goto-char (point-min))
 572         (when (search-forward "\n\n" nil t)
 573           (delete-region (point-min) (1- (point))))))
 574     res))
 575
 576 (defun gnus-request-post (gnus-command-method)
 577   "Post the current buffer using GNUS-COMMAND-METHOD."
 578   (when (stringp gnus-command-method)
 579     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 580   (funcall (gnus-get-function gnus-command-method 'request-post)
 581            (nth 1 gnus-command-method)))
 582
 583 (defun gnus-request-expunge-group (group gnus-command-method)
 584   "Expunge GROUP, which is removing articles that have been marked as deleted."
 585   (when (stringp gnus-command-method)
 586     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 587   (funcall (gnus-get-function gnus-command-method 'request-expunge-group)
 588            (gnus-group-real-name group)
 589            (nth 1 gnus-command-method)))
 590
 591 (defun gnus-request-scan (group gnus-command-method)
 592   "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD.
 593 If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
 594   (let ((gnus-command-method
 595          (if group (gnus-find-method-for-group group) gnus-command-method))
 596         (gnus-inhibit-demon t)
 597         (mail-source-plugged gnus-plugged))
 598     (when (or gnus-plugged
 599               (not (gnus-agent-method-p gnus-command-method)))
 600       (setq gnus-internal-registry-spool-current-method gnus-command-method)
 601       (funcall (gnus-get-function gnus-command-method 'request-scan)
 602                (and group (gnus-group-real-name group))
 603                (nth 1 gnus-command-method)))))
 604
 605 (defun gnus-request-update-info (info gnus-command-method)
 606   (when (gnus-check-backend-function
 607          'request-update-info (car gnus-command-method))
 608     (when (stringp gnus-command-method)
 609       (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 610     (funcall (gnus-get-function gnus-command-method 'request-update-info)
 611              (gnus-group-real-name (gnus-info-group info)) info
 612              (nth 1 gnus-command-method))))
 613
 614 (defsubst gnus-request-marks (info gnus-command-method)
 615   "Request that GNUS-COMMAND-METHOD update INFO."
 616   (when (stringp gnus-command-method)
 617     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 618   (when (gnus-check-backend-function
 619          'request-marks (car gnus-command-method))
 620     (let ((group (gnus-info-group info)))
 621       (and (funcall (gnus-get-function gnus-command-method
 622                                        'request-update-info)
 623                     (gnus-group-real-name group)
 624                     info (nth 1 gnus-command-method))
 625            ;; If the minimum article number is greater than 1, then all
 626            ;; smaller article numbers are known not to exist; we'll
 627            ;; artificially add those to the 'read range.
 628            (let* ((active (gnus-active group))
 629                   (min (car active)))
 630              (when (> min 1)
 631                (let* ((range (if (= min 2) 1 (cons 1 (1- min))))
 632                       (read (gnus-info-read info))
 633                       (new-read (gnus-range-add read (list range))))
 634                  (gnus-info-set-read info new-read)))
 635              info)))))
 636
 637 (defun gnus-request-expire-articles (articles group &optional force)
 638   (let* ((gnus-command-method (gnus-find-method-for-group group))
 639          (gnus-inhibit-demon t)
 640          (not-deleted
 641           (funcall
 642            (gnus-get-function gnus-command-method 'request-expire-articles)
 643            articles (gnus-group-real-name group) (nth 1 gnus-command-method)
 644            force)))
 645     (when (and gnus-agent
 646                (gnus-agent-method-p gnus-command-method))
 647       (let ((expired-articles (gnus-sorted-difference articles not-deleted)))
 648         (when expired-articles
 649           (gnus-agent-expire expired-articles group 'force))))
 650     not-deleted))
 651
 652 (defun gnus-request-move-article (article group server accept-function
 653                                           &optional last move-is-internal)
 654   (let* ((gnus-command-method (gnus-find-method-for-group group))
 655          (result (funcall (gnus-get-function gnus-command-method
 656                                              'request-move-article)
 657                           article (gnus-group-real-name group)
 658                           (nth 1 gnus-command-method) accept-function last move-is-internal)))
 659     (when (and result gnus-agent
 660                (gnus-agent-method-p gnus-command-method))
 661       (gnus-agent-unfetch-articles group (list article)))
 662     result))
 663
 664 (defun gnus-request-accept-article (group &optional gnus-command-method last
 665                                           no-encode)
 666   ;; Make sure there's a newline at the end of the article.
 667   (when (stringp gnus-command-method)
 668     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 669   (when (and (not gnus-command-method)
 670              (stringp group))
 671     (setq gnus-command-method (or (gnus-find-method-for-group group)
 672                                   (gnus-group-name-to-method group))))
 673   (goto-char (point-max))
 674   (unless (bolp)
 675     (insert "\n"))
 676   (unless no-encode
 677     (let ((message-options message-options))
 678       (message-options-set-recipient)
 679       (save-restriction
 680         (message-narrow-to-head)
 681         (let ((mail-parse-charset message-default-charset))
 682           (mail-encode-encoded-word-buffer)))
 683       (message-encode-message-body)))
 684   (let ((gnus-command-method (or gnus-command-method
 685                                  (gnus-find-method-for-group group)))
 686         (result
 687          (funcall
 688           (gnus-get-function gnus-command-method 'request-accept-article)
 689           (if (stringp group) (gnus-group-real-name group) group)
 690           (cadr gnus-command-method)
 691           last)))
 692     (when (and gnus-agent (gnus-agent-method-p gnus-command-method))
 693       (gnus-agent-regenerate-group group (list (cdr result))))
 694     result))
 695
 696 (defun gnus-request-replace-article (article group buffer &optional no-encode)
 697   (unless no-encode
 698     (let ((message-options message-options))
 699       (message-options-set-recipient)
 700       (save-restriction
 701         (message-narrow-to-head)
 702         (let ((mail-parse-charset message-default-charset))
 703           (mail-encode-encoded-word-buffer)))
 704       (message-encode-message-body)))
 705   (let* ((func (car (gnus-group-name-to-method group)))
 706          (result (funcall (intern (format "%s-request-replace-article" func))
 707                           article (gnus-group-real-name group) buffer)))
 708     (when (and gnus-agent (gnus-agent-method-p gnus-command-method))
 709       (gnus-agent-regenerate-group group (list article)))
 710     result))
 711
 712 (defun gnus-request-associate-buffer (group)
 713   (let ((gnus-command-method (gnus-find-method-for-group group)))
 714     (funcall (gnus-get-function gnus-command-method 'request-associate-buffer)
 715              (gnus-group-real-name group))))
 716
 717 (defun gnus-request-restore-buffer (article group)
 718   "Request a new buffer restored to the state of ARTICLE."
 719   (let ((gnus-command-method (gnus-find-method-for-group group)))
 720     (funcall (gnus-get-function gnus-command-method 'request-restore-buffer)
 721              article (gnus-group-real-name group)
 722              (nth 1 gnus-command-method))))
 723
 724 (defun gnus-request-create-group (group &optional gnus-command-method args)
 725   (when (stringp gnus-command-method)
 726     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 727   (let ((gnus-command-method
 728          (or gnus-command-method (gnus-find-method-for-group group))))
 729     (funcall (gnus-get-function gnus-command-method 'request-create-group)
 730              (gnus-group-real-name group) (nth 1 gnus-command-method) args)))
 731
 732 (defun gnus-request-delete-group (group &optional force)
 733   (let* ((gnus-command-method (gnus-find-method-for-group group))
 734          (result
 735           (funcall (gnus-get-function gnus-command-method 'request-delete-group)
 736                    (gnus-group-real-name group) force (nth 1 gnus-command-method))))
 737     (when result
 738       (gnus-cache-delete-group group)
 739       (gnus-agent-delete-group group))
 740     result))
 741
 742 (defun gnus-request-rename-group (group new-name)
 743   (let* ((gnus-command-method (gnus-find-method-for-group group))
 744          (result
 745           (funcall (gnus-get-function gnus-command-method 'request-rename-group)
 746                    (gnus-group-real-name group)
 747                    (gnus-group-real-name new-name) (nth 1 gnus-command-method))))
 748     (when result
 749       (gnus-cache-rename-group group new-name)
 750       (gnus-agent-rename-group group new-name))
 751     result))
 752
 753 (defun gnus-close-backends ()
 754   ;; Send a close request to all backends that support such a request.
 755   (let ((methods gnus-valid-select-methods)
 756         (gnus-inhibit-demon t)
 757         func gnus-command-method)
 758     (while (setq gnus-command-method (pop methods))
 759       (when (fboundp (setq func (intern
 760                                  (concat (car gnus-command-method)
 761                                          "-request-close"))))
 762         (funcall func)))))
 763
 764 (defun gnus-asynchronous-p (gnus-command-method)
 765   (let ((func (gnus-get-function gnus-command-method 'asynchronous-p t)))
 766     (when (fboundp func)
 767       (funcall func))))
 768
 769 (defun gnus-remove-denial (gnus-command-method)
 770   (when (stringp gnus-command-method)
 771     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 772   (let* ((elem (assoc gnus-command-method gnus-opened-servers))
 773          (status (cadr elem)))
 774     ;; If this hasn't been opened before, we add it to the list.
 775     (when (eq status 'denied)
 776       ;; Set the status of this server.
 777       (setcar (cdr elem) 'closed))))
 778
 779 (provide 'gnus-int)
 780
 781 ;;; gnus-int.el ends here