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 3, 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., 51 Franklin Street, Fifth Floor,
  21 ;; Boston, MA 02110-1301, 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     (mapc '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         (gmm-write-region (point-min) (point-max) file nil 'no-message nil
 485                           'excl))
 486       (rename-file file novfile 'replace)
 487       (setf (nnmaildir--art-msgid article) msgid)
 488       nov)))
 489
 490 (defun nnmaildir--cache-nov (group article nov)
 491   (let ((cache (nnmaildir--grp-cache group))
 492         (index (nnmaildir--grp-index group))
 493         goner)
 494     (unless (nnmaildir--art-nov article)
 495       (setq goner (aref cache index))
 496       (if goner (setf (nnmaildir--art-nov goner) nil))
 497       (aset cache index article)
 498       (setf (nnmaildir--grp-index group) (% (1+ index) (length cache))))
 499     (setf (nnmaildir--art-nov article) nov)))
 500
 501 (defun nnmaildir--grp-add-art (server group article)
 502   (let ((nov (nnmaildir--update-nov server group article))
 503         count num min nlist nlist-cdr insert-nlist)
 504     (when nov
 505       (setq count (1+ (nnmaildir--grp-count group))
 506             num (nnmaildir--art-num article)
 507             min (if (= count 1) num
 508                   (min num (nnmaildir--grp-min group)))
 509             nlist (nnmaildir--grp-nlist group))
 510       (if (or (null nlist) (> num (caar nlist)))
 511           (setq nlist (cons (cons num article) nlist))
 512         (setq insert-nlist t
 513               nlist-cdr (cdr nlist))
 514         (while (and nlist-cdr (< num (caar nlist-cdr)))
 515           (setq nlist nlist-cdr
 516                 nlist-cdr (cdr nlist))))
 517       (let ((inhibit-quit t))
 518         (setf (nnmaildir--grp-count group) count)
 519         (setf (nnmaildir--grp-min group) min)
 520         (if insert-nlist
 521             (setcdr nlist (cons (cons num article) nlist-cdr))
 522           (setf (nnmaildir--grp-nlist group) nlist))
 523         (set (intern (nnmaildir--art-prefix article)
 524                      (nnmaildir--grp-flist group))
 525              article)
 526         (set (intern (nnmaildir--art-msgid article)
 527                      (nnmaildir--grp-mlist group))
 528              article)
 529         (set (intern (nnmaildir--grp-name group)
 530                      (nnmaildir--srv-groups server))
 531              group))
 532       (nnmaildir--cache-nov group article nov)
 533       t)))
 534
 535 (defun nnmaildir--group-ls (server pgname)
 536   (or (nnmaildir--param pgname 'directory-files)
 537       (nnmaildir--srv-ls server)))
 538
 539 (defun nnmaildir-article-number-to-file-name
 540   (number group-name server-address-string)
 541   (let ((group (nnmaildir--prepare server-address-string group-name))
 542         article dir pgname)
 543     (catch 'return
 544       (unless group
 545         ;; The given group or server does not exist.
 546         (throw 'return nil))
 547       (setq article (nnmaildir--nlist-art group number))
 548       (unless article
 549         ;; The given article number does not exist in this group.
 550         (throw 'return nil))
 551       (setq pgname (nnmaildir--pgname nnmaildir--cur-server group-name)
 552             dir (nnmaildir--srv-dir nnmaildir--cur-server)
 553             dir (nnmaildir--srvgrp-dir dir group-name)
 554             dir (if (nnmaildir--param pgname 'read-only)
 555                     (nnmaildir--new dir) (nnmaildir--cur dir)))
 556       (concat dir (nnmaildir--art-prefix article)
 557               (nnmaildir--art-suffix article)))))
 558
 559 (defun nnmaildir-article-number-to-base-name
 560   (number group-name server-address-string)
 561   (let ((x (nnmaildir--prepare server-address-string group-name)))
 562     (when x
 563       (setq x (nnmaildir--nlist-art x number))
 564       (and x (cons (nnmaildir--art-prefix x)
 565                    (nnmaildir--art-suffix x))))))
 566
 567 (defun nnmaildir-base-name-to-article-number
 568   (base-name group-name server-address-string)
 569   (let ((x (nnmaildir--prepare server-address-string group-name)))
 570     (when x
 571       (setq x (nnmaildir--grp-flist x)
 572             x (nnmaildir--flist-art x base-name))
 573       (and x (nnmaildir--art-num x)))))
 574
 575 (defun nnmaildir--nlist-iterate (nlist ranges func)
 576   (let (entry high low nlist2)
 577     (if (eq ranges 'all)
 578         (setq ranges `((1 . ,(caar nlist)))))
 579     (while ranges
 580       (setq entry (car ranges) ranges (cdr ranges))
 581       (while (and ranges (eq entry (car ranges)))
 582         (setq ranges (cdr ranges))) ;; skip duplicates
 583       (if (numberp entry)
 584           (setq low entry
 585                 high entry)
 586         (setq low (car entry)
 587               high (cdr entry)))
 588       (setq nlist2 nlist) ;; Don't assume any sorting of ranges
 589       (catch 'iterate-loop
 590         (while nlist2
 591           (if (<= (caar nlist2) high) (throw 'iterate-loop nil))
 592           (setq nlist2 (cdr nlist2))))
 593       (catch 'iterate-loop
 594         (while nlist2
 595           (setq entry (car nlist2) nlist2 (cdr nlist2))
 596           (if (< (car entry) low) (throw 'iterate-loop nil))
 597           (funcall func (cdr entry)))))))
 598
 599 (defun nnmaildir--up2-1 (n)
 600   (if (zerop n) 1 (1- (lsh 1 (1+ (logb n))))))
 601
 602 (defun nnmaildir--system-name ()
 603   (gnus-replace-in-string
 604    (gnus-replace-in-string
 605     (gnus-replace-in-string
 606      (system-name)
 607      "\\\\" "\\134" 'literal)
 608     "/" "\\057" 'literal)
 609    ":" "\\072" 'literal))
 610
 611 (defun nnmaildir-request-type (group &optional article)
 612   'mail)
 613
 614 (defun nnmaildir-status-message (&optional server)
 615   (nnmaildir--prepare server nil)
 616   (nnmaildir--srv-error nnmaildir--cur-server))
 617
 618 (defun nnmaildir-server-opened (&optional server)
 619   (and nnmaildir--cur-server
 620        (if server
 621            (string-equal server (nnmaildir--srv-address nnmaildir--cur-server))
 622          t)
 623        (nnmaildir--srv-groups nnmaildir--cur-server)
 624        t))
 625
 626 (defun nnmaildir-open-server (server &optional defs)
 627   (let ((x server)
 628         dir size)
 629     (catch 'return
 630       (setq server (intern-soft x nnmaildir--servers))
 631       (if server
 632           (and (setq server (symbol-value server))
 633                (nnmaildir--srv-groups server)
 634                (setq nnmaildir--cur-server server)
 635                (throw 'return t))
 636         (setq server (make-nnmaildir--srv :address x))
 637         (let ((inhibit-quit t))
 638           (set (intern x nnmaildir--servers) server)))
 639       (setq dir (assq 'directory defs))
 640       (unless dir
 641         (setf (nnmaildir--srv-error server)
 642               "You must set \"directory\" in the select method")
 643         (throw 'return nil))
 644       (setq dir (cadr dir)
 645             dir (eval dir)
 646             dir (expand-file-name dir)
 647             dir (file-name-as-directory dir))
 648       (unless (file-exists-p dir)
 649         (setf (nnmaildir--srv-error server) (concat "No such directory: " dir))
 650         (throw 'return nil))
 651       (setf (nnmaildir--srv-dir server) dir)
 652       (setq x (assq 'directory-files defs))
 653       (if (null x)
 654           (setq x (if nnheader-directory-files-is-safe 'directory-files
 655                     'nnheader-directory-files-safe))
 656         (setq x (cadr x))
 657         (unless (functionp x)
 658           (setf (nnmaildir--srv-error server)
 659                 (concat "Not a function: " (prin1-to-string x)))
 660           (throw 'return nil)))
 661       (setf (nnmaildir--srv-ls server) x)
 662       (setq size (length (funcall x dir nil "\\`[^.]" 'nosort))
 663             size (nnmaildir--up2-1 size))
 664       (and (setq x (assq 'get-new-mail defs))
 665            (setq x (cdr x))
 666            (car x)
 667            (setf (nnmaildir--srv-gnm server) t)
 668            (require 'nnmail))
 669       (setq x (assq 'target-prefix defs))
 670       (if x
 671           (progn
 672             (setq x (cadr x)
 673                   x (eval x))
 674             (setf (nnmaildir--srv-target-prefix server) x))
 675         (setq x (assq 'create-directory defs))
 676         (if x
 677             (progn
 678               (setq x (cadr x)
 679                     x (eval x)
 680                     x (file-name-as-directory x))
 681               (setf (nnmaildir--srv-target-prefix server) x))
 682           (setf (nnmaildir--srv-target-prefix server) "")))
 683       (setf (nnmaildir--srv-groups server) (make-vector size 0))
 684       (setq nnmaildir--cur-server server)
 685       t)))
 686
 687 (defun nnmaildir--parse-filename (file)
 688   (let ((prefix (car file))
 689         timestamp len)
 690     (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix)
 691         (progn
 692           (setq timestamp (concat "0000" (match-string 1 prefix))
 693                 len (- (length timestamp) 4))
 694           (vector (string-to-number (substring timestamp 0 len))
 695                   (string-to-number (substring timestamp len))
 696                   (match-string 2 prefix)
 697                   file))
 698       file)))
 699
 700 (defun nnmaildir--sort-files (a b)
 701   (catch 'return
 702     (if (consp a)
 703         (throw 'return (and (consp b) (string-lessp (car a) (car b)))))
 704     (if (consp b) (throw 'return t))
 705     (if (< (aref a 0) (aref b 0)) (throw 'return t))
 706     (if (> (aref a 0) (aref b 0)) (throw 'return nil))
 707     (if (< (aref a 1) (aref b 1)) (throw 'return t))
 708     (if (> (aref a 1) (aref b 1)) (throw 'return nil))
 709     (string-lessp (aref a 2) (aref b 2))))
 710
 711 (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls)
 712   (catch 'return
 713     (let ((36h-ago (- (car (current-time)) 2))
 714           absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
 715           files num dir flist group x)
 716       (setq absdir (nnmaildir--srvgrp-dir srv-dir gname)
 717             nndir (nnmaildir--nndir absdir))
 718       (unless (file-exists-p absdir)
 719         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 720               (concat "No such directory: " absdir))
 721         (throw 'return nil))
 722       (setq tdir (nnmaildir--tmp absdir)
 723             ndir (nnmaildir--new absdir)
 724             cdir (nnmaildir--cur absdir)
 725             nattr (file-attributes ndir)
 726             cattr (file-attributes cdir))
 727       (unless (and (file-exists-p tdir) nattr cattr)
 728         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 729               (concat "Not a maildir: " absdir))
 730         (throw 'return nil))
 731       (setq group (nnmaildir--prepare nil gname)
 732             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
 733       (if group
 734           (setq isnew nil)
 735         (setq isnew t
 736               group (make-nnmaildir--grp :name gname :index 0))
 737         (nnmaildir--mkdir nndir)
 738         (nnmaildir--mkdir (nnmaildir--nov-dir   nndir))
 739         (nnmaildir--mkdir (nnmaildir--marks-dir nndir)))
 740       (setq read-only (nnmaildir--param pgname 'read-only)
 741             ls (or (nnmaildir--param pgname 'directory-files) srv-ls))
 742       (unless read-only
 743         (setq x (nth 11 (file-attributes tdir)))
 744         (unless (and (= x (nth 11 nattr)) (= x (nth 11 cattr)))
 745           (setf (nnmaildir--srv-error nnmaildir--cur-server)
 746                 (concat "Maildir spans filesystems: " absdir))
 747           (throw 'return nil))
 748         (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort))
 749           (setq x (file-attributes file))
 750           (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago))
 751               (delete-file file))))
 752       (or scan-msgs
 753           isnew
 754           (throw 'return t))
 755       (setq nattr (nth 5 nattr))
 756       (if (equal nattr (nnmaildir--grp-new group))
 757           (setq nattr nil))
 758       (if read-only (setq dir (and (or isnew nattr) ndir))
 759         (when (or isnew nattr)
 760           (dolist (file  (funcall ls ndir nil "\\`[^.]" 'nosort))
 761             (setq x (concat ndir file))
 762             (and (time-less-p (nth 5 (file-attributes x)) (current-time))
 763                  (rename-file x (concat cdir file ":2,"))))
 764           (setf (nnmaildir--grp-new group) nattr))
 765         (setq cattr (nth 5 (file-attributes cdir)))
 766         (if (equal cattr (nnmaildir--grp-cur group))
 767             (setq cattr nil))
 768         (setq dir (and (or isnew cattr) cdir)))
 769       (unless dir (throw 'return t))
 770       (setq files (funcall ls dir nil "\\`[^.]" 'nosort)
 771             files (save-match-data
 772                     (mapcar
 773                      (lambda (f)
 774                        (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f)
 775                        (cons (match-string 1 f) (match-string 2 f)))
 776                      files)))
 777       (when isnew
 778         (setq num (nnmaildir--up2-1 (length files)))
 779         (setf (nnmaildir--grp-flist group) (make-vector num 0))
 780         (setf (nnmaildir--grp-mlist group) (make-vector num 0))
 781         (setf (nnmaildir--grp-mmth group) (make-vector 1 0))
 782         (setq num (nnmaildir--param pgname 'nov-cache-size))
 783         (if (numberp num) (if (< num 1) (setq num 1))
 784           (setq num 16
 785                 cdir (nnmaildir--marks-dir nndir)
 786                 ndir (nnmaildir--subdir cdir "tick")
 787                 cdir (nnmaildir--subdir cdir "read"))
 788           (dolist (file files)
 789             (setq file (car file))
 790             (if (or (not (file-exists-p (concat cdir file)))
 791                     (file-exists-p (concat ndir file)))
 792                 (setq num (1+ num)))))
 793         (setf (nnmaildir--grp-cache group) (make-vector num nil))
 794         (let ((inhibit-quit t))
 795           (set (intern gname groups) group))
 796         (or scan-msgs (throw 'return t)))
 797       (setq flist (nnmaildir--grp-flist group)
 798             files (mapcar
 799                    (lambda (file)
 800                      (and (null (nnmaildir--flist-art flist (car file)))
 801                           file))
 802                    files)
 803             files (delq nil files)
 804             files (mapcar 'nnmaildir--parse-filename files)
 805             files (sort files 'nnmaildir--sort-files))
 806       (dolist (file files)
 807         (setq file (if (consp file) file (aref file 3))
 808               x (make-nnmaildir--art :prefix (car file) :suffix (cdr file)))
 809         (nnmaildir--grp-add-art nnmaildir--cur-server group x))
 810       (if read-only (setf (nnmaildir--grp-new group) nattr)
 811         (setf (nnmaildir--grp-cur group) cattr)))
 812     t))
 813
 814 (defun nnmaildir-request-scan (&optional scan-group server)
 815   (let ((coding-system-for-write nnheader-file-coding-system)
 816         (buffer-file-coding-system nil)
 817         (file-coding-system-alist nil)
 818         (nnmaildir-get-new-mail t)
 819         (nnmaildir-group-alist nil)
 820         (nnmaildir-active-file nil)
 821         x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen
 822         deactivate-mark)
 823     (nnmaildir--prepare server nil)
 824     (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server)
 825           srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
 826           method (nnmaildir--srv-method nnmaildir--cur-server)
 827           groups (nnmaildir--srv-groups nnmaildir--cur-server)
 828           target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
 829     (nnmaildir--with-work-buffer
 830       (save-match-data
 831         (if (stringp scan-group)
 832             (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
 833                 (if (nnmaildir--srv-gnm nnmaildir--cur-server)
 834                     (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
 835               (unintern scan-group groups))
 836           (setq x (nth 5 (file-attributes srv-dir))
 837                 scan-group (null scan-group))
 838           (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
 839               (if scan-group
 840                   (mapatoms (lambda (sym)
 841                               (nnmaildir--scan (symbol-name sym) t groups
 842                                                method srv-dir srv-ls))
 843                             groups))
 844             (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
 845                   dirs (if (zerop (length target-prefix))
 846                            dirs
 847                          (gnus-remove-if
 848                           (lambda (dir)
 849                             (and (>= (length dir) (length target-prefix))
 850                                  (string= (substring dir 0
 851                                                      (length target-prefix))
 852                                           target-prefix)))
 853                           dirs))
 854                   seen (nnmaildir--up2-1 (length dirs))
 855                   seen (make-vector seen 0))
 856             (dolist (grp-dir dirs)
 857               (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
 858                                    srv-ls)
 859                   (intern grp-dir seen)))
 860             (setq x nil)
 861             (mapatoms (lambda (group)
 862                         (setq group (symbol-name group))
 863                         (unless (intern-soft group seen)
 864                           (setq x (cons group x))))
 865                       groups)
 866             (dolist (grp x)
 867               (unintern grp groups))
 868             (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
 869                   (nth 5 (file-attributes srv-dir))))
 870           (and scan-group
 871                (nnmaildir--srv-gnm nnmaildir--cur-server)
 872                (nnmail-get-new-mail 'nnmaildir nil nil))))))
 873   t)
 874
 875 (defun nnmaildir-request-list (&optional server)
 876   (nnmaildir-request-scan 'find-new-groups server)
 877   (let (pgname ro deactivate-mark)
 878     (nnmaildir--prepare server nil)
 879     (nnmaildir--with-nntp-buffer
 880       (erase-buffer)
 881       (mapatoms (lambda (group)
 882                   (setq pgname (symbol-name group)
 883                         pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
 884                         group (symbol-value group)
 885                         ro (nnmaildir--param pgname 'read-only))
 886                   (insert (gnus-replace-in-string
 887                            (nnmaildir--grp-name group) " " "\\ " t)
 888                           " ")
 889                   (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 890                          nntp-server-buffer)
 891                   (insert " ")
 892                   (princ (nnmaildir--grp-min group) nntp-server-buffer)
 893                   (insert " " (if ro "n" "y") "\n"))
 894                 (nnmaildir--srv-groups nnmaildir--cur-server))))
 895   t)
 896
 897 (defun nnmaildir-request-newgroups (date &optional server)
 898   (nnmaildir-request-list server))
 899
 900 (defun nnmaildir-retrieve-groups (groups &optional server)
 901   (let (group deactivate-mark)
 902     (nnmaildir--prepare server nil)
 903     (nnmaildir--with-nntp-buffer
 904       (erase-buffer)
 905       (dolist (gname groups)
 906         (setq group (nnmaildir--prepare nil gname))
 907         (if (null group) (insert "411 no such news group\n")
 908           (insert "211 ")
 909           (princ (nnmaildir--grp-count group) nntp-server-buffer)
 910           (insert " ")
 911           (princ (nnmaildir--grp-min   group) nntp-server-buffer)
 912           (insert " ")
 913           (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 914                  nntp-server-buffer)
 915           (insert " "
 916                   (gnus-replace-in-string gname " " "\\ " t)
 917                   "\n")))))
 918   'group)
 919
 920 (defun nnmaildir-request-update-info (gname info &optional server)
 921   (let ((group (nnmaildir--prepare server gname))
 922         pgname flist always-marks never-marks old-marks dotfile num dir
 923         markdirs marks mark ranges markdir article read end new-marks ls
 924         old-mmth new-mmth mtime mark-sym existing missing deactivate-mark
 925         article-list)
 926     (catch 'return
 927       (unless group
 928         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 929               (concat "No such group: " gname))
 930         (throw 'return nil))
 931       (setq gname (nnmaildir--grp-name group)
 932             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
 933             flist (nnmaildir--grp-flist group))
 934       (when (zerop (nnmaildir--grp-count group))
 935         (gnus-info-set-read info nil)
 936         (gnus-info-set-marks info nil 'extend)
 937         (throw 'return info))
 938       (setq old-marks (cons 'read (gnus-info-read info))
 939             old-marks (cons old-marks (gnus-info-marks info))
 940             always-marks (nnmaildir--param pgname 'always-marks)
 941             never-marks (nnmaildir--param pgname 'never-marks)
 942             existing (nnmaildir--grp-nlist group)
 943             existing (mapcar 'car existing)
 944             existing (nreverse existing)
 945             existing (gnus-compress-sequence existing 'always-list)
 946             missing (list (cons 1 (nnmaildir--group-maxnum
 947                                    nnmaildir--cur-server group)))
 948             missing (gnus-range-difference missing existing)
 949             dir (nnmaildir--srv-dir nnmaildir--cur-server)
 950             dir (nnmaildir--srvgrp-dir dir gname)
 951             dir (nnmaildir--nndir dir)
 952             dir (nnmaildir--marks-dir dir)
 953             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
 954             markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
 955             new-mmth (nnmaildir--up2-1 (length markdirs))
 956             new-mmth (make-vector new-mmth 0)
 957             old-mmth (nnmaildir--grp-mmth group))
 958       (dolist (mark markdirs)
 959         (setq markdir (nnmaildir--subdir dir mark)
 960               mark-sym (intern mark)
 961               ranges nil)
 962         (catch 'got-ranges
 963           (if (memq mark-sym never-marks) (throw 'got-ranges nil))
 964           (when (memq mark-sym always-marks)
 965             (setq ranges existing)
 966             (throw 'got-ranges nil))
 967           (setq mtime (nth 5 (file-attributes markdir)))
 968           (set (intern mark new-mmth) mtime)
 969           (when (equal mtime (symbol-value (intern-soft mark old-mmth)))
 970             (setq ranges (assq mark-sym old-marks))
 971             (if ranges (setq ranges (cdr ranges)))
 972             (throw 'got-ranges nil))
 973           (setq article-list nil)
 974           (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort))
 975             (setq article (nnmaildir--flist-art flist prefix))
 976             (if article
 977                 (setq article-list
 978                       (cons (nnmaildir--art-num article) article-list))))
 979           (setq ranges (gnus-add-to-range ranges (sort article-list '<))))
 980         (if (eq mark-sym 'read) (setq read ranges)
 981           (if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
 982       (gnus-info-set-read info (gnus-range-add read missing))
 983       (gnus-info-set-marks info marks 'extend)
 984       (setf (nnmaildir--grp-mmth group) new-mmth)
 985       info)))
 986
 987 (defun nnmaildir-request-group (gname &optional server fast)
 988   (let ((group (nnmaildir--prepare server gname))
 989         deactivate-mark)
 990     (catch 'return
 991       (unless group
 992         ;; (insert "411 no such news group\n")
 993         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 994               (concat "No such group: " gname))
 995         (throw 'return nil))
 996       (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
 997       (if fast (throw 'return t))
 998       (nnmaildir--with-nntp-buffer
 999         (erase-buffer)
1000         (insert "211 ")
1001         (princ (nnmaildir--grp-count group) nntp-server-buffer)
1002         (insert " ")
1003         (princ (nnmaildir--grp-min   group) nntp-server-buffer)
1004         (insert " ")
1005         (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
1006                nntp-server-buffer)
1007         (insert " " (gnus-replace-in-string gname " " "\\ " t) "\n")
1008         t))))
1009
1010 (defun nnmaildir-request-create-group (gname &optional server args)
1011   (nnmaildir--prepare server nil)
1012   (catch 'return
1013     (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
1014           srv-dir dir groups)
1015       (when (zerop (length gname))
1016         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1017               "Invalid (empty) group name")
1018         (throw 'return nil))
1019       (when (eq (aref "." 0) (aref gname 0))
1020         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1021               "Group names may not start with \".\"")
1022         (throw 'return nil))
1023       (when (save-match-data (string-match "[\0/\t]" gname))
1024         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1025               (concat "Invalid characters (null, tab, or /) in group name: "
1026                       gname))
1027         (throw 'return nil))
1028       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
1029       (when (intern-soft gname groups)
1030         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1031               (concat "Group already exists: " gname))
1032         (throw 'return nil))
1033       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1034       (if (file-name-absolute-p target-prefix)
1035           (setq dir (expand-file-name target-prefix))
1036         (setq dir srv-dir
1037               dir (file-truename dir)
1038               dir (concat dir target-prefix)))
1039       (setq dir (nnmaildir--subdir dir gname))
1040       (nnmaildir--mkdir dir)
1041       (nnmaildir--mkdir (nnmaildir--tmp dir))
1042       (nnmaildir--mkdir (nnmaildir--new dir))
1043       (nnmaildir--mkdir (nnmaildir--cur dir))
1044       (unless (string= target-prefix "")
1045         (make-symbolic-link (concat target-prefix gname)
1046                             (concat srv-dir gname)))
1047       (nnmaildir-request-scan 'find-new-groups))))
1048
1049 (defun nnmaildir-request-rename-group (gname new-name &optional server)
1050   (let ((group (nnmaildir--prepare server gname))
1051         (coding-system-for-write nnheader-file-coding-system)
1052         (buffer-file-coding-system nil)
1053         (file-coding-system-alist nil)
1054         srv-dir x groups)
1055     (catch 'return
1056       (unless group
1057         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1058               (concat "No such group: " gname))
1059         (throw 'return nil))
1060       (when (zerop (length new-name))
1061         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1062               "Invalid (empty) group name")
1063         (throw 'return nil))
1064       (when (eq (aref "." 0) (aref new-name 0))
1065         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1066               "Group names may not start with \".\"")
1067         (throw 'return nil))
1068       (when (save-match-data (string-match "[\0/\t]" new-name))
1069         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1070               (concat "Invalid characters (null, tab, or /) in group name: "
1071                       new-name))
1072         (throw 'return nil))
1073       (if (string-equal gname new-name) (throw 'return t))
1074       (when (intern-soft new-name
1075                          (nnmaildir--srv-groups nnmaildir--cur-server))
1076         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1077               (concat "Group already exists: " new-name))
1078         (throw 'return nil))
1079       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1080       (condition-case err
1081           (rename-file (concat srv-dir gname)
1082                        (concat srv-dir new-name))
1083         (error
1084          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1085                (concat "Error renaming link: " (prin1-to-string err)))
1086          (throw 'return nil)))
1087       (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
1088             groups (make-vector (length x) 0))
1089       (mapatoms (lambda (sym)
1090                   (unless (eq (symbol-value sym) group)
1091                     (set (intern (symbol-name sym) groups)
1092                          (symbol-value sym))))
1093                 x)
1094       (setq group (copy-sequence group))
1095       (setf (nnmaildir--grp-name group) new-name)
1096       (set (intern new-name groups) group)
1097       (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
1098       t)))
1099
1100 (defun nnmaildir-request-delete-group (gname force &optional server)
1101   (let ((group (nnmaildir--prepare server gname))
1102         pgname grp-dir target dir ls deactivate-mark)
1103     (catch 'return
1104       (unless group
1105         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1106               (concat "No such group: " gname))
1107         (throw 'return nil))
1108       (setq gname (nnmaildir--grp-name group)
1109             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1110             grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1111             target (car (file-attributes (concat grp-dir gname)))
1112             grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
1113       (unless (or force (stringp target))
1114         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1115               (concat "Not a symlink: " gname))
1116         (throw 'return nil))
1117       (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
1118           (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
1119       (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
1120       (if (not force)
1121           (progn
1122             (setq grp-dir (directory-file-name grp-dir))
1123             (nnmaildir--unlink grp-dir))
1124         (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname))
1125         (if (nnmaildir--param pgname 'read-only)
1126             (progn (delete-directory  (nnmaildir--tmp grp-dir))
1127                    (nnmaildir--unlink (nnmaildir--new grp-dir))
1128                    (delete-directory  (nnmaildir--cur grp-dir)))
1129           (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls)
1130           (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls)
1131           (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls))
1132         (setq dir (nnmaildir--nndir grp-dir))
1133         (dolist (subdir `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir)
1134                           ,@(funcall ls (nnmaildir--marks-dir dir)
1135                                      'full "\\`[^.]" 'nosort)))
1136           (nnmaildir--delete-dir-files subdir ls))
1137         (setq dir (nnmaildir--nndir grp-dir))
1138         (nnmaildir--unlink (concat dir "markfile"))
1139         (nnmaildir--unlink (concat dir "markfile{new}"))
1140         (delete-directory (nnmaildir--marks-dir dir))
1141         (delete-directory dir)
1142         (if (not (stringp target))
1143             (delete-directory grp-dir)
1144           (setq grp-dir (directory-file-name grp-dir)
1145                 dir target)
1146           (unless (eq (aref "/" 0) (aref dir 0))
1147             (setq dir (concat (file-truename
1148                                (nnmaildir--srv-dir nnmaildir--cur-server))
1149                               dir)))
1150           (delete-directory dir)
1151           (nnmaildir--unlink grp-dir)))
1152       t)))
1153
1154 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1155   (let ((group (nnmaildir--prepare server gname))
1156         srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1157         deactivate-mark)
1158     (setq insert-nov
1159           (lambda (article)
1160             (setq nov (nnmaildir--update-nov nnmaildir--cur-server group
1161                                              article))
1162             (when nov
1163               (nnmaildir--cache-nov group article nov)
1164               (setq num (nnmaildir--art-num article))
1165               (princ num nntp-server-buffer)
1166               (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1167                       (nnmaildir--art-msgid article) "\t"
1168                       (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir "
1169                       (gnus-replace-in-string gname " " "\\ " t) ":")
1170               (princ num nntp-server-buffer)
1171               (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1172     (catch 'return
1173       (unless group
1174         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1175               (if gname (concat "No such group: " gname) "No current group"))
1176         (throw 'return nil))
1177       (nnmaildir--with-nntp-buffer
1178         (erase-buffer)
1179         (setq mlist (nnmaildir--grp-mlist group)
1180               nlist (nnmaildir--grp-nlist group)
1181               gname (nnmaildir--grp-name group)
1182               srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1183               dir (nnmaildir--srvgrp-dir srv-dir gname))
1184         (cond
1185          ((null nlist))
1186          ((and fetch-old (not (numberp fetch-old)))
1187           (nnmaildir--nlist-iterate nlist 'all insert-nov))
1188          ((null articles))
1189          ((stringp (car articles))
1190           (dolist (msgid articles)
1191             (setq article (nnmaildir--mlist-art mlist msgid))
1192             (if article (funcall insert-nov article))))
1193          (t
1194           (if fetch-old
1195               ;; Assume the article range list is sorted ascending
1196               (setq stop (car articles)
1197                     start (car (last articles))
1198                     stop  (if (numberp stop)  stop  (car stop))
1199                     start (if (numberp start) start (cdr start))
1200                     stop (- stop fetch-old)
1201                     stop (if (< stop 1) 1 stop)
1202                     articles (list (cons stop start))))
1203           (nnmaildir--nlist-iterate nlist articles insert-nov)))
1204         (sort-numeric-fields 1 (point-min) (point-max))
1205         'nov))))
1206
1207 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1208   (let ((group (nnmaildir--prepare server gname))
1209         (case-fold-search t)
1210         list article dir pgname deactivate-mark)
1211     (catch 'return
1212       (unless group
1213         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1214               (if gname (concat "No such group: " gname) "No current group"))
1215         (throw 'return nil))
1216       (if (numberp num-msgid)
1217           (setq article (nnmaildir--nlist-art group num-msgid))
1218         (setq list (nnmaildir--grp-mlist group)
1219               article (nnmaildir--mlist-art list num-msgid))
1220         (if article (setq num-msgid (nnmaildir--art-num article))
1221           (catch 'found
1222             (mapatoms
1223               (lambda (group-sym)
1224                 (setq group (symbol-value group-sym)
1225                       list (nnmaildir--grp-mlist group)
1226                       article (nnmaildir--mlist-art list num-msgid))
1227                 (when article
1228                   (setq num-msgid (nnmaildir--art-num article))
1229                   (throw 'found nil)))
1230               (nnmaildir--srv-groups nnmaildir--cur-server))))
1231         (unless article
1232           (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1233           (throw 'return nil)))
1234       (setq gname (nnmaildir--grp-name group)
1235             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1236             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1237             dir (nnmaildir--srvgrp-dir dir gname)
1238             dir (if (nnmaildir--param pgname 'read-only)
1239                     (nnmaildir--new dir) (nnmaildir--cur dir))
1240             nnmaildir-article-file-name
1241             (concat dir
1242                     (nnmaildir--art-prefix article)
1243                     (nnmaildir--art-suffix article)))
1244       (unless (file-exists-p nnmaildir-article-file-name)
1245         (nnmaildir--expired-article group article)
1246         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1247               "Article has expired")
1248         (throw 'return nil))
1249       (save-excursion
1250         (set-buffer (or to-buffer nntp-server-buffer))
1251         (erase-buffer)
1252         (nnheader-insert-file-contents nnmaildir-article-file-name))
1253       (cons gname num-msgid))))
1254
1255 (defun nnmaildir-request-post (&optional server)
1256   (let (message-required-mail-headers)
1257     (funcall message-send-mail-function)))
1258
1259 (defun nnmaildir-request-replace-article (number gname buffer)
1260   (let ((group (nnmaildir--prepare nil gname))
1261         (coding-system-for-write nnheader-file-coding-system)
1262         (buffer-file-coding-system nil)
1263         (file-coding-system-alist nil)
1264         dir file article suffix tmpfile deactivate-mark)
1265     (catch 'return
1266       (unless group
1267         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1268               (concat "No such group: " gname))
1269         (throw 'return nil))
1270       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1271                               'read-only)
1272         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1273               (concat "Read-only group: " group))
1274         (throw 'return nil))
1275       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1276             dir (nnmaildir--srvgrp-dir dir gname)
1277             article (nnmaildir--nlist-art group number))
1278       (unless article
1279         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1280               (concat "No such article: " (number-to-string number)))
1281         (throw 'return nil))
1282       (setq suffix (nnmaildir--art-suffix article)
1283             file (nnmaildir--art-prefix article)
1284             tmpfile (concat (nnmaildir--tmp dir) file))
1285       (when (file-exists-p tmpfile)
1286         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1287               (concat "File exists: " tmpfile))
1288         (throw 'return nil))
1289       (save-excursion
1290         (set-buffer buffer)
1291         (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1292                           'excl))
1293       (unix-sync) ;; no fsync :(
1294       (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1295       t)))
1296
1297 (defun nnmaildir-request-move-article (article gname server accept-form
1298                                                &optional last move-is-internal)
1299   (let ((group (nnmaildir--prepare server gname))
1300         pgname suffix result nnmaildir--file deactivate-mark)
1301     (catch 'return
1302       (unless group
1303         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1304               (concat "No such group: " gname))
1305         (throw 'return nil))
1306       (setq gname (nnmaildir--grp-name group)
1307             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1308             article (nnmaildir--nlist-art group article))
1309       (unless article
1310         (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1311         (throw 'return nil))
1312       (setq suffix (nnmaildir--art-suffix article)
1313             nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1314             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1315             nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1316                                 (nnmaildir--new nnmaildir--file)
1317                               (nnmaildir--cur nnmaildir--file))
1318             nnmaildir--file (concat nnmaildir--file
1319                                     (nnmaildir--art-prefix article)
1320                                     suffix))
1321       (unless (file-exists-p nnmaildir--file)
1322         (nnmaildir--expired-article group article)
1323         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1324               "Article has expired")
1325         (throw 'return nil))
1326       (nnmaildir--with-move-buffer
1327         (erase-buffer)
1328         (nnheader-insert-file-contents nnmaildir--file)
1329         (setq result (eval accept-form)))
1330       (unless (or (null result) (nnmaildir--param pgname 'read-only))
1331         (nnmaildir--unlink nnmaildir--file)
1332         (nnmaildir--expired-article group article))
1333       result)))
1334
1335 (defun nnmaildir-request-accept-article (gname &optional server last)
1336   (let ((group (nnmaildir--prepare server gname))
1337         (coding-system-for-write nnheader-file-coding-system)
1338         (buffer-file-coding-system nil)
1339         (file-coding-system-alist nil)
1340         srv-dir dir file time tmpfile curfile 24h article)
1341     (catch 'return
1342       (unless group
1343         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1344               (concat "No such group: " gname))
1345         (throw 'return nil))
1346       (setq gname (nnmaildir--grp-name group))
1347       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1348                               'read-only)
1349         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1350               (concat "Read-only group: " gname))
1351         (throw 'return nil))
1352       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1353             dir (nnmaildir--srvgrp-dir srv-dir gname)
1354             time (current-time)
1355             file (format-time-string "%s." time))
1356       (unless (string-equal nnmaildir--delivery-time file)
1357         (setq nnmaildir--delivery-time file
1358               nnmaildir--delivery-count 0))
1359       (when (and (consp (cdr time))
1360                  (consp (cddr time)))
1361         (setq file (concat file "M" (number-to-string (caddr time)))))
1362       (setq file (concat file nnmaildir--delivery-pid)
1363             file (concat file "Q" (number-to-string nnmaildir--delivery-count))
1364             file (concat file "." (nnmaildir--system-name))
1365             tmpfile (concat (nnmaildir--tmp dir) file)
1366             curfile (concat (nnmaildir--cur dir) file ":2,"))
1367       (when (file-exists-p tmpfile)
1368         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1369               (concat "File exists: " tmpfile))
1370         (throw 'return nil))
1371       (when (file-exists-p curfile)
1372         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1373               (concat "File exists: " curfile))
1374         (throw 'return nil))
1375       (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count)
1376             24h (run-with-timer 86400 nil
1377                                 (lambda ()
1378                                   (nnmaildir--unlink tmpfile)
1379                                   (setf (nnmaildir--srv-error
1380                                           nnmaildir--cur-server)
1381                                         "24-hour timer expired")
1382                                   (throw 'return nil))))
1383       (condition-case nil (add-name-to-file nnmaildir--file tmpfile)
1384         (error
1385          (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1386                            'excl)
1387          (unix-sync))) ;; no fsync :(
1388       (nnheader-cancel-timer 24h)
1389       (condition-case err
1390           (add-name-to-file tmpfile curfile)
1391         (error
1392          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1393                (concat "Error linking: " (prin1-to-string err)))
1394          (nnmaildir--unlink tmpfile)
1395          (throw 'return nil)))
1396       (nnmaildir--unlink tmpfile)
1397       (setq article (make-nnmaildir--art :prefix file :suffix ":2,"))
1398       (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1399           (cons gname (nnmaildir--art-num article))))))
1400
1401 (defun nnmaildir-save-mail (group-art)
1402   (catch 'return
1403     (unless group-art
1404       (throw 'return nil))
1405     (let (ga gname x groups nnmaildir--file deactivate-mark)
1406       (save-excursion
1407         (goto-char (point-min))
1408         (save-match-data
1409           (while (looking-at "From ")
1410             (replace-match "X-From-Line: ")
1411             (forward-line 1))))
1412       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1413             ga (car group-art) group-art (cdr group-art)
1414             gname (car ga))
1415       (or (intern-soft gname groups)
1416           (nnmaildir-request-create-group gname)
1417           (throw 'return nil)) ;; not that nnmail bothers to check :(
1418       (unless (nnmaildir-request-accept-article gname)
1419         (throw 'return nil))
1420       (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1421             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1422             x (nnmaildir--prepare nil gname)
1423             x (nnmaildir--grp-nlist x)
1424             x (cdar x)
1425             nnmaildir--file (concat nnmaildir--file
1426                                     (nnmaildir--art-prefix x)
1427                                     (nnmaildir--art-suffix x)))
1428       (delq nil
1429             (mapcar
1430              (lambda (ga)
1431                (setq gname (car ga))
1432                (and (or (intern-soft gname groups)
1433                         (nnmaildir-request-create-group gname))
1434                     (nnmaildir-request-accept-article gname)
1435                     ga))
1436              group-art)))))
1437
1438 (defun nnmaildir-active-number (gname)
1439   0)
1440
1441 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1442   (let ((no-force (not force))
1443         (group (nnmaildir--prepare server gname))
1444         pgname time boundary bound-iter high low target dir nlist nlist2
1445         stop article didnt nnmaildir--file nnmaildir-article-file-name
1446         deactivate-mark)
1447     (catch 'return
1448       (unless group
1449         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1450               (if gname (concat "No such group: " gname) "No current group"))
1451         (throw 'return (gnus-uncompress-range ranges)))
1452       (setq gname (nnmaildir--grp-name group)
1453             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1454       (if (nnmaildir--param pgname 'read-only)
1455           (throw 'return (gnus-uncompress-range ranges)))
1456       (setq time (nnmaildir--param pgname 'expire-age))
1457       (unless time
1458         (setq time (or (and nnmail-expiry-wait-function
1459                             (funcall nnmail-expiry-wait-function gname))
1460                        nnmail-expiry-wait))
1461         (if (eq time 'immediate)
1462             (setq time 0)
1463           (if (numberp time)
1464               (setq time (* time 86400)))))
1465       (when no-force
1466         (unless (integerp time) ;; handle 'never
1467           (throw 'return (gnus-uncompress-range ranges)))
1468         (setq boundary (current-time)
1469               high (- (car boundary) (/ time 65536))
1470               low (- (cadr boundary) (% time 65536)))
1471         (if (< low 0)
1472             (setq low (+ low 65536)
1473                   high (1- high)))
1474         (setcar (cdr boundary) low)
1475         (setcar boundary high))
1476       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1477             dir (nnmaildir--srvgrp-dir dir gname)
1478             dir (nnmaildir--cur dir)
1479             nlist (nnmaildir--grp-nlist group)
1480             ranges (reverse ranges))
1481       (nnmaildir--with-move-buffer
1482         (nnmaildir--nlist-iterate
1483          nlist ranges
1484          (lambda (article)
1485            (setq nnmaildir--file (nnmaildir--art-prefix article)
1486                  nnmaildir--file (concat dir nnmaildir--file
1487                                          (nnmaildir--art-suffix article))
1488                  time (file-attributes nnmaildir--file))
1489            (cond
1490             ((null time)
1491              (nnmaildir--expired-article group article))
1492             ((and no-force
1493                   (progn
1494                     (setq time (nth 5 time)
1495                           bound-iter boundary)
1496                     (while (and bound-iter time
1497                                 (= (car bound-iter) (car time)))
1498                       (setq bound-iter (cdr bound-iter)
1499                             time (cdr time)))
1500                     (and bound-iter time
1501                          (car-less-than-car bound-iter time))))
1502              (setq didnt (cons (nnmaildir--art-num article) didnt)))
1503             (t
1504              (setq nnmaildir-article-file-name nnmaildir--file
1505                    target (if force nil
1506                             (save-excursion
1507                               (save-restriction
1508                                 (nnmaildir--param pgname 'expire-group)))))
1509              (when (and (stringp target)
1510                         (not (string-equal target pgname))) ;; Move it.
1511                (erase-buffer)
1512                (nnheader-insert-file-contents nnmaildir--file)
1513                (let ((group-art (gnus-request-accept-article
1514                                  target nil nil 'no-encode)))
1515                  (when (consp group-art)
1516                    ;; Maybe also copy: dormant forward reply save tick
1517                    ;; (gnus-add-mark? gnus-request-set-mark?)
1518                    (gnus-group-mark-article-read target (cdr group-art)))))
1519              (if (equal target pgname)
1520                  ;; Leave it here.
1521                  (setq didnt (cons (nnmaildir--art-num article) didnt))
1522                (nnmaildir--unlink nnmaildir--file)
1523                (nnmaildir--expired-article group article))))))
1524         (erase-buffer))
1525       didnt)))
1526
1527 (defun nnmaildir-request-set-mark (gname actions &optional server)
1528   (let ((group (nnmaildir--prepare server gname))
1529         (coding-system-for-write nnheader-file-coding-system)
1530         (buffer-file-coding-system nil)
1531         (file-coding-system-alist nil)
1532         del-mark del-action add-action set-action marksdir nlist
1533         ranges begin end article all-marks todo-marks mdir mfile
1534         pgname ls permarkfile deactivate-mark)
1535     (setq del-mark
1536           (lambda (mark)
1537             (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
1538                   mfile (concat mfile (nnmaildir--art-prefix article)))
1539             (nnmaildir--unlink mfile))
1540           del-action (lambda (article) (mapcar del-mark todo-marks))
1541           add-action
1542           (lambda (article)
1543             (mapcar
1544              (lambda (mark)
1545                (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
1546                      permarkfile (concat mdir ":")
1547                      mfile (concat mdir (nnmaildir--art-prefix article)))
1548                (nnmaildir--condcase err (add-name-to-file permarkfile mfile)
1549                  (cond
1550                   ((nnmaildir--eexist-p err))
1551                   ((nnmaildir--enoent-p err)
1552                    (nnmaildir--mkdir mdir)
1553                    (nnmaildir--mkfile permarkfile)
1554                    (add-name-to-file permarkfile mfile))
1555                   ((nnmaildir--emlink-p err)
1556                    (let ((permarkfilenew (concat permarkfile "{new}")))
1557                      (nnmaildir--mkfile permarkfilenew)
1558                      (rename-file permarkfilenew permarkfile 'replace)
1559                      (add-name-to-file permarkfile mfile)))
1560                   (t (signal (car err) (cdr err))))))
1561              todo-marks))
1562           set-action (lambda (article)
1563                        (funcall add-action)
1564                        (mapcar (lambda (mark)
1565                                  (unless (memq mark todo-marks)
1566                                    (funcall del-mark mark)))
1567                                all-marks)))
1568     (catch 'return
1569       (unless group
1570         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1571               (concat "No such group: " gname))
1572         (dolist (action actions)
1573           (setq ranges (gnus-range-add ranges (car action))))
1574         (throw 'return ranges))
1575       (setq nlist (nnmaildir--grp-nlist group)
1576             marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1577             marksdir (nnmaildir--srvgrp-dir marksdir gname)
1578             marksdir (nnmaildir--nndir marksdir)
1579             marksdir (nnmaildir--marks-dir marksdir)
1580             gname (nnmaildir--grp-name group)
1581             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1582             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1583             all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1584             all-marks (mapcar 'intern all-marks))
1585       (dolist (action actions)
1586         (setq ranges (car action)
1587               todo-marks (caddr action))
1588         (dolist (mark todo-marks)
1589           (add-to-list 'all-marks mark))
1590         (if (numberp (cdr ranges)) (setq ranges (list ranges)))
1591         (nnmaildir--nlist-iterate nlist ranges
1592                                   (cond ((eq 'del (cadr action)) del-action)
1593                                         ((eq 'add (cadr action)) add-action)
1594                                         (t set-action))))
1595       nil)))
1596
1597 (defun nnmaildir-close-group (gname &optional server)
1598   (let ((group (nnmaildir--prepare server gname))
1599         pgname ls dir msgdir files flist dirs)
1600     (if (null group)
1601         (progn
1602           (setf (nnmaildir--srv-error nnmaildir--cur-server)
1603                 (concat "No such group: " gname))
1604           nil)
1605       (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1606             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1607             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1608             dir (nnmaildir--srvgrp-dir dir gname)
1609             msgdir (if (nnmaildir--param pgname 'read-only)
1610                        (nnmaildir--new dir) (nnmaildir--cur dir))
1611             dir (nnmaildir--nndir dir)
1612             dirs (cons (nnmaildir--nov-dir dir)
1613                        (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1614                                 'nosort))
1615             dirs (mapcar
1616                   (lambda (dir)
1617                     (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
1618                   dirs)
1619             files (funcall ls msgdir nil "\\`[^.]" 'nosort)
1620             flist (nnmaildir--up2-1 (length files))
1621             flist (make-vector flist 0))
1622       (save-match-data
1623         (dolist (file files)
1624           (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1625           (intern (match-string 1 file) flist)))
1626       (dolist (dir dirs)
1627         (setq files (cdr dir)
1628               dir (file-name-as-directory (car dir)))
1629         (dolist (file files)
1630           (unless (or (intern-soft file flist) (string= file ":"))
1631             (setq file (concat dir file))
1632             (delete-file file))))
1633       t)))
1634
1635 (defun nnmaildir-close-server (&optional server)
1636   (let (flist ls dirs dir files file x)
1637     (nnmaildir--prepare server nil)
1638     (when nnmaildir--cur-server
1639       (setq server nnmaildir--cur-server
1640             nnmaildir--cur-server nil)
1641       (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
1642   t)
1643
1644 (defun nnmaildir-request-close ()
1645   (let (servers buffer)
1646     (mapatoms (lambda (server)
1647                 (setq servers (cons (symbol-name server) servers)))
1648               nnmaildir--servers)
1649     (mapc 'nnmaildir-close-server servers)
1650     (setq buffer (get-buffer " *nnmaildir work*"))
1651     (if buffer (kill-buffer buffer))
1652     (setq buffer (get-buffer " *nnmaildir nov*"))
1653     (if buffer (kill-buffer buffer))
1654     (setq buffer (get-buffer " *nnmaildir move*"))
1655     (if buffer (kill-buffer buffer)))
1656   t)
1657
1658 (provide 'nnmaildir)
1659
1660 ;; Local Variables:
1661 ;; indent-tabs-mode: t
1662 ;; fill-column: 77
1663 ;; End:
1664
1665 ;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849
1666 ;;; nnmaildir.el ends here