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