X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnndb.el;h=655c3b96ee1d96a7d84c31e849c6ec12adde5a67;hb=c358f44b1670d12d5eff5fe5a447a19afd34a252;hp=a7029ab525ee580e55a9d54be2d22cb38b91fa80;hpb=aa88205ebb3cd4ade3696b2faf1d72a687cffa49;p=gnus diff --git a/lisp/nndb.el b/lisp/nndb.el index a7029ab52..655c3b96e 100644 --- a/lisp/nndb.el +++ b/lisp/nndb.el @@ -1,14 +1,19 @@ ;;; nndb.el --- nndb access for Gnus -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; Author: Kai Grossjohann +;; Copyright (C) 1997, 1998, 2000, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Kai Grossjohann +;; Joe Hildebrand +;; David Blacka ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -18,47 +23,49 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: -;; I have shamelessly snarfed the code of nntp.el from sgnus. -;; Kai +;;; This was based upon Kai Grossjohan's shamessly snarfed code and +;;; further modified by Joe Hildebrand. It has been updated for Red +;;; Gnus. + +;; TODO: +;; +;; * Fix bug where server connection can be lost and impossible to regain +;; This hasn't happened to me in a while; think it was fixed in Rgnus +;; +;; * make it handle different nndb servers seemlessly +;; +;; * Optimize expire if FORCE +;; +;; * Optimize move (only expire once) +;; +;; * Deal with add/deletion of groups +;; +;; * make the backend TOUCH an article when marked as expireable (will +;; make article expire 'expiry' days after that moment). + +;;; Code: +;; For Emacs < 22.2. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) ;;- ;; Register nndb with known select methods. -(require 'gnus) -(require 'gnus-load) -(require 'nnmail) - -(setq gnus-valid-select-methods - (cons '("nndb" mail address respool prompt-address) - gnus-valid-select-methods)) - - -;;; Code: +(require 'gnus-start) +(unless (assoc "nndb" gnus-valid-select-methods) + (gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address)) +(require 'nnmail) (require 'nnheader) (require 'nntp) (eval-when-compile (require 'cl)) -(eval-and-compile - (unless (fboundp 'open-network-stream) - (require 'tcp))) - -(eval-when-compile (require 'cl)) - -(eval-and-compile - (autoload 'news-setup "rnewspost") - (autoload 'news-reply-mode "rnewspost") - (autoload 'cancel-timer "timer") - (autoload 'telnet "telnet" nil t) - (autoload 'telnet-send-input "telnet" nil t) - (autoload 'timezone-parse-date "timezone")) - ;; Declare nndb as derived from nntp (nnoo-declare nndb nntp) @@ -69,20 +76,20 @@ (defvoo nndb-deliver-program "nndel" "*The program used to put a message in an NNDB group.") +(defvoo nndb-server-side-expiry nil + "If t, expiry calculation will occur on the server side.") + +(defvoo nndb-set-expire-date-on-mark nil + "If t, the expiry date for a given article will be set to the time +it was marked as expireable; otherwise the date will be the time the +article was posted to nndb") + ;; Variables copied from nntp (defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file) "Like nntp-server-opened-hook." nntp-server-opened-hook) -;(defvoo nndb-rlogin-parameters '("telnet" "${NNDBSERVER:=localhost}" "9000") -; "*Parameters to nndb-open-login. Like nntp-rlogin-parameters." -; nntp-rlogin-parameters) - -;(defvoo nndb-rlogin-user-name nil -; "*User name for rlogin connect method." -; nntp-rlogin-user-name) - (defvoo nndb-address "localhost" "*The name of the NNDB server." nntp-address) @@ -91,15 +98,14 @@ "*Port number to connect to." nntp-port-number) -;(defvoo nndb-current-group "" -; "Like nntp-current-group." -; nntp-current-group) +;; change to 'news if you are actually using nndb for news +(defvoo nndb-article-type 'mail) (defvoo nndb-status-string nil "" nntp-status-string) -(defconst nndb-version "nndb 0.3" +(defconst nndb-version "nndb 0.7" "Version numbers of this version of NNDB.") @@ -107,121 +113,215 @@ (nnoo-define-basics nndb) -;; Import other stuff from nntp as is. +;;------------------------------------------------------------------ -(nnoo-import nndb - (nntp)) +;; this function turns the lisp list into a string list. There is +;; probably a more efficient way to do this. +(defun nndb-build-article-string (articles) + (let (art-string art) + (while articles + (setq art (pop articles)) + (setq art-string (concat art-string art " "))) + art-string)) -;;- maybe this should be mail?? -;;-(defun nndb-request-type (group &optional article) -;;- 'news) +(defun nndb-build-expire-rest-list (total expire) + (let (art rest) + (while total + (setq art (pop total)) + (if (memq art expire) + () + (push art rest))) + rest)) -;;------------------------------------------------------------------ -;;- only new stuff below -; nndb-request-update-info does not exist and is not needed +;; +(deffoo nndb-request-type (group &optional article) + nndb-article-type) -; nndb-request-update-mark does not exist and is not needed +;; nndb-request-update-info does not exist and is not needed -; nndb-request-scan does not exist -; get new mail from somewhere -- maybe this is not needed? -; --> todo +;; nndb-request-update-mark does not exist; it should be used to TOUCH +;; articles as they are marked exipirable +(defun nndb-touch-article (group article) + (nntp-send-command nil "X-TOUCH" article)) -(deffoo nndb-request-create-group (group &optional server args) - "Creates a group if it doesn't exist yet." - (nntp-send-command "^[23].*\n" "MKGROUP" group)) +(deffoo nndb-request-update-mark + (group article mark) + "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'" + (if (and nndb-set-expire-date-on-mark (string-equal mark "E")) + (nndb-touch-article group article)) + mark) -; todo -- use some other time than the creation time of the article -; best is time since article has been marked as expirable -(deffoo nndb-request-expire-articles +;; nndb-request-create-group -- currently this isn't necessary; nndb +;; creates groups on demand. + +;; todo -- use some other time than the creation time of the article +;; best is time since article has been marked as expirable + +(defun nndb-request-expire-articles-local (articles &optional group server force) - "Expires ARTICLES from GROUP on SERVER. -If FORCE, delete regardless of expiration date, otherwise use normal -expiry mechanism." - (let (msg art) - (nntp-possibly-change-group group server) ;;- + "Let gnus do the date check and issue the delete commands." + (let (msg art delete-list (num-delete 0) rest) + (nntp-possibly-change-group group server) (while articles (setq art (pop articles)) - (nntp-send-command "^\\([23]\\|^423\\).*\n" "DATE" art) + (nntp-send-command "^\\([23]\\|^423\\).*\n" "X-DATE" art) (setq msg (nndb-status-message)) - ;; CCC we shouldn't be using the variable nndb-status-string? - (if (string-match "^423" (nnheader-get-report 'nndb)) - () - (unless (string-match "\\([0-9]+\\) \\([0-9]+\\)$" msg) - (error "Not a valid response for DATE command: %s" - msg)) - (if (nnmail-expired-article-p - group - (list (string-to-int - (substring msg (match-beginning 1) (match-end 1))) - (string-to-int - (substring msg (match-beginning 2) (match-end 2)))) - force) - (nnheader-message 5 "Deleting article %s in %s..." - art group) - (nntp-send-command "^[23].*\n" "DELETE" art)))))) + (if (string-match "^423" msg) + () + (or (string-match "'\\(.+\\)'" msg) + (error "Not a valid response for X-DATE command: %s" + msg)) + (if (nnmail-expired-article-p + group + (date-to-time (substring msg (match-beginning 1) (match-end 1))) + force) + (progn + (setq delete-list (concat delete-list " " (int-to-string art))) + (setq num-delete (1+ num-delete))) + (push art rest)))) + (if (> (length delete-list) 0) + (progn + (nnheader-message 5 "Deleting %s article(s) from %s" + (int-to-string num-delete) group) + (nntp-send-command "^[23].*\n" "X-DELETE" delete-list)) + ) + + (nnheader-message 5 "") + (nconc rest articles))) + +(defun nndb-get-remote-expire-response () + (let (list) + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (if (looking-at "^[34]") + ;; x-expire returned error--presume no articles were expirable) + (setq list nil) + ;; otherwise, pull all of the following numbers into the list + (re-search-forward "follows\r?\n?" nil t) + (while (re-search-forward "^[0-9]+$" nil t) + (push (string-to-number (match-string 0)) list))) + list)) + +(defun nndb-request-expire-articles-remote + (articles &optional group server force) + "Let the nndb backend expire articles" + (let (days art-string delete-list (num-delete 0)) + (nntp-possibly-change-group group server) + + ;; first calculate the wait period in days + (setq days (or (and nnmail-expiry-wait-function + (funcall nnmail-expiry-wait-function group)) + nnmail-expiry-wait)) + ;; now handle the special cases + (cond (force + (setq days 0)) + ((eq days 'never) + ;; This isn't an expirable group. + (setq days -1)) + ((eq days 'immediate) + (setq days 0))) + + + ;; build article string + (setq art-string (concat days " " (nndb-build-article-string articles))) + (nntp-send-command "^\.\r?\n\\|^[345].*\n" "X-EXPIRE" art-string) + + (setq delete-list (nndb-get-remote-expire-response)) + (setq num-delete (length delete-list)) + (if (> num-delete 0) + (nnheader-message 5 "Deleting %s article(s) from %s" + (int-to-string num-delete) group)) + + (nndb-build-expire-rest-list articles delete-list))) + +(deffoo nndb-request-expire-articles + (articles &optional group server force) + "Expires ARTICLES from GROUP on SERVER. +If FORCE, delete regardless of exiration date, otherwise use normal +expiry mechanism." + (if nndb-server-side-expiry + (nndb-request-expire-articles-remote articles group server force) + (nndb-request-expire-articles-local articles group server force))) + +;; _Something_ defines it... +(declare-function nndb-request-article "nndb" t t) (deffoo nndb-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) "Move ARTICLE (a number) from GROUP on SERVER. Evals ACCEPT-FORM in current buffer, where the article is. Optional LAST is ignored." - (let ((artbuf (get-buffer-create " *nndb move*")) - result) - (and - (nndb-request-article article group server artbuf) - (save-excursion - (set-buffer artbuf) - (setq result (eval accept-form)) - (kill-buffer (current-buffer)) - result) - (nndb-request-expire-articles (list article) - group - server - t)) - result)) - + ;; we guess that the second arg in accept-form is the new group, + ;; which it will be for nndb, which is all that matters anyway + (let ((new-group (nth 1 accept-form)) result) + (nntp-possibly-change-group group server) + + ;; use the move command for nndb-to-nndb moves + (if (string-match "^nndb" new-group) + (let ((new-group-name (gnus-group-real-name new-group))) + (nntp-send-command "^[23].*\n" "X-MOVE" article new-group-name) + (cons new-group article)) + ;; else move normally + (let ((artbuf (get-buffer-create " *nndb move*"))) + (and + (nndb-request-article article group server artbuf) + (save-excursion + (set-buffer artbuf) + (insert-buffer-substring nntp-server-buffer) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result) + (nndb-request-expire-articles (list article) + group + server + t)) + result) + ))) + (deffoo nndb-request-accept-article (group server &optional last) "The article in the current buffer is put into GROUP." - (nntp-possibly-change-group group server) ;;- - (let (art statmsg) + (nntp-possibly-change-group group server) + (let (art msg) (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) (nnheader-insert "") - (nntp-encode-text) - (nntp-send-buffer "^[23].*\n") - (setq statmsg (nntp-status-message)) - (unless (string-match "^\\([0-9]+\\)" statmsg) - (error "nndb: %s" statmsg)) - (setq art (substring statmsg - (match-beginning 1) - (match-end 1))) - (message "nndb: accepted %s" art) - (list art)))) + (nntp-send-buffer "^[23].*\n")) + + (set-buffer nntp-server-buffer) + (setq msg (buffer-string)) + (or (string-match "^\\([0-9]+\\)" msg) + (error "nndb: %s" msg)) + (setq art (substring msg (match-beginning 1) (match-end 1))) + (nnheader-message 5 "nndb: accepted %s" art) + (list art))) (deffoo nndb-request-replace-article (article group buffer) - "ARTICLE is the number of the article in GROUP to be replaced -with the contents of the BUFFER." + "ARTICLE is the number of the article in GROUP to be replaced with the contents of the BUFFER." (set-buffer buffer) - (let (art statmsg) - (when (nntp-send-command "^[23].*\r?\n" "REPLACE" (int-to-string article)) - (nnheader-insert "") - (nntp-encode-text) - (nntp-send-buffer "^[23].*\n") -; (setq statmsg (nntp-status-message)) -; (or (string-match "^\\([0-9]+\\)" statmsg) -; (error "nndb: %s" statmsg)) -; (setq art (substring statmsg -; (match-beginning 1) -; (match-end 1))) -; (message "nndb: replaced %s" art) - (list (int-to-string article))))) - -; nndb-request-delete-group does not exist -; todo -- maybe later - -; nndb-request-rename-group does not exist -; todo -- maybe later + (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article)) + (nnheader-insert "") + (nntp-send-buffer "^[23.*\n") + (list (int-to-string article)))) -(provide 'nndb) + ; nndb-request-delete-group does not exist + ; todo -- maybe later + + ; nndb-request-rename-group does not exist + ; todo -- maybe later + +;; -- standard compatability functions +(deffoo nndb-status-message (&optional server) + "Return server status as a string." + (set-buffer nntp-server-buffer) + (buffer-string)) + +;; Import stuff from nntp + +(nnoo-import nndb + (nntp)) + +(provide 'nndb) +;;; arch-tag: 83bd6fb4-58d9-4fed-a901-c6c625ad5f8a +;;; nndb.el ends here