|
16
|
1 ;;; gnus-int.el --- backend interface functions for Gnus
|
|
|
2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
|
|
|
5 ;; Keywords: news
|
|
|
6
|
|
|
7 ;; This file is part of GNU Emacs.
|
|
|
8
|
|
|
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
10 ;; it under the terms of the GNU General Public License as published by
|
|
|
11 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
12 ;; any later version.
|
|
|
13
|
|
|
14 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
17 ;; GNU General Public License for more details.
|
|
|
18
|
|
|
19 ;; You should have received a copy of the GNU General Public License
|
|
|
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
22 ;; Boston, MA 02111-1307, USA.
|
|
|
23
|
|
|
24 ;;; Commentary:
|
|
|
25
|
|
|
26 ;;; Code:
|
|
|
27
|
|
|
28 (require 'gnus)
|
|
|
29
|
|
|
30 (defcustom gnus-open-server-hook nil
|
|
|
31 "Hook called just before opening connection to the news server."
|
|
|
32 :group 'gnus-start
|
|
|
33 :type 'hook)
|
|
|
34
|
|
|
35 ;;;
|
|
|
36 ;;; Server Communication
|
|
|
37 ;;;
|
|
|
38
|
|
|
39 (defun gnus-start-news-server (&optional confirm)
|
|
|
40 "Open a method for getting news.
|
|
|
41 If CONFIRM is non-nil, the user will be asked for an NNTP server."
|
|
|
42 (let (how)
|
|
|
43 (if gnus-current-select-method
|
|
|
44 ;; Stream is already opened.
|
|
|
45 nil
|
|
|
46 ;; Open NNTP server.
|
|
|
47 (unless gnus-nntp-service
|
|
|
48 (setq gnus-nntp-server nil))
|
|
|
49 (when confirm
|
|
|
50 ;; Read server name with completion.
|
|
|
51 (setq gnus-nntp-server
|
|
|
52 (completing-read "NNTP server: "
|
|
|
53 (mapcar (lambda (server) (list server))
|
|
|
54 (cons (list gnus-nntp-server)
|
|
|
55 gnus-secondary-servers))
|
|
|
56 nil nil gnus-nntp-server)))
|
|
|
57
|
|
|
58 (when (and gnus-nntp-server
|
|
|
59 (stringp gnus-nntp-server)
|
|
|
60 (not (string= gnus-nntp-server "")))
|
|
|
61 (setq gnus-select-method
|
|
|
62 (cond ((or (string= gnus-nntp-server "")
|
|
|
63 (string= gnus-nntp-server "::"))
|
|
|
64 (list 'nnspool (system-name)))
|
|
|
65 ((string-match "^:" gnus-nntp-server)
|
|
|
66 (list 'nnmh gnus-nntp-server
|
|
|
67 (list 'nnmh-directory
|
|
|
68 (file-name-as-directory
|
|
|
69 (expand-file-name
|
|
|
70 (concat "~/" (substring
|
|
|
71 gnus-nntp-server 1)))))
|
|
|
72 (list 'nnmh-get-new-mail nil)))
|
|
|
73 (t
|
|
|
74 (list 'nntp gnus-nntp-server)))))
|
|
|
75
|
|
|
76 (setq how (car gnus-select-method))
|
|
|
77 (cond
|
|
|
78 ((eq how 'nnspool)
|
|
|
79 (require 'nnspool)
|
|
|
80 (gnus-message 5 "Looking up local news spool..."))
|
|
|
81 ((eq how 'nnmh)
|
|
|
82 (require 'nnmh)
|
|
|
83 (gnus-message 5 "Looking up mh spool..."))
|
|
|
84 (t
|
|
|
85 (require 'nntp)))
|
|
|
86 (setq gnus-current-select-method gnus-select-method)
|
|
|
87 (run-hooks 'gnus-open-server-hook)
|
|
|
88 (or
|
|
|
89 ;; gnus-open-server-hook might have opened it
|
|
|
90 (gnus-server-opened gnus-select-method)
|
|
|
91 (gnus-open-server gnus-select-method)
|
|
|
92 (gnus-y-or-n-p
|
|
|
93 (format
|
|
|
94 "%s (%s) open error: '%s'. Continue? "
|
|
|
95 (car gnus-select-method) (cadr gnus-select-method)
|
|
|
96 (gnus-status-message gnus-select-method)))
|
|
|
97 (gnus-error 1 "Couldn't open server on %s"
|
|
|
98 (nth 1 gnus-select-method))))))
|
|
|
99
|
|
|
100 (defun gnus-check-group (group)
|
|
|
101 "Try to make sure that the server where GROUP exists is alive."
|
|
|
102 (let ((method (gnus-find-method-for-group group)))
|
|
|
103 (or (gnus-server-opened method)
|
|
|
104 (gnus-open-server method))))
|
|
|
105
|
|
|
106 (defun gnus-check-server (&optional method silent)
|
|
|
107 "Check whether the connection to METHOD is down.
|
|
|
108 If METHOD is nil, use `gnus-select-method'.
|
|
|
109 If it is down, start it up (again)."
|
|
|
110 (let ((method (or method gnus-select-method)))
|
|
|
111 ;; Transform virtual server names into select methods.
|
|
|
112 (when (stringp method)
|
|
|
113 (setq method (gnus-server-to-method method)))
|
|
|
114 (if (gnus-server-opened method)
|
|
|
115 ;; The stream is already opened.
|
|
|
116 t
|
|
|
117 ;; Open the server.
|
|
|
118 (unless silent
|
|
|
119 (gnus-message 5 "Opening %s server%s..." (car method)
|
|
|
120 (if (equal (nth 1 method) "") ""
|
|
|
121 (format " on %s" (nth 1 method)))))
|
|
|
122 (run-hooks 'gnus-open-server-hook)
|
|
|
123 (prog1
|
|
|
124 (gnus-open-server method)
|
|
|
125 (unless silent
|
|
|
126 (message ""))))))
|
|
|
127
|
|
|
128 (defun gnus-get-function (method function &optional noerror)
|
|
|
129 "Return a function symbol based on METHOD and FUNCTION."
|
|
|
130 ;; Translate server names into methods.
|
|
|
131 (unless method
|
|
|
132 (error "Attempted use of a nil select method"))
|
|
|
133 (when (stringp method)
|
|
|
134 (setq method (gnus-server-to-method method)))
|
|
|
135 (let ((func (intern (format "%s-%s" (car method) function))))
|
|
|
136 ;; If the functions isn't bound, we require the backend in
|
|
|
137 ;; question.
|
|
|
138 (unless (fboundp func)
|
|
|
139 (require (car method))
|
|
|
140 (when (and (not (fboundp func))
|
|
|
141 (not noerror))
|
|
|
142 ;; This backend doesn't implement this function.
|
|
|
143 (error "No such function: %s" func)))
|
|
|
144 func))
|
|
|
145
|
|
|
146
|
|
|
147 ;;;
|
|
|
148 ;;; Interface functions to the backends.
|
|
|
149 ;;;
|
|
|
150
|
|
|
151 (defun gnus-open-server (method)
|
|
|
152 "Open a connection to METHOD."
|
|
|
153 (when (stringp method)
|
|
|
154 (setq method (gnus-server-to-method method)))
|
|
|
155 (let ((elem (assoc method gnus-opened-servers)))
|
|
|
156 ;; If this method was previously denied, we just return nil.
|
|
|
157 (if (eq (nth 1 elem) 'denied)
|
|
|
158 (progn
|
|
|
159 (gnus-message 1 "Denied server")
|
|
|
160 nil)
|
|
|
161 ;; Open the server.
|
|
|
162 (let ((result
|
|
|
163 (funcall (gnus-get-function method 'open-server)
|
|
|
164 (nth 1 method) (nthcdr 2 method))))
|
|
|
165 ;; If this hasn't been opened before, we add it to the list.
|
|
|
166 (unless elem
|
|
|
167 (setq elem (list method nil)
|
|
|
168 gnus-opened-servers (cons elem gnus-opened-servers)))
|
|
|
169 ;; Set the status of this server.
|
|
|
170 (setcar (cdr elem) (if result 'ok 'denied))
|
|
|
171 ;; Return the result from the "open" call.
|
|
|
172 result))))
|
|
|
173
|
|
|
174 (defun gnus-close-server (method)
|
|
|
175 "Close the connection to METHOD."
|
|
|
176 (when (stringp method)
|
|
|
177 (setq method (gnus-server-to-method method)))
|
|
|
178 (funcall (gnus-get-function method 'close-server) (nth 1 method)))
|
|
|
179
|
|
|
180 (defun gnus-request-list (method)
|
|
|
181 "Request the active file from METHOD."
|
|
|
182 (when (stringp method)
|
|
|
183 (setq method (gnus-server-to-method method)))
|
|
|
184 (funcall (gnus-get-function method 'request-list) (nth 1 method)))
|
|
|
185
|
|
|
186 (defun gnus-request-list-newsgroups (method)
|
|
|
187 "Request the newsgroups file from METHOD."
|
|
|
188 (when (stringp method)
|
|
|
189 (setq method (gnus-server-to-method method)))
|
|
|
190 (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method)))
|
|
|
191
|
|
|
192 (defun gnus-request-newgroups (date method)
|
|
|
193 "Request all new groups since DATE from METHOD."
|
|
|
194 (when (stringp method)
|
|
|
195 (setq method (gnus-server-to-method method)))
|
|
|
196 (let ((func (gnus-get-function method 'request-newgroups t)))
|
|
|
197 (when func
|
|
|
198 (funcall func date (nth 1 method)))))
|
|
|
199
|
|
|
200 (defun gnus-server-opened (method)
|
|
|
201 "Check whether a connection to METHOD has been opened."
|
|
|
202 (when (stringp method)
|
|
|
203 (setq method (gnus-server-to-method method)))
|
|
|
204 (funcall (gnus-get-function method 'server-opened) (nth 1 method)))
|
|
|
205
|
|
|
206 (defun gnus-status-message (method)
|
|
|
207 "Return the status message from METHOD.
|
|
|
208 If METHOD is a string, it is interpreted as a group name. The method
|
|
|
209 this group uses will be queried."
|
|
|
210 (let ((method (if (stringp method) (gnus-find-method-for-group method)
|
|
|
211 method)))
|
|
|
212 (funcall (gnus-get-function method 'status-message) (nth 1 method))))
|
|
|
213
|
|
|
214 (defun gnus-request-regenerate (method)
|
|
|
215 "Request a data generation from METHOD."
|
|
|
216 (when (stringp method)
|
|
|
217 (setq method (gnus-server-to-method method)))
|
|
|
218 (funcall (gnus-get-function method 'request-regenerate) (nth 1 method)))
|
|
|
219
|
|
|
220 (defun gnus-request-group (group &optional dont-check method)
|
|
|
221 "Request GROUP. If DONT-CHECK, no information is required."
|
|
|
222 (let ((method (or method (gnus-find-method-for-group group))))
|
|
|
223 (when (stringp method)
|
|
|
224 (setq method (gnus-server-to-method method)))
|
|
|
225 (funcall (gnus-get-function method 'request-group)
|
|
|
226 (gnus-group-real-name group) (nth 1 method) dont-check)))
|
|
|
227
|
|
|
228 (defun gnus-list-active-group (group)
|
|
|
229 "Request active information on GROUP."
|
|
|
230 (let ((method (gnus-find-method-for-group group))
|
|
|
231 (func 'list-active-group))
|
|
|
232 (when (gnus-check-backend-function func group)
|
|
|
233 (funcall (gnus-get-function method func)
|
|
|
234 (gnus-group-real-name group) (nth 1 method)))))
|
|
|
235
|
|
|
236 (defun gnus-request-group-description (group)
|
|
|
237 "Request a description of GROUP."
|
|
|
238 (let ((method (gnus-find-method-for-group group))
|
|
|
239 (func 'request-group-description))
|
|
|
240 (when (gnus-check-backend-function func group)
|
|
|
241 (funcall (gnus-get-function method func)
|
|
|
242 (gnus-group-real-name group) (nth 1 method)))))
|
|
|
243
|
|
|
244 (defun gnus-close-group (group)
|
|
|
245 "Request the GROUP be closed."
|
|
|
246 (let ((method (gnus-find-method-for-group group)))
|
|
|
247 (funcall (gnus-get-function method 'close-group)
|
|
|
248 (gnus-group-real-name group) (nth 1 method))))
|
|
|
249
|
|
|
250 (defun gnus-retrieve-headers (articles group &optional fetch-old)
|
|
|
251 "Request headers for ARTICLES in GROUP.
|
|
|
252 If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
|
|
|
253 (let ((method (gnus-find-method-for-group group)))
|
|
|
254 (if (and gnus-use-cache (numberp (car articles)))
|
|
|
255 (gnus-cache-retrieve-headers articles group fetch-old)
|
|
|
256 (funcall (gnus-get-function method 'retrieve-headers)
|
|
|
257 articles (gnus-group-real-name group) (nth 1 method)
|
|
|
258 fetch-old))))
|
|
|
259
|
|
|
260 (defun gnus-retrieve-groups (groups method)
|
|
|
261 "Request active information on GROUPS from METHOD."
|
|
|
262 (when (stringp method)
|
|
|
263 (setq method (gnus-server-to-method method)))
|
|
|
264 (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method)))
|
|
|
265
|
|
|
266 (defun gnus-request-type (group &optional article)
|
|
|
267 "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
|
|
|
268 (let ((method (gnus-find-method-for-group group)))
|
|
|
269 (if (not (gnus-check-backend-function 'request-type (car method)))
|
|
|
270 'unknown
|
|
|
271 (funcall (gnus-get-function method 'request-type)
|
|
|
272 (gnus-group-real-name group) article))))
|
|
|
273
|
|
|
274 (defun gnus-request-update-mark (group article mark)
|
|
|
275 "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
|
|
|
276 (let ((method (gnus-find-method-for-group group)))
|
|
|
277 (if (not (gnus-check-backend-function 'request-update-mark (car method)))
|
|
|
278 mark
|
|
|
279 (funcall (gnus-get-function method 'request-update-mark)
|
|
|
280 (gnus-group-real-name group) article mark))))
|
|
|
281
|
|
|
282 (defun gnus-request-article (article group &optional buffer)
|
|
|
283 "Request the ARTICLE in GROUP.
|
|
|
284 ARTICLE can either be an article number or an article Message-ID.
|
|
|
285 If BUFFER, insert the article in that group."
|
|
|
286 (let ((method (gnus-find-method-for-group group)))
|
|
|
287 (funcall (gnus-get-function method 'request-article)
|
|
|
288 article (gnus-group-real-name group) (nth 1 method) buffer)))
|
|
|
289
|
|
|
290 (defun gnus-request-head (article group)
|
|
|
291 "Request the head of ARTICLE in GROUP."
|
|
|
292 (let* ((method (gnus-find-method-for-group group))
|
|
|
293 (head (gnus-get-function method 'request-head t))
|
|
|
294 res clean-up)
|
|
|
295 (cond
|
|
|
296 ;; Check the cache.
|
|
|
297 ((and gnus-use-cache
|
|
|
298 (numberp article)
|
|
|
299 (gnus-cache-request-article article group))
|
|
|
300 (setq res (cons group article)
|
|
|
301 clean-up t))
|
|
|
302 ;; Use `head' function.
|
|
|
303 ((fboundp head)
|
|
|
304 (setq res (funcall head article (gnus-group-real-name group)
|
|
|
305 (nth 1 method))))
|
|
|
306 ;; Use `article' function.
|
|
|
307 (t
|
|
|
308 (setq res (gnus-request-article article group)
|
|
|
309 clean-up t)))
|
|
|
310 (when clean-up
|
|
|
311 (save-excursion
|
|
|
312 (set-buffer nntp-server-buffer)
|
|
|
313 (goto-char (point-min))
|
|
|
314 (when (search-forward "\n\n" nil t)
|
|
|
315 (delete-region (1- (point)) (point-max)))
|
|
|
316 (nnheader-fold-continuation-lines)))
|
|
|
317 res))
|
|
|
318
|
|
|
319 (defun gnus-request-body (article group)
|
|
|
320 "Request the body of ARTICLE in GROUP."
|
|
|
321 (let ((method (gnus-find-method-for-group group)))
|
|
|
322 (funcall (gnus-get-function method 'request-body)
|
|
|
323 article (gnus-group-real-name group) (nth 1 method))))
|
|
|
324
|
|
|
325 (defun gnus-request-post (method)
|
|
|
326 "Post the current buffer using METHOD."
|
|
|
327 (when (stringp method)
|
|
|
328 (setq method (gnus-server-to-method method)))
|
|
|
329 (funcall (gnus-get-function method 'request-post) (nth 1 method)))
|
|
|
330
|
|
|
331 (defun gnus-request-scan (group method)
|
|
|
332 "Request a SCAN being performed in GROUP from METHOD.
|
|
|
333 If GROUP is nil, all groups on METHOD are scanned."
|
|
|
334 (let ((method (if group (gnus-find-method-for-group group) method)))
|
|
|
335 (funcall (gnus-get-function method 'request-scan)
|
|
|
336 (and group (gnus-group-real-name group)) (nth 1 method))))
|
|
|
337
|
|
|
338 (defsubst gnus-request-update-info (info method)
|
|
|
339 "Request that METHOD update INFO."
|
|
|
340 (when (stringp method)
|
|
|
341 (setq method (gnus-server-to-method method)))
|
|
|
342 (when (gnus-check-backend-function 'request-update-info (car method))
|
|
|
343 (funcall (gnus-get-function method 'request-update-info)
|
|
|
344 (gnus-group-real-name (gnus-info-group info))
|
|
|
345 info (nth 1 method))))
|
|
|
346
|
|
|
347 (defun gnus-request-expire-articles (articles group &optional force)
|
|
|
348 (let ((method (gnus-find-method-for-group group)))
|
|
|
349 (funcall (gnus-get-function method 'request-expire-articles)
|
|
|
350 articles (gnus-group-real-name group) (nth 1 method)
|
|
|
351 force)))
|
|
|
352
|
|
|
353 (defun gnus-request-move-article
|
|
|
354 (article group server accept-function &optional last)
|
|
|
355 (let ((method (gnus-find-method-for-group group)))
|
|
|
356 (funcall (gnus-get-function method 'request-move-article)
|
|
|
357 article (gnus-group-real-name group)
|
|
|
358 (nth 1 method) accept-function last)))
|
|
|
359
|
|
|
360 (defun gnus-request-accept-article (group method &optional last)
|
|
|
361 ;; Make sure there's a newline at the end of the article.
|
|
|
362 (when (stringp method)
|
|
|
363 (setq method (gnus-server-to-method method)))
|
|
|
364 (when (and (not method)
|
|
|
365 (stringp group))
|
|
|
366 (setq method (gnus-group-name-to-method group)))
|
|
|
367 (goto-char (point-max))
|
|
|
368 (unless (bolp)
|
|
|
369 (insert "\n"))
|
|
|
370 (let ((func (car (or method (gnus-find-method-for-group group)))))
|
|
|
371 (funcall (intern (format "%s-request-accept-article" func))
|
|
|
372 (if (stringp group) (gnus-group-real-name group) group)
|
|
|
373 (cadr method)
|
|
|
374 last)))
|
|
|
375
|
|
|
376 (defun gnus-request-replace-article (article group buffer)
|
|
|
377 (let ((func (car (gnus-find-method-for-group group))))
|
|
|
378 (funcall (intern (format "%s-request-replace-article" func))
|
|
|
379 article (gnus-group-real-name group) buffer)))
|
|
|
380
|
|
|
381 (defun gnus-request-associate-buffer (group)
|
|
|
382 (let ((method (gnus-find-method-for-group group)))
|
|
|
383 (funcall (gnus-get-function method 'request-associate-buffer)
|
|
|
384 (gnus-group-real-name group))))
|
|
|
385
|
|
|
386 (defun gnus-request-restore-buffer (article group)
|
|
|
387 "Request a new buffer restored to the state of ARTICLE."
|
|
|
388 (let ((method (gnus-find-method-for-group group)))
|
|
|
389 (funcall (gnus-get-function method 'request-restore-buffer)
|
|
|
390 article (gnus-group-real-name group) (nth 1 method))))
|
|
|
391
|
|
|
392 (defun gnus-request-create-group (group &optional method args)
|
|
|
393 (when (stringp method)
|
|
|
394 (setq method (gnus-server-to-method method)))
|
|
|
395 (let ((method (or method (gnus-find-method-for-group group))))
|
|
|
396 (funcall (gnus-get-function method 'request-create-group)
|
|
|
397 (gnus-group-real-name group) (nth 1 method) args)))
|
|
|
398
|
|
|
399 (defun gnus-request-delete-group (group &optional force)
|
|
|
400 (let ((method (gnus-find-method-for-group group)))
|
|
|
401 (funcall (gnus-get-function method 'request-delete-group)
|
|
|
402 (gnus-group-real-name group) force (nth 1 method))))
|
|
|
403
|
|
|
404 (defun gnus-request-rename-group (group new-name)
|
|
|
405 (let ((method (gnus-find-method-for-group group)))
|
|
|
406 (funcall (gnus-get-function method 'request-rename-group)
|
|
|
407 (gnus-group-real-name group)
|
|
|
408 (gnus-group-real-name new-name) (nth 1 method))))
|
|
|
409
|
|
|
410 (defun gnus-close-backends ()
|
|
|
411 ;; Send a close request to all backends that support such a request.
|
|
|
412 (let ((methods gnus-valid-select-methods)
|
|
|
413 func method)
|
|
|
414 (while (setq method (pop methods))
|
|
|
415 (when (fboundp (setq func (intern
|
|
|
416 (concat (car method) "-request-close"))))
|
|
|
417 (funcall func)))))
|
|
|
418
|
|
|
419 (defun gnus-asynchronous-p (method)
|
|
|
420 (let ((func (gnus-get-function method 'asynchronous-p t)))
|
|
|
421 (when (fboundp func)
|
|
|
422 (funcall func))))
|
|
|
423
|
|
|
424 (defun gnus-remove-denial (method)
|
|
|
425 (when (stringp method)
|
|
|
426 (setq method (gnus-server-to-method method)))
|
|
|
427 (let* ((elem (assoc method gnus-opened-servers))
|
|
|
428 (status (cadr elem)))
|
|
|
429 ;; If this hasn't been opened before, we add it to the list.
|
|
|
430 (when (eq status 'denied)
|
|
|
431 ;; Set the status of this server.
|
|
|
432 (setcar (cdr elem) 'closed))))
|
|
|
433
|
|
|
434 (provide 'gnus-int)
|
|
|
435
|
|
|
436 ;;; gnus-int.el ends here
|
