lisp/gnus/nnmaildir.el

   1 ;;; nnmaildir.el --- maildir backend for Gnus
   2
   3 ;; This file is in the public domain.
   4
   5 ;; Author: Paul Jarc <prj@po.cwru.edu>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>
  25 ;; and in the maildir(5) man page from qmail (available at
  26 ;; <URL:http://www.qmail.org/man/man5/maildir.html>).  nnmaildir also stores
  27 ;; extra information in the .nnmaildir/ directory within a maildir.
  28 ;;
  29 ;; Some goals of nnmaildir:
  30 ;; * Everything Just Works, and correctly.  E.g., NOV data is automatically
  31 ;;   regenerated when stale; no need for manually running
  32 ;;   *-generate-nov-databases.
  33 ;; * Perfect reliability: [C-g] will never corrupt its data in memory, and
  34 ;;   SIGKILL will never corrupt its data in the filesystem.
  35 ;; * Allow concurrent operation as much as possible.  If files change out
  36 ;;   from under us, adapt to the changes or degrade gracefully.
  37 ;; * We use the filesystem as a database, so that, e.g., it's easy to
  38 ;;   manipulate marks from outside Gnus.
  39 ;; * All information about a group is stored in the maildir, for easy backup,
  40 ;;   copying, restoring, etc.
  41 ;;
  42 ;; Todo:
  43 ;; * When moving an article for expiry, copy all the marks except 'expire
  44 ;;   from the original article.
  45 ;; * Add a hook for when moving messages from new/ to cur/, to support
  46 ;;   nnmail's duplicate detection.
  47 ;; * Improve generated Xrefs, so crossposts are detectable.
  48 ;; * Improve code readability.
  49
  50 ;;; Code:
  51
  52 ;; eval this before editing
  53 [(progn
  54    (put 'nnmaildir--with-nntp-buffer 'lisp-indent-function 0)
  55    (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0)
  56    (put 'nnmaildir--with-nov-buffer  'lisp-indent-function 0)
  57    (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0)
  58    (put 'nnmaildir--condcase         'lisp-indent-function 2)
  59    )
  60 ]
  61
  62 (require 'nnheader)
  63 (require 'gnus)
  64 (require 'gnus-util)
  65 (require 'gnus-range)
  66 (require 'gnus-start)
  67 (require 'gnus-int)
  68 (require 'message)
  69 (require 'nnmail)
  70
  71 (eval-when-compile (require 'cl-lib))
  72
  73 (defconst nnmaildir-version "Gnus")
  74
  75 (defconst nnmaildir-flag-mark-mapping
  76   '((?F . tick)
  77     (?P . forward)
  78     (?R . reply)
  79     (?S . read))
  80   "Alist mapping Maildir filename flags to Gnus marks.
  81 Maildir filenames are of the form \"unique-id:2,FLAGS\",
  82 where FLAGS are a string of characters in ASCII order.
  83 Some of the FLAGS correspond to Gnus marks.")
  84
  85 (defsubst nnmaildir--mark-to-flag (mark)
  86   "Find the Maildir flag that corresponds to MARK (an atom).
  87 Return a character, or nil if not found.
  88 See `nnmaildir-flag-mark-mapping'."
  89   (car (rassq mark nnmaildir-flag-mark-mapping)))
  90
  91 (defsubst nnmaildir--flag-to-mark (flag)
  92   "Find the Gnus mark that corresponds to FLAG (a character).
  93 Return an atom, or nil if not found.
  94 See `nnmaildir-flag-mark-mapping'."
  95   (cdr (assq flag nnmaildir-flag-mark-mapping)))
  96
  97 (defun nnmaildir--ensure-suffix (filename)
  98   "Ensure that FILENAME contains the suffix \":2,\"."
  99   (if (string-match-p ":2," filename)
 100       filename
 101     (concat filename ":2,")))
 102
 103 (defun nnmaildir--add-flag (flag suffix)
 104   "Return a copy of SUFFIX where FLAG is set.
 105 SUFFIX should start with \":2,\"."
 106   (unless (string-match-p "^:2," suffix)
 107     (error "Invalid suffix `%s'" suffix))
 108   (let* ((flags (substring suffix 3))
 109          (flags-as-list (append flags nil))
 110          (new-flags
 111           (concat (gnus-delete-duplicates
 112                    ;; maildir flags must be sorted
 113                    (sort (cons flag flags-as-list) '<)))))
 114     (concat ":2," new-flags)))
 115
 116 (defun nnmaildir--remove-flag (flag suffix)
 117   "Return a copy of SUFFIX where FLAG is cleared.
 118 SUFFIX should start with \":2,\"."
 119   (unless (string-match-p "^:2," suffix)
 120     (error "Invalid suffix `%s'" suffix))
 121   (let* ((flags (substring suffix 3))
 122          (flags-as-list (append flags nil))
 123          (new-flags (concat (delq flag flags-as-list))))
 124     (concat ":2," new-flags)))
 125
 126 (defvar nnmaildir-article-file-name nil
 127   "The filename of the most recently requested article.
 128 This variable is set by `nnmaildir-request-article'.")
 129
 130 ;; The filename of the article being moved/copied:
 131 (defvar nnmaildir--file nil)
 132
 133 ;; Variables to generate filenames of messages being delivered:
 134 (defvar   nnmaildir--delivery-time "")
 135 (defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
 136 (defvar   nnmaildir--delivery-count nil)
 137
 138 ;; An obarry containing symbols whose names are server names and whose values
 139 ;; are servers:
 140 (defvar nnmaildir--servers (make-vector 3 0))
 141 ;; The current server:
 142 (defvar nnmaildir--cur-server nil)
 143
 144 ;; A copy of nnmail-extra-headers
 145 (defvar nnmaildir--extra nil)
 146
 147 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
 148 ["subject\tfrom\tdate"
 149  "references\tchars\tlines"
 150  "To: you\tIn-Reply-To: <your.mess@ge>"
 151  (12345 67890)     ;; modtime of the corresponding article file
 152  (to in-reply-to)] ;; contemporary value of nnmail-extra-headers
 153 (defconst nnmaildir--novlen 5)
 154 (defmacro nnmaildir--nov-new (beg mid end mtime extra)
 155   `(vector ,beg ,mid ,end ,mtime ,extra))
 156 (defmacro nnmaildir--nov-get-beg   (nov) `(aref ,nov 0))
 157 (defmacro nnmaildir--nov-get-mid   (nov) `(aref ,nov 1))
 158 (defmacro nnmaildir--nov-get-end   (nov) `(aref ,nov 2))
 159 (defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3))
 160 (defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4))
 161 (defmacro nnmaildir--nov-set-beg   (nov value) `(aset ,nov 0 ,value))
 162 (defmacro nnmaildir--nov-set-mid   (nov value) `(aset ,nov 1 ,value))
 163 (defmacro nnmaildir--nov-set-end   (nov value) `(aset ,nov 2 ,value))
 164 (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value))
 165 (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value))
 166
 167 (cl-defstruct nnmaildir--art
 168   (prefix nil :type string)  ;; "time.pid.host"
 169   (suffix nil :type string)  ;; ":2,flags"
 170   (num    nil :type natnum)  ;; article number
 171   (msgid  nil :type string)  ;; "<mess.age@id>"
 172   (nov    nil :type vector)) ;; cached nov structure, or nil
 173
 174 (cl-defstruct nnmaildir--grp
 175   (name  nil :type string)  ;; "group.name"
 176   (new   nil :type list)    ;; new/ modtime
 177   (cur   nil :type list)    ;; cur/ modtime
 178   (min   1   :type natnum)  ;; minimum article number
 179   (count 0   :type natnum)  ;; count of articles
 180   (nlist nil :type list)    ;; list of articles, ordered descending by number
 181   (flist nil :type vector)  ;; obarray mapping filename prefix->article
 182   (mlist nil :type vector)  ;; obarray mapping message-id->article
 183   (cache nil :type vector)  ;; nov cache
 184   (index nil :type natnum)  ;; index of next cache entry to replace
 185   (mmth  nil :type vector)) ;; obarray mapping mark name->dir modtime
 186                                         ; ("Mark Mod Time Hash")
 187
 188 (cl-defstruct nnmaildir--srv
 189   (address       nil :type string)         ;; server address string
 190   (method        nil :type list)           ;; (nnmaildir "address" ...)
 191   (prefix        nil :type string)         ;; "nnmaildir+address:"
 192   (dir           nil :type string)         ;; "/expanded/path/to/server/dir/"
 193   (ls            nil :type function)       ;; directory-files function
 194   (groups        nil :type vector)         ;; obarray mapping group name->group
 195   (curgrp        nil :type nnmaildir--grp) ;; current group, or nil
 196   (error         nil :type string)         ;; last error message, or nil
 197   (mtime         nil :type list)           ;; modtime of dir
 198   (gnm           nil)                      ;; flag: split from mail-sources?
 199   (target-prefix nil :type string))        ;; symlink target prefix
 200
 201 (defun nnmaildir--article-set-flags (article new-suffix curdir)
 202   (let* ((prefix (nnmaildir--art-prefix article))
 203          (suffix (nnmaildir--art-suffix article))
 204          (article-file (concat curdir prefix suffix))
 205          (new-name (concat curdir prefix new-suffix)))
 206     (unless (file-exists-p article-file)
 207       (error "Couldn't find article file %s" article-file))
 208     (rename-file article-file new-name 'replace)
 209     (setf (nnmaildir--art-suffix article) new-suffix)))
 210
 211 (defun nnmaildir--expired-article (group article)
 212   (setf (nnmaildir--art-nov article) nil)
 213   (let ((flist  (nnmaildir--grp-flist group))
 214         (mlist  (nnmaildir--grp-mlist group))
 215         (min    (nnmaildir--grp-min   group))
 216         (count  (1- (nnmaildir--grp-count group)))
 217         (prefix (nnmaildir--art-prefix article))
 218         (msgid  (nnmaildir--art-msgid  article))
 219         (new-nlist nil)
 220         (nlist-pre '(nil . nil))
 221         nlist-post num)
 222     (unless (zerop count)
 223       (setq nlist-post (nnmaildir--grp-nlist group)
 224             num (nnmaildir--art-num article))
 225       (if (eq num (caar nlist-post))
 226           (setq new-nlist (cdr nlist-post))
 227         (setq new-nlist nlist-post
 228               nlist-pre nlist-post
 229               nlist-post (cdr nlist-post))
 230         (while (/= num (caar nlist-post))
 231           (setq nlist-pre nlist-post
 232                 nlist-post (cdr nlist-post)))
 233         (setq nlist-post (cdr nlist-post))
 234         (if (eq num min)
 235             (setq min (caar nlist-pre)))))
 236     (let ((inhibit-quit t))
 237       (setf (nnmaildir--grp-min   group) min)
 238       (setf (nnmaildir--grp-count group) count)
 239       (setf (nnmaildir--grp-nlist group) new-nlist)
 240       (setcdr nlist-pre nlist-post)
 241       (unintern prefix flist)
 242       (unintern msgid mlist))))
 243
 244 (defun nnmaildir--nlist-art (group num)
 245   (let ((entry (assq num (nnmaildir--grp-nlist group))))
 246     (if entry
 247         (cdr entry))))
 248 (defmacro nnmaildir--flist-art (list file)
 249   `(symbol-value (intern-soft ,file ,list)))
 250 (defmacro nnmaildir--mlist-art (list msgid)
 251   `(symbol-value (intern-soft ,msgid ,list)))
 252
 253 (defun nnmaildir--pgname (server gname)
 254   (let ((prefix (nnmaildir--srv-prefix server)))
 255     (if prefix (concat prefix gname)
 256       (setq gname (gnus-group-prefixed-name gname
 257                                             (nnmaildir--srv-method server)))
 258       (setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname))
 259       gname)))
 260
 261 (defun nnmaildir--param (pgname param)
 262   (setq param (gnus-group-find-parameter pgname param 'allow-list))
 263   (if (vectorp param) (setq param (aref param 0)))
 264   (eval param))
 265
 266 (defmacro nnmaildir--with-nntp-buffer (&rest body)
 267   (declare (debug (body)))
 268   `(with-current-buffer nntp-server-buffer
 269      ,@body))
 270 (defmacro nnmaildir--with-work-buffer (&rest body)
 271   (declare (debug (body)))
 272   `(with-current-buffer (get-buffer-create " *nnmaildir work*")
 273      ,@body))
 274 (defmacro nnmaildir--with-nov-buffer (&rest body)
 275   (declare (debug (body)))
 276   `(with-current-buffer (get-buffer-create " *nnmaildir nov*")
 277      ,@body))
 278 (defmacro nnmaildir--with-move-buffer (&rest body)
 279   (declare (debug (body)))
 280   `(with-current-buffer (get-buffer-create " *nnmaildir move*")
 281      ,@body))
 282
 283 (defsubst nnmaildir--subdir (dir subdir)
 284   (file-name-as-directory (concat dir subdir)))
 285 (defsubst nnmaildir--srvgrp-dir (srv-dir gname)
 286   (nnmaildir--subdir srv-dir gname))
 287 (defsubst nnmaildir--tmp       (dir) (nnmaildir--subdir dir "tmp"))
 288 (defsubst nnmaildir--new       (dir) (nnmaildir--subdir dir "new"))
 289 (defsubst nnmaildir--cur       (dir) (nnmaildir--subdir dir "cur"))
 290 (defsubst nnmaildir--nndir     (dir) (nnmaildir--subdir dir ".nnmaildir"))
 291 (defsubst nnmaildir--nov-dir   (dir) (nnmaildir--subdir dir "nov"))
 292 (defsubst nnmaildir--marks-dir (dir) (nnmaildir--subdir dir "marks"))
 293 (defsubst nnmaildir--num-dir   (dir) (nnmaildir--subdir dir "num"))
 294
 295 (defmacro nnmaildir--unlink (file-arg)
 296   `(let ((file ,file-arg))
 297      (if (file-attributes file) (delete-file file))))
 298 (defun nnmaildir--mkdir (dir)
 299   (or (file-exists-p (file-name-as-directory dir))
 300       (make-directory-internal (directory-file-name dir))))
 301 (defun nnmaildir--mkfile (file)
 302   (write-region "" nil file nil 'no-message))
 303 (defun nnmaildir--delete-dir-files (dir ls)
 304   (when (file-attributes dir)
 305     (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
 306     (delete-directory dir)))
 307
 308 (defun nnmaildir--group-maxnum (server group)
 309   (catch 'return
 310     (if (zerop (nnmaildir--grp-count group)) (throw 'return 0))
 311     (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server)
 312                                     (nnmaildir--grp-name group)))
 313           (number-opened 1)
 314           attr ino-opened nlink number-linked)
 315       (setq dir (nnmaildir--nndir dir)
 316             dir (nnmaildir--num-dir dir))
 317       (while t
 318         (setq attr (file-attributes
 319                     (concat dir (number-to-string number-opened))))
 320         (or attr (throw 'return (1- number-opened)))
 321         (setq ino-opened (nth 10 attr)
 322               nlink (nth 1 attr)
 323               number-linked (+ number-opened nlink))
 324         (if (or (< nlink 1) (< number-linked nlink))
 325             (signal 'error '("Arithmetic overflow")))
 326         (setq attr (file-attributes
 327                     (concat dir (number-to-string number-linked))))
 328         (or attr (throw 'return (1- number-linked)))
 329         (unless (equal ino-opened (nth 10 attr))
 330           (setq number-opened number-linked))))))
 331
 332 ;; Make the given server, if non-nil, be the current server.  Then make the
 333 ;; given group, if non-nil, be the current group of the current server.  Then
 334 ;; return the group object for the current group.
 335 (defun nnmaildir--prepare (server group)
 336   (catch 'return
 337     (if (null server)
 338         (unless (setq server nnmaildir--cur-server)
 339           (throw 'return nil))
 340       (unless (setq server (intern-soft server nnmaildir--servers))
 341         (throw 'return nil))
 342       (setq server (symbol-value server)
 343             nnmaildir--cur-server server))
 344     (let ((groups (nnmaildir--srv-groups server)))
 345       (when groups
 346         (unless (nnmaildir--srv-method server)
 347           (setf (nnmaildir--srv-method server)
 348                 (or (gnus-server-to-method
 349                      (concat "nnmaildir:" (nnmaildir--srv-address server)))
 350                     (throw 'return nil))))
 351         (if (null group)
 352             (nnmaildir--srv-curgrp server)
 353           (symbol-value (intern-soft group groups)))))))
 354
 355 (defun nnmaildir--tab-to-space (string)
 356   (let ((pos 0))
 357     (while (string-match "\t" string pos)
 358       (aset string (match-beginning 0) ? )
 359       (setq pos (match-end 0))))
 360   string)
 361
 362 (defmacro nnmaildir--condcase (errsym body &rest handler)
 363   (declare (debug (sexp form body)))
 364   `(condition-case ,errsym
 365        (let ((system-messages-locale "C")) ,body)
 366      (error . ,handler)))
 367
 368 (defun nnmaildir--emlink-p (err)
 369   (and (eq (car err) 'file-error)
 370        (string= (downcase (caddr err)) "too many links")))
 371
 372 (defun nnmaildir--enoent-p (err)
 373   (eq (car err) 'file-missing))
 374
 375 (defun nnmaildir--eexist-p (err)
 376   (eq (car err) 'file-already-exists))
 377
 378 (defun nnmaildir--new-number (nndir)
 379   "Allocate a new article number by atomically creating a file under NNDIR."
 380   (let ((numdir (nnmaildir--num-dir nndir))
 381         (make-new-file t)
 382         (number-open 1)
 383         number-link previous-number-link path-open path-link ino-open)
 384     (nnmaildir--mkdir numdir)
 385     (catch 'return
 386       (while t
 387         (setq path-open (concat numdir (number-to-string number-open)))
 388         (if (not make-new-file)
 389             (setq previous-number-link number-link)
 390           (nnmaildir--mkfile path-open)
 391           ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
 392           (setq make-new-file nil
 393                 previous-number-link 0))
 394         (let* ((attr (file-attributes path-open))
 395                (nlink (nth 1 attr)))
 396           (setq ino-open (nth 10 attr)
 397                 number-link (+ number-open nlink))
 398           (if (or (< nlink 1) (< number-link nlink))
 399               (signal 'error '("Arithmetic overflow"))))
 400         (if (= number-link previous-number-link)
 401             ;; We've already tried this number, in the previous loop iteration,
 402             ;; and failed.
 403             (signal 'error `("Corrupt internal nnmaildir data" ,path-open)))
 404         (setq path-link (concat numdir (number-to-string number-link)))
 405         (nnmaildir--condcase err
 406             (progn
 407               (add-name-to-file path-open path-link)
 408               (throw 'return number-link))
 409           (cond
 410            ((nnmaildir--emlink-p err)
 411             (setq make-new-file t
 412                   number-open number-link))
 413            ((nnmaildir--eexist-p err)
 414             (let ((attr (file-attributes path-link)))
 415               (unless (equal (nth 10 attr) ino-open)
 416                 (setq number-open number-link
 417                       number-link 0))))
 418            (t (signal (car err) (cdr err)))))))))
 419
 420 (defun nnmaildir--update-nov (server group article)
 421   (let ((nnheader-file-coding-system 'binary)
 422         (srv-dir (nnmaildir--srv-dir server))
 423         (storage-version 1) ;; [version article-number msgid [...nov...]]
 424         dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
 425         nov msgid nov-beg nov-mid nov-end field val old-extra num
 426         deactivate-mark)
 427     (catch 'return
 428       (setq gname (nnmaildir--grp-name group)
 429             pgname (nnmaildir--pgname server gname)
 430             dir (nnmaildir--srvgrp-dir srv-dir gname)
 431             msgdir (if (nnmaildir--param pgname 'read-only)
 432                        (nnmaildir--new dir) (nnmaildir--cur dir))
 433             prefix (nnmaildir--art-prefix article)
 434             suffix (nnmaildir--art-suffix article)
 435             file (concat msgdir prefix suffix)
 436             attr (file-attributes file))
 437       (unless attr
 438         (nnmaildir--expired-article group article)
 439         (throw 'return nil))
 440       (setq mtime (nth 5 attr)
 441             attr (nth 7 attr)
 442             nov (nnmaildir--art-nov article)
 443             dir (nnmaildir--nndir dir)
 444             novdir (nnmaildir--nov-dir dir)
 445             novfile (concat novdir prefix))
 446       (unless (equal nnmaildir--extra nnmail-extra-headers)
 447         (setq nnmaildir--extra (copy-sequence nnmail-extra-headers)))
 448       (nnmaildir--with-nov-buffer
 449         ;; First we'll check for already-parsed NOV data.
 450         (cond ((not (file-exists-p novfile))
 451                ;; The NOV file doesn't exist; we have to parse the message.
 452                (setq nov nil))
 453               ((not nov)
 454                ;; The file exists, but the data isn't in memory; read the file.
 455                (erase-buffer)
 456                (nnheader-insert-file-contents novfile)
 457                (setq nov (read (current-buffer)))
 458                (if (not (and (vectorp nov)
 459                              (/= 0 (length nov))
 460                              (equal storage-version (aref nov 0))))
 461                    ;; This NOV data seems to be in the wrong format.
 462                    (setq nov nil)
 463                  (unless (nnmaildir--art-num   article)
 464                    (setf (nnmaildir--art-num   article) (aref nov 1)))
 465                  (unless (nnmaildir--art-msgid article)
 466                    (setf (nnmaildir--art-msgid article) (aref nov 2)))
 467                  (setq nov (aref nov 3)))))
 468         ;; Now check whether the already-parsed data (if we have any) is
 469         ;; usable: if the message has been edited or if nnmail-extra-headers
 470         ;; has been augmented since this data was parsed from the message,
 471         ;; then we have to reparse.  Otherwise it's up-to-date.
 472         (when (and nov (equal mtime (nnmaildir--nov-get-mtime nov)))
 473           ;; The timestamp matches.  Now check nnmail-extra-headers.
 474           (setq old-extra (nnmaildir--nov-get-extra nov))
 475           (when (equal nnmaildir--extra old-extra) ;; common case
 476             ;; Save memory; use a single copy of the list value.
 477             (nnmaildir--nov-set-extra nov nnmaildir--extra)
 478             (throw 'return nov))
 479           ;; They're not equal, but maybe the new is a subset of the old.
 480           (if (null nnmaildir--extra)
 481               ;; The empty set is a subset of every set.
 482               (throw 'return nov))
 483           (if (not (memq nil (mapcar (lambda (e) (memq e old-extra))
 484                                      nnmaildir--extra)))
 485               (throw 'return nov)))
 486         ;; Parse the NOV data out of the message.
 487         (erase-buffer)
 488         (nnheader-insert-file-contents file)
 489         (insert "\n")
 490         (goto-char (point-min))
 491         (save-restriction
 492           (if (search-forward "\n\n" nil 'noerror)
 493               (progn
 494                 (setq nov-mid (count-lines (point) (point-max)))
 495                 (narrow-to-region (point-min) (1- (point))))
 496             (setq nov-mid 0))
 497           (goto-char (point-min))
 498           (delete-char 1)
 499           (setq nov (nnheader-parse-naked-head)
 500                 field (or (mail-header-lines nov) 0)))
 501         (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
 502           (setq nov-mid field))
 503         (setq nov-mid (number-to-string nov-mid)
 504               nov-mid (concat (number-to-string attr) "\t" nov-mid))
 505         (save-match-data
 506           (setq field (or (mail-header-references nov) ""))
 507           (nnmaildir--tab-to-space field)
 508           (setq nov-mid (concat field "\t" nov-mid)
 509                 nov-beg (mapconcat
 510                           (lambda (f) (nnmaildir--tab-to-space (or f "")))
 511                           (list (mail-header-subject nov)
 512                                 (mail-header-from nov)
 513                                 (mail-header-date nov)) "\t")
 514                 nov-end (mapconcat
 515                           (lambda (extra)
 516                             (setq field (symbol-name (car extra))
 517                                   val (cdr extra))
 518                             (nnmaildir--tab-to-space field)
 519                             (nnmaildir--tab-to-space val)
 520                             (concat field ": " val))
 521                           (mail-header-extra nov) "\t")))
 522         (setq msgid (mail-header-id nov))
 523         (if (or (null msgid) (nnheader-fake-message-id-p msgid))
 524             (setq msgid (concat "<" prefix "@nnmaildir>")))
 525         (nnmaildir--tab-to-space msgid)
 526         ;; The data is parsed; create an nnmaildir NOV structure.
 527         (setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime
 528                                       nnmaildir--extra)
 529               num (nnmaildir--art-num article))
 530         (unless num
 531           (setq num (nnmaildir--new-number dir))
 532           (setf (nnmaildir--art-num article) num))
 533         ;; Store this new NOV data in a file
 534         (erase-buffer)
 535         (prin1 (vector storage-version num msgid nov) (current-buffer))
 536         (setq file (concat novfile ":"))
 537         (nnmaildir--unlink file)
 538         (write-region (point-min) (point-max) file nil 'no-message nil
 539                       'excl))
 540       (rename-file file novfile 'replace)
 541       (setf (nnmaildir--art-msgid article) msgid)
 542       nov)))
 543
 544 (defun nnmaildir--cache-nov (group article nov)
 545   (let ((cache (nnmaildir--grp-cache group))
 546         (index (nnmaildir--grp-index group))
 547         goner)
 548     (unless (nnmaildir--art-nov article)
 549       (setq goner (aref cache index))
 550       (if goner (setf (nnmaildir--art-nov goner) nil))
 551       (aset cache index article)
 552       (setf (nnmaildir--grp-index group) (% (1+ index) (length cache))))
 553     (setf (nnmaildir--art-nov article) nov)))
 554
 555 (defun nnmaildir--grp-add-art (server group article)
 556   (let ((nov (nnmaildir--update-nov server group article))
 557         count num min nlist nlist-cdr insert-nlist)
 558     (when nov
 559       (setq count (1+ (nnmaildir--grp-count group))
 560             num (nnmaildir--art-num article)
 561             min (if (= count 1) num
 562                   (min num (nnmaildir--grp-min group)))
 563             nlist (nnmaildir--grp-nlist group))
 564       (if (or (null nlist) (> num (caar nlist)))
 565           (setq nlist (cons (cons num article) nlist))
 566         (setq insert-nlist t
 567               nlist-cdr (cdr nlist))
 568         (while (and nlist-cdr (< num (caar nlist-cdr)))
 569           (setq nlist nlist-cdr
 570                 nlist-cdr (cdr nlist))))
 571       (let ((inhibit-quit t))
 572         (setf (nnmaildir--grp-count group) count)
 573         (setf (nnmaildir--grp-min group) min)
 574         (if insert-nlist
 575             (setcdr nlist (cons (cons num article) nlist-cdr))
 576           (setf (nnmaildir--grp-nlist group) nlist))
 577         (set (intern (nnmaildir--art-prefix article)
 578                      (nnmaildir--grp-flist group))
 579              article)
 580         (set (intern (nnmaildir--art-msgid article)
 581                      (nnmaildir--grp-mlist group))
 582              article)
 583         (set (intern (nnmaildir--grp-name group)
 584                      (nnmaildir--srv-groups server))
 585              group))
 586       (nnmaildir--cache-nov group article nov)
 587       t)))
 588
 589 (defun nnmaildir--group-ls (server pgname)
 590   (or (nnmaildir--param pgname 'directory-files)
 591       (nnmaildir--srv-ls server)))
 592
 593 (defun nnmaildir-article-number-to-file-name
 594   (number group-name server-address-string)
 595   (let ((group (nnmaildir--prepare server-address-string group-name))
 596         article dir pgname)
 597     (catch 'return
 598       (unless group
 599         ;; The given group or server does not exist.
 600         (throw 'return nil))
 601       (setq article (nnmaildir--nlist-art group number))
 602       (unless article
 603         ;; The given article number does not exist in this group.
 604         (throw 'return nil))
 605       (setq pgname (nnmaildir--pgname nnmaildir--cur-server group-name)
 606             dir (nnmaildir--srv-dir nnmaildir--cur-server)
 607             dir (nnmaildir--srvgrp-dir dir group-name)
 608             dir (if (nnmaildir--param pgname 'read-only)
 609                     (nnmaildir--new dir) (nnmaildir--cur dir)))
 610       (concat dir (nnmaildir--art-prefix article)
 611               (nnmaildir--art-suffix article)))))
 612
 613 (defun nnmaildir-article-number-to-base-name
 614   (number group-name server-address-string)
 615   (let ((x (nnmaildir--prepare server-address-string group-name)))
 616     (when x
 617       (setq x (nnmaildir--nlist-art x number))
 618       (and x (cons (nnmaildir--art-prefix x)
 619                    (nnmaildir--art-suffix x))))))
 620
 621 (defun nnmaildir-base-name-to-article-number
 622   (base-name group-name server-address-string)
 623   (let ((x (nnmaildir--prepare server-address-string group-name)))
 624     (when x
 625       (setq x (nnmaildir--grp-flist x)
 626             x (nnmaildir--flist-art x base-name))
 627       (and x (nnmaildir--art-num x)))))
 628
 629 (defun nnmaildir--nlist-iterate (nlist ranges func)
 630   (let (entry high low nlist2)
 631     (if (eq ranges 'all)
 632         (setq ranges `((1 . ,(caar nlist)))))
 633     (while ranges
 634       (setq entry (car ranges) ranges (cdr ranges))
 635       (while (and ranges (eq entry (car ranges)))
 636         (setq ranges (cdr ranges))) ;; skip duplicates
 637       (if (numberp entry)
 638           (setq low entry
 639                 high entry)
 640         (setq low (car entry)
 641               high (cdr entry)))
 642       (setq nlist2 nlist) ;; Don't assume any sorting of ranges
 643       (catch 'iterate-loop
 644         (while nlist2
 645           (if (<= (caar nlist2) high) (throw 'iterate-loop nil))
 646           (setq nlist2 (cdr nlist2))))
 647       (catch 'iterate-loop
 648         (while nlist2
 649           (setq entry (car nlist2) nlist2 (cdr nlist2))
 650           (if (< (car entry) low) (throw 'iterate-loop nil))
 651           (funcall func (cdr entry)))))))
 652
 653 (defun nnmaildir--up2-1 (n)
 654   (if (zerop n) 1 (1- (lsh 1 (1+ (logb n))))))
 655
 656 (defun nnmaildir--system-name ()
 657   (replace-regexp-in-string
 658    ":" "\\072"
 659    (replace-regexp-in-string
 660     "/" "\\057"
 661     (replace-regexp-in-string "\\\\" "\\134" (system-name) nil 'literal)
 662     nil 'literal)
 663    nil 'literal))
 664
 665 (defun nnmaildir-request-type (_group &optional _article)
 666   'mail)
 667
 668 (defun nnmaildir-status-message (&optional server)
 669   (nnmaildir--prepare server nil)
 670   (nnmaildir--srv-error nnmaildir--cur-server))
 671
 672 (defun nnmaildir-server-opened (&optional server)
 673   (and nnmaildir--cur-server
 674        (if server
 675            (string-equal server (nnmaildir--srv-address nnmaildir--cur-server))
 676          t)
 677        (nnmaildir--srv-groups nnmaildir--cur-server)
 678        t))
 679
 680 (defun nnmaildir-open-server (server &optional defs)
 681   (let ((x server)
 682         dir size)
 683     (catch 'return
 684       (setq server (intern-soft x nnmaildir--servers))
 685       (if server
 686           (and (setq server (symbol-value server))
 687                (nnmaildir--srv-groups server)
 688                (setq nnmaildir--cur-server server)
 689                (throw 'return t))
 690         (setq server (make-nnmaildir--srv :address x))
 691         (let ((inhibit-quit t))
 692           (set (intern x nnmaildir--servers) server)))
 693       (setq dir (assq 'directory defs))
 694       (unless dir
 695         (setf (nnmaildir--srv-error server)
 696               "You must set \"directory\" in the select method")
 697         (throw 'return nil))
 698       (setq dir (cadr dir)
 699             dir (eval dir)
 700             dir (expand-file-name dir)
 701             dir (file-name-as-directory dir))
 702       (unless (file-exists-p dir)
 703         (setf (nnmaildir--srv-error server) (concat "No such directory: " dir))
 704         (throw 'return nil))
 705       (setf (nnmaildir--srv-dir server) dir)
 706       (setq x (assq 'directory-files defs))
 707       (if (null x)
 708           (setq x (if nnheader-directory-files-is-safe 'directory-files
 709                     'nnheader-directory-files-safe))
 710         (setq x (cadr x))
 711         (unless (functionp x)
 712           (setf (nnmaildir--srv-error server)
 713                 (concat "Not a function: " (prin1-to-string x)))
 714           (throw 'return nil)))
 715       (setf (nnmaildir--srv-ls server) x)
 716       (setq size (length (funcall x dir nil "\\`[^.]" 'nosort))
 717             size (nnmaildir--up2-1 size))
 718       (and (setq x (assq 'get-new-mail defs))
 719            (setq x (cdr x))
 720            (car x)
 721            (setf (nnmaildir--srv-gnm server) t)
 722            (require 'nnmail))
 723       (setq x (assq 'target-prefix defs))
 724       (if x
 725           (progn
 726             (setq x (cadr x)
 727                   x (eval x))
 728             (setf (nnmaildir--srv-target-prefix server) x))
 729         (setq x (assq 'create-directory defs))
 730         (if x
 731             (progn
 732               (setq x (cadr x)
 733                     x (eval x)
 734                     x (file-name-as-directory x))
 735               (setf (nnmaildir--srv-target-prefix server) x))
 736           (setf (nnmaildir--srv-target-prefix server) "")))
 737       (setf (nnmaildir--srv-groups server) (make-vector size 0))
 738       (setq nnmaildir--cur-server server)
 739       t)))
 740
 741 (defun nnmaildir--parse-filename (file)
 742   (let ((prefix (car file))
 743         timestamp len)
 744     (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix)
 745         (progn
 746           (setq timestamp (concat "0000" (match-string 1 prefix))
 747                 len (- (length timestamp) 4))
 748           (vector (string-to-number (substring timestamp 0 len))
 749                   (string-to-number (substring timestamp len))
 750                   (match-string 2 prefix)
 751                   file))
 752       file)))
 753
 754 (defun nnmaildir--sort-files (a b)
 755   (catch 'return
 756     (if (consp a)
 757         (throw 'return (and (consp b) (string-lessp (car a) (car b)))))
 758     (if (consp b) (throw 'return t))
 759     (if (< (aref a 0) (aref b 0)) (throw 'return t))
 760     (if (> (aref a 0) (aref b 0)) (throw 'return nil))
 761     (if (< (aref a 1) (aref b 1)) (throw 'return t))
 762     (if (> (aref a 1) (aref b 1)) (throw 'return nil))
 763     (string-lessp (aref a 2) (aref b 2))))
 764
 765 (defun nnmaildir--scan (gname scan-msgs groups _method srv-dir srv-ls)
 766   (catch 'return
 767     (let ((36h-ago (- (car (current-time)) 2))
 768           absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
 769           files num dir flist group x)
 770       (setq absdir (nnmaildir--srvgrp-dir srv-dir gname)
 771             nndir (nnmaildir--nndir absdir))
 772       (unless (file-exists-p absdir)
 773         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 774               (concat "No such directory: " absdir))
 775         (throw 'return nil))
 776       (setq tdir (nnmaildir--tmp absdir)
 777             ndir (nnmaildir--new absdir)
 778             cdir (nnmaildir--cur absdir)
 779             nattr (file-attributes ndir)
 780             cattr (file-attributes cdir))
 781       (unless (and (file-exists-p tdir) nattr cattr)
 782         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 783               (concat "Not a maildir: " absdir))
 784         (throw 'return nil))
 785       (setq group (nnmaildir--prepare nil gname)
 786             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
 787       (if group
 788           (setq isnew nil)
 789         (setq isnew t
 790               group (make-nnmaildir--grp :name gname :index 0))
 791         (nnmaildir--mkdir nndir)
 792         (nnmaildir--mkdir (nnmaildir--nov-dir   nndir))
 793         (nnmaildir--mkdir (nnmaildir--marks-dir nndir)))
 794       (setq read-only (nnmaildir--param pgname 'read-only)
 795             ls (or (nnmaildir--param pgname 'directory-files) srv-ls))
 796       (unless read-only
 797         (setq x (nth 11 (file-attributes tdir)))
 798         (unless (and (equal x (nth 11 nattr)) (equal x (nth 11 cattr)))
 799           (setf (nnmaildir--srv-error nnmaildir--cur-server)
 800                 (concat "Maildir spans filesystems: " absdir))
 801           (throw 'return nil))
 802         (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort))
 803           (setq x (file-attributes file))
 804           (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago))
 805               (delete-file file))))
 806       (or scan-msgs
 807           isnew
 808           (throw 'return t))
 809       (setq nattr (nth 5 nattr))
 810       (if (equal nattr (nnmaildir--grp-new group))
 811           (setq nattr nil))
 812       (if read-only (setq dir (and (or isnew nattr) ndir))
 813         (when (or isnew nattr)
 814           (dolist (file  (funcall ls ndir nil "\\`[^.]" 'nosort))
 815             (setq x (concat ndir file))
 816             (and (time-less-p (nth 5 (file-attributes x)) nil)
 817                  (rename-file x (concat cdir (nnmaildir--ensure-suffix file)))))
 818           (setf (nnmaildir--grp-new group) nattr))
 819         (setq cattr (nth 5 (file-attributes cdir)))
 820         (if (equal cattr (nnmaildir--grp-cur group))
 821             (setq cattr nil))
 822         (setq dir (and (or isnew cattr) cdir)))
 823       (unless dir (throw 'return t))
 824       (setq files (funcall ls dir nil "\\`[^.]" 'nosort)
 825             files (save-match-data
 826                     (mapcar
 827                      (lambda (f)
 828                        (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f)
 829                        (cons (match-string 1 f) (match-string 2 f)))
 830                      files)))
 831       (when isnew
 832         (setq num (nnmaildir--up2-1 (length files)))
 833         (setf (nnmaildir--grp-flist group) (make-vector num 0))
 834         (setf (nnmaildir--grp-mlist group) (make-vector num 0))
 835         (setf (nnmaildir--grp-mmth group) (make-vector 1 0))
 836         (setq num (nnmaildir--param pgname 'nov-cache-size))
 837         (if (numberp num) (if (< num 1) (setq num 1))
 838           (setq num 16
 839                 cdir (nnmaildir--marks-dir nndir)
 840                 ndir (nnmaildir--subdir cdir "tick")
 841                 cdir (nnmaildir--subdir cdir "read"))
 842           (dolist (prefix-suffix files)
 843             (let ((prefix (car prefix-suffix))
 844                   (suffix (cdr prefix-suffix)))
 845               ;; increase num for each unread or ticked article
 846               (when (or
 847                      ;; first look for marks in suffix, if it's valid...
 848                      (when (and (stringp suffix)
 849                                 (string-prefix-p ":2," suffix))
 850                        (or
 851                         (not (string-match-p
 852                               (string (nnmaildir--mark-to-flag 'read)) suffix))
 853                         (string-match-p
 854                          (string (nnmaildir--mark-to-flag 'tick)) suffix)))
 855                      ;; then look in marks directories
 856                      (not (file-exists-p (concat cdir prefix)))
 857                      (file-exists-p (concat ndir prefix)))
 858                 (cl-incf num)))))
 859         (setf (nnmaildir--grp-cache group) (make-vector num nil))
 860         (let ((inhibit-quit t))
 861           (set (intern gname groups) group))
 862         (or scan-msgs (throw 'return t)))
 863       (setq flist (nnmaildir--grp-flist group)
 864             files (mapcar
 865                    (lambda (file)
 866                      (and (null (nnmaildir--flist-art flist (car file)))
 867                           file))
 868                    files)
 869             files (delq nil files)
 870             files (mapcar 'nnmaildir--parse-filename files)
 871             files (sort files 'nnmaildir--sort-files))
 872       (dolist (file files)
 873         (setq file (if (consp file) file (aref file 3))
 874               x (make-nnmaildir--art :prefix (car file) :suffix (cdr file)))
 875         (nnmaildir--grp-add-art nnmaildir--cur-server group x))
 876       (if read-only (setf (nnmaildir--grp-new group) nattr)
 877         (setf (nnmaildir--grp-cur group) cattr)))
 878     t))
 879
 880 (defvar nnmaildir-get-new-mail)
 881 (defvar nnmaildir-group-alist)
 882 (defvar nnmaildir-active-file)
 883
 884 (defun nnmaildir-request-scan (&optional scan-group server)
 885   (let ((coding-system-for-write nnheader-file-coding-system)
 886         (buffer-file-coding-system nil)
 887         (file-coding-system-alist nil)
 888         (nnmaildir-get-new-mail t)
 889         (nnmaildir-group-alist nil)
 890         (nnmaildir-active-file nil)
 891         x srv-ls srv-dir method groups target-prefix dirs seen
 892         deactivate-mark)
 893     (nnmaildir--prepare server nil)
 894     (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server)
 895           srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
 896           method (nnmaildir--srv-method nnmaildir--cur-server)
 897           groups (nnmaildir--srv-groups nnmaildir--cur-server)
 898           target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
 899     (nnmaildir--with-work-buffer
 900       (save-match-data
 901         (if (stringp scan-group)
 902             (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
 903                 (if (nnmaildir--srv-gnm nnmaildir--cur-server)
 904                     (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
 905               (unintern scan-group groups))
 906           (setq x (nth 5 (file-attributes srv-dir))
 907                 scan-group (null scan-group))
 908           (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
 909               (if scan-group
 910                   (mapatoms (lambda (sym)
 911                               (nnmaildir--scan (symbol-name sym) t groups
 912                                                method srv-dir srv-ls))
 913                             groups))
 914             (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
 915                   dirs (if (zerop (length target-prefix))
 916                            dirs
 917                          (seq-remove
 918                           (lambda (dir)
 919                             (and (>= (length dir) (length target-prefix))
 920                                  (string= (substring dir 0
 921                                                      (length target-prefix))
 922                                           target-prefix)))
 923                           dirs))
 924                   seen (nnmaildir--up2-1 (length dirs))
 925                   seen (make-vector seen 0))
 926             (dolist (grp-dir dirs)
 927               (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
 928                                    srv-ls)
 929                   (intern grp-dir seen)))
 930             (setq x nil)
 931             (mapatoms (lambda (group)
 932                         (setq group (symbol-name group))
 933                         (unless (intern-soft group seen)
 934                           (setq x (cons group x))))
 935                       groups)
 936             (dolist (grp x)
 937               (unintern grp groups))
 938             (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
 939                   (nth 5 (file-attributes srv-dir))))
 940           (and scan-group
 941                (nnmaildir--srv-gnm nnmaildir--cur-server)
 942                (nnmail-get-new-mail 'nnmaildir nil nil))))))
 943   t)
 944
 945 (defun nnmaildir-request-list (&optional server)
 946   (nnmaildir-request-scan 'find-new-groups server)
 947   (let (pgname ro deactivate-mark)
 948     (nnmaildir--prepare server nil)
 949     (nnmaildir--with-nntp-buffer
 950       (erase-buffer)
 951       (mapatoms (lambda (group)
 952                   (setq pgname (symbol-name group)
 953                         pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
 954                         group (symbol-value group)
 955                         ro (nnmaildir--param pgname 'read-only))
 956                   (insert (replace-regexp-in-string
 957                            " " "\\ "
 958                            (nnmaildir--grp-name group) nil t)
 959                           " ")
 960                   (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 961                          nntp-server-buffer)
 962                   (insert " ")
 963                   (princ (nnmaildir--grp-min group) nntp-server-buffer)
 964                   (insert " " (if ro "n" "y") "\n"))
 965                 (nnmaildir--srv-groups nnmaildir--cur-server))))
 966   t)
 967
 968 (defun nnmaildir-request-newgroups (_date &optional server)
 969   (nnmaildir-request-list server))
 970
 971 (defun nnmaildir-retrieve-groups (groups &optional server)
 972   (let (group deactivate-mark)
 973     (nnmaildir--prepare server nil)
 974     (nnmaildir--with-nntp-buffer
 975       (erase-buffer)
 976       (dolist (gname groups)
 977         (setq group (nnmaildir--prepare nil gname))
 978         (if (null group) (insert "411 no such news group\n")
 979           (insert "211 ")
 980           (princ (nnmaildir--grp-count group) nntp-server-buffer)
 981           (insert " ")
 982           (princ (nnmaildir--grp-min   group) nntp-server-buffer)
 983           (insert " ")
 984           (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 985                  nntp-server-buffer)
 986           (insert " "
 987                   (replace-regexp-in-string " " "\\ " gname nil t)
 988                   "\n")))))
 989   'group)
 990
 991 (defun nnmaildir-request-update-info (gname info &optional server)
 992   (let* ((group (nnmaildir--prepare server gname))
 993          (curdir (nnmaildir--cur
 994                   (nnmaildir--srvgrp-dir
 995                    (nnmaildir--srv-dir nnmaildir--cur-server) gname)))
 996          (curdir-mtime (nth 5 (file-attributes curdir)))
 997          pgname flist always-marks never-marks old-marks dir
 998          all-marks marks ranges markdir read ls
 999          old-mmth new-mmth mtime existing missing deactivate-mark)
1000     (catch 'return
1001       (unless group
1002         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1003               (concat "No such group: " gname))
1004         (throw 'return nil))
1005       (setq gname (nnmaildir--grp-name group)
1006             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1007             flist (nnmaildir--grp-flist group))
1008       (when (zerop (nnmaildir--grp-count group))
1009         (gnus-info-set-read info nil)
1010         (gnus-info-set-marks info nil 'extend)
1011         (throw 'return info))
1012       (setq old-marks (cons 'read (gnus-info-read info))
1013             old-marks (cons old-marks (gnus-info-marks info))
1014             always-marks (nnmaildir--param pgname 'always-marks)
1015             never-marks (nnmaildir--param pgname 'never-marks)
1016             existing (nnmaildir--grp-nlist group)
1017             existing (mapcar 'car existing)
1018             existing (nreverse existing)
1019             existing (gnus-compress-sequence existing 'always-list)
1020             missing (list (cons 1 (nnmaildir--group-maxnum
1021                                    nnmaildir--cur-server group)))
1022             missing (gnus-range-difference missing existing)
1023             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1024             dir (nnmaildir--srvgrp-dir dir gname)
1025             dir (nnmaildir--nndir dir)
1026             dir (nnmaildir--marks-dir dir)
1027             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1028             all-marks (gnus-delete-duplicates
1029                        ;; get mark names from mark dirs and from flag
1030                        ;; mappings
1031                        (append
1032                         (mapcar 'cdr nnmaildir-flag-mark-mapping)
1033                         (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort))))
1034             new-mmth (nnmaildir--up2-1 (length all-marks))
1035             new-mmth (make-vector new-mmth 0)
1036             old-mmth (nnmaildir--grp-mmth group))
1037       (dolist (mark all-marks)
1038         (setq markdir (nnmaildir--subdir dir (symbol-name mark))
1039               ranges nil)
1040         (catch 'got-ranges
1041           (if (memq mark never-marks) (throw 'got-ranges nil))
1042           (when (memq mark always-marks)
1043             (setq ranges existing)
1044             (throw 'got-ranges nil))
1045           ;; Find the mtime for this mark.  If this mark can be expressed as
1046           ;; a filename flag, get the later of the mtimes for markdir and
1047           ;; curdir, otherwise only the markdir counts.
1048           (setq mtime
1049                 (let ((markdir-mtime (nth 5 (file-attributes markdir))))
1050                   (cond
1051                    ((null (nnmaildir--mark-to-flag mark))
1052                     markdir-mtime)
1053                    ((null markdir-mtime)
1054                     curdir-mtime)
1055                    ((null curdir-mtime)
1056                     ;; this should never happen...
1057                     markdir-mtime)
1058                    ((time-less-p markdir-mtime curdir-mtime)
1059                     curdir-mtime)
1060                    (t
1061                     markdir-mtime))))
1062           (set (intern (symbol-name mark) new-mmth) mtime)
1063           (when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth)))
1064             (setq ranges (assq mark old-marks))
1065             (if ranges (setq ranges (cdr ranges)))
1066             (throw 'got-ranges nil))
1067           (let ((article-list nil))
1068             ;; Consider the article marked if it either has the flag in the
1069             ;; filename, or is in the markdir.  As you'd rarely remove a
1070             ;; flag/mark, this should avoid losing information in the most
1071             ;; common usage pattern.
1072             (or
1073              (let ((flag (nnmaildir--mark-to-flag mark)))
1074                ;; If this mark has a corresponding maildir flag...
1075                (when flag
1076                  (let ((regexp
1077                         (concat "\\`[^.].*:2,[A-Z]*" (string flag))))
1078                    ;; ...then find all files with that flag.
1079                    (dolist (filename (funcall ls curdir nil regexp 'nosort))
1080                      (let* ((prefix (car (split-string filename ":2,")))
1081                             (article (nnmaildir--flist-art flist prefix)))
1082                        (when article
1083                          (push (nnmaildir--art-num article) article-list)))))))
1084              ;; Also check Gnus-specific mark directory, if it exists.
1085              (when (file-directory-p markdir)
1086                (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort))
1087                  (let ((article (nnmaildir--flist-art flist prefix)))
1088                    (when article
1089                      (push (nnmaildir--art-num article) article-list))))))
1090             (setq ranges (gnus-add-to-range ranges (sort article-list '<)))))
1091         (if (eq mark 'read) (setq read ranges)
1092           (if ranges (setq marks (cons (cons mark ranges) marks)))))
1093       (gnus-info-set-read info (gnus-range-add read missing))
1094       (gnus-info-set-marks info marks 'extend)
1095       (setf (nnmaildir--grp-mmth group) new-mmth)
1096       info)))
1097
1098 (defun nnmaildir-request-group (gname &optional server fast _info)
1099   (let ((group (nnmaildir--prepare server gname))
1100         deactivate-mark)
1101     (catch 'return
1102       (unless group
1103         ;; (insert "411 no such news group\n")
1104         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1105               (concat "No such group: " gname))
1106         (throw 'return nil))
1107       (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
1108       (if fast (throw 'return t))
1109       (nnmaildir--with-nntp-buffer
1110         (erase-buffer)
1111         (insert "211 ")
1112         (princ (nnmaildir--grp-count group) nntp-server-buffer)
1113         (insert " ")
1114         (princ (nnmaildir--grp-min   group) nntp-server-buffer)
1115         (insert " ")
1116         (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
1117                nntp-server-buffer)
1118         (insert " " (replace-regexp-in-string " " "\\ " gname nil t) "\n")
1119         t))))
1120
1121 (defun nnmaildir-request-create-group (gname &optional server _args)
1122   (nnmaildir--prepare server nil)
1123   (catch 'return
1124     (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
1125           srv-dir dir groups)
1126       (when (zerop (length gname))
1127         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1128               "Invalid (empty) group name")
1129         (throw 'return nil))
1130       (when (eq (aref "." 0) (aref gname 0))
1131         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1132               "Group names may not start with \".\"")
1133         (throw 'return nil))
1134       (when (save-match-data (string-match "[\0/\t]" gname))
1135         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1136               (concat "Invalid characters (null, tab, or /) in group name: "
1137                       gname))
1138         (throw 'return nil))
1139       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
1140       (when (intern-soft gname groups)
1141         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1142               (concat "Group already exists: " gname))
1143         (throw 'return nil))
1144       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1145       (if (file-name-absolute-p target-prefix)
1146           (setq dir (expand-file-name target-prefix))
1147         (setq dir srv-dir
1148               dir (file-truename dir)
1149               dir (concat dir target-prefix)))
1150       (setq dir (nnmaildir--subdir dir gname))
1151       (nnmaildir--mkdir dir)
1152       (nnmaildir--mkdir (nnmaildir--tmp dir))
1153       (nnmaildir--mkdir (nnmaildir--new dir))
1154       (nnmaildir--mkdir (nnmaildir--cur dir))
1155       (unless (string= target-prefix "")
1156         (make-symbolic-link (concat target-prefix gname)
1157                             (concat srv-dir gname)))
1158       (nnmaildir-request-scan 'find-new-groups))))
1159
1160 (defun nnmaildir-request-rename-group (gname new-name &optional server)
1161   (let ((group (nnmaildir--prepare server gname))
1162         (coding-system-for-write nnheader-file-coding-system)
1163         (buffer-file-coding-system nil)
1164         (file-coding-system-alist nil)
1165         srv-dir x groups)
1166     (catch 'return
1167       (unless group
1168         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1169               (concat "No such group: " gname))
1170         (throw 'return nil))
1171       (when (zerop (length new-name))
1172         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1173               "Invalid (empty) group name")
1174         (throw 'return nil))
1175       (when (eq (aref "." 0) (aref new-name 0))
1176         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1177               "Group names may not start with \".\"")
1178         (throw 'return nil))
1179       (when (save-match-data (string-match "[\0/\t]" new-name))
1180         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1181               (concat "Invalid characters (null, tab, or /) in group name: "
1182                       new-name))
1183         (throw 'return nil))
1184       (if (string-equal gname new-name) (throw 'return t))
1185       (when (intern-soft new-name
1186                          (nnmaildir--srv-groups nnmaildir--cur-server))
1187         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1188               (concat "Group already exists: " new-name))
1189         (throw 'return nil))
1190       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1191       (condition-case err
1192           (rename-file (concat srv-dir gname)
1193                        (concat srv-dir new-name))
1194         (error
1195          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1196                (concat "Error renaming link: " (prin1-to-string err)))
1197          (throw 'return nil)))
1198       (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
1199             groups (make-vector (length x) 0))
1200       (mapatoms (lambda (sym)
1201                   (unless (eq (symbol-value sym) group)
1202                     (set (intern (symbol-name sym) groups)
1203                          (symbol-value sym))))
1204                 x)
1205       (setq group (copy-sequence group))
1206       (setf (nnmaildir--grp-name group) new-name)
1207       (set (intern new-name groups) group)
1208       (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
1209       t)))
1210
1211 (defun nnmaildir-request-delete-group (gname force &optional server)
1212   (let ((group (nnmaildir--prepare server gname))
1213         pgname grp-dir target dir ls deactivate-mark)
1214     (catch 'return
1215       (unless group
1216         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1217               (concat "No such group: " gname))
1218         (throw 'return nil))
1219       (setq gname (nnmaildir--grp-name group)
1220             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1221             grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1222             target (car (file-attributes (concat grp-dir gname)))
1223             grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
1224       (unless (or force (stringp target))
1225         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1226               (concat "Not a symlink: " gname))
1227         (throw 'return nil))
1228       (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
1229           (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
1230       (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
1231       (if (not force)
1232           (progn
1233             (setq grp-dir (directory-file-name grp-dir))
1234             (nnmaildir--unlink grp-dir))
1235         (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname))
1236         (if (nnmaildir--param pgname 'read-only)
1237             (progn (delete-directory  (nnmaildir--tmp grp-dir))
1238                    (nnmaildir--unlink (nnmaildir--new grp-dir))
1239                    (delete-directory  (nnmaildir--cur grp-dir)))
1240           (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls)
1241           (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls)
1242           (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls))
1243         (setq dir (nnmaildir--nndir grp-dir))
1244         (dolist (subdir `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir)
1245                           ,@(funcall ls (nnmaildir--marks-dir dir)
1246                                      'full "\\`[^.]" 'nosort)))
1247           (nnmaildir--delete-dir-files subdir ls))
1248         (setq dir (nnmaildir--nndir grp-dir))
1249         (nnmaildir--unlink (concat dir "markfile"))
1250         (nnmaildir--unlink (concat dir "markfile{new}"))
1251         (delete-directory (nnmaildir--marks-dir dir))
1252         (delete-directory dir)
1253         (if (not (stringp target))
1254             (delete-directory grp-dir)
1255           (setq grp-dir (directory-file-name grp-dir)
1256                 dir target)
1257           (unless (eq (aref "/" 0) (aref dir 0))
1258             (setq dir (concat (file-truename
1259                                (nnmaildir--srv-dir nnmaildir--cur-server))
1260                               dir)))
1261           (delete-directory dir)
1262           (nnmaildir--unlink grp-dir)))
1263       t)))
1264
1265 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1266   (let ((group (nnmaildir--prepare server gname))
1267         nlist mlist article num start stop nov insert-nov
1268         deactivate-mark)
1269     (setq insert-nov
1270           (lambda (article)
1271             (setq nov (nnmaildir--update-nov nnmaildir--cur-server group
1272                                              article))
1273             (when nov
1274               (nnmaildir--cache-nov group article nov)
1275               (setq num (nnmaildir--art-num article))
1276               (princ num nntp-server-buffer)
1277               (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1278                       (nnmaildir--art-msgid article) "\t"
1279                       (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir "
1280                       (replace-regexp-in-string " " "\\ " gname nil t) ":")
1281               (princ num nntp-server-buffer)
1282               (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1283     (catch 'return
1284       (unless group
1285         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1286               (if gname (concat "No such group: " gname) "No current group"))
1287         (throw 'return nil))
1288       (nnmaildir--with-nntp-buffer
1289         (erase-buffer)
1290         (setq mlist (nnmaildir--grp-mlist group)
1291               nlist (nnmaildir--grp-nlist group)
1292               gname (nnmaildir--grp-name group))
1293         (cond
1294          ((null nlist))
1295          ((and fetch-old (not (numberp fetch-old)))
1296           (nnmaildir--nlist-iterate nlist 'all insert-nov))
1297          ((null articles))
1298          ((stringp (car articles))
1299           (dolist (msgid articles)
1300             (setq article (nnmaildir--mlist-art mlist msgid))
1301             (if article (funcall insert-nov article))))
1302          (t
1303           (if fetch-old
1304               ;; Assume the article range list is sorted ascending
1305               (setq stop (car articles)
1306                     start (car (last articles))
1307                     stop  (if (numberp stop)  stop  (car stop))
1308                     start (if (numberp start) start (cdr start))
1309                     stop (- stop fetch-old)
1310                     stop (if (< stop 1) 1 stop)
1311                     articles (list (cons stop start))))
1312           (nnmaildir--nlist-iterate nlist articles insert-nov)))
1313         (sort-numeric-fields 1 (point-min) (point-max))
1314         'nov))))
1315
1316 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1317   (let ((group (nnmaildir--prepare server gname))
1318         (case-fold-search t)
1319         list article dir pgname deactivate-mark)
1320     (catch 'return
1321       (unless group
1322         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1323               (if gname (concat "No such group: " gname) "No current group"))
1324         (throw 'return nil))
1325       (if (numberp num-msgid)
1326           (setq article (nnmaildir--nlist-art group num-msgid))
1327         (setq list (nnmaildir--grp-mlist group)
1328               article (nnmaildir--mlist-art list num-msgid))
1329         (if article (setq num-msgid (nnmaildir--art-num article))
1330           (catch 'found
1331             (mapatoms
1332               (lambda (group-sym)
1333                 (setq group (symbol-value group-sym)
1334                       list (nnmaildir--grp-mlist group)
1335                       article (nnmaildir--mlist-art list num-msgid))
1336                 (when article
1337                   (setq num-msgid (nnmaildir--art-num article))
1338                   (throw 'found nil)))
1339               (nnmaildir--srv-groups nnmaildir--cur-server))))
1340         (unless article
1341           (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1342           (throw 'return nil)))
1343       (setq gname (nnmaildir--grp-name group)
1344             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1345             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1346             dir (nnmaildir--srvgrp-dir dir gname)
1347             dir (if (nnmaildir--param pgname 'read-only)
1348                     (nnmaildir--new dir) (nnmaildir--cur dir))
1349             nnmaildir-article-file-name
1350             (concat dir
1351                     (nnmaildir--art-prefix article)
1352                     (nnmaildir--art-suffix article)))
1353       (unless (file-exists-p nnmaildir-article-file-name)
1354         (nnmaildir--expired-article group article)
1355         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1356               "Article has expired")
1357         (throw 'return nil))
1358       (with-current-buffer (or to-buffer nntp-server-buffer)
1359         (erase-buffer)
1360         (nnheader-insert-file-contents nnmaildir-article-file-name))
1361       (cons gname num-msgid))))
1362
1363 (defun nnmaildir-request-post (&optional _server)
1364   (let (message-required-mail-headers)
1365     (funcall message-send-mail-function)))
1366
1367 (defun nnmaildir-request-replace-article (number gname buffer)
1368   (let ((group (nnmaildir--prepare nil gname))
1369         (coding-system-for-write nnheader-file-coding-system)
1370         (buffer-file-coding-system nil)
1371         (file-coding-system-alist nil)
1372         dir file article suffix tmpfile deactivate-mark)
1373     (catch 'return
1374       (unless group
1375         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1376               (concat "No such group: " gname))
1377         (throw 'return nil))
1378       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1379                               'read-only)
1380         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1381               (concat "Read-only group: " group))
1382         (throw 'return nil))
1383       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1384             dir (nnmaildir--srvgrp-dir dir gname)
1385             article (nnmaildir--nlist-art group number))
1386       (unless article
1387         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1388               (concat "No such article: " (number-to-string number)))
1389         (throw 'return nil))
1390       (setq suffix (nnmaildir--art-suffix article)
1391             file (nnmaildir--art-prefix article)
1392             tmpfile (concat (nnmaildir--tmp dir) file))
1393       (when (file-exists-p tmpfile)
1394         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1395               (concat "File exists: " tmpfile))
1396         (throw 'return nil))
1397       (with-current-buffer buffer
1398         (write-region (point-min) (point-max) tmpfile nil 'no-message nil
1399                       'excl))
1400       (unix-sync) ;; no fsync :(
1401       (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1402       t)))
1403
1404 (defun nnmaildir-request-move-article (article gname server accept-form
1405                                        &optional _last _move-is-internal)
1406   (let ((group (nnmaildir--prepare server gname))
1407         pgname suffix result nnmaildir--file deactivate-mark)
1408     (catch 'return
1409       (unless group
1410         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1411               (concat "No such group: " gname))
1412         (throw 'return nil))
1413       (setq gname (nnmaildir--grp-name group)
1414             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1415             article (nnmaildir--nlist-art group article))
1416       (unless article
1417         (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1418         (throw 'return nil))
1419       (setq suffix (nnmaildir--art-suffix article)
1420             nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1421             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1422             nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1423                                 (nnmaildir--new nnmaildir--file)
1424                               (nnmaildir--cur nnmaildir--file))
1425             nnmaildir--file (concat nnmaildir--file
1426                                     (nnmaildir--art-prefix article)
1427                                     suffix))
1428       (unless (file-exists-p nnmaildir--file)
1429         (nnmaildir--expired-article group article)
1430         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1431               "Article has expired")
1432         (throw 'return nil))
1433       (nnmaildir--with-move-buffer
1434         (erase-buffer)
1435         (nnheader-insert-file-contents nnmaildir--file)
1436         (setq result (eval accept-form)))
1437       (unless (or (null result) (nnmaildir--param pgname 'read-only))
1438         (nnmaildir--unlink nnmaildir--file)
1439         (nnmaildir--expired-article group article))
1440       result)))
1441
1442 (defun nnmaildir-request-accept-article (gname &optional server _last)
1443   (let ((group (nnmaildir--prepare server gname))
1444         (coding-system-for-write nnheader-file-coding-system)
1445         (buffer-file-coding-system nil)
1446         (file-coding-system-alist nil)
1447         srv-dir dir file time tmpfile curfile 24h article)
1448     (catch 'return
1449       (unless group
1450         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1451               (concat "No such group: " gname))
1452         (throw 'return nil))
1453       (setq gname (nnmaildir--grp-name group))
1454       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1455                               'read-only)
1456         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1457               (concat "Read-only group: " gname))
1458         (throw 'return nil))
1459       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1460             dir (nnmaildir--srvgrp-dir srv-dir gname)
1461             time (current-time)
1462             file (format-time-string "%s." time))
1463       (unless (string-equal nnmaildir--delivery-time file)
1464         (setq nnmaildir--delivery-time file
1465               nnmaildir--delivery-count 0))
1466       (when (and (consp (cdr time))
1467                  (consp (cddr time)))
1468         (setq file (concat file "M" (number-to-string (caddr time)))))
1469       (setq file (concat file nnmaildir--delivery-pid)
1470             file (concat file "Q" (number-to-string nnmaildir--delivery-count))
1471             file (concat file "." (nnmaildir--system-name))
1472             tmpfile (concat (nnmaildir--tmp dir) file)
1473             curfile (concat (nnmaildir--cur dir) file ":2,"))
1474       (when (file-exists-p tmpfile)
1475         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1476               (concat "File exists: " tmpfile))
1477         (throw 'return nil))
1478       (when (file-exists-p curfile)
1479         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1480               (concat "File exists: " curfile))
1481         (throw 'return nil))
1482       (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count)
1483             24h (run-with-timer 86400 nil
1484                                 (lambda ()
1485                                   (nnmaildir--unlink tmpfile)
1486                                   (setf (nnmaildir--srv-error
1487                                           nnmaildir--cur-server)
1488                                         "24-hour timer expired")
1489                                   (throw 'return nil))))
1490       (condition-case nil (add-name-to-file nnmaildir--file tmpfile)
1491         (error
1492          (write-region (point-min) (point-max) tmpfile nil 'no-message nil
1493                        'excl)
1494          (when (fboundp 'unix-sync)
1495            (unix-sync)))) ;; no fsync :(
1496       (nnheader-cancel-timer 24h)
1497       (condition-case err
1498           (add-name-to-file tmpfile curfile)
1499         (error
1500          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1501                (concat "Error linking: " (prin1-to-string err)))
1502          (nnmaildir--unlink tmpfile)
1503          (throw 'return nil)))
1504       (nnmaildir--unlink tmpfile)
1505       (setq article (make-nnmaildir--art :prefix file :suffix ":2,"))
1506       (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1507           (cons gname (nnmaildir--art-num article))))))
1508
1509 (defun nnmaildir-save-mail (group-art)
1510   (catch 'return
1511     (unless group-art
1512       (throw 'return nil))
1513     (let (ga gname x groups nnmaildir--file deactivate-mark)
1514       (save-excursion
1515         (goto-char (point-min))
1516         (save-match-data
1517           (while (looking-at "From ")
1518             (replace-match "X-From-Line: ")
1519             (forward-line 1))))
1520       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1521             ga (car group-art) group-art (cdr group-art)
1522             gname (car ga))
1523       (or (intern-soft gname groups)
1524           (nnmaildir-request-create-group gname)
1525           (throw 'return nil)) ;; not that nnmail bothers to check :(
1526       (unless (nnmaildir-request-accept-article gname)
1527         (throw 'return nil))
1528       (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1529             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1530             x (nnmaildir--prepare nil gname)
1531             x (nnmaildir--grp-nlist x)
1532             x (cdar x)
1533             nnmaildir--file (concat nnmaildir--file
1534                                     (nnmaildir--art-prefix x)
1535                                     (nnmaildir--art-suffix x)))
1536       (delq nil
1537             (mapcar
1538              (lambda (ga)
1539                (setq gname (car ga))
1540                (and (or (intern-soft gname groups)
1541                         (nnmaildir-request-create-group gname))
1542                     (nnmaildir-request-accept-article gname)
1543                     ga))
1544              group-art)))))
1545
1546 (defun nnmaildir-active-number (_gname)
1547   0)
1548
1549 (declare-function gnus-group-mark-article-read "gnus-group" (group article))
1550
1551 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1552   (let ((no-force (not force))
1553         (group (nnmaildir--prepare server gname))
1554         pgname time boundary bound-iter high low target dir nlist
1555         didnt nnmaildir--file nnmaildir-article-file-name
1556         deactivate-mark)
1557     (catch 'return
1558       (unless group
1559         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1560               (if gname (concat "No such group: " gname) "No current group"))
1561         (throw 'return (gnus-uncompress-range ranges)))
1562       (setq gname (nnmaildir--grp-name group)
1563             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1564       (if (nnmaildir--param pgname 'read-only)
1565           (throw 'return (gnus-uncompress-range ranges)))
1566       (setq time (nnmaildir--param pgname 'expire-age))
1567       (unless time
1568         (setq time (or (and nnmail-expiry-wait-function
1569                             (funcall nnmail-expiry-wait-function gname))
1570                        nnmail-expiry-wait))
1571         (if (eq time 'immediate)
1572             (setq time 0)
1573           (if (numberp time)
1574               (setq time (round (* time 86400))))))
1575       (when no-force
1576         (unless (integerp time) ;; handle 'never
1577           (throw 'return (gnus-uncompress-range ranges)))
1578         (setq boundary (current-time)
1579               high (- (car boundary) (/ time 65536))
1580               low (- (cadr boundary) (% time 65536)))
1581         (if (< low 0)
1582             (setq low (+ low 65536)
1583                   high (1- high)))
1584         (setcar (cdr boundary) low)
1585         (setcar boundary high))
1586       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1587             dir (nnmaildir--srvgrp-dir dir gname)
1588             dir (nnmaildir--cur dir)
1589             nlist (nnmaildir--grp-nlist group)
1590             ranges (reverse ranges))
1591       (nnmaildir--with-move-buffer
1592         (nnmaildir--nlist-iterate
1593          nlist ranges
1594          (lambda (article)
1595            (setq nnmaildir--file (nnmaildir--art-prefix article)
1596                  nnmaildir--file (concat dir nnmaildir--file
1597                                          (nnmaildir--art-suffix article))
1598                  time (file-attributes nnmaildir--file))
1599            (cond
1600             ((null time)
1601              (nnmaildir--expired-article group article))
1602             ((and no-force
1603                   (progn
1604                     (setq time (nth 5 time)
1605                           bound-iter boundary)
1606                     (while (and bound-iter time
1607                                 (= (car bound-iter) (car time)))
1608                       (setq bound-iter (cdr bound-iter)
1609                             time (cdr time)))
1610                     (and bound-iter time
1611                          (car-less-than-car bound-iter time))))
1612              (setq didnt (cons (nnmaildir--art-num article) didnt)))
1613             (t
1614              (setq nnmaildir-article-file-name nnmaildir--file
1615                    target (if force nil
1616                             (save-excursion
1617                               (save-restriction
1618                                 (nnmaildir--param pgname 'expire-group)))))
1619              (when (and (stringp target)
1620                         (not (string-equal target pgname))) ;; Move it.
1621                (erase-buffer)
1622                (nnheader-insert-file-contents nnmaildir--file)
1623                (let ((group-art (gnus-request-accept-article
1624                                  target nil nil 'no-encode)))
1625                  (when (consp group-art)
1626                    ;; Maybe also copy: dormant forward reply save tick
1627                    ;; (gnus-add-mark? gnus-request-set-mark?)
1628                    (gnus-group-mark-article-read target (cdr group-art)))))
1629              (if (equal target pgname)
1630                  ;; Leave it here.
1631                  (setq didnt (cons (nnmaildir--art-num article) didnt))
1632                (nnmaildir--unlink nnmaildir--file)
1633                (nnmaildir--expired-article group article))))))
1634         (erase-buffer))
1635       didnt)))
1636
1637 (defvar nnmaildir--article)
1638
1639 (defun nnmaildir-request-set-mark (gname actions &optional server)
1640   (let* ((group (nnmaildir--prepare server gname))
1641          (curdir (nnmaildir--cur
1642                   (nnmaildir--srvgrp-dir
1643                    (nnmaildir--srv-dir nnmaildir--cur-server)
1644                    gname)))
1645          (coding-system-for-write nnheader-file-coding-system)
1646          (buffer-file-coding-system nil)
1647          (file-coding-system-alist nil)
1648          marksdir nlist
1649          ranges all-marks todo-marks mdir mfile
1650          pgname ls permarkfile deactivate-mark
1651          (del-mark
1652           (lambda (mark)
1653             (let ((prefix (nnmaildir--art-prefix nnmaildir--article))
1654                   (suffix (nnmaildir--art-suffix nnmaildir--article))
1655                   (flag (nnmaildir--mark-to-flag mark)))
1656               (when flag
1657                 ;; If this mark corresponds to a flag, remove the flag from
1658                 ;; the file name.
1659                 (nnmaildir--article-set-flags
1660                  nnmaildir--article (nnmaildir--remove-flag flag suffix)
1661                  curdir))
1662               ;; We still want to delete the hardlink in the marks dir if
1663               ;; present, regardless of whether this mark has a maildir flag or
1664               ;; not, to avoid getting out of sync.
1665               (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
1666                     mfile (concat mfile prefix))
1667               (nnmaildir--unlink mfile))))
1668          (del-action (lambda (article)
1669                        (let ((nnmaildir--article article))
1670                          (mapcar del-mark todo-marks))))
1671          (add-action
1672           (lambda (article)
1673             (mapcar
1674              (lambda (mark)
1675                (let ((prefix (nnmaildir--art-prefix article))
1676                      (suffix (nnmaildir--art-suffix article))
1677                      (flag (nnmaildir--mark-to-flag mark)))
1678                  (if flag
1679                      ;; If there is a corresponding maildir flag, just rename
1680                      ;; the file.
1681                      (nnmaildir--article-set-flags
1682                       article (nnmaildir--add-flag flag suffix) curdir)
1683                    ;; Otherwise, use nnmaildir-specific marks dir.
1684                    (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
1685                          permarkfile (concat mdir ":")
1686                          mfile (concat mdir prefix))
1687                    (nnmaildir--condcase err (add-name-to-file permarkfile mfile)
1688                      (cond
1689                       ((nnmaildir--eexist-p err))
1690                       ((nnmaildir--enoent-p err)
1691                        (nnmaildir--mkdir mdir)
1692                        (nnmaildir--mkfile permarkfile)
1693                        (add-name-to-file permarkfile mfile))
1694                       ((nnmaildir--emlink-p err)
1695                        (let ((permarkfilenew (concat permarkfile "{new}")))
1696                          (nnmaildir--mkfile permarkfilenew)
1697                          (rename-file permarkfilenew permarkfile 'replace)
1698                          (add-name-to-file permarkfile mfile)))
1699                       (t (signal (car err) (cdr err))))))))
1700              todo-marks)))
1701          (set-action (lambda (article)
1702                        (funcall add-action article)
1703                        (let ((nnmaildir--article article))
1704                          (mapcar (lambda (mark)
1705                                    (unless (memq mark todo-marks)
1706                                      (funcall del-mark mark)))
1707                                  all-marks)))))
1708     (catch 'return
1709       (unless group
1710         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1711               (concat "No such group: " gname))
1712         (dolist (action actions)
1713           (setq ranges (gnus-range-add ranges (car action))))
1714         (throw 'return ranges))
1715       (setq nlist (nnmaildir--grp-nlist group)
1716             marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1717             marksdir (nnmaildir--srvgrp-dir marksdir gname)
1718             marksdir (nnmaildir--nndir marksdir)
1719             marksdir (nnmaildir--marks-dir marksdir)
1720             gname (nnmaildir--grp-name group)
1721             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1722             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1723             all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1724             all-marks (gnus-delete-duplicates
1725                        ;; get mark names from mark dirs and from flag
1726                        ;; mappings
1727                        (append
1728                         (mapcar 'cdr nnmaildir-flag-mark-mapping)
1729                         (mapcar 'intern all-marks))))
1730       (dolist (action actions)
1731         (setq ranges (car action)
1732               todo-marks (caddr action))
1733         (dolist (mark todo-marks)
1734           (cl-pushnew mark all-marks :test #'equal))
1735         (if (numberp (cdr ranges)) (setq ranges (list ranges)))
1736         (nnmaildir--nlist-iterate nlist ranges
1737                                   (cond ((eq 'del (cadr action)) del-action)
1738                                         ((eq 'add (cadr action)) add-action)
1739                                         ((eq 'set (cadr action)) set-action))))
1740       nil)))
1741
1742 (defun nnmaildir-close-group (gname &optional server)
1743   (let ((group (nnmaildir--prepare server gname))
1744         pgname ls dir msgdir files flist dirs)
1745     (if (null group)
1746         (progn
1747           (setf (nnmaildir--srv-error nnmaildir--cur-server)
1748                 (concat "No such group: " gname))
1749           nil)
1750       (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1751             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1752             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1753             dir (nnmaildir--srvgrp-dir dir gname)
1754             msgdir (if (nnmaildir--param pgname 'read-only)
1755                        (nnmaildir--new dir) (nnmaildir--cur dir))
1756             dir (nnmaildir--nndir dir)
1757             dirs (cons (nnmaildir--nov-dir dir)
1758                        (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1759                                 'nosort))
1760             dirs (mapcar
1761                   (lambda (dir)
1762                     (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
1763                   dirs)
1764             files (funcall ls msgdir nil "\\`[^.]" 'nosort)
1765             flist (nnmaildir--up2-1 (length files))
1766             flist (make-vector flist 0))
1767       (save-match-data
1768         (dolist (file files)
1769           (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1770           (intern (match-string 1 file) flist)))
1771       (dolist (dir dirs)
1772         (setq files (cdr dir)
1773               dir (file-name-as-directory (car dir)))
1774         (dolist (file files)
1775           (unless (or (intern-soft file flist) (string= file ":"))
1776             (setq file (concat dir file))
1777             (delete-file file))))
1778       t)))
1779
1780 (defun nnmaildir-close-server (&optional server)
1781   (nnmaildir--prepare server nil)
1782   (when nnmaildir--cur-server
1783     (setq server nnmaildir--cur-server
1784           nnmaildir--cur-server nil)
1785     (unintern (nnmaildir--srv-address server) nnmaildir--servers))
1786   t)
1787
1788 (defun nnmaildir-request-close ()
1789   (let (servers buffer)
1790     (mapatoms (lambda (server)
1791                 (setq servers (cons (symbol-name server) servers)))
1792               nnmaildir--servers)
1793     (mapc 'nnmaildir-close-server servers)
1794     (setq buffer (get-buffer " *nnmaildir work*"))
1795     (if buffer (kill-buffer buffer))
1796     (setq buffer (get-buffer " *nnmaildir nov*"))
1797     (if buffer (kill-buffer buffer))
1798     (setq buffer (get-buffer " *nnmaildir move*"))
1799     (if buffer (kill-buffer buffer)))
1800   t)
1801
1802 (provide 'nnmaildir)
1803
1804 ;; Local Variables:
1805 ;; indent-tabs-mode: t
1806 ;; fill-column: 77
1807 ;; End:
1808
1809 ;;; nnmaildir.el ends here