cgit.sxemacs.org Git - gnus/blob - lisp/nndb.el

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