X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnmaildir.el;h=829b3761cd3fcc387d0feea0f6ec895f61d1a207;hp=a271f54f5dd4323f3cc5edd3aa6a8a9a5e62a03e;hb=b58d62328adf02b341b460a98819a54a0d629b60;hpb=125d88b46ad2efa065f06d5dac37a245b488985a diff --git a/lisp/nnmaildir.el b/lisp/nnmaildir.el index a271f54f5..829b3761c 100644 --- a/lisp/nnmaildir.el +++ b/lisp/nnmaildir.el @@ -1,5 +1,6 @@ ;;; nnmaildir.el --- maildir backend for Gnus -;; Public domain. + +;; This file is in the public domain. ;; Author: Paul Jarc @@ -7,7 +8,7 @@ ;; 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, @@ -17,8 +18,8 @@ ;; 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: @@ -41,6 +42,8 @@ ;; copying, restoring, etc. ;; ;; Todo: +;; * When moving an article for expiry, copy all the marks except 'expire +;; from the original article. ;; * Add a hook for when moving messages from new/ to cur/, to support ;; nnmail's duplicate detection. ;; * Improve generated Xrefs, so crossposts are detectable. @@ -54,6 +57,7 @@ (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0) (put 'nnmaildir--with-nov-buffer 'lisp-indent-function 0) (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0) + (put 'nnmaildir--condcase 'lisp-indent-function 2) ) ] @@ -240,7 +244,7 @@ by nnmaildir-request-article.") (write-region "" nil file nil 'no-message)) (defun nnmaildir--delete-dir-files (dir ls) (when (file-attributes dir) - (mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort)) + (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort)) (delete-directory dir))) (defun nnmaildir--group-maxnum (server group) @@ -302,9 +306,18 @@ by nnmaildir-request-article.") (setq pos (match-end 0)))) string) +(defmacro nnmaildir--condcase (errsym body &rest handler) + `(condition-case ,errsym + (let ((system-messages-locale "C")) ,body) + (error . ,handler))) + (defun nnmaildir--emlink-p (err) (and (eq (car err) 'file-error) - (string= (caddr err) "too many links"))) + (string= (downcase (caddr err)) "too many links"))) + +(defun nnmaildir--enoent-p (err) + (and (eq (car err) 'file-error) + (string= (downcase (caddr err)) "no such file or directory"))) (defun nnmaildir--eexist-p (err) (eq (car err) 'file-already-exists)) @@ -336,21 +349,20 @@ by nnmaildir-request-article.") ;; and failed. (signal 'error `("Corrupt internal nnmaildir data" ,path-open))) (setq path-link (concat numdir (number-to-string number-link))) - (condition-case err + (nnmaildir--condcase err (progn (add-name-to-file path-open path-link) (throw 'return number-link)) - (error - (cond - ((nnmaildir--emlink-p err) - (setq make-new-file t - number-open number-link)) - ((nnmaildir--eexist-p err) - (let ((attr (file-attributes path-link))) - (if (/= (nth 10 attr) ino-open) - (setq number-open number-link - number-link 0)))) - (t (signal (car err) (cdr err)))))))))) + (cond + ((nnmaildir--emlink-p err) + (setq make-new-file t + number-open number-link)) + ((nnmaildir--eexist-p err) + (let ((attr (file-attributes path-link))) + (if (/= (nth 10 attr) ino-open) + (setq number-open number-link + number-link 0)))) + (t (signal (car err) (cdr err))))))))) (defun nnmaildir--update-nov (server group article) (let ((nnheader-file-coding-system 'binary) @@ -470,7 +482,8 @@ by nnmaildir-request-article.") (prin1 (vector storage-version num msgid nov) (current-buffer)) (setq file (concat novfile ":")) (nnmaildir--unlink file) - (write-region (point-min) (point-max) file nil 'no-message nil 'excl)) + (gmm-write-region (point-min) (point-max) file nil 'no-message nil + 'excl)) (rename-file file novfile 'replace) (setf (nnmaildir--art-msgid article) msgid) nov))) @@ -733,12 +746,10 @@ by nnmaildir-request-article.") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Maildir spans filesystems: " absdir)) (throw 'return nil)) - (mapcar - (lambda (file) - (setq x (file-attributes file)) - (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago)) - (delete-file file))) - (funcall ls tdir 'full "\\`[^.]" 'nosort))) + (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort)) + (setq x (file-attributes file)) + (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago)) + (delete-file file)))) (or scan-msgs isnew (throw 'return t)) @@ -747,12 +758,10 @@ by nnmaildir-request-article.") (setq nattr nil)) (if read-only (setq dir (and (or isnew nattr) ndir)) (when (or isnew nattr) - (mapcar - (lambda (file) - (let ((path (concat ndir file))) - (and (time-less-p (nth 5 (file-attributes path)) (current-time)) - (rename-file path (concat cdir file ":2,"))))) - (funcall ls ndir nil "\\`[^.]" 'nosort)) + (dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort)) + (setq x (concat ndir file)) + (and (time-less-p (nth 5 (file-attributes x)) (current-time)) + (rename-file x (concat cdir file ":2,")))) (setf (nnmaildir--grp-new group) nattr)) (setq cattr (nth 5 (file-attributes cdir))) (if (equal cattr (nnmaildir--grp-cur group)) @@ -777,13 +786,11 @@ by nnmaildir-request-article.") cdir (nnmaildir--marks-dir nndir) ndir (nnmaildir--subdir cdir "tick") cdir (nnmaildir--subdir cdir "read")) - (mapcar - (lambda (file) - (setq file (car file)) - (if (or (not (file-exists-p (concat cdir file))) - (file-exists-p (concat ndir file))) - (setq num (1+ num)))) - files)) + (dolist (file files) + (setq file (car file)) + (if (or (not (file-exists-p (concat cdir file))) + (file-exists-p (concat ndir file))) + (setq num (1+ num))))) (setf (nnmaildir--grp-cache group) (make-vector num nil)) (let ((inhibit-quit t)) (set (intern gname groups) group)) @@ -797,12 +804,10 @@ by nnmaildir-request-article.") files (delq nil files) files (mapcar 'nnmaildir--parse-filename files) files (sort files 'nnmaildir--sort-files)) - (mapcar - (lambda (file) - (setq file (if (consp file) file (aref file 3)) - x (make-nnmaildir--art :prefix (car file) :suffix (cdr file))) - (nnmaildir--grp-add-art nnmaildir--cur-server group x)) - files) + (dolist (file files) + (setq file (if (consp file) file (aref file 3)) + x (make-nnmaildir--art :prefix (car file) :suffix (cdr file))) + (nnmaildir--grp-add-art nnmaildir--cur-server group x)) (if read-only (setf (nnmaildir--grp-new group) nattr) (setf (nnmaildir--grp-cur group) cattr))) t)) @@ -849,19 +854,18 @@ by nnmaildir-request-article.") dirs)) seen (nnmaildir--up2-1 (length dirs)) seen (make-vector seen 0)) - (mapcar - (lambda (grp-dir) - (if (nnmaildir--scan grp-dir scan-group groups method srv-dir - srv-ls) - (intern grp-dir seen))) - dirs) + (dolist (grp-dir dirs) + (if (nnmaildir--scan grp-dir scan-group groups method srv-dir + srv-ls) + (intern grp-dir seen))) (setq x nil) (mapatoms (lambda (group) (setq group (symbol-name group)) (unless (intern-soft group seen) (setq x (cons group x)))) groups) - (mapcar (lambda (grp) (unintern grp groups)) x) + (dolist (grp x) + (unintern grp groups)) (setf (nnmaildir--srv-mtime nnmaildir--cur-server) (nth 5 (file-attributes srv-dir)))) (and scan-group @@ -880,7 +884,9 @@ by nnmaildir-request-article.") pgname (nnmaildir--pgname nnmaildir--cur-server pgname) group (symbol-value group) ro (nnmaildir--param pgname 'read-only)) - (insert (nnmaildir--grp-name group) " ") + (insert (gnus-replace-in-string + (nnmaildir--grp-name group) " " "\\ " t) + " ") (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) (insert " ") @@ -897,26 +903,27 @@ by nnmaildir-request-article.") (nnmaildir--prepare server nil) (nnmaildir--with-nntp-buffer (erase-buffer) - (mapcar - (lambda (gname) - (setq group (nnmaildir--prepare nil gname)) - (if (null group) (insert "411 no such news group\n") - (insert "211 ") - (princ (nnmaildir--grp-count group) nntp-server-buffer) - (insert " ") - (princ (nnmaildir--grp-min group) nntp-server-buffer) - (insert " ") - (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) - nntp-server-buffer) - (insert " " gname "\n"))) - groups))) + (dolist (gname groups) + (setq group (nnmaildir--prepare nil gname)) + (if (null group) (insert "411 no such news group\n") + (insert "211 ") + (princ (nnmaildir--grp-count group) nntp-server-buffer) + (insert " ") + (princ (nnmaildir--grp-min group) nntp-server-buffer) + (insert " ") + (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) + nntp-server-buffer) + (insert " " + (gnus-replace-in-string gname " " "\\ " t) + "\n"))))) 'group) (defun nnmaildir-request-update-info (gname info &optional server) (let ((group (nnmaildir--prepare server gname)) pgname flist always-marks never-marks old-marks dotfile num dir markdirs marks mark ranges markdir article read end new-marks ls - old-mmth new-mmth mtime mark-sym existing missing deactivate-mark) + old-mmth new-mmth mtime mark-sym existing missing deactivate-mark + article-list) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) @@ -949,33 +956,30 @@ by nnmaildir-request-article.") new-mmth (nnmaildir--up2-1 (length markdirs)) new-mmth (make-vector new-mmth 0) old-mmth (nnmaildir--grp-mmth group)) - (mapcar - (lambda (mark) - (setq markdir (nnmaildir--subdir dir mark) - mark-sym (intern mark) - ranges nil) - (catch 'got-ranges - (if (memq mark-sym never-marks) (throw 'got-ranges nil)) - (when (memq mark-sym always-marks) - (setq ranges existing) - (throw 'got-ranges nil)) - (setq mtime (nth 5 (file-attributes markdir))) - (set (intern mark new-mmth) mtime) - (when (equal mtime (symbol-value (intern-soft mark old-mmth))) - (setq ranges (assq mark-sym old-marks)) - (if ranges (setq ranges (cdr ranges))) - (throw 'got-ranges nil)) - (mapcar - (lambda (prefix) - (setq article (nnmaildir--flist-art flist prefix)) - (if article - (setq ranges - (gnus-add-to-range ranges - `(,(nnmaildir--art-num article)))))) - (funcall ls markdir nil "\\`[^.]" 'nosort))) - (if (eq mark-sym 'read) (setq read ranges) - (if ranges (setq marks (cons (cons mark-sym ranges) marks))))) - markdirs) + (dolist (mark markdirs) + (setq markdir (nnmaildir--subdir dir mark) + mark-sym (intern mark) + ranges nil) + (catch 'got-ranges + (if (memq mark-sym never-marks) (throw 'got-ranges nil)) + (when (memq mark-sym always-marks) + (setq ranges existing) + (throw 'got-ranges nil)) + (setq mtime (nth 5 (file-attributes markdir))) + (set (intern mark new-mmth) mtime) + (when (equal mtime (symbol-value (intern-soft mark old-mmth))) + (setq ranges (assq mark-sym old-marks)) + (if ranges (setq ranges (cdr ranges))) + (throw 'got-ranges nil)) + (setq article-list nil) + (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort)) + (setq article (nnmaildir--flist-art flist prefix)) + (if article + (setq article-list + (cons (nnmaildir--art-num article) article-list)))) + (setq ranges (gnus-add-to-range ranges (sort article-list '<)))) + (if (eq mark-sym 'read) (setq read ranges) + (if ranges (setq marks (cons (cons mark-sym ranges) marks))))) (gnus-info-set-read info (gnus-range-add read missing)) (gnus-info-set-marks info marks 'extend) (setf (nnmaildir--grp-mmth group) new-mmth) @@ -1001,7 +1005,7 @@ by nnmaildir-request-article.") (insert " ") (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) - (insert " " gname "\n") + (insert " " (gnus-replace-in-string gname " " "\\ " t) "\n") t)))) (defun nnmaildir-request-create-group (gname &optional server args) @@ -1019,7 +1023,7 @@ by nnmaildir-request-article.") (throw 'return nil)) (when (save-match-data (string-match "[\0/\t]" gname)) (setf (nnmaildir--srv-error nnmaildir--cur-server) - (concat "Illegal characters (null, tab, or /) in group name: " + (concat "Invalid characters (null, tab, or /) in group name: " gname)) (throw 'return nil)) (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)) @@ -1064,7 +1068,7 @@ by nnmaildir-request-article.") (throw 'return nil)) (when (save-match-data (string-match "[\0/\t]" new-name)) (setf (nnmaildir--srv-error nnmaildir--cur-server) - (concat "Illegal characters (null, tab, or /) in group name: " + (concat "Invalid characters (null, tab, or /) in group name: " new-name)) (throw 'return nil)) (if (string-equal gname new-name) (throw 'return t)) @@ -1127,10 +1131,10 @@ by nnmaildir-request-article.") (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls) (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls)) (setq dir (nnmaildir--nndir grp-dir)) - (mapcar (lambda (subdir) (nnmaildir--delete-dir-files subdir ls)) - `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir) - ,@(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" - 'nosort))) + (dolist (subdir `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir) + ,@(funcall ls (nnmaildir--marks-dir dir) + 'full "\\`[^.]" 'nosort))) + (nnmaildir--delete-dir-files subdir ls)) (setq dir (nnmaildir--nndir grp-dir)) (nnmaildir--unlink (concat dir "markfile")) (nnmaildir--unlink (concat dir "markfile{new}")) @@ -1163,7 +1167,7 @@ by nnmaildir-request-article.") (insert "\t" (nnmaildir--nov-get-beg nov) "\t" (nnmaildir--art-msgid article) "\t" (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " - gname ":") + (gnus-replace-in-string gname " " "\\ " t) ":") (princ num nntp-server-buffer) (insert "\t" (nnmaildir--nov-get-end nov) "\n")))) (catch 'return @@ -1184,11 +1188,9 @@ by nnmaildir-request-article.") (nnmaildir--nlist-iterate nlist 'all insert-nov)) ((null articles)) ((stringp (car articles)) - (mapcar - (lambda (msgid) - (setq article (nnmaildir--mlist-art mlist msgid)) - (if article (funcall insert-nov article))) - articles)) + (dolist (msgid articles) + (setq article (nnmaildir--mlist-art mlist msgid)) + (if article (funcall insert-nov article)))) (t (if fetch-old ;; Assume the article range list is sorted ascending @@ -1287,14 +1289,14 @@ by nnmaildir-request-article.") (throw 'return nil)) (save-excursion (set-buffer buffer) - (write-region (point-min) (point-max) tmpfile nil 'no-message nil - 'excl)) + (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil + 'excl)) (unix-sync) ;; no fsync :( (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace) t))) (defun nnmaildir-request-move-article (article gname server accept-form - &optional last) + &optional last move-is-internal) (let ((group (nnmaildir--prepare server gname)) pgname suffix result nnmaildir--file deactivate-mark) (catch 'return @@ -1379,13 +1381,12 @@ by nnmaildir-request-article.") nnmaildir--cur-server) "24-hour timer expired") (throw 'return nil)))) - (condition-case nil - (add-name-to-file nnmaildir--file tmpfile) + (condition-case nil (add-name-to-file nnmaildir--file tmpfile) (error - (write-region (point-min) (point-max) tmpfile nil 'no-message nil - 'excl) + (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil + 'excl) (unix-sync))) ;; no fsync :( - (cancel-timer 24h) + (nnheader-cancel-timer 24h) (condition-case err (add-name-to-file tmpfile curfile) (error @@ -1510,7 +1511,12 @@ by nnmaildir-request-article.") (not (string-equal target pgname))) ;; Move it. (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) - (gnus-request-accept-article target nil nil 'no-encode)) + (let ((group-art (gnus-request-accept-article + target nil nil 'no-encode))) + (when (consp group-art) + ;; Maybe also copy: dormant forward reply save tick + ;; (gnus-add-mark? gnus-request-set-mark?) + (gnus-group-mark-article-read target (cdr group-art))))) (if (equal target pgname) ;; Leave it here. (setq didnt (cons (nnmaildir--art-num article) didnt)) @@ -1540,22 +1546,19 @@ by nnmaildir-request-article.") (setq mdir (nnmaildir--subdir marksdir (symbol-name mark)) permarkfile (concat mdir ":") mfile (concat mdir (nnmaildir--art-prefix article))) - (condition-case err - (add-name-to-file permarkfile mfile) - (error - (cond - ((nnmaildir--eexist-p err)) - ((and (eq (car err) 'file-error) - (string= (caddr err) "no such file or directory")) - (nnmaildir--mkdir mdir) - (nnmaildir--mkfile permarkfile) - (add-name-to-file permarkfile mfile)) - ((nnmaildir--emlink-p err) - (let ((permarkfilenew (concat permarkfile "{new}"))) - (nnmaildir--mkfile permarkfilenew) - (rename-file permarkfilenew permarkfile 'replace) - (add-name-to-file permarkfile mfile))) - (t (signal (car err) (cdr err))))))) + (nnmaildir--condcase err (add-name-to-file permarkfile mfile) + (cond + ((nnmaildir--eexist-p err)) + ((nnmaildir--enoent-p err) + (nnmaildir--mkdir mdir) + (nnmaildir--mkfile permarkfile) + (add-name-to-file permarkfile mfile)) + ((nnmaildir--emlink-p err) + (let ((permarkfilenew (concat permarkfile "{new}"))) + (nnmaildir--mkfile permarkfilenew) + (rename-file permarkfilenew permarkfile 'replace) + (add-name-to-file permarkfile mfile))) + (t (signal (car err) (cdr err)))))) todo-marks)) set-action (lambda (article) (funcall add-action) @@ -1567,9 +1570,8 @@ by nnmaildir-request-article.") (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) - (mapcar (lambda (action) - (setq ranges (gnus-range-add ranges (car action)))) - actions) + (dolist (action actions) + (setq ranges (gnus-range-add ranges (car action)))) (throw 'return ranges)) (setq nlist (nnmaildir--grp-nlist group) marksdir (nnmaildir--srv-dir nnmaildir--cur-server) @@ -1581,17 +1583,16 @@ by nnmaildir-request-article.") ls (nnmaildir--group-ls nnmaildir--cur-server pgname) all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort) all-marks (mapcar 'intern all-marks)) - (mapcar - (lambda (action) - (setq ranges (car action) - todo-marks (caddr action)) - (mapcar (lambda (mark) (add-to-list 'all-marks mark)) todo-marks) - (if (numberp (cdr ranges)) (setq ranges (list ranges))) - (nnmaildir--nlist-iterate nlist ranges - (cond ((eq 'del (cadr action)) del-action) - ((eq 'add (cadr action)) add-action) - (t set-action)))) - actions) + (dolist (action actions) + (setq ranges (car action) + todo-marks (caddr action)) + (dolist (mark todo-marks) + (add-to-list 'all-marks mark)) + (if (numberp (cdr ranges)) (setq ranges (list ranges))) + (nnmaildir--nlist-iterate nlist ranges + (cond ((eq 'del (cadr action)) del-action) + ((eq 'add (cadr action)) add-action) + (t set-action)))) nil))) (defun nnmaildir-close-group (gname &optional server) @@ -1620,22 +1621,16 @@ by nnmaildir-request-article.") flist (nnmaildir--up2-1 (length files)) flist (make-vector flist 0)) (save-match-data - (mapcar - (lambda (file) - (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) - (intern (match-string 1 file) flist)) - files)) - (mapcar - (lambda (dir) - (setq files (cdr dir) - dir (file-name-as-directory (car dir))) - (mapcar - (lambda (file) - (unless (or (intern-soft file flist) (string= file ":")) - (setq file (concat dir file)) - (delete-file file))) - files)) - dirs) + (dolist (file files) + (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) + (intern (match-string 1 file) flist))) + (dolist (dir dirs) + (setq files (cdr dir) + dir (file-name-as-directory (car dir))) + (dolist (file files) + (unless (or (intern-soft file flist) (string= file ":")) + (setq file (concat dir file)) + (delete-file file)))) t))) (defun nnmaildir-close-server (&optional server) @@ -1652,7 +1647,7 @@ by nnmaildir-request-article.") (mapatoms (lambda (server) (setq servers (cons (symbol-name server) servers))) nnmaildir--servers) - (mapcar 'nnmaildir-close-server servers) + (mapc 'nnmaildir-close-server servers) (setq buffer (get-buffer " *nnmaildir work*")) (if buffer (kill-buffer buffer)) (setq buffer (get-buffer " *nnmaildir nov*"))