X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnmaildir.el;h=5b72b52079d4d874f4f9fb3287daf5fbcf64ae79;hp=fd16969836f0dc8c78d7635de6f0e3900e01c366;hb=90f7e57cdbebca17652f43459b3f5dfbfb26d7fa;hpb=0da64b228e766eda681d2f3a37e8664b689799d4 diff --git a/lisp/nnmaildir.el b/lisp/nnmaildir.el index fd1696983..5b72b5207 100644 --- a/lisp/nnmaildir.el +++ b/lisp/nnmaildir.el @@ -1,14 +1,15 @@ ;;; nnmaildir.el --- maildir backend for Gnus -;; Public domain. + +;; This file is in the public domain. ;; Author: Paul Jarc ;; 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 @@ -16,9 +17,7 @@ ;; 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: @@ -41,6 +40,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. @@ -58,20 +59,71 @@ ) ] -(eval-and-compile - (require 'nnheader) - (require 'gnus) - (require 'gnus-util) - (require 'gnus-range) - (require 'gnus-start) - (require 'gnus-int) - (require 'message)) +(require 'nnheader) +(require 'gnus) +(require 'gnus-util) +(require 'gnus-range) +(require 'gnus-start) +(require 'gnus-int) +(require 'message) +(require 'nnmail) + (eval-when-compile - (require 'cl) - (require 'nnmail)) + (require 'cl)) (defconst nnmaildir-version "Gnus") +(defconst nnmaildir-flag-mark-mapping + '((?F . tick) + (?P . forward) + (?R . reply) + (?S . read)) + "Alist mapping Maildir filename flags to Gnus marks. +Maildir filenames are of the form \"unique-id:2,FLAGS\", +where FLAGS are a string of characters in ASCII order. +Some of the FLAGS correspond to Gnus marks.") + +(defsubst nnmaildir--mark-to-flag (mark) + "Find the Maildir flag that corresponds to MARK (an atom). +Return a character, or nil if not found. +See `nnmaildir-flag-mark-mapping'." + (car (rassq mark nnmaildir-flag-mark-mapping))) + +(defsubst nnmaildir--flag-to-mark (flag) + "Find the Gnus mark that corresponds to FLAG (a character). +Return an atom, or nil if not found. +See `nnmaildir-flag-mark-mapping'." + (cdr (assq flag nnmaildir-flag-mark-mapping))) + +(defun nnmaildir--ensure-suffix (filename) + "Ensure that FILENAME contains the suffix \":2,\"." + (if (gnus-string-match-p ":2," filename) + filename + (concat filename ":2,"))) + +(defun nnmaildir--add-flag (flag suffix) + "Return a copy of SUFFIX where FLAG is set. +SUFFIX should start with \":2,\"." + (unless (gnus-string-match-p "^:2," suffix) + (error "Invalid suffix `%s'" suffix)) + (let* ((flags (substring suffix 3)) + (flags-as-list (append flags nil)) + (new-flags + (concat (gnus-delete-duplicates + ;; maildir flags must be sorted + (sort (cons flag flags-as-list) '<))))) + (concat ":2," new-flags))) + +(defun nnmaildir--remove-flag (flag suffix) + "Return a copy of SUFFIX where FLAG is cleared. +SUFFIX should start with \":2,\"." + (unless (gnus-string-match-p "^:2," suffix) + (error "Invalid suffix `%s'" suffix)) + (let* ((flags (substring suffix 3)) + (flags-as-list (append flags nil)) + (new-flags (concat (delq flag flags-as-list)))) + (concat ":2," new-flags))) + (defvar nnmaildir-article-file-name nil "*The filename of the most recently requested article. This variable is set by nnmaildir-request-article.") @@ -147,6 +199,16 @@ by nnmaildir-request-article.") (gnm nil) ;; flag: split from mail-sources? (target-prefix nil :type string)) ;; symlink target prefix +(defun nnmaildir--article-set-flags (article new-suffix curdir) + (let* ((prefix (nnmaildir--art-prefix article)) + (suffix (nnmaildir--art-suffix article)) + (article-file (concat curdir prefix suffix)) + (new-name (concat curdir prefix new-suffix))) + (unless (file-exists-p article-file) + (error "Couldn't find article file %s" article-file)) + (rename-file article-file new-name 'replace) + (setf (nnmaildir--art-suffix article) new-suffix))) + (defun nnmaildir--expired-article (group article) (setf (nnmaildir--art-nov article) nil) (let ((flist (nnmaildir--grp-flist group)) @@ -203,33 +265,33 @@ by nnmaildir-request-article.") (eval param)) (defmacro nnmaildir--with-nntp-buffer (&rest body) - `(save-excursion - (set-buffer nntp-server-buffer) + (declare (debug (body))) + `(with-current-buffer nntp-server-buffer ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir work*")) + (declare (debug (body))) + `(with-current-buffer (get-buffer-create " *nnmaildir work*") ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir nov*")) + (declare (debug (body))) + `(with-current-buffer (get-buffer-create " *nnmaildir nov*") ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir move*")) + (declare (debug (body))) + `(with-current-buffer (get-buffer-create " *nnmaildir move*") ,@body)) -(defmacro nnmaildir--subdir (dir subdir) - `(file-name-as-directory (concat ,dir ,subdir))) -(defmacro nnmaildir--srvgrp-dir (srv-dir gname) - `(nnmaildir--subdir ,srv-dir ,gname)) -(defmacro nnmaildir--tmp (dir) `(nnmaildir--subdir ,dir "tmp")) -(defmacro nnmaildir--new (dir) `(nnmaildir--subdir ,dir "new")) -(defmacro nnmaildir--cur (dir) `(nnmaildir--subdir ,dir "cur")) -(defmacro nnmaildir--nndir (dir) `(nnmaildir--subdir ,dir ".nnmaildir")) -(defmacro nnmaildir--nov-dir (dir) `(nnmaildir--subdir ,dir "nov")) -(defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks")) -(defmacro nnmaildir--num-dir (dir) `(nnmaildir--subdir ,dir "num")) +(defsubst nnmaildir--subdir (dir subdir) + (file-name-as-directory (concat dir subdir))) +(defsubst nnmaildir--srvgrp-dir (srv-dir gname) + (nnmaildir--subdir srv-dir gname)) +(defsubst nnmaildir--tmp (dir) (nnmaildir--subdir dir "tmp")) +(defsubst nnmaildir--new (dir) (nnmaildir--subdir dir "new")) +(defsubst nnmaildir--cur (dir) (nnmaildir--subdir dir "cur")) +(defsubst nnmaildir--nndir (dir) (nnmaildir--subdir dir ".nnmaildir")) +(defsubst nnmaildir--nov-dir (dir) (nnmaildir--subdir dir "nov")) +(defsubst nnmaildir--marks-dir (dir) (nnmaildir--subdir dir "marks")) +(defsubst nnmaildir--num-dir (dir) (nnmaildir--subdir dir "num")) (defmacro nnmaildir--unlink (file-arg) `(let ((file ,file-arg)) @@ -241,7 +303,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) @@ -265,36 +327,31 @@ by nnmaildir-request-article.") (setq attr (file-attributes (concat dir (number-to-string number-linked)))) (or attr (throw 'return (1- number-linked))) - (if (/= ino-opened (nth 10 attr)) - (setq number-opened number-linked)))))) + (unless (equal ino-opened (nth 10 attr)) + (setq number-opened number-linked)))))) ;; Make the given server, if non-nil, be the current server. Then make the ;; given group, if non-nil, be the current group of the current server. Then ;; return the group object for the current group. (defun nnmaildir--prepare (server group) - (let (x groups) - (catch 'return - (if (null server) - (unless (setq server nnmaildir--cur-server) - (throw 'return nil)) - (unless (setq server (intern-soft server nnmaildir--servers)) + (catch 'return + (if (null server) + (unless (setq server nnmaildir--cur-server) (throw 'return nil)) - (setq server (symbol-value server) - nnmaildir--cur-server server)) - (unless (setq groups (nnmaildir--srv-groups server)) + (unless (setq server (intern-soft server nnmaildir--servers)) (throw 'return nil)) - (unless (nnmaildir--srv-method server) - (setq x (concat "nnmaildir:" (nnmaildir--srv-address server)) - x (gnus-server-to-method x)) - (unless x (throw 'return nil)) - (setf (nnmaildir--srv-method server) x)) - (if (null group) - (unless (setq group (nnmaildir--srv-curgrp server)) - (throw 'return nil)) - (unless (setq group (intern-soft group groups)) - (throw 'return nil)) - (setq group (symbol-value group))) - group))) + (setq server (symbol-value server) + nnmaildir--cur-server server)) + (let ((groups (nnmaildir--srv-groups server))) + (when groups + (unless (nnmaildir--srv-method server) + (setf (nnmaildir--srv-method server) + (or (gnus-server-to-method + (concat "nnmaildir:" (nnmaildir--srv-address server))) + (throw 'return nil)))) + (if (null group) + (nnmaildir--srv-curgrp server) + (symbol-value (intern-soft group groups))))))) (defun nnmaildir--tab-to-space (string) (let ((pos 0)) @@ -304,6 +361,7 @@ by nnmaildir-request-article.") string) (defmacro nnmaildir--condcase (errsym body &rest handler) + (declare (debug (sexp form body))) `(condition-case ,errsym (let ((system-messages-locale "C")) ,body) (error . ,handler))) @@ -356,9 +414,9 @@ by nnmaildir-request-article.") 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)))) + (unless (equal (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) @@ -366,7 +424,7 @@ by nnmaildir-request-article.") (srv-dir (nnmaildir--srv-dir server)) (storage-version 1) ;; [version article-number msgid [...nov...]] dir gname pgname msgdir prefix suffix file attr mtime novdir novfile - nov msgid nov-beg nov-mid nov-end field val old-extra num numdir + nov msgid nov-beg nov-mid nov-end field val old-extra num deactivate-mark) (catch 'return (setq gname (nnmaildir--grp-name group) @@ -479,7 +537,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))) @@ -605,7 +664,7 @@ by nnmaildir-request-article.") "/" "\\057" 'literal) ":" "\\072" 'literal)) -(defun nnmaildir-request-type (group &optional article) +(defun nnmaildir-request-type (_group &optional _article) 'mail) (defun nnmaildir-status-message (&optional server) @@ -705,7 +764,7 @@ by nnmaildir-request-article.") (if (> (aref a 1) (aref b 1)) (throw 'return nil)) (string-lessp (aref a 2) (aref b 2)))) -(defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls) +(defun nnmaildir--scan (gname scan-msgs groups _method srv-dir srv-ls) (catch 'return (let ((36h-ago (- (car (current-time)) 2)) absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls @@ -738,16 +797,14 @@ by nnmaildir-request-article.") ls (or (nnmaildir--param pgname 'directory-files) srv-ls)) (unless read-only (setq x (nth 11 (file-attributes tdir))) - (unless (and (= x (nth 11 nattr)) (= x (nth 11 cattr))) + (unless (and (equal x (nth 11 nattr)) (equal x (nth 11 cattr))) (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)) @@ -756,12 +813,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 (nnmaildir--ensure-suffix file))))) (setf (nnmaildir--grp-new group) nattr)) (setq cattr (nth 5 (file-attributes cdir))) (if (equal cattr (nnmaildir--grp-cur group)) @@ -786,13 +841,23 @@ 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 (prefix-suffix files) + (let ((prefix (car prefix-suffix)) + (suffix (cdr prefix-suffix))) + ;; increase num for each unread or ticked article + (when (or + ;; first look for marks in suffix, if it's valid... + (when (and (stringp suffix) + (gnus-string-prefix-p ":2," suffix)) + (or + (not (gnus-string-match-p + (string (nnmaildir--mark-to-flag 'read)) suffix)) + (gnus-string-match-p + (string (nnmaildir--mark-to-flag 'tick)) suffix))) + ;; then look in marks directories + (not (file-exists-p (concat cdir prefix))) + (file-exists-p (concat ndir prefix))) + (incf num))))) (setf (nnmaildir--grp-cache group) (make-vector num nil)) (let ((inhibit-quit t)) (set (intern gname groups) group)) @@ -806,16 +871,18 @@ 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)) +(defvar nnmaildir-get-new-mail) +(defvar nnmaildir-group-alist) +(defvar nnmaildir-active-file) + (defun nnmaildir-request-scan (&optional scan-group server) (let ((coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) @@ -823,7 +890,7 @@ by nnmaildir-request-article.") (nnmaildir-get-new-mail t) (nnmaildir-group-alist nil) (nnmaildir-active-file nil) - x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen + x srv-ls srv-dir method groups target-prefix dirs seen deactivate-mark) (nnmaildir--prepare server nil) (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server) @@ -858,19 +925,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 @@ -889,7 +955,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 " ") @@ -898,7 +966,7 @@ by nnmaildir-request-article.") (nnmaildir--srv-groups nnmaildir--cur-server)))) t) -(defun nnmaildir-request-newgroups (date &optional server) +(defun nnmaildir-request-newgroups (_date &optional server) (nnmaildir-request-list server)) (defun nnmaildir-retrieve-groups (groups &optional server) @@ -906,26 +974,30 @@ 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) + (let* ((group (nnmaildir--prepare server gname)) + (curdir (nnmaildir--cur + (nnmaildir--srvgrp-dir + (nnmaildir--srv-dir nnmaildir--cur-server) gname))) + (curdir-mtime (nth 5 (file-attributes curdir))) + pgname flist always-marks never-marks old-marks dir + all-marks marks ranges markdir read ls + old-mmth new-mmth mtime existing missing deactivate-mark) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) @@ -954,43 +1026,77 @@ by nnmaildir-request-article.") dir (nnmaildir--nndir dir) dir (nnmaildir--marks-dir dir) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) - markdirs (funcall ls dir nil "\\`[^.]" 'nosort) - new-mmth (nnmaildir--up2-1 (length markdirs)) + all-marks (gnus-delete-duplicates + ;; get mark names from mark dirs and from flag + ;; mappings + (append + (mapcar 'cdr nnmaildir-flag-mark-mapping) + (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort)))) + new-mmth (nnmaildir--up2-1 (length all-marks)) 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 all-marks) + (setq markdir (nnmaildir--subdir dir (symbol-name mark)) + ranges nil) + (catch 'got-ranges + (if (memq mark never-marks) (throw 'got-ranges nil)) + (when (memq mark always-marks) + (setq ranges existing) + (throw 'got-ranges nil)) + ;; Find the mtime for this mark. If this mark can be expressed as + ;; a filename flag, get the later of the mtimes for markdir and + ;; curdir, otherwise only the markdir counts. + (setq mtime + (let ((markdir-mtime (nth 5 (file-attributes markdir)))) + (cond + ((null (nnmaildir--mark-to-flag mark)) + markdir-mtime) + ((null markdir-mtime) + curdir-mtime) + ((null curdir-mtime) + ;; this should never happen... + markdir-mtime) + ((time-less-p markdir-mtime curdir-mtime) + curdir-mtime) + (t + markdir-mtime)))) + (set (intern (symbol-name mark) new-mmth) mtime) + (when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth))) + (setq ranges (assq mark old-marks)) + (if ranges (setq ranges (cdr ranges))) + (throw 'got-ranges nil)) + (let ((article-list nil)) + ;; Consider the article marked if it either has the flag in the + ;; filename, or is in the markdir. As you'd rarely remove a + ;; flag/mark, this should avoid losing information in the most + ;; common usage pattern. + (or + (let ((flag (nnmaildir--mark-to-flag mark))) + ;; If this mark has a corresponding maildir flag... + (when flag + (let ((regexp + (concat "\\`[^.].*:2,[A-Z]*" (string flag)))) + ;; ...then find all files with that flag. + (dolist (filename (funcall ls curdir nil regexp 'nosort)) + (let* ((prefix (car (split-string filename ":2,"))) + (article (nnmaildir--flist-art flist prefix))) + (when article + (push (nnmaildir--art-num article) article-list))))))) + ;; Also check Gnus-specific mark directory, if it exists. + (when (file-directory-p markdir) + (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort)) + (let ((article (nnmaildir--flist-art flist prefix))) + (when article + (push (nnmaildir--art-num article) article-list)))))) + (setq ranges (gnus-add-to-range ranges (sort article-list '<))))) + (if (eq mark 'read) (setq read ranges) + (if ranges (setq marks (cons (cons mark 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) info))) -(defun nnmaildir-request-group (gname &optional server fast) +(defun nnmaildir-request-group (gname &optional server fast _info) (let ((group (nnmaildir--prepare server gname)) deactivate-mark) (catch 'return @@ -1010,10 +1116,10 @@ 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) +(defun nnmaildir-request-create-group (gname &optional server _args) (nnmaildir--prepare server nil) (catch 'return (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) @@ -1028,7 +1134,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)) @@ -1073,7 +1179,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)) @@ -1136,10 +1242,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}")) @@ -1159,7 +1265,7 @@ by nnmaildir-request-article.") (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old) (let ((group (nnmaildir--prepare server gname)) - srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov + nlist mlist article num start stop nov insert-nov deactivate-mark) (setq insert-nov (lambda (article) @@ -1172,7 +1278,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,20 +1290,16 @@ by nnmaildir-request-article.") (erase-buffer) (setq mlist (nnmaildir--grp-mlist group) nlist (nnmaildir--grp-nlist group) - gname (nnmaildir--grp-name group) - srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) - dir (nnmaildir--srvgrp-dir srv-dir gname)) + gname (nnmaildir--grp-name group)) (cond ((null nlist)) ((and fetch-old (not (numberp fetch-old))) (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 @@ -1254,13 +1356,12 @@ by nnmaildir-request-article.") (setf (nnmaildir--srv-error nnmaildir--cur-server) "Article has expired") (throw 'return nil)) - (save-excursion - (set-buffer (or to-buffer nntp-server-buffer)) + (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) (nnheader-insert-file-contents nnmaildir-article-file-name)) (cons gname num-msgid)))) -(defun nnmaildir-request-post (&optional server) +(defun nnmaildir-request-post (&optional _server) (let (message-required-mail-headers) (funcall message-send-mail-function))) @@ -1294,16 +1395,15 @@ by nnmaildir-request-article.") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "File exists: " tmpfile)) (throw 'return nil)) - (save-excursion - (set-buffer buffer) - (write-region (point-min) (point-max) tmpfile nil 'no-message nil - 'excl)) + (with-current-buffer buffer + (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 @@ -1340,7 +1440,7 @@ by nnmaildir-request-article.") (nnmaildir--expired-article group article)) result))) -(defun nnmaildir-request-accept-article (gname &optional server last) +(defun nnmaildir-request-accept-article (gname &optional server _last) (let ((group (nnmaildir--prepare server gname)) (coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) @@ -1390,11 +1490,13 @@ by nnmaildir-request-article.") (throw 'return nil)))) (condition-case nil (add-name-to-file nnmaildir--file tmpfile) (error - (write-region (point-min) (point-max) tmpfile nil 'no-message nil - 'excl) - (unix-sync))) ;; no fsync :( - (cancel-timer 24h) - (condition-case err (add-name-to-file tmpfile curfile) + (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil + 'excl) + (when (fboundp 'unix-sync) + (unix-sync)))) ;; no fsync :( + (nnheader-cancel-timer 24h) + (condition-case err + (add-name-to-file tmpfile curfile) (error (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Error linking: " (prin1-to-string err))) @@ -1442,14 +1544,16 @@ by nnmaildir-request-article.") ga)) group-art))))) -(defun nnmaildir-active-number (gname) +(defun nnmaildir-active-number (_gname) 0) +(declare-function gnus-group-mark-article-read "gnus-group" (group article)) + (defun nnmaildir-request-expire-articles (ranges &optional gname server force) (let ((no-force (not force)) (group (nnmaildir--prepare server gname)) - pgname time boundary bound-iter high low target dir nlist nlist2 - stop article didnt nnmaildir--file nnmaildir-article-file-name + pgname time boundary bound-iter high low target dir nlist + didnt nnmaildir--file nnmaildir-article-file-name deactivate-mark) (catch 'return (unless group @@ -1468,7 +1572,7 @@ by nnmaildir-request-article.") (if (eq time 'immediate) (setq time 0) (if (numberp time) - (setq time (* time 86400))))) + (setq time (round (* time 86400)))))) (when no-force (unless (integerp time) ;; handle 'never (throw 'return (gnus-uncompress-range ranges))) @@ -1517,7 +1621,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)) @@ -1526,54 +1635,83 @@ by nnmaildir-request-article.") (erase-buffer)) didnt))) +(defvar nnmaildir--article) + (defun nnmaildir-request-set-mark (gname actions &optional server) - (let ((group (nnmaildir--prepare server gname)) - (coding-system-for-write nnheader-file-coding-system) - (buffer-file-coding-system nil) - (file-coding-system-alist nil) - del-mark del-action add-action set-action marksdir nlist - ranges begin end article all-marks todo-marks mdir mfile - pgname ls permarkfile deactivate-mark) - (setq del-mark + (let* ((group (nnmaildir--prepare server gname)) + (curdir (nnmaildir--cur + (nnmaildir--srvgrp-dir + (nnmaildir--srv-dir nnmaildir--cur-server) + gname))) + (coding-system-for-write nnheader-file-coding-system) + (buffer-file-coding-system nil) + (file-coding-system-alist nil) + marksdir nlist + ranges all-marks todo-marks mdir mfile + pgname ls permarkfile deactivate-mark + (del-mark (lambda (mark) - (setq mfile (nnmaildir--subdir marksdir (symbol-name mark)) - mfile (concat mfile (nnmaildir--art-prefix article))) - (nnmaildir--unlink mfile)) - del-action (lambda (article) (mapcar del-mark todo-marks)) - add-action + (let ((prefix (nnmaildir--art-prefix nnmaildir--article)) + (suffix (nnmaildir--art-suffix nnmaildir--article)) + (flag (nnmaildir--mark-to-flag mark))) + (when flag + ;; If this mark corresponds to a flag, remove the flag from + ;; the file name. + (nnmaildir--article-set-flags + nnmaildir--article (nnmaildir--remove-flag flag suffix) + curdir)) + ;; We still want to delete the hardlink in the marks dir if + ;; present, regardless of whether this mark has a maildir flag or + ;; not, to avoid getting out of sync. + (setq mfile (nnmaildir--subdir marksdir (symbol-name mark)) + mfile (concat mfile prefix)) + (nnmaildir--unlink mfile)))) + (del-action (lambda (article) + (let ((nnmaildir--article article)) + (mapcar del-mark todo-marks)))) + (add-action (lambda (article) (mapcar (lambda (mark) - (setq mdir (nnmaildir--subdir marksdir (symbol-name mark)) - permarkfile (concat mdir ":") - mfile (concat mdir (nnmaildir--art-prefix article))) - (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) - (mapcar (lambda (mark) - (unless (memq mark todo-marks) - (funcall del-mark mark))) - all-marks))) + (let ((prefix (nnmaildir--art-prefix article)) + (suffix (nnmaildir--art-suffix article)) + (flag (nnmaildir--mark-to-flag mark))) + (if flag + ;; If there is a corresponding maildir flag, just rename + ;; the file. + (nnmaildir--article-set-flags + article (nnmaildir--add-flag flag suffix) curdir) + ;; Otherwise, use nnmaildir-specific marks dir. + (setq mdir (nnmaildir--subdir marksdir (symbol-name mark)) + permarkfile (concat mdir ":") + mfile (concat mdir prefix)) + (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 article) + (let ((nnmaildir--article article)) + (mapcar (lambda (mark) + (unless (memq mark todo-marks) + (funcall del-mark mark))) + all-marks))))) (catch 'return (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) @@ -1584,18 +1722,22 @@ by nnmaildir-request-article.") pgname (nnmaildir--pgname nnmaildir--cur-server gname) 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) + all-marks (gnus-delete-duplicates + ;; get mark names from mark dirs and from flag + ;; mappings + (append + (mapcar 'cdr nnmaildir-flag-mark-mapping) + (mapcar 'intern all-marks)))) + (dolist (action actions) + (setq ranges (car action) + todo-marks (caddr action)) + (dolist (mark todo-marks) + (pushnew mark all-marks :test #'equal)) + (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) + ((eq 'set (cadr action)) set-action)))) nil))) (defun nnmaildir-close-group (gname &optional server) @@ -1624,25 +1766,21 @@ 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) + (defvar flist) (defvar ls) (defvar dirs) (defvar dir) + (defvar files) (defvar file) (defvar x) (let (flist ls dirs dir files file x) (nnmaildir--prepare server nil) (when nnmaildir--cur-server @@ -1656,7 +1794,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*")) @@ -1672,5 +1810,4 @@ by nnmaildir-request-article.") ;; fill-column: 77 ;; End: -;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849 ;;; nnmaildir.el ends here