lisp/gnus/nndb.el

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