X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnbabyl.el;h=ae417a0ffe8351cd6c8b1583b4b99a4dfd35606e;hp=df50dec6421711eb11d143a2531d06df5a2781cf;hb=d588ae3db11ee057d2fc3dfa5364dcfe3f84e368;hpb=2b93d0d6a7c0119e3c23f9ab27c52f932deea075 diff --git a/lisp/nnbabyl.el b/lisp/nnbabyl.el index df50dec64..ae417a0ff 100644 --- a/lisp/nnbabyl.el +++ b/lisp/nnbabyl.el @@ -1,16 +1,17 @@ ;;; nnbabyl.el --- rmail mbox access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen -;; Masanobu UMEDA +;; Copyright (C) 1995-2015 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA ;; Keywords: news, mail ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -18,19 +19,20 @@ ;; GNU General Public License for more details. ;; 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. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;; For an overview of what the interface functions do, please see the -;; Gnus sources. +;; Gnus sources. ;;; Code: (require 'nnheader) -(require 'rmail) +(condition-case nil + (require 'rmail) + (error (nnheader-message + 5 "Ignore rmail errors from this file, you don't have rmail"))) (require 'nnmail) (require 'nnoo) (eval-when-compile (require 'cl)) @@ -46,6 +48,7 @@ (defvoo nnbabyl-get-new-mail t "If non-nil, nnbabyl will check the incoming mail file and split the mail.") + (defvoo nnbabyl-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") @@ -64,9 +67,6 @@ (defvoo nnbabyl-previous-buffer-mode nil) -(eval-and-compile - (autoload 'gnus-set-text-properties "gnus-ems")) - ;;; Interface functions @@ -74,8 +74,7 @@ (nnoo-define-basics nnbabyl) (deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let ((number (length articles)) (count 0) @@ -85,10 +84,11 @@ (while (setq article (pop articles)) (setq art-string (nnbabyl-article-string article)) (set-buffer nnbabyl-mbox-buffer) - (beginning-of-line) + (end-of-line) (when (or (search-forward art-string nil t) (search-backward art-string nil t)) - (re-search-backward delim nil t) + (unless (re-search-backward delim nil t) + (goto-char (point-min))) (while (and (not (looking-at ".+:")) (zerop (forward-line 1)))) (setq start (point)) @@ -105,7 +105,7 @@ (> number nnmail-large-newsgroup) (zerop (% (incf count) 20)) (nnheader-message 5 "nnbabyl: Receiving headers... %d%%" - (/ (* count 100) number)))) + (floor (* count 100.0) number)))) (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) @@ -117,7 +117,8 @@ (deffoo nnbabyl-open-server (server &optional defs) (nnoo-change-server 'nnbabyl server defs) - (cond + (nnbabyl-create-mbox) + (cond ((not (file-exists-p nnbabyl-mbox-file)) (nnbabyl-close-server) (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file)) @@ -133,8 +134,7 @@ ;; Restore buffer mode. (when (and (nnbabyl-server-opened) nnbabyl-previous-buffer-mode) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (narrow-to-region (caar nnbabyl-previous-buffer-mode) (cdar nnbabyl-previous-buffer-mode)) @@ -152,16 +152,17 @@ (deffoo nnbabyl-request-article (article &optional newsgroup server buffer) (nnbabyl-possibly-change-newsgroup newsgroup server) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (when (search-forward (nnbabyl-article-string article) nil t) (let (start stop summary-line) - (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (goto-char (point-min)) + (end-of-line)) (while (and (not (looking-at ".+:")) (zerop (forward-line 1)))) (setq start (point)) - (or (when (re-search-forward + (or (when (re-search-forward (concat "^" nnbabyl-mail-delimiter) nil t) (beginning-of-line) t) @@ -173,7 +174,7 @@ (insert-buffer-substring nnbabyl-mbox-buffer start stop) (goto-char (point-min)) ;; If there is an EOOH header, then we have to remove some - ;; duplicated headers. + ;; duplicated headers. (setq summary-line (looking-at "Summary-line:")) (when (search-forward "\n*** EOOH ***" nil t) (if summary-line @@ -185,14 +186,14 @@ (delete-region (progn (beginning-of-line) (point)) (or (search-forward "\n\n" nil t) (point))))) - (if (numberp article) + (if (numberp article) (cons nnbabyl-current-group article) (nnbabyl-article-group-number))))))) -(deffoo nnbabyl-request-group (group &optional server dont-check) +(deffoo nnbabyl-request-group (group &optional server dont-check info) (let ((active (cadr (assoc group nnbabyl-group-alist)))) (save-excursion - (cond + (cond ((or (null active) (null (nnbabyl-possibly-change-newsgroup group server))) (nnheader-report 'nnbabyl "No such group: %s" group)) @@ -201,20 +202,20 @@ (nnheader-insert "")) (t (nnheader-report 'nnbabyl "Selected group %s" group) - (nnheader-insert "211 %d %d %d %s\n" + (nnheader-insert "211 %d %d %d %s\n" (1+ (- (cdr active) (car active))) (car active) (cdr active) group)))))) (deffoo nnbabyl-request-scan (&optional group server) (nnbabyl-possibly-change-newsgroup group server) (nnbabyl-read-mbox) - (nnmail-get-new-mail - 'nnbabyl + (nnmail-get-new-mail + 'nnbabyl (lambda () - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (save-buffer))) - nnbabyl-mbox-file group + (file-name-directory nnbabyl-mbox-file) + group (lambda () (save-excursion (let ((in-buf (current-buffer))) @@ -231,18 +232,19 @@ (deffoo nnbabyl-close-group (group &optional server) t) -(deffoo nnbabyl-request-create-group (group &optional server args) +(deffoo nnbabyl-request-create-group (group &optional server args) (nnmail-activate 'nnbabyl) (unless (assoc group nnbabyl-group-alist) - (setq nnbabyl-group-alist (cons (list group (cons 1 0)) - nnbabyl-group-alist)) + (push (list group (cons 1 0)) + nnbabyl-group-alist) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) t) (deffoo nnbabyl-request-list (&optional server) (save-excursion (nnmail-find-file nnbabyl-active-file) - (setq nnbabyl-group-alist (nnmail-get-active)))) + (setq nnbabyl-group-alist (nnmail-get-active)) + t)) (deffoo nnbabyl-request-newgroups (date &optional server) (nnbabyl-request-list server)) @@ -251,28 +253,36 @@ (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented.")) (deffoo nnbabyl-request-expire-articles - (articles newsgroup &optional server force) + (articles newsgroup &optional server force) (nnbabyl-possibly-change-newsgroup newsgroup server) (let* ((is-old t) rest) (nnmail-activate 'nnbabyl) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) - (gnus-set-text-properties (point-min) (point-max) nil) + (with-current-buffer nnbabyl-mbox-buffer + (set-text-properties (point-min) (point-max) nil) (while (and articles is-old) (goto-char (point-min)) - (if (search-forward (nnbabyl-article-string (car articles)) nil t) - (if (setq is-old - (nnmail-expired-article-p - newsgroup - (buffer-substring - (point) (progn (end-of-line) (point))) force)) - (progn - (nnheader-message 5 "Deleting article %d in %s..." - (car articles) newsgroup) - (nnbabyl-delete-mail)) - (setq rest (cons (car articles) rest)))) + (when (search-forward (nnbabyl-article-string (car articles)) nil t) + (if (setq is-old + (nnmail-expired-article-p + newsgroup + (buffer-substring + (point) (progn (end-of-line) (point))) force)) + (progn + (unless (eq nnmail-expiry-target 'delete) + (with-temp-buffer + (nnbabyl-request-article (car articles) + newsgroup server + (current-buffer)) + (let ((nnml-current-directory nil)) + (nnmail-expiry-target-group + nnmail-expiry-target newsgroup))) + (nnbabyl-possibly-change-newsgroup newsgroup server)) + (nnheader-message 5 "Deleting article %d in %s..." + (car articles) newsgroup) + (nnbabyl-delete-mail)) + (push (car articles) rest))) (setq articles (cdr articles))) (save-buffer) ;; Find the lowest active article in this group. @@ -286,21 +296,19 @@ (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) (nconc rest articles)))) -(deffoo nnbabyl-request-move-article - (article group server accept-form &optional last) +(deffoo nnbabyl-request-move-article + (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnbabyl move*")) result) - (and + (and (nnbabyl-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) - (while (re-search-forward - "^X-Gnus-Newsgroup:" + (while (re-search-forward + "^X-Gnus-Newsgroup:" (save-excursion (search-forward "\n\n" nil t) (point)) t) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (delete-region (point-at-bol) (progn (forward-line 1) (point)))) (setq result (eval accept-form)) (kill-buffer (current-buffer)) result) @@ -318,7 +326,7 @@ (nnmail-check-syntax) (let ((buf (current-buffer)) result beg) - (and + (and (nnmail-activate 'nnbabyl) (save-excursion (goto-char (point-min)) @@ -327,24 +335,37 @@ (save-excursion (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) (delete-region (point) (progn (forward-line 1) (point))))) - (setq result (car (nnbabyl-save-mail - (if (stringp group) - (list (cons group (nnbabyl-active-number group))) - (nnmail-article-group 'nnbabyl-active-number))))) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) + (setq result + (if (stringp group) + (list (cons group (nnbabyl-active-number group))) + (nnmail-article-group 'nnbabyl-active-number))) + (if (and (null result) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result (car (nnbabyl-save-mail result)))) (set-buffer nnbabyl-mbox-buffer) (goto-char (point-max)) (search-backward "\n\^_") (goto-char (match-end 0)) (insert-buffer-substring buf) (when last + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) (save-buffer) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) result)))) (deffoo nnbabyl-request-replace-article (article group buffer) (nnbabyl-possibly-change-newsgroup group) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (if (not (search-forward (nnbabyl-article-string article) nil t)) nil @@ -358,8 +379,7 @@ ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) ;; Delete all articles in this group. (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) @@ -367,9 +387,10 @@ (while (search-forward ident nil t) (setq found t) (nnbabyl-delete-mail)) - (and found (save-buffer))))) + (when found + (save-buffer))))) ;; Remove the group from all structures. - (setq nnbabyl-group-alist + (setq nnbabyl-group-alist (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist) nnbabyl-current-group nil) ;; Save the active file. @@ -378,8 +399,7 @@ (deffoo nnbabyl-request-rename-group (group new-name &optional server) (nnbabyl-possibly-change-newsgroup group server) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) @@ -387,7 +407,8 @@ (while (search-forward ident nil t) (replace-match new-ident t t) (setq found t)) - (and found (save-buffer)))) + (when found + (save-buffer)))) (let ((entry (assoc group nnbabyl-group-alist))) (and entry (setcar entry new-name)) (setq nnbabyl-current-group nil) @@ -403,39 +424,39 @@ ;; delimiter line. (defun nnbabyl-delete-mail (&optional force leave-delim) ;; Delete the current X-Gnus-Newsgroup line. - (or force - (delete-region - (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (unless force + (delete-region (point-at-bol) (progn (forward-line 1) (point)))) ;; Beginning of the article. (save-excursion (save-restriction (widen) (narrow-to-region (save-excursion - (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (goto-char (point-min)) + (end-of-line)) (if leave-delim (progn (forward-line 1) (point)) (match-beginning 0))) (progn (forward-line 1) - (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) + (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) nil t) (match-beginning 0)) (point-max)))) (goto-char (point-min)) ;; Only delete the article if no other groups owns it as well. - (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) - (delete-region (point-min) (point-max)))))) + (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) + (delete-region (point-min) (point-max)))))) (defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server) - (when (and server + (when (and server (not (nnbabyl-server-opened server))) (nnbabyl-open-server server)) - (if (or (not nnbabyl-mbox-buffer) - (not (buffer-name nnbabyl-mbox-buffer))) - (save-excursion (nnbabyl-read-mbox))) - (or nnbabyl-group-alist - (nnmail-activate 'nnbabyl)) + (when (or (not nnbabyl-mbox-buffer) + (not (buffer-name nnbabyl-mbox-buffer))) + (save-excursion (nnbabyl-read-mbox))) + (unless nnbabyl-group-alist + (nnmail-activate 'nnbabyl)) (if newsgroup (if (assoc newsgroup nnbabyl-group-alist) (setq nnbabyl-current-group newsgroup) @@ -444,31 +465,31 @@ (defun nnbabyl-article-string (article) (if (numberp article) - (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" + (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" (int-to-string article) " ") (concat "\nMessage-ID: " article))) (defun nnbabyl-article-group-number () (save-excursion (goto-char (point-min)) - (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " - nil t) - (cons (buffer-substring (match-beginning 1) (match-end 1)) - (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))))))) + (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " + nil t) + (cons (buffer-substring (match-beginning 1) (match-end 1)) + (string-to-number + (buffer-substring (match-beginning 2) (match-end 2))))))) (defun nnbabyl-insert-lines () "Insert how many lines and chars there are in the body of the mail." (let (lines chars) (save-excursion (goto-char (point-min)) - (when (search-forward "\n\n" nil t) + (when (search-forward "\n\n" nil t) ;; There may be an EOOH line here... (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") (search-forward "\n\n" nil t)) (setq chars (- (point-max) (point)) lines (max (- (count-lines (point) (point-max)) 1) 0)) - ;; Move back to the end of the headers. + ;; Move back to the end of the headers. (goto-char (point-min)) (search-forward "\n\n" nil t) (forward-char -1) @@ -495,19 +516,18 @@ ;; If there is a C-l at the beginning of the narrowed region, this ;; isn't really a "save", but rather a "scan". (goto-char (point-min)) - (or (looking-at "\^L") - (save-excursion - (insert "\^L\n0, unseen,,\n*** EOOH ***\n") - (goto-char (point-max)) - (insert "\^_\n"))) - (if (search-forward "\n\n" nil t) - (progn - (forward-char -1) - (while group-art - (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" - (caar group-art) (cdar group-art) - (current-time-string))) - (setq group-art (cdr group-art))))) + (unless (looking-at "\^L") + (save-excursion + (insert "\^L\n0, unseen,,\n*** EOOH ***\n") + (goto-char (point-max)) + (insert "\^_\n"))) + (when (search-forward "\n\n" nil t) + (forward-char -1) + (while group-art + (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" + (caar group-art) (cdar group-art) + (current-time-string))) + (setq group-art (cdr group-art)))) t)) (defun nnbabyl-active-number (group) @@ -518,41 +538,42 @@ ;; This group is new, so we create a new entry for it. ;; This might be a bit naughty... creating groups on the drop of ;; a hat, but I don't know... - (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 1))) - nnbabyl-group-alist))) + (push (list group (setq active (cons 1 1))) + nnbabyl-group-alist)) (cdr active))) -(defun nnbabyl-read-mbox () - (nnmail-activate 'nnbabyl) +(defun nnbabyl-create-mbox () (unless (file-exists-p nnbabyl-mbox-file) ;; Create a new, empty RMAIL mbox file. - (save-excursion - (set-buffer (setq nnbabyl-mbox-buffer - (create-file-buffer nnbabyl-mbox-file))) + (with-current-buffer (setq nnbabyl-mbox-buffer + (create-file-buffer nnbabyl-mbox-file)) (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") (nnmail-write-region - (point-min) (point-max) nnbabyl-mbox-file t 'nomesg))) - - (if (and nnbabyl-mbox-buffer - (buffer-name nnbabyl-mbox-buffer) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) - (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) - () ; This buffer hasn't changed since we read it last. Possibly. + (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) + +(defun nnbabyl-read-mbox () + (nnmail-activate 'nnbabyl) + (nnbabyl-create-mbox) + + (unless (and nnbabyl-mbox-buffer + (buffer-name nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer + (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) + ;; This buffer has changed since we read it last. Possibly. (save-excursion (let ((delim (concat "^" nnbabyl-mail-delimiter)) (alist nnbabyl-group-alist) start end number) - (set-buffer (setq nnbabyl-mbox-buffer - (nnheader-find-file-noselect - nnbabyl-mbox-file nil 'raw))) + (set-buffer (setq nnbabyl-mbox-buffer + (nnheader-find-file-noselect + nnbabyl-mbox-file nil t))) ;; Save previous buffer mode. - (setq nnbabyl-previous-buffer-mode + (setq nnbabyl-previous-buffer-mode (cons (cons (point-min) (point-max)) major-mode)) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (widen) (setq buffer-read-only nil) (fundamental-mode) @@ -563,20 +584,23 @@ (goto-char (point-max)) (when (and (re-search-backward (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " - (caar alist)) nil t) + (caar alist)) + nil t) (> (setq number - (string-to-number + (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))) (cdadar alist))) - (setcdr (cadar alist) (1+ number))) + (setcdr (cadar alist) number)) (setq alist (cdr alist))) - - ;; We go through the mbox and make sure that each and + + ;; We go through the mbox and make sure that each and ;; every mail belongs to some group or other. (goto-char (point-min)) - (re-search-forward delim nil t) - (setq start (match-end 0)) + (if (looking-at "\^L") + (setq start (point)) + (re-search-forward delim nil t) + (setq start (match-end 0))) (while (re-search-forward delim nil t) (setq end (match-end 0)) (unless (search-backward "\nX-Gnus-Newsgroup: " start t) @@ -584,7 +608,7 @@ (save-excursion (save-restriction (narrow-to-region (goto-char start) end) - (nnbabyl-save-mail + (nnbabyl-save-mail (nnmail-article-group 'nnbabyl-active-number)) (setq end (point-max))))) (goto-char (setq start end))) @@ -611,8 +635,7 @@ (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t) (if (intern-soft (setq id (match-string 1)) idents) (progn - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))) + (delete-region (point-at-bol) (progn (forward-line 1) (point))) (nnheader-message 7 "Moving %s..." id) (nnbabyl-save-mail (nnmail-article-group 'nnbabyl-active-number))) @@ -620,7 +643,7 @@ (when (buffer-modified-p (current-buffer)) (save-buffer)) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) - (message "")))) + (nnheader-message 5 "")))) (provide 'nnbabyl)