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