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