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