Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-int.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 0293115a14e9
children ec9a17fef872
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
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