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