Mercurial > emacs
comparison lisp/gnus/nndb.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | |
children | 06f2ccbf6e0f |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
1 ;;; nndb.el --- nndb access for Gnus | |
2 | |
3 ;; Copyright (C) 1997, 1998, 2000, 2003 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> | |
6 ;; Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de> | |
7 ;; Joe Hildebrand <joe.hildebrand@ilg.com> | |
8 ;; David Blacka <davidb@rwhois.net> | |
9 ;; Keywords: news | |
10 | |
11 ;; This file is part of GNU Emacs. | |
12 | |
13 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
14 ;; it under the terms of the GNU General Public License as published by | |
15 ;; the Free Software Foundation; either version 2, or (at your option) | |
16 ;; any later version. | |
17 | |
18 ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 ;; GNU General Public License for more details. | |
22 | |
23 ;; You should have received a copy of the GNU General Public License | |
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
26 ;; Boston, MA 02111-1307, USA. | |
27 | |
28 ;;; Commentary: | |
29 | |
30 ;;; This was based upon Kai Grossjohan's shamessly snarfed code and | |
31 ;;; further modified by Joe Hildebrand. It has been updated for Red | |
32 ;;; Gnus. | |
33 | |
34 ;; TODO: | |
35 ;; | |
36 ;; * Fix bug where server connection can be lost and impossible to regain | |
37 ;; This hasn't happened to me in a while; think it was fixed in Rgnus | |
38 ;; | |
39 ;; * make it handle different nndb servers seemlessly | |
40 ;; | |
41 ;; * Optimize expire if FORCE | |
42 ;; | |
43 ;; * Optimize move (only expire once) | |
44 ;; | |
45 ;; * Deal with add/deletion of groups | |
46 ;; | |
47 ;; * make the backend TOUCH an article when marked as expireable (will | |
48 ;; make article expire 'expiry' days after that moment). | |
49 | |
50 ;;- | |
51 ;; Register nndb with known select methods. | |
52 | |
53 (gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address) | |
54 | |
55 ;;; Code: | |
56 | |
57 (require 'nnmail) | |
58 (require 'nnheader) | |
59 (require 'nntp) | |
60 (eval-when-compile (require 'cl)) | |
61 | |
62 (eval-and-compile | |
63 (unless (fboundp 'open-network-stream) | |
64 (require 'tcp))) | |
65 | |
66 (eval-when-compile (require 'cl)) | |
67 | |
68 (eval-and-compile | |
69 (autoload 'news-setup "rnewspost") | |
70 (autoload 'news-reply-mode "rnewspost") | |
71 (autoload 'cancel-timer "timer") | |
72 (autoload 'telnet "telnet" nil t) | |
73 (autoload 'telnet-send-input "telnet" nil t) | |
74 (autoload 'gnus-declare-backend "gnus-start")) | |
75 | |
76 ;; Declare nndb as derived from nntp | |
77 | |
78 (nnoo-declare nndb nntp) | |
79 | |
80 ;; Variables specific to nndb | |
81 | |
82 ;;- currently not used but just in case... | |
83 (defvoo nndb-deliver-program "nndel" | |
84 "*The program used to put a message in an NNDB group.") | |
85 | |
86 (defvoo nndb-server-side-expiry nil | |
87 "If t, expiry calculation will occur on the server side.") | |
88 | |
89 (defvoo nndb-set-expire-date-on-mark nil | |
90 "If t, the expiry date for a given article will be set to the time | |
91 it was marked as expireable; otherwise the date will be the time the | |
92 article was posted to nndb") | |
93 | |
94 ;; Variables copied from nntp | |
95 | |
96 (defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file) | |
97 "Like nntp-server-opened-hook." | |
98 nntp-server-opened-hook) | |
99 | |
100 (defvoo nndb-address "localhost" | |
101 "*The name of the NNDB server." | |
102 nntp-address) | |
103 | |
104 (defvoo nndb-port-number 9000 | |
105 "*Port number to connect to." | |
106 nntp-port-number) | |
107 | |
108 ;; change to 'news if you are actually using nndb for news | |
109 (defvoo nndb-article-type 'mail) | |
110 | |
111 (defvoo nndb-status-string nil "" nntp-status-string) | |
112 | |
113 | |
114 | |
115 (defconst nndb-version "nndb 0.7" | |
116 "Version numbers of this version of NNDB.") | |
117 | |
118 | |
119 ;;; Interface functions. | |
120 | |
121 (nnoo-define-basics nndb) | |
122 | |
123 ;;------------------------------------------------------------------ | |
124 | |
125 ;; this function turns the lisp list into a string list. There is | |
126 ;; probably a more efficient way to do this. | |
127 (defun nndb-build-article-string (articles) | |
128 (let (art-string art) | |
129 (while articles | |
130 (setq art (pop articles)) | |
131 (setq art-string (concat art-string art " "))) | |
132 art-string)) | |
133 | |
134 (defun nndb-build-expire-rest-list (total expire) | |
135 (let (art rest) | |
136 (while total | |
137 (setq art (pop total)) | |
138 (if (memq art expire) | |
139 () | |
140 (push art rest))) | |
141 rest)) | |
142 | |
143 | |
144 ;; | |
145 (deffoo nndb-request-type (group &optional article) | |
146 nndb-article-type) | |
147 | |
148 ;; nndb-request-update-info does not exist and is not needed | |
149 | |
150 ;; nndb-request-update-mark does not exist; it should be used to TOUCH | |
151 ;; articles as they are marked exipirable | |
152 (defun nndb-touch-article (group article) | |
153 (nntp-send-command nil "X-TOUCH" article)) | |
154 | |
155 (deffoo nndb-request-update-mark | |
156 (group article mark) | |
157 "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'" | |
158 (if (and nndb-set-expire-date-on-mark (string-equal mark "E")) | |
159 (nndb-touch-article group article)) | |
160 mark) | |
161 | |
162 ;; nndb-request-create-group -- currently this isn't necessary; nndb | |
163 ;; creates groups on demand. | |
164 | |
165 ;; todo -- use some other time than the creation time of the article | |
166 ;; best is time since article has been marked as expirable | |
167 | |
168 (defun nndb-request-expire-articles-local | |
169 (articles &optional group server force) | |
170 "Let gnus do the date check and issue the delete commands." | |
171 (let (msg art delete-list (num-delete 0) rest) | |
172 (nntp-possibly-change-group group server) | |
173 (while articles | |
174 (setq art (pop articles)) | |
175 (nntp-send-command "^\\([23]\\|^423\\).*\n" "X-DATE" art) | |
176 (setq msg (nndb-status-message)) | |
177 (if (string-match "^423" msg) | |
178 () | |
179 (or (string-match "'\\(.+\\)'" msg) | |
180 (error "Not a valid response for X-DATE command: %s" | |
181 msg)) | |
182 (if (nnmail-expired-article-p | |
183 group | |
184 (date-to-time (substring msg (match-beginning 1) (match-end 1))) | |
185 force) | |
186 (progn | |
187 (setq delete-list (concat delete-list " " (int-to-string art))) | |
188 (setq num-delete (1+ num-delete))) | |
189 (push art rest)))) | |
190 (if (> (length delete-list) 0) | |
191 (progn | |
192 (nnheader-message 5 "Deleting %s article(s) from %s" | |
193 (int-to-string num-delete) group) | |
194 (nntp-send-command "^[23].*\n" "X-DELETE" delete-list)) | |
195 ) | |
196 | |
197 (nnheader-message 5 "") | |
198 (nconc rest articles))) | |
199 | |
200 (defun nndb-get-remote-expire-response () | |
201 (let (list) | |
202 (set-buffer nntp-server-buffer) | |
203 (goto-char (point-min)) | |
204 (if (looking-at "^[34]") | |
205 ;; x-expire returned error--presume no articles were expirable) | |
206 (setq list nil) | |
207 ;; otherwise, pull all of the following numbers into the list | |
208 (re-search-forward "follows\r?\n?" nil t) | |
209 (while (re-search-forward "^[0-9]+$" nil t) | |
210 (push (string-to-int (match-string 0)) list))) | |
211 list)) | |
212 | |
213 (defun nndb-request-expire-articles-remote | |
214 (articles &optional group server force) | |
215 "Let the nndb backend expire articles" | |
216 (let (days art-string delete-list (num-delete 0)) | |
217 (nntp-possibly-change-group group server) | |
218 | |
219 ;; first calculate the wait period in days | |
220 (setq days (or (and nnmail-expiry-wait-function | |
221 (funcall nnmail-expiry-wait-function group)) | |
222 nnmail-expiry-wait)) | |
223 ;; now handle the special cases | |
224 (cond (force | |
225 (setq days 0)) | |
226 ((eq days 'never) | |
227 ;; This isn't an expirable group. | |
228 (setq days -1)) | |
229 ((eq days 'immediate) | |
230 (setq days 0))) | |
231 | |
232 | |
233 ;; build article string | |
234 (setq art-string (concat days " " (nndb-build-article-string articles))) | |
235 (nntp-send-command "^\.\r?\n\\|^[345].*\n" "X-EXPIRE" art-string) | |
236 | |
237 (setq delete-list (nndb-get-remote-expire-response)) | |
238 (setq num-delete (length delete-list)) | |
239 (if (> num-delete 0) | |
240 (nnheader-message 5 "Deleting %s article(s) from %s" | |
241 (int-to-string num-delete) group)) | |
242 | |
243 (nndb-build-expire-rest-list articles delete-list))) | |
244 | |
245 (deffoo nndb-request-expire-articles | |
246 (articles &optional group server force) | |
247 "Expires ARTICLES from GROUP on SERVER. | |
248 If FORCE, delete regardless of exiration date, otherwise use normal | |
249 expiry mechanism." | |
250 (if nndb-server-side-expiry | |
251 (nndb-request-expire-articles-remote articles group server force) | |
252 (nndb-request-expire-articles-local articles group server force))) | |
253 | |
254 (deffoo nndb-request-move-article | |
255 (article group server accept-form &optional last) | |
256 "Move ARTICLE (a number) from GROUP on SERVER. | |
257 Evals ACCEPT-FORM in current buffer, where the article is. | |
258 Optional LAST is ignored." | |
259 ;; we guess that the second arg in accept-form is the new group, | |
260 ;; which it will be for nndb, which is all that matters anyway | |
261 (let ((new-group (nth 1 accept-form)) result) | |
262 (nntp-possibly-change-group group server) | |
263 | |
264 ;; use the move command for nndb-to-nndb moves | |
265 (if (string-match "^nndb" new-group) | |
266 (let ((new-group-name (gnus-group-real-name new-group))) | |
267 (nntp-send-command "^[23].*\n" "X-MOVE" article new-group-name) | |
268 (cons new-group article)) | |
269 ;; else move normally | |
270 (let ((artbuf (get-buffer-create " *nndb move*"))) | |
271 (and | |
272 (nndb-request-article article group server artbuf) | |
273 (save-excursion | |
274 (set-buffer artbuf) | |
275 (insert-buffer-substring nntp-server-buffer) | |
276 (setq result (eval accept-form)) | |
277 (kill-buffer (current-buffer)) | |
278 result) | |
279 (nndb-request-expire-articles (list article) | |
280 group | |
281 server | |
282 t)) | |
283 result) | |
284 ))) | |
285 | |
286 (deffoo nndb-request-accept-article (group server &optional last) | |
287 "The article in the current buffer is put into GROUP." | |
288 (nntp-possibly-change-group group server) | |
289 (let (art msg) | |
290 (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) | |
291 (nnheader-insert "") | |
292 (nntp-send-buffer "^[23].*\n")) | |
293 | |
294 (set-buffer nntp-server-buffer) | |
295 (setq msg (buffer-string)) | |
296 (or (string-match "^\\([0-9]+\\)" msg) | |
297 (error "nndb: %s" msg)) | |
298 (setq art (substring msg (match-beginning 1) (match-end 1))) | |
299 (nnheader-message 5 "nndb: accepted %s" art) | |
300 (list art))) | |
301 | |
302 (deffoo nndb-request-replace-article (article group buffer) | |
303 "ARTICLE is the number of the article in GROUP to be replaced with the contents of the BUFFER." | |
304 (set-buffer buffer) | |
305 (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article)) | |
306 (nnheader-insert "") | |
307 (nntp-send-buffer "^[23.*\n") | |
308 (list (int-to-string article)))) | |
309 | |
310 ; nndb-request-delete-group does not exist | |
311 ; todo -- maybe later | |
312 | |
313 ; nndb-request-rename-group does not exist | |
314 ; todo -- maybe later | |
315 | |
316 ;; -- standard compatability functions | |
317 | |
318 (deffoo nndb-status-message (&optional server) | |
319 "Return server status as a string." | |
320 (set-buffer nntp-server-buffer) | |
321 (buffer-string)) | |
322 | |
323 ;; Import stuff from nntp | |
324 | |
325 (nnoo-import nndb | |
326 (nntp)) | |
327 | |
328 (provide 'nndb) | |
329 | |
330 ;;; arch-tag: 83bd6fb4-58d9-4fed-a901-c6c625ad5f8a | |
331 ;;; nndb.el ends here |