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