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