cgit.sxemacs.org Git - gnus/blob - lisp/nnmaildir.el

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