X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnml.el;h=b35c04514f1765b652073bc42e29939029f6ac71;hb=924913e6cedd0aeaeef01a251afa770a86c01815;hp=5e0924d38cc14df6ab62c0f21038fef48a1fc82e;hpb=4f4ec0da7512fb94e604997f836c1297d82be173;p=gnus diff --git a/lisp/nnml.el b/lisp/nnml.el index 5e0924d38..b35c04514 100644 --- a/lisp/nnml.el +++ b/lisp/nnml.el @@ -58,12 +58,13 @@ all. This may very well take some time.") -(defconst nnml-version "nnml 0.2" +(defconst nnml-version "nnml 1.0" "nnml version.") (defvar nnml-nov-file-name ".overview") (defvar nnml-current-directory nil) +(defvar nnml-current-group nil) (defvar nnml-status-string "") (defvar nnml-nov-buffer-alist nil) (defvar nnml-group-alist nil) @@ -84,6 +85,7 @@ all. This may very well take some time.") (list 'nnml-nov-is-evil nnml-nov-is-evil) (list 'nnml-nov-file-name nnml-nov-file-name) '(nnml-current-directory nil) + '(nnml-current-group nil) '(nnml-status-string "") '(nnml-nov-buffer-alist nil) '(nnml-group-alist nil) @@ -93,7 +95,7 @@ all. This may very well take some time.") ;;; Interface functions. -(defun nnml-retrieve-headers (sequence &optional newsgroup server) +(defun nnml-retrieve-headers (sequence &optional newsgroup server fetch-old) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) @@ -101,45 +103,47 @@ all. This may very well take some time.") (number (length sequence)) (count 0) beg article) - (nnml-possibly-change-directory newsgroup) - (if (nnml-retrieve-headers-with-nov sequence) - 'nov - (while sequence - (setq article (car sequence)) - (setq file - (concat nnml-current-directory (prin1-to-string article))) - (if (and (file-exists-p file) - (not (file-directory-p file))) - (progn - (insert (format "221 %d Article retrieved.\n" article)) - (setq beg (point)) - (insert-file-contents file) - (goto-char beg) - (if (search-forward "\n\n" nil t) - (forward-char -1) - (goto-char (point-max)) - (insert "\n\n")) - (insert ".\n") - (delete-region (point) (point-max)))) - (setq sequence (cdr sequence)) - (setq count (1+ count)) + (if (stringp (car sequence)) + 'headers + (nnml-possibly-change-directory newsgroup) + (if (nnml-retrieve-headers-with-nov sequence fetch-old) + 'nov + (while sequence + (setq article (car sequence)) + (setq file + (concat nnml-current-directory (int-to-string article))) + (if (and (file-exists-p file) + (not (file-directory-p file))) + (progn + (insert (format "221 %d Article retrieved.\n" article)) + (setq beg (point)) + (nnheader-insert-head file) + (goto-char beg) + (if (search-forward "\n\n" nil t) + (forward-char -1) + (goto-char (point-max)) + (insert "\n\n")) + (insert ".\n") + (delete-region (point) (point-max)))) + (setq sequence (cdr sequence)) + (setq count (1+ count)) + (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup) + (zerop (% count 20)) + gnus-verbose-backends + (message "nnml: Receiving headers... %d%%" + (/ (* count 100) number)))) + (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) - (zerop (% count 20)) gnus-verbose-backends - (message "nnml: Receiving headers... %d%%" - (/ (* count 100) number)))) + (message "nnml: Receiving headers...done")) - (and (numberp nnmail-large-newsgroup) - (> number nnmail-large-newsgroup) - gnus-verbose-backends - (message "nnml: Receiving headers... done")) - - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - 'headers)))) + ;; Fold continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) + (replace-match " " t t)) + 'headers))))) (defun nnml-open-server (server &optional defs) (nnheader-init-server-buffer) @@ -171,15 +175,22 @@ all. This may very well take some time.") (defun nnml-request-article (id &optional newsgroup server buffer) (nnml-possibly-change-directory newsgroup) - (let ((file (if (stringp id) - nil - (concat nnml-current-directory (prin1-to-string id)))) - (nntp-server-buffer (or buffer nntp-server-buffer))) - (if (and (stringp file) - (file-exists-p file) - (not (file-directory-p file))) - (save-excursion - (nnmail-find-file file))))) + (let* ((group-num (and (stringp id) (nnml-find-group-number id))) + (number (if (numberp id) id (cdr group-num))) + (file + (and number + (concat + (if (numberp id) + nnml-current-directory + (nnmail-article-pathname (car group-num) nnml-directory)) + (int-to-string number)))) + (nntp-server-buffer (or buffer nntp-server-buffer))) + (and file + (file-exists-p file) + (not (file-directory-p file)) + (save-excursion (nnmail-find-file file)) + ;; We return the article number. + (cons newsgroup (string-to-int (file-name-nondirectory file)))))) (defun nnml-request-group (group &optional server dont-check) (if (not (nnml-possibly-change-directory group)) @@ -188,25 +199,20 @@ all. This may very well take some time.") nil) (if dont-check t - (nnml-get-new-mail group) - (let ((timestamp (nth 5 (file-attributes nnml-active-file)))) - (if (or (not nnml-active-timestamp) - (> (nth 0 timestamp) (nth 0 nnml-active-timestamp)) - (> (nth 1 timestamp) (nth 1 nnml-active-timestamp))) - (progn - (setq nnml-active-timestamp timestamp) - (nnml-request-list) - (setq nnml-group-alist (nnmail-get-active)))) - (let ((active (nth 1 (assoc group nnml-group-alist)))) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (if (not active) - () - (insert (format "211 %d %d %d %s\n" - (max (1+ (- (cdr active) (car active))) 0) - (car active) (cdr active) group)) - t))))))) + (nnmail-activate 'nnml) + (let ((active (nth 1 (assoc group nnml-group-alist)))) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (if (not active) + () + (insert (format "211 %d %d %d %s\n" + (max (1+ (- (cdr active) (car active))) 0) + (car active) (cdr active) group)) + t)))))) + +(defun nnml-request-scan (&optional group server) + (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group)) (defun nnml-close-group (group &optional server) t) @@ -217,11 +223,10 @@ all. This may very well take some time.") t) (defun nnml-request-create-group (group &optional server) - (nnml-request-list) - (setq nnml-group-alist (nnmail-get-active)) + (nnmail-activate 'nnml) (or (assoc group nnml-group-alist) (let (active) - (setq nnml-group-alist (cons (list group (setq active (cons 0 0))) + (setq nnml-group-alist (cons (list group (setq active (cons 1 0))) nnml-group-alist)) (nnml-possibly-create-directory group) (nnml-possibly-change-directory group) @@ -238,7 +243,6 @@ all. This may very well take some time.") t) (defun nnml-request-list (&optional server) - (if server (nnml-get-new-mail)) (save-excursion (nnmail-find-file nnml-active-file) (setq nnml-group-alist (nnmail-get-active)))) @@ -253,8 +257,6 @@ all. This may very well take some time.") (defun nnml-request-post (&optional server) (mail-send-and-exit nil)) -(fset 'nnml-request-post-buffer 'nnmail-request-post-buffer) - (defun nnml-request-expire-articles (articles newsgroup &optional server force) (nnml-possibly-change-directory newsgroup) (let* ((days (or (and nnmail-expiry-wait-function @@ -267,24 +269,32 @@ all. This may very well take some time.") (string-to-int name))) (directory-files nnml-current-directory nil "^[0-9]+$" t))) (max-article (and active-articles (apply 'max active-articles))) + (is-old t) article rest mod-time) - (while articles - (setq article (concat nnml-current-directory (int-to-string - (car articles)))) + (nnmail-activate 'nnml) + + (while (and articles is-old) + (setq article (concat nnml-current-directory + (int-to-string (car articles)))) (if (setq mod-time (nth 5 (file-attributes article))) (if (and (or (not nnmail-keep-last-article) (not max-article) (not (= (car articles) max-article))) (or force - (> (nnmail-days-between - (current-time-string) - (current-time-string mod-time)) - days))) + (and (not (equal mod-time '(0 0))) + (setq is-old + (> (nnmail-days-between + (current-time-string) + (current-time-string mod-time)) + days))))) (progn - (and gnus-verbose-backends (message "Deleting %s..." article)) + (and gnus-verbose-backends + (message "Deleting article %s in %s..." + article newsgroup)) (condition-case () - (delete-file article) - (file-error nil)) + (funcall nnmail-delete-file-function article) + (file-error + (setq rest (cons (car articles) rest)))) (setq active-articles (delq (car articles) active-articles)) (nnml-nov-delete-article newsgroup (car articles))) (setq rest (cons (car articles) rest)))) @@ -297,7 +307,7 @@ all. This may very well take some time.") (nnmail-save-active nnml-group-alist nnml-active-file)) (nnml-save-nov) (message "") - rest)) + (nconc rest articles))) (defun nnml-request-move-article (article group server accept-form &optional last) @@ -313,8 +323,9 @@ all. This may very well take some time.") result) (progn (condition-case () - (delete-file (concat nnml-current-directory - (int-to-string article))) + (funcall nnmail-delete-file-function + (concat nnml-current-directory + (int-to-string article))) (file-error nil)) (nnml-nov-delete-article group article) (and last (nnml-save-nov)))) @@ -324,8 +335,7 @@ all. This may very well take some time.") (let (result) (if (stringp group) (and - (nnml-request-list) - (setq nnml-group-alist (nnmail-get-active)) + (nnmail-activate 'nnml) ;; We trick the choosing function into believing that only one ;; group is availiable. (let ((nnmail-split-methods (list (list group "")))) @@ -334,8 +344,7 @@ all. This may very well take some time.") (nnmail-save-active nnml-group-alist nnml-active-file) (and last (nnml-save-nov)))) (and - (nnml-request-list) - (setq nnml-group-alist (nnmail-get-active)) + (nnmail-activate 'nnml) (setq result (car (nnml-save-mail))) (progn (nnmail-save-active nnml-group-alist nnml-active-file) @@ -360,24 +369,128 @@ all. This may very well take some time.") (art (concat (int-to-string article) "\t")) nov-line) (setq nov-line (nnml-make-nov-line chars)) + ;; Replace the NOV line in the NOV file. (save-excursion (set-buffer (nnml-open-nov group)) (goto-char (point-min)) (if (or (looking-at art) - (search-forward (concat "\n" art))) - (progn - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))) - (insert (int-to-string article) nov-line) - (nnml-save-nov)) - (kill-buffer (current-buffer))) + (search-forward (concat "\n" art) nil t)) + ;; Delete the old NOV line. + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point))) + ;; The line isn't here, so we have to find out where + ;; we should insert it. (This situation should never + ;; occur, but one likes to make sure...) + (while (and (looking-at "[0-9]+\t") + (< (string-to-int + (buffer-substring + (match-beginning 0) (match-end 0))) + article) + (zerop (forward-line 1))))) + (beginning-of-line) + (insert (int-to-string article) nov-line) + (nnml-save-nov) t))))) +(defun nnml-request-delete-group (group &optional force server) + (nnml-possibly-change-directory group) + ;; Delete all articles in GROUP. + (if (not force) + () ; Don't delete the articles. + (let ((articles + (directory-files + nnml-current-directory t + (concat "^[0-9]+$\\|" (regexp-quote nnml-nov-file-name) "$")))) + (while articles + (and (file-writable-p (car articles)) + (progn + (and gnus-verbose-backends + (message (message "Deleting article %s in %s..." + (car articles) group))) + (funcall nnmail-delete-file-function (car articles)))) + (setq articles (cdr articles)))) + ;; Try to delete the directory itself. + (condition-case () + (delete-directory nnml-current-directory) + (error nil))) + ;; Remove the group from all structures. + (setq nnml-group-alist + (delq (assoc group nnml-group-alist) nnml-group-alist) + nnml-current-group nil + nnml-current-directory nil) + ;; Save the active file. + (nnmail-save-active nnml-group-alist nnml-active-file) + t) + +(defun nnml-request-rename-group (group new-name &optional server) + (nnml-possibly-change-directory group) + ;; Rename directory. + (and (file-writable-p nnml-current-directory) + (condition-case () + (progn + (rename-file + (directory-file-name nnml-current-directory) + (directory-file-name + (nnmail-article-pathname new-name nnml-directory))) + t) + (error nil)) + ;; That went ok, so we change the internal structures. + (let ((entry (assoc group nnml-group-alist))) + (and entry (setcar entry new-name)) + (setq nnml-current-directory nil + nnml-current-group nil) + ;; Save the new group alist. + (nnmail-save-active nnml-group-alist nnml-active-file) + t))) -;;; Internal functions +;;; Internal functions. -(defun nnml-retrieve-headers-with-nov (articles) +;; Find an article number in the current group given the Message-ID. +(defun nnml-find-group-number (id) + (save-excursion + (set-buffer (get-buffer-create " *nnml id*")) + (buffer-disable-undo (current-buffer)) + (let ((alist nnml-group-alist) + number) + ;; We want to look through all .overview files, but we want to + ;; start with the one in the current directory. It seems most + ;; likely that the article we are looking for is in that group. + (if (setq number (nnml-find-id nnml-current-group id)) + (cons nnml-current-group number) + ;; It wasn't there, so we look through the other groups as well. + (while (and (not number) + alist) + (or (string= (car (car alist)) nnml-current-group) + (setq number (nnml-find-id (car (car alist)) id))) + (or number + (setq alist (cdr alist)))) + (and number + (cons (car (car alist)) number)))))) + +(defun nnml-find-id (group id) + (erase-buffer) + (insert-file-contents + (concat (nnmail-article-pathname group nnml-directory) + nnml-nov-file-name)) + (let (number found) + (while (and (not found) + (search-forward id nil t)) ; We find the ID. + ;; And the id is in the fourth field. + (if (search-backward + "\t" (save-excursion (beginning-of-line) (point)) t 4) + (progn + (beginning-of-line) + (setq found t) + ;; We return the article number. + (setq number + (condition-case () + (read (current-buffer)) + (error nil)))))) + number)) + + +(defun nnml-retrieve-headers-with-nov (articles &optional fetch-old) (if (or gnus-nov-is-evil nnml-nov-is-evil) nil (let ((first (car articles)) @@ -389,22 +502,28 @@ all. This may very well take some time.") (set-buffer nntp-server-buffer) (erase-buffer) (insert-file-contents nov) - (goto-char (point-min)) - (while (and (not (eobp)) (< first (read (current-buffer)))) - (forward-line 1)) - (beginning-of-line) - (if (not (eobp)) (delete-region 1 (point))) - (while (and (not (eobp)) (>= last (read (current-buffer)))) - (forward-line 1)) - (beginning-of-line) - (if (not (eobp)) (delete-region (point) (point-max))) - t))))) + (if (and fetch-old + (not (numberp fetch-old))) + t ; Don't remove anything. + (if fetch-old + (setq first (max 1 (- first fetch-old)))) + (goto-char (point-min)) + (while (and (not (eobp)) (< first (read (current-buffer)))) + (forward-line 1)) + (beginning-of-line) + (if (not (eobp)) (delete-region 1 (point))) + (while (and (not (eobp)) (>= last (read (current-buffer)))) + (forward-line 1)) + (beginning-of-line) + (if (not (eobp)) (delete-region (point) (point-max))) + t)))))) (defun nnml-possibly-change-directory (newsgroup &optional force) (if newsgroup (let ((pathname (nnmail-article-pathname newsgroup nnml-directory))) (and (or force (file-directory-p pathname)) - (setq nnml-current-directory pathname))) + (setq nnml-current-directory pathname + nnml-current-group newsgroup))) t)) (defun nnml-possibly-create-directory (group) @@ -414,8 +533,7 @@ all. This may very well take some time.") (setq dirs (cons dir dirs)) (setq dir (file-name-directory (directory-file-name dir)))) (while dirs - (if (make-directory (directory-file-name (car dirs))) - (error "Could not create directory %s" (car dirs))) + (make-directory (directory-file-name (car dirs))) (and gnus-verbose-backends (message "Creating mail directory %s" (car dirs))) (setq dirs (cdr dirs))))) @@ -461,68 +579,19 @@ all. This may very well take some time.") (defun nnml-active-number (group) "Compute the next article number in GROUP." (let ((active (car (cdr (assoc group nnml-group-alist))))) + ;; The group wasn't known to nnml, so we just create an active + ;; entry for it. (or active (progn (setq active (cons 1 0)) (setq nnml-group-alist (cons (list group active) nnml-group-alist)))) (setcdr active (1+ (cdr active))) - (let (file) - (while (file-exists-p - (setq file (concat (nnmail-article-pathname - group nnml-directory) - (int-to-string (cdr active))))) - (setcdr active (1+ (cdr active))))) + (while (file-exists-p + (concat (nnmail-article-pathname group nnml-directory) + (int-to-string (cdr active)))) + (setcdr active (1+ (cdr active)))) (cdr active))) -(defun nnml-get-new-mail (&optional group) - "Read new incoming mail." - (let ((spools (nnmail-get-spool-files group)) - incoming incomings) - (if (or (not nnml-get-new-mail) (not nnmail-spool-file)) - () - ;; We first activate all the groups. - (nnml-request-list) - (setq nnml-group-alist (nnmail-get-active)) - ;; The we go through all the existing spool files and split the - ;; mail from each. - (while spools - (and - (file-exists-p (car spools)) - (> (nth 7 (file-attributes (car spools))) 0) - (progn - (and gnus-verbose-backends - (message "nnml: Reading incoming mail...")) - (setq incoming - (nnmail-move-inbox - (car spools) (concat nnml-directory "Incoming"))) - (nnmail-split-incoming incoming 'nnml-save-mail) - (setq incomings (cons incoming incomings)) - ;; The following has been commented away, just to make sure - ;; that nobody ever loses any mail. If you feel safe that - ;; nnml will never do anything strange, just remove those - ;; two semicolons, and avoid having lots of "Incoming*" - ;; files. - ;; (delete-file incoming) - )) - (setq spools (cdr spools))) - ;; If we did indeed read any incoming spools, we save all info. - (if incoming - (progn - (nnmail-save-active nnml-group-alist nnml-active-file) - (nnml-save-nov) - (run-hooks 'nnmail-read-incoming-hook) - (and gnus-verbose-backends - (message "nnml: Reading incoming mail...done")))) - (while incomings - ;; The following has been commented away, just to make sure - ;; that nobody ever loses any mail. If you feel safe that - ;; nnfolder will never do anything strange, just remove those - ;; two semicolons, and avoid having lots of "Incoming*" - ;; files. - ;; (and (file-writable-p incoming) (delete-file incoming)) - (setq incomings (cdr incomings)))))) - - (defun nnml-add-nov (group article line) "Add a nov line for the GROUP base." (save-excursion @@ -657,7 +726,7 @@ all. This may very well take some time.") (save-excursion (set-buffer nntp-server-buffer) (if (file-exists-p nov) - (delete-file nov)) + (funcall nnmail-delete-file-function nov)) (save-excursion (set-buffer nov-buffer) (buffer-disable-undo (current-buffer)) @@ -670,7 +739,7 @@ all. This may very well take some time.") (setq chars (- (point-max) (point))) (point))) - (if (not (= 0 chars)) ; none of them empty files... + (if (not (= 0 chars)) ; none of them empty files... (progn (setq nov-line (nnml-make-nov-line chars)) (save-excursion