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