1 ;;; gnus-int.el --- backend interface functions for Gnus
2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
3 ;; Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
9 ;; This file is part of GNU Emacs.
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)
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.
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.
30 (eval-when-compile (require 'cl))
34 (defcustom gnus-open-server-hook nil
35 "Hook called just before opening connection to the news server."
39 (defvar gnus-server-unopen-status nil
40 "The default status if the server is not able to open.
41 If the server is covered by Gnus agent, the possible values are
42 `denied', set the server denied; `offline', set the server offline;
43 `nil', ask user. If the server is not covered by Gnus agent, set the
47 ;;; Server Communication
50 (defun gnus-start-news-server (&optional confirm)
51 "Open a method for getting news.
52 If CONFIRM is non-nil, the user will be asked for an NNTP server."
54 (if gnus-current-select-method
55 ;; Stream is already opened.
58 (unless gnus-nntp-service
59 (setq gnus-nntp-server nil))
61 ;; Read server name with completion.
62 (setq gnus-nntp-server
63 (completing-read "NNTP server: "
64 (mapcar (lambda (server) (list server))
65 (cons (list gnus-nntp-server)
66 gnus-secondary-servers))
67 nil nil gnus-nntp-server)))
69 (when (and gnus-nntp-server
70 (stringp gnus-nntp-server)
71 (not (string= gnus-nntp-server "")))
72 (setq gnus-select-method
73 (cond ((or (string= gnus-nntp-server "")
74 (string= gnus-nntp-server "::"))
75 (list 'nnspool (system-name)))
76 ((string-match "^:" gnus-nntp-server)
77 (list 'nnmh gnus-nntp-server
79 (file-name-as-directory
81 (substring gnus-nntp-server 1) "~/")))
82 (list 'nnmh-get-new-mail nil)))
84 (list 'nntp gnus-nntp-server)))))
86 (setq how (car gnus-select-method))
90 (gnus-message 5 "Looking up local news spool..."))
93 (gnus-message 5 "Looking up mh spool..."))
96 (setq gnus-current-select-method gnus-select-method)
97 (gnus-run-hooks 'gnus-open-server-hook)
99 ;; gnus-open-server-hook might have opened it
100 (gnus-server-opened gnus-select-method)
101 (gnus-open-server gnus-select-method)
105 "%s (%s) open error: '%s'. Continue? "
106 (car gnus-select-method) (cadr gnus-select-method)
107 (gnus-status-message gnus-select-method)))
108 (gnus-error 1 "Couldn't open server on %s"
109 (nth 1 gnus-select-method))))))
111 (defun gnus-check-group (group)
112 "Try to make sure that the server where GROUP exists is alive."
113 (let ((method (gnus-find-method-for-group group)))
114 (or (gnus-server-opened method)
115 (gnus-open-server method))))
117 (defun gnus-check-server (&optional method silent)
118 "Check whether the connection to METHOD is down.
119 If METHOD is nil, use `gnus-select-method'.
120 If it is down, start it up (again)."
121 (let ((method (or method gnus-select-method))
123 ;; Transform virtual server names into select methods.
124 (when (stringp method)
125 (setq method (gnus-server-to-method method)))
126 (if (gnus-server-opened method)
127 ;; The stream is already opened.
131 (gnus-message 5 "Opening %s server%s..." (car method)
132 (if (equal (nth 1 method) "") ""
133 (format " on %s" (nth 1 method)))))
134 (gnus-run-hooks 'gnus-open-server-hook)
137 (setq result (gnus-open-server method))
138 (quit (message "Quit gnus-check-server")
141 (gnus-message 5 "Opening %s server%s...%s" (car method)
142 (if (equal (nth 1 method) "") ""
143 (format " on %s" (nth 1 method)))
144 (if result "done" "failed")))))))
146 (defun gnus-get-function (method function &optional noerror)
147 "Return a function symbol based on METHOD and FUNCTION."
148 ;; Translate server names into methods.
150 (error "Attempted use of a nil select method"))
151 (when (stringp method)
152 (setq method (gnus-server-to-method method)))
153 ;; Check cache of constructed names.
154 (let* ((method-sym (if gnus-agent
155 (gnus-agent-get-function method)
157 (method-fns (get method-sym 'gnus-method-functions))
158 (func (let ((method-fnlist-elt (assq function method-fns)))
159 (unless method-fnlist-elt
160 (setq method-fnlist-elt
162 (intern (format "%s-%s" method-sym function))))
163 (put method-sym 'gnus-method-functions
164 (cons method-fnlist-elt method-fns)))
165 (cdr method-fnlist-elt))))
166 ;; Maybe complain if there is no function.
167 (unless (fboundp func)
169 (error "Trying to require a method that doesn't exist"))
170 (require (car method))
171 (when (not (fboundp func))
174 (error "No such function: %s" func))))
179 ;;; Interface functions to the backends.
182 (defun gnus-open-server (gnus-command-method)
183 "Open a connection to GNUS-COMMAND-METHOD."
184 (when (stringp gnus-command-method)
185 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
186 (let ((elem (assoc gnus-command-method gnus-opened-servers)))
187 ;; If this method was previously denied, we just return nil.
188 (if (eq (nth 1 elem) 'denied)
190 (gnus-message 1 "Denied server")
195 (funcall (gnus-get-function gnus-command-method 'open-server)
196 (nth 1 gnus-command-method)
197 (nthcdr 2 gnus-command-method))
199 (message "Quit trying to open server")
201 ;; If this hasn't been opened before, we add it to the list.
203 (setq elem (list gnus-command-method nil)
204 gnus-opened-servers (cons elem gnus-opened-servers)))
205 ;; Set the status of this server.
208 (if (eq (cadr elem) 'offline)
212 (not (eq (cadr elem) 'offline))
213 (gnus-agent-method-p gnus-command-method))
214 (or gnus-server-unopen-status
216 (format "Unable to open %s:%s, go offline? "
217 (car gnus-command-method)
218 (cadr gnus-command-method)))
222 ;; Return the result from the "open" call.
223 (or (eq (cadr elem) 'offline)
226 (defun gnus-close-server (gnus-command-method)
227 "Close the connection to GNUS-COMMAND-METHOD."
228 (when (stringp gnus-command-method)
229 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
230 (funcall (gnus-get-function gnus-command-method 'close-server)
231 (nth 1 gnus-command-method)))
233 (defun gnus-request-list (gnus-command-method)
234 "Request the active file from GNUS-COMMAND-METHOD."
235 (when (stringp gnus-command-method)
236 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
237 (funcall (gnus-get-function gnus-command-method 'request-list)
238 (nth 1 gnus-command-method)))
240 (defun gnus-request-list-newsgroups (gnus-command-method)
241 "Request the newsgroups file from GNUS-COMMAND-METHOD."
242 (when (stringp gnus-command-method)
243 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
244 (funcall (gnus-get-function gnus-command-method 'request-list-newsgroups)
245 (nth 1 gnus-command-method)))
247 (defun gnus-request-newgroups (date gnus-command-method)
248 "Request all new groups since DATE from GNUS-COMMAND-METHOD."
249 (when (stringp gnus-command-method)
250 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
251 (let ((func (gnus-get-function gnus-command-method 'request-newgroups t)))
253 (funcall func date (nth 1 gnus-command-method)))))
255 (defun gnus-server-opened (gnus-command-method)
256 "Check whether a connection to GNUS-COMMAND-METHOD has been opened."
257 (unless (eq (gnus-server-status gnus-command-method)
259 (when (stringp gnus-command-method)
260 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
261 (funcall (inline (gnus-get-function gnus-command-method 'server-opened))
262 (nth 1 gnus-command-method))))
264 (defun gnus-status-message (gnus-command-method)
265 "Return the status message from GNUS-COMMAND-METHOD.
266 If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method
267 this group uses will be queried."
268 (let ((gnus-command-method
269 (if (stringp gnus-command-method)
270 (gnus-find-method-for-group gnus-command-method)
271 gnus-command-method)))
272 (funcall (gnus-get-function gnus-command-method 'status-message)
273 (nth 1 gnus-command-method))))
275 (defun gnus-request-regenerate (gnus-command-method)
276 "Request a data generation from GNUS-COMMAND-METHOD."
277 (when (stringp gnus-command-method)
278 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
279 (funcall (gnus-get-function gnus-command-method 'request-regenerate)
280 (nth 1 gnus-command-method)))
282 (defun gnus-request-group (group &optional dont-check gnus-command-method)
283 "Request GROUP. If DONT-CHECK, no information is required."
284 (let ((gnus-command-method
285 (or gnus-command-method (inline (gnus-find-method-for-group group)))))
286 (when (stringp gnus-command-method)
287 (setq gnus-command-method
288 (inline (gnus-server-to-method gnus-command-method))))
289 (funcall (inline (gnus-get-function gnus-command-method 'request-group))
290 (gnus-group-real-name group) (nth 1 gnus-command-method)
293 (defun gnus-list-active-group (group)
294 "Request active information on GROUP."
295 (let ((gnus-command-method (gnus-find-method-for-group group))
296 (func 'list-active-group))
297 (when (gnus-check-backend-function func group)
298 (funcall (gnus-get-function gnus-command-method func)
299 (gnus-group-real-name group) (nth 1 gnus-command-method)))))
301 (defun gnus-request-group-description (group)
302 "Request a description of GROUP."
303 (let ((gnus-command-method (gnus-find-method-for-group group))
304 (func 'request-group-description))
305 (when (gnus-check-backend-function func group)
306 (funcall (gnus-get-function gnus-command-method func)
307 (gnus-group-real-name group) (nth 1 gnus-command-method)))))
309 (defun gnus-request-group-articles (group)
310 "Request a list of existing articles in GROUP."
311 (let ((gnus-command-method (gnus-find-method-for-group group))
312 (func 'request-group-articles))
313 (when (gnus-check-backend-function func group)
314 (funcall (gnus-get-function gnus-command-method func)
315 (gnus-group-real-name group) (nth 1 gnus-command-method)))))
317 (defun gnus-close-group (group)
318 "Request the GROUP be closed."
319 (let ((gnus-command-method (inline (gnus-find-method-for-group group))))
320 (funcall (gnus-get-function gnus-command-method 'close-group)
321 (gnus-group-real-name group) (nth 1 gnus-command-method))))
323 (defun gnus-retrieve-headers (articles group &optional fetch-old)
324 "Request headers for ARTICLES in GROUP.
325 If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
326 (let ((gnus-command-method (gnus-find-method-for-group group)))
328 ((and gnus-use-cache (numberp (car articles)))
329 (gnus-cache-retrieve-headers articles group fetch-old))
330 ((and gnus-agent gnus-agent-cache (gnus-online gnus-command-method)
331 (gnus-agent-method-p gnus-command-method))
332 (gnus-agent-retrieve-headers articles group fetch-old))
334 (funcall (gnus-get-function gnus-command-method 'retrieve-headers)
335 articles (gnus-group-real-name group)
336 (nth 1 gnus-command-method) fetch-old)))))
338 (defun gnus-retrieve-articles (articles group)
339 "Request ARTICLES in GROUP."
340 (let ((gnus-command-method (gnus-find-method-for-group group)))
341 (funcall (gnus-get-function gnus-command-method 'retrieve-articles)
342 articles (gnus-group-real-name group)
343 (nth 1 gnus-command-method))))
345 (defun gnus-retrieve-groups (groups gnus-command-method)
346 "Request active information on GROUPS from GNUS-COMMAND-METHOD."
347 (when (stringp gnus-command-method)
348 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
349 (funcall (gnus-get-function gnus-command-method 'retrieve-groups)
350 groups (nth 1 gnus-command-method)))
352 (defun gnus-request-type (group &optional article)
353 "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
354 (let ((gnus-command-method (gnus-find-method-for-group group)))
355 (if (not (gnus-check-backend-function
356 'request-type (car gnus-command-method)))
358 (funcall (gnus-get-function gnus-command-method 'request-type)
359 (gnus-group-real-name group) article))))
361 (defun gnus-request-set-mark (group action)
362 "Set marks on articles in the backend."
363 (let ((gnus-command-method (gnus-find-method-for-group group)))
364 (if (not (gnus-check-backend-function
365 'request-set-mark (car gnus-command-method)))
367 (funcall (gnus-get-function gnus-command-method 'request-set-mark)
368 (gnus-group-real-name group) action
369 (nth 1 gnus-command-method)))))
371 (defun gnus-request-update-mark (group article mark)
372 "Allow the backend to change the mark the user tries to put on an article."
373 (let ((gnus-command-method (gnus-find-method-for-group group)))
374 (if (not (gnus-check-backend-function
375 'request-update-mark (car gnus-command-method)))
377 (funcall (gnus-get-function gnus-command-method 'request-update-mark)
378 (gnus-group-real-name group) article mark))))
380 (defun gnus-request-article (article group &optional buffer)
381 "Request the ARTICLE in GROUP.
382 ARTICLE can either be an article number or an article Message-ID.
383 If BUFFER, insert the article in that group."
384 (let ((gnus-command-method (gnus-find-method-for-group group)))
385 (funcall (gnus-get-function gnus-command-method 'request-article)
386 article (gnus-group-real-name group)
387 (nth 1 gnus-command-method) buffer)))
389 (defun gnus-request-head (article group)
390 "Request the head of ARTICLE in GROUP."
391 (let* ((gnus-command-method (gnus-find-method-for-group group))
392 (head (gnus-get-function gnus-command-method 'request-head t))
398 (gnus-cache-request-article article group))
399 (setq res (cons group article)
401 ((and gnus-agent gnus-agent-cache gnus-plugged
403 (gnus-agent-request-article article group))
404 (setq res (cons group article)
406 ;; Use `head' function.
408 (setq res (funcall head article (gnus-group-real-name group)
409 (nth 1 gnus-command-method))))
410 ;; Use `article' function.
412 (setq res (gnus-request-article article group)
416 (set-buffer nntp-server-buffer)
417 (goto-char (point-min))
418 (when (search-forward "\n\n" nil t)
419 (delete-region (1- (point)) (point-max)))
420 (nnheader-fold-continuation-lines)))
423 (defun gnus-request-body (article group)
424 "Request the body of ARTICLE in GROUP."
425 (let* ((gnus-command-method (gnus-find-method-for-group group))
426 (head (gnus-get-function gnus-command-method 'request-body t))
432 (gnus-cache-request-article article group))
433 (setq res (cons group article)
435 ;; Check the agent cache.
436 ((and gnus-agent gnus-agent-cache gnus-plugged
438 (gnus-agent-request-article article group))
439 (setq res (cons group article)
441 ;; Use `head' function.
443 (setq res (funcall head article (gnus-group-real-name group)
444 (nth 1 gnus-command-method))))
445 ;; Use `article' function.
447 (setq res (gnus-request-article article group)
451 (set-buffer nntp-server-buffer)
452 (goto-char (point-min))
453 (when (search-forward "\n\n" nil t)
454 (delete-region (point-min) (1- (point))))))
457 (defun gnus-request-post (gnus-command-method)
458 "Post the current buffer using GNUS-COMMAND-METHOD."
459 (when (stringp gnus-command-method)
460 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
461 (funcall (gnus-get-function gnus-command-method 'request-post)
462 (nth 1 gnus-command-method)))
464 (defun gnus-request-scan (group gnus-command-method)
465 "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD.
466 If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
467 (let ((gnus-command-method
468 (if group (gnus-find-method-for-group group) gnus-command-method))
469 (gnus-inhibit-demon t)
470 (mail-source-plugged gnus-plugged))
471 (if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method)))
472 (funcall (gnus-get-function gnus-command-method 'request-scan)
473 (and group (gnus-group-real-name group))
474 (nth 1 gnus-command-method)))))
476 (defsubst gnus-request-update-info (info gnus-command-method)
477 "Request that GNUS-COMMAND-METHOD update INFO."
478 (when (stringp gnus-command-method)
479 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
480 (when (gnus-check-backend-function
481 'request-update-info (car gnus-command-method))
482 (funcall (gnus-get-function gnus-command-method 'request-update-info)
483 (gnus-group-real-name (gnus-info-group info))
484 info (nth 1 gnus-command-method))))
486 (defun gnus-request-expire-articles (articles group &optional force)
487 (let ((gnus-command-method (gnus-find-method-for-group group)))
488 (funcall (gnus-get-function gnus-command-method 'request-expire-articles)
489 articles (gnus-group-real-name group) (nth 1 gnus-command-method)
492 (defun gnus-request-move-article
493 (article group server accept-function &optional last)
494 (let ((gnus-command-method (gnus-find-method-for-group group)))
495 (funcall (gnus-get-function gnus-command-method 'request-move-article)
496 article (gnus-group-real-name group)
497 (nth 1 gnus-command-method) accept-function last)))
499 (defun gnus-request-accept-article (group &optional gnus-command-method last
501 ;; Make sure there's a newline at the end of the article.
502 (when (stringp gnus-command-method)
503 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
504 (when (and (not gnus-command-method)
506 (setq gnus-command-method (gnus-group-name-to-method group)))
507 (goto-char (point-max))
510 (let ((func (car (or gnus-command-method
511 (gnus-find-method-for-group group)))))
512 (funcall (intern (format "%s-request-accept-article" func))
513 (if (stringp group) (gnus-group-real-name group) group)
514 (cadr gnus-command-method)
517 (defun gnus-request-replace-article (article group buffer &optional no-encode)
518 (let ((func (car (gnus-group-name-to-method group))))
519 (funcall (intern (format "%s-request-replace-article" func))
520 article (gnus-group-real-name group) buffer)))
522 (defun gnus-request-associate-buffer (group)
523 (let ((gnus-command-method (gnus-find-method-for-group group)))
524 (funcall (gnus-get-function gnus-command-method 'request-associate-buffer)
525 (gnus-group-real-name group))))
527 (defun gnus-request-restore-buffer (article group)
528 "Request a new buffer restored to the state of ARTICLE."
529 (let ((gnus-command-method (gnus-find-method-for-group group)))
530 (funcall (gnus-get-function gnus-command-method 'request-restore-buffer)
531 article (gnus-group-real-name group)
532 (nth 1 gnus-command-method))))
534 (defun gnus-request-create-group (group &optional gnus-command-method args)
535 (when (stringp gnus-command-method)
536 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
537 (let ((gnus-command-method
538 (or gnus-command-method (gnus-find-method-for-group group))))
539 (funcall (gnus-get-function gnus-command-method 'request-create-group)
540 (gnus-group-real-name group) (nth 1 gnus-command-method) args)))
542 (defun gnus-request-delete-group (group &optional force)
543 (let ((gnus-command-method (gnus-find-method-for-group group)))
544 (funcall (gnus-get-function gnus-command-method 'request-delete-group)
545 (gnus-group-real-name group) force (nth 1 gnus-command-method))))
547 (defun gnus-request-rename-group (group new-name)
548 (let ((gnus-command-method (gnus-find-method-for-group group)))
549 (funcall (gnus-get-function gnus-command-method 'request-rename-group)
550 (gnus-group-real-name group)
551 (gnus-group-real-name new-name) (nth 1 gnus-command-method))))
553 (defun gnus-close-backends ()
554 ;; Send a close request to all backends that support such a request.
555 (let ((methods gnus-valid-select-methods)
556 (gnus-inhibit-demon t)
557 func gnus-command-method)
558 (while (setq gnus-command-method (pop methods))
559 (when (fboundp (setq func (intern
560 (concat (car gnus-command-method)
564 (defun gnus-asynchronous-p (gnus-command-method)
565 (let ((func (gnus-get-function gnus-command-method 'asynchronous-p t)))
569 (defun gnus-remove-denial (gnus-command-method)
570 (when (stringp gnus-command-method)
571 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
572 (let* ((elem (assoc gnus-command-method gnus-opened-servers))
573 (status (cadr elem)))
574 ;; If this hasn't been opened before, we add it to the list.
575 (when (eq status 'denied)
576 ;; Set the status of this server.
577 (setcar (cdr elem) 'closed))))
581 ;;; gnus-int.el ends here