lisp/gnus/nndb.el

   1 ;;; nndb.el --- nndb access for Gnus
   2
   3 ;; Copyright (C) 1997, 1998, 2000, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008, 2009, 2010  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 of the License, or
  17 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  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 ;;; Code:
  50
  51 ;; For Emacs < 22.2.
  52 (eval-and-compile
  53   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  54
  55 ;;-
  56 ;; Register nndb with known select methods.
  57
  58 (require 'gnus-start)
  59 (unless (assoc "nndb" gnus-valid-select-methods)
  60   (gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address))
  61
  62 (require 'nnmail)
  63 (require 'nnheader)
  64 (require 'nntp)
  65 (eval-when-compile (require 'cl))
  66
  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)
 201       (push (string-to-number (match-string 0)) list)))
 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
 245 ;; _Something_ defines it...
 246 (declare-function nndb-request-article "nndb" t t)
 247
 248 (deffoo nndb-request-move-article
 249     (article group server accept-form &optional last move-is-internal)
 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
 310 ;; -- standard compatibility functions
 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
 324 ;; arch-tag: 83bd6fb4-58d9-4fed-a901-c6c625ad5f8a
 325 ;;; nndb.el ends here