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

   1 ;;; nnmaildir.el --- maildir backend for Gnus
   2 ;; Public domain.
   3
   4 ;; Author: Paul Jarc <prj@po.cwru.edu>
   5
   6 ;; This file is part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 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     (mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
 247     (delete-directory dir)))
 248
 249 (defun nnmaildir--group-maxnum (server group)
 250   (catch 'return
 251     (if (zerop (nnmaildir--grp-count group)) (throw 'return 0))
 252     (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server)
 253                                     (nnmaildir--grp-name group)))
 254           (number-opened 1)
 255           attr ino-opened nlink number-linked)
 256       (setq dir (nnmaildir--nndir dir)
 257             dir (nnmaildir--num-dir dir))
 258       (while t
 259         (setq attr (file-attributes
 260                     (concat dir (number-to-string number-opened))))
 261         (or attr (throw 'return (1- number-opened)))
 262         (setq ino-opened (nth 10 attr)
 263               nlink (nth 1 attr)
 264               number-linked (+ number-opened nlink))
 265         (if (or (< nlink 1) (< number-linked nlink))
 266             (signal 'error '("Arithmetic overflow")))
 267         (setq attr (file-attributes
 268                     (concat dir (number-to-string number-linked))))
 269         (or attr (throw 'return (1- number-linked)))
 270         (if (/= ino-opened (nth 10 attr))
 271             (setq number-opened number-linked))))))
 272
 273 ;; Make the given server, if non-nil, be the current server.  Then make the
 274 ;; given group, if non-nil, be the current group of the current server.  Then
 275 ;; return the group object for the current group.
 276 (defun nnmaildir--prepare (server group)
 277   (let (x groups)
 278     (catch 'return
 279       (if (null server)
 280           (unless (setq server nnmaildir--cur-server)
 281             (throw 'return nil))
 282         (unless (setq server (intern-soft server nnmaildir--servers))
 283           (throw 'return nil))
 284         (setq server (symbol-value server)
 285               nnmaildir--cur-server server))
 286       (unless (setq groups (nnmaildir--srv-groups server))
 287         (throw 'return nil))
 288       (unless (nnmaildir--srv-method server)
 289         (setq x (concat "nnmaildir:" (nnmaildir--srv-address server))
 290               x (gnus-server-to-method x))
 291         (unless x (throw 'return nil))
 292         (setf (nnmaildir--srv-method server) x))
 293       (if (null group)
 294           (unless (setq group (nnmaildir--srv-curgrp server))
 295             (throw 'return nil))
 296         (unless (setq group (intern-soft group groups))
 297           (throw 'return nil))
 298         (setq group (symbol-value group)))
 299       group)))
 300
 301 (defun nnmaildir--tab-to-space (string)
 302   (let ((pos 0))
 303     (while (string-match "\t" string pos)
 304       (aset string (match-beginning 0) ? )
 305       (setq pos (match-end 0))))
 306   string)
 307
 308 (defmacro nnmaildir--condcase (errsym body &rest handler)
 309   `(condition-case ,errsym
 310        (let ((system-messages-locale "C")) ,body)
 311      (error . ,handler)))
 312
 313 (defun nnmaildir--emlink-p (err)
 314   (and (eq (car err) 'file-error)
 315        (string= (downcase (caddr err)) "too many links")))
 316
 317 (defun nnmaildir--enoent-p (err)
 318   (and (eq (car err) 'file-error)
 319        (string= (downcase (caddr err)) "no such file or directory")))
 320
 321 (defun nnmaildir--eexist-p (err)
 322   (eq (car err) 'file-already-exists))
 323
 324 (defun nnmaildir--new-number (nndir)
 325   "Allocate a new article number by atomically creating a file under NNDIR."
 326   (let ((numdir (nnmaildir--num-dir nndir))
 327         (make-new-file t)
 328         (number-open 1)
 329         number-link previous-number-link path-open path-link ino-open)
 330     (nnmaildir--mkdir numdir)
 331     (catch 'return
 332       (while t
 333         (setq path-open (concat numdir (number-to-string number-open)))
 334         (if (not make-new-file)
 335             (setq previous-number-link number-link)
 336           (nnmaildir--mkfile path-open)
 337           ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
 338           (setq make-new-file nil
 339                 previous-number-link 0))
 340         (let* ((attr (file-attributes path-open))
 341                (nlink (nth 1 attr)))
 342           (setq ino-open (nth 10 attr)
 343                 number-link (+ number-open nlink))
 344           (if (or (< nlink 1) (< number-link nlink))
 345               (signal 'error '("Arithmetic overflow"))))
 346         (if (= number-link previous-number-link)
 347             ;; We've already tried this number, in the previous loop iteration,
 348             ;; and failed.
 349             (signal 'error `("Corrupt internal nnmaildir data" ,path-open)))
 350         (setq path-link (concat numdir (number-to-string number-link)))
 351         (nnmaildir--condcase err
 352             (progn
 353               (add-name-to-file path-open path-link)
 354               (throw 'return number-link))
 355           (cond
 356            ((nnmaildir--emlink-p err)
 357             (setq make-new-file t
 358                   number-open number-link))
 359            ((nnmaildir--eexist-p err)
 360             (let ((attr (file-attributes path-link)))
 361               (if (/= (nth 10 attr) ino-open)
 362                   (setq number-open number-link
 363                         number-link 0))))
 364            (t (signal (car err) (cdr err)))))))))
 365
 366 (defun nnmaildir--update-nov (server group article)
 367   (let ((nnheader-file-coding-system 'binary)
 368         (srv-dir (nnmaildir--srv-dir server))
 369         (storage-version 1) ;; [version article-number msgid [...nov...]]
 370         dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
 371         nov msgid nov-beg nov-mid nov-end field val old-extra num numdir
 372         deactivate-mark)
 373     (catch 'return
 374       (setq gname (nnmaildir--grp-name group)
 375             pgname (nnmaildir--pgname server gname)
 376             dir (nnmaildir--srvgrp-dir srv-dir gname)
 377             msgdir (if (nnmaildir--param pgname 'read-only)
 378                        (nnmaildir--new dir) (nnmaildir--cur dir))
 379             prefix (nnmaildir--art-prefix article)
 380             suffix (nnmaildir--art-suffix article)
 381             file (concat msgdir prefix suffix)
 382             attr (file-attributes file))
 383       (unless attr
 384         (nnmaildir--expired-article group article)
 385         (throw 'return nil))
 386       (setq mtime (nth 5 attr)
 387             attr (nth 7 attr)
 388             nov (nnmaildir--art-nov article)
 389             dir (nnmaildir--nndir dir)
 390             novdir (nnmaildir--nov-dir dir)
 391             novfile (concat novdir prefix))
 392       (unless (equal nnmaildir--extra nnmail-extra-headers)
 393         (setq nnmaildir--extra (copy-sequence nnmail-extra-headers)))
 394       (nnmaildir--with-nov-buffer
 395         ;; First we'll check for already-parsed NOV data.
 396         (cond ((not (file-exists-p novfile))
 397                ;; The NOV file doesn't exist; we have to parse the message.
 398                (setq nov nil))
 399               ((not nov)
 400                ;; The file exists, but the data isn't in memory; read the file.
 401                (erase-buffer)
 402                (nnheader-insert-file-contents novfile)
 403                (setq nov (read (current-buffer)))
 404                (if (not (and (vectorp nov)
 405                              (/= 0 (length nov))
 406                              (equal storage-version (aref nov 0))))
 407                    ;; This NOV data seems to be in the wrong format.
 408                    (setq nov nil)
 409                  (unless (nnmaildir--art-num   article)
 410                    (setf (nnmaildir--art-num   article) (aref nov 1)))
 411                  (unless (nnmaildir--art-msgid article)
 412                    (setf (nnmaildir--art-msgid article) (aref nov 2)))
 413                  (setq nov (aref nov 3)))))
 414         ;; Now check whether the already-parsed data (if we have any) is
 415         ;; usable: if the message has been edited or if nnmail-extra-headers
 416         ;; has been augmented since this data was parsed from the message,
 417         ;; then we have to reparse.  Otherwise it's up-to-date.
 418         (when (and nov (equal mtime (nnmaildir--nov-get-mtime nov)))
 419           ;; The timestamp matches.  Now check nnmail-extra-headers.
 420           (setq old-extra (nnmaildir--nov-get-extra nov))
 421           (when (equal nnmaildir--extra old-extra) ;; common case
 422             ;; Save memory; use a single copy of the list value.
 423             (nnmaildir--nov-set-extra nov nnmaildir--extra)
 424             (throw 'return nov))
 425           ;; They're not equal, but maybe the new is a subset of the old.
 426           (if (null nnmaildir--extra)
 427               ;; The empty set is a subset of every set.
 428               (throw 'return nov))
 429           (if (not (memq nil (mapcar (lambda (e) (memq e old-extra))
 430                                      nnmaildir--extra)))
 431               (throw 'return nov)))
 432         ;; Parse the NOV data out of the message.
 433         (erase-buffer)
 434         (nnheader-insert-file-contents file)
 435         (insert "\n")
 436         (goto-char (point-min))
 437         (save-restriction
 438           (if (search-forward "\n\n" nil 'noerror)
 439               (progn
 440                 (setq nov-mid (count-lines (point) (point-max)))
 441                 (narrow-to-region (point-min) (1- (point))))
 442             (setq nov-mid 0))
 443           (goto-char (point-min))
 444           (delete-char 1)
 445           (setq nov (nnheader-parse-naked-head)
 446                 field (or (mail-header-lines nov) 0)))
 447         (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
 448           (setq nov-mid field))
 449         (setq nov-mid (number-to-string nov-mid)
 450               nov-mid (concat (number-to-string attr) "\t" nov-mid))
 451         (save-match-data
 452           (setq field (or (mail-header-references nov) ""))
 453           (nnmaildir--tab-to-space field)
 454           (setq nov-mid (concat field "\t" nov-mid)
 455                 nov-beg (mapconcat
 456                           (lambda (f) (nnmaildir--tab-to-space (or f "")))
 457                           (list (mail-header-subject nov)
 458                                 (mail-header-from nov)
 459                                 (mail-header-date nov)) "\t")
 460                 nov-end (mapconcat
 461                           (lambda (extra)
 462                             (setq field (symbol-name (car extra))
 463                                   val (cdr extra))
 464                             (nnmaildir--tab-to-space field)
 465                             (nnmaildir--tab-to-space val)
 466                             (concat field ": " val))
 467                           (mail-header-extra nov) "\t")))
 468         (setq msgid (mail-header-id nov))
 469         (if (or (null msgid) (nnheader-fake-message-id-p msgid))
 470             (setq msgid (concat "<" prefix "@nnmaildir>")))
 471         (nnmaildir--tab-to-space msgid)
 472         ;; The data is parsed; create an nnmaildir NOV structure.
 473         (setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime
 474                                       nnmaildir--extra)
 475               num (nnmaildir--art-num article))
 476         (unless num
 477           (setq num (nnmaildir--new-number dir))
 478           (setf (nnmaildir--art-num article) num))
 479         ;; Store this new NOV data in a file
 480         (erase-buffer)
 481         (prin1 (vector storage-version num msgid nov) (current-buffer))
 482         (setq file (concat novfile ":"))
 483         (nnmaildir--unlink file)
 484         (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         (mapcar
 749          (lambda (file)
 750            (setq x (file-attributes file))
 751            (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago))
 752                (delete-file file)))
 753          (funcall ls tdir 'full "\\`[^.]" 'nosort)))
 754       (or scan-msgs
 755           isnew
 756           (throw 'return t))
 757       (setq nattr (nth 5 nattr))
 758       (if (equal nattr (nnmaildir--grp-new group))
 759           (setq nattr nil))
 760       (if read-only (setq dir (and (or isnew nattr) ndir))
 761         (when (or isnew nattr)
 762           (mapcar
 763            (lambda (file)
 764              (let ((path (concat ndir file)))
 765                (and (time-less-p (nth 5 (file-attributes path)) (current-time))
 766                     (rename-file path (concat cdir file ":2,")))))
 767            (funcall ls ndir nil "\\`[^.]" 'nosort))
 768           (setf (nnmaildir--grp-new group) nattr))
 769         (setq cattr (nth 5 (file-attributes cdir)))
 770         (if (equal cattr (nnmaildir--grp-cur group))
 771             (setq cattr nil))
 772         (setq dir (and (or isnew cattr) cdir)))
 773       (unless dir (throw 'return t))
 774       (setq files (funcall ls dir nil "\\`[^.]" 'nosort)
 775             files (save-match-data
 776                     (mapcar
 777                      (lambda (f)
 778                        (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f)
 779                        (cons (match-string 1 f) (match-string 2 f)))
 780                      files)))
 781       (when isnew
 782         (setq num (nnmaildir--up2-1 (length files)))
 783         (setf (nnmaildir--grp-flist group) (make-vector num 0))
 784         (setf (nnmaildir--grp-mlist group) (make-vector num 0))
 785         (setf (nnmaildir--grp-mmth group) (make-vector 1 0))
 786         (setq num (nnmaildir--param pgname 'nov-cache-size))
 787         (if (numberp num) (if (< num 1) (setq num 1))
 788           (setq num 16
 789                 cdir (nnmaildir--marks-dir nndir)
 790                 ndir (nnmaildir--subdir cdir "tick")
 791                 cdir (nnmaildir--subdir cdir "read"))
 792           (mapcar
 793            (lambda (file)
 794              (setq file (car file))
 795              (if (or (not (file-exists-p (concat cdir file)))
 796                      (file-exists-p (concat ndir file)))
 797                  (setq num (1+ num))))
 798            files))
 799         (setf (nnmaildir--grp-cache group) (make-vector num nil))
 800         (let ((inhibit-quit t))
 801           (set (intern gname groups) group))
 802         (or scan-msgs (throw 'return t)))
 803       (setq flist (nnmaildir--grp-flist group)
 804             files (mapcar
 805                    (lambda (file)
 806                      (and (null (nnmaildir--flist-art flist (car file)))
 807                           file))
 808                    files)
 809             files (delq nil files)
 810             files (mapcar 'nnmaildir--parse-filename files)
 811             files (sort files 'nnmaildir--sort-files))
 812       (mapcar
 813        (lambda (file)
 814          (setq file (if (consp file) file (aref file 3))
 815                x (make-nnmaildir--art :prefix (car file) :suffix (cdr file)))
 816          (nnmaildir--grp-add-art nnmaildir--cur-server group x))
 817        files)
 818       (if read-only (setf (nnmaildir--grp-new group) nattr)
 819         (setf (nnmaildir--grp-cur group) cattr)))
 820     t))
 821
 822 (defun nnmaildir-request-scan (&optional scan-group server)
 823   (let ((coding-system-for-write nnheader-file-coding-system)
 824         (buffer-file-coding-system nil)
 825         (file-coding-system-alist nil)
 826         (nnmaildir-get-new-mail t)
 827         (nnmaildir-group-alist nil)
 828         (nnmaildir-active-file nil)
 829         x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen
 830         deactivate-mark)
 831     (nnmaildir--prepare server nil)
 832     (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server)
 833           srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
 834           method (nnmaildir--srv-method nnmaildir--cur-server)
 835           groups (nnmaildir--srv-groups nnmaildir--cur-server)
 836           target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
 837     (nnmaildir--with-work-buffer
 838       (save-match-data
 839         (if (stringp scan-group)
 840             (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
 841                 (if (nnmaildir--srv-gnm nnmaildir--cur-server)
 842                     (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
 843               (unintern scan-group groups))
 844           (setq x (nth 5 (file-attributes srv-dir))
 845                 scan-group (null scan-group))
 846           (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
 847               (if scan-group
 848                   (mapatoms (lambda (sym)
 849                               (nnmaildir--scan (symbol-name sym) t groups
 850                                                method srv-dir srv-ls))
 851                             groups))
 852             (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
 853                   dirs (if (zerop (length target-prefix))
 854                            dirs
 855                          (gnus-remove-if
 856                           (lambda (dir)
 857                             (and (>= (length dir) (length target-prefix))
 858                                  (string= (substring dir 0
 859                                                      (length target-prefix))
 860                                           target-prefix)))
 861                           dirs))
 862                   seen (nnmaildir--up2-1 (length dirs))
 863                   seen (make-vector seen 0))
 864             (mapcar
 865              (lambda (grp-dir)
 866                (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
 867                                     srv-ls)
 868                    (intern grp-dir seen)))
 869              dirs)
 870             (setq x nil)
 871             (mapatoms (lambda (group)
 872                         (setq group (symbol-name group))
 873                         (unless (intern-soft group seen)
 874                           (setq x (cons group x))))
 875                       groups)
 876             (mapcar (lambda (grp) (unintern grp groups)) x)
 877             (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
 878                   (nth 5 (file-attributes srv-dir))))
 879           (and scan-group
 880                (nnmaildir--srv-gnm nnmaildir--cur-server)
 881                (nnmail-get-new-mail 'nnmaildir nil nil))))))
 882   t)
 883
 884 (defun nnmaildir-request-list (&optional server)
 885   (nnmaildir-request-scan 'find-new-groups server)
 886   (let (pgname ro deactivate-mark)
 887     (nnmaildir--prepare server nil)
 888     (nnmaildir--with-nntp-buffer
 889       (erase-buffer)
 890       (mapatoms (lambda (group)
 891                   (setq pgname (symbol-name group)
 892                         pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
 893                         group (symbol-value group)
 894                         ro (nnmaildir--param pgname 'read-only))
 895                   (insert (nnmaildir--grp-name group) " ")
 896                   (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 897                          nntp-server-buffer)
 898                   (insert " ")
 899                   (princ (nnmaildir--grp-min group) nntp-server-buffer)
 900                   (insert " " (if ro "n" "y") "\n"))
 901                 (nnmaildir--srv-groups nnmaildir--cur-server))))
 902   t)
 903
 904 (defun nnmaildir-request-newgroups (date &optional server)
 905   (nnmaildir-request-list server))
 906
 907 (defun nnmaildir-retrieve-groups (groups &optional server)
 908   (let (group deactivate-mark)
 909     (nnmaildir--prepare server nil)
 910     (nnmaildir--with-nntp-buffer
 911       (erase-buffer)
 912       (mapcar
 913        (lambda (gname)
 914          (setq group (nnmaildir--prepare nil gname))
 915          (if (null group) (insert "411 no such news group\n")
 916            (insert "211 ")
 917            (princ (nnmaildir--grp-count group) nntp-server-buffer)
 918            (insert " ")
 919            (princ (nnmaildir--grp-min   group) nntp-server-buffer)
 920            (insert " ")
 921            (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 922                   nntp-server-buffer)
 923            (insert " " gname "\n")))
 924        groups)))
 925   'group)
 926
 927 (defun nnmaildir-request-update-info (gname info &optional server)
 928   (let ((group (nnmaildir--prepare server gname))
 929         pgname flist always-marks never-marks old-marks dotfile num dir
 930         markdirs marks mark ranges markdir article read end new-marks ls
 931         old-mmth new-mmth mtime mark-sym existing missing deactivate-mark)
 932     (catch 'return
 933       (unless group
 934         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 935               (concat "No such group: " gname))
 936         (throw 'return nil))
 937       (setq gname (nnmaildir--grp-name group)
 938             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
 939             flist (nnmaildir--grp-flist group))
 940       (when (zerop (nnmaildir--grp-count group))
 941         (gnus-info-set-read info nil)
 942         (gnus-info-set-marks info nil 'extend)
 943         (throw 'return info))
 944       (setq old-marks (cons 'read (gnus-info-read info))
 945             old-marks (cons old-marks (gnus-info-marks info))
 946             always-marks (nnmaildir--param pgname 'always-marks)
 947             never-marks (nnmaildir--param pgname 'never-marks)
 948             existing (nnmaildir--grp-nlist group)
 949             existing (mapcar 'car existing)
 950             existing (nreverse existing)
 951             existing (gnus-compress-sequence existing 'always-list)
 952             missing (list (cons 1 (nnmaildir--group-maxnum
 953                                    nnmaildir--cur-server group)))
 954             missing (gnus-range-difference missing existing)
 955             dir (nnmaildir--srv-dir nnmaildir--cur-server)
 956             dir (nnmaildir--srvgrp-dir dir gname)
 957             dir (nnmaildir--nndir dir)
 958             dir (nnmaildir--marks-dir dir)
 959             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
 960             markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
 961             new-mmth (nnmaildir--up2-1 (length markdirs))
 962             new-mmth (make-vector new-mmth 0)
 963             old-mmth (nnmaildir--grp-mmth group))
 964       (mapcar
 965        (lambda (mark)
 966          (setq markdir (nnmaildir--subdir dir mark)
 967                mark-sym (intern mark)
 968                ranges nil)
 969          (catch 'got-ranges
 970            (if (memq mark-sym never-marks) (throw 'got-ranges nil))
 971            (when (memq mark-sym always-marks)
 972              (setq ranges existing)
 973              (throw 'got-ranges nil))
 974            (setq mtime (nth 5 (file-attributes markdir)))
 975            (set (intern mark new-mmth) mtime)
 976            (when (equal mtime (symbol-value (intern-soft mark old-mmth)))
 977              (setq ranges (assq mark-sym old-marks))
 978              (if ranges (setq ranges (cdr ranges)))
 979              (throw 'got-ranges nil))
 980            (mapcar
 981             (lambda (prefix)
 982               (setq article (nnmaildir--flist-art flist prefix))
 983               (if article
 984                   (setq ranges
 985                         (gnus-add-to-range ranges
 986                                            `(,(nnmaildir--art-num article))))))
 987             (funcall ls markdir nil "\\`[^.]" 'nosort)))
 988          (if (eq mark-sym 'read) (setq read ranges)
 989            (if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
 990        markdirs)
 991       (gnus-info-set-read info (gnus-range-add read missing))
 992       (gnus-info-set-marks info marks 'extend)
 993       (setf (nnmaildir--grp-mmth group) new-mmth)
 994       info)))
 995
 996 (defun nnmaildir-request-group (gname &optional server fast)
 997   (let ((group (nnmaildir--prepare server gname))
 998         deactivate-mark)
 999     (catch 'return
1000       (unless group
1001         ;; (insert "411 no such news group\n")
1002         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1003               (concat "No such group: " gname))
1004         (throw 'return nil))
1005       (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
1006       (if fast (throw 'return t))
1007       (nnmaildir--with-nntp-buffer
1008         (erase-buffer)
1009         (insert "211 ")
1010         (princ (nnmaildir--grp-count group) nntp-server-buffer)
1011         (insert " ")
1012         (princ (nnmaildir--grp-min   group) nntp-server-buffer)
1013         (insert " ")
1014         (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
1015                nntp-server-buffer)
1016         (insert " " gname "\n")
1017         t))))
1018
1019 (defun nnmaildir-request-create-group (gname &optional server args)
1020   (nnmaildir--prepare server nil)
1021   (catch 'return
1022     (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
1023           srv-dir dir groups)
1024       (when (zerop (length gname))
1025         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1026               "Invalid (empty) group name")
1027         (throw 'return nil))
1028       (when (eq (aref "." 0) (aref gname 0))
1029         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1030               "Group names may not start with \".\"")
1031         (throw 'return nil))
1032       (when (save-match-data (string-match "[\0/\t]" gname))
1033         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1034               (concat "Invalid characters (null, tab, or /) in group name: "
1035                       gname))
1036         (throw 'return nil))
1037       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
1038       (when (intern-soft gname groups)
1039         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1040               (concat "Group already exists: " gname))
1041         (throw 'return nil))
1042       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1043       (if (file-name-absolute-p target-prefix)
1044           (setq dir (expand-file-name target-prefix))
1045         (setq dir srv-dir
1046               dir (file-truename dir)
1047               dir (concat dir target-prefix)))
1048       (setq dir (nnmaildir--subdir dir gname))
1049       (nnmaildir--mkdir dir)
1050       (nnmaildir--mkdir (nnmaildir--tmp dir))
1051       (nnmaildir--mkdir (nnmaildir--new dir))
1052       (nnmaildir--mkdir (nnmaildir--cur dir))
1053       (unless (string= target-prefix "")
1054         (make-symbolic-link (concat target-prefix gname)
1055                             (concat srv-dir gname)))
1056       (nnmaildir-request-scan 'find-new-groups))))
1057
1058 (defun nnmaildir-request-rename-group (gname new-name &optional server)
1059   (let ((group (nnmaildir--prepare server gname))
1060         (coding-system-for-write nnheader-file-coding-system)
1061         (buffer-file-coding-system nil)
1062         (file-coding-system-alist nil)
1063         srv-dir x groups)
1064     (catch 'return
1065       (unless group
1066         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1067               (concat "No such group: " gname))
1068         (throw 'return nil))
1069       (when (zerop (length new-name))
1070         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1071               "Invalid (empty) group name")
1072         (throw 'return nil))
1073       (when (eq (aref "." 0) (aref new-name 0))
1074         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1075               "Group names may not start with \".\"")
1076         (throw 'return nil))
1077       (when (save-match-data (string-match "[\0/\t]" new-name))
1078         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1079               (concat "Invalid characters (null, tab, or /) in group name: "
1080                       new-name))
1081         (throw 'return nil))
1082       (if (string-equal gname new-name) (throw 'return t))
1083       (when (intern-soft new-name
1084                          (nnmaildir--srv-groups nnmaildir--cur-server))
1085         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1086               (concat "Group already exists: " new-name))
1087         (throw 'return nil))
1088       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1089       (condition-case err
1090           (rename-file (concat srv-dir gname)
1091                        (concat srv-dir new-name))
1092         (error
1093          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1094                (concat "Error renaming link: " (prin1-to-string err)))
1095          (throw 'return nil)))
1096       (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
1097             groups (make-vector (length x) 0))
1098       (mapatoms (lambda (sym)
1099                   (unless (eq (symbol-value sym) group)
1100                     (set (intern (symbol-name sym) groups)
1101                          (symbol-value sym))))
1102                 x)
1103       (setq group (copy-sequence group))
1104       (setf (nnmaildir--grp-name group) new-name)
1105       (set (intern new-name groups) group)
1106       (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
1107       t)))
1108
1109 (defun nnmaildir-request-delete-group (gname force &optional server)
1110   (let ((group (nnmaildir--prepare server gname))
1111         pgname grp-dir target dir ls deactivate-mark)
1112     (catch 'return
1113       (unless group
1114         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1115               (concat "No such group: " gname))
1116         (throw 'return nil))
1117       (setq gname (nnmaildir--grp-name group)
1118             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1119             grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1120             target (car (file-attributes (concat grp-dir gname)))
1121             grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
1122       (unless (or force (stringp target))
1123         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1124               (concat "Not a symlink: " gname))
1125         (throw 'return nil))
1126       (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
1127           (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
1128       (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
1129       (if (not force)
1130           (progn
1131             (setq grp-dir (directory-file-name grp-dir))
1132             (nnmaildir--unlink grp-dir))
1133         (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname))
1134         (if (nnmaildir--param pgname 'read-only)
1135             (progn (delete-directory  (nnmaildir--tmp grp-dir))
1136                    (nnmaildir--unlink (nnmaildir--new grp-dir))
1137                    (delete-directory  (nnmaildir--cur grp-dir)))
1138           (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls)
1139           (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls)
1140           (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls))
1141         (setq dir (nnmaildir--nndir grp-dir))
1142         (mapcar (lambda (subdir) (nnmaildir--delete-dir-files subdir ls))
1143                 `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir)
1144                   ,@(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1145                              'nosort)))
1146         (setq dir (nnmaildir--nndir grp-dir))
1147         (nnmaildir--unlink (concat dir "markfile"))
1148         (nnmaildir--unlink (concat dir "markfile{new}"))
1149         (delete-directory (nnmaildir--marks-dir dir))
1150         (delete-directory dir)
1151         (if (not (stringp target))
1152             (delete-directory grp-dir)
1153           (setq grp-dir (directory-file-name grp-dir)
1154                 dir target)
1155           (unless (eq (aref "/" 0) (aref dir 0))
1156             (setq dir (concat (file-truename
1157                                (nnmaildir--srv-dir nnmaildir--cur-server))
1158                               dir)))
1159           (delete-directory dir)
1160           (nnmaildir--unlink grp-dir)))
1161       t)))
1162
1163 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1164   (let ((group (nnmaildir--prepare server gname))
1165         srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1166         deactivate-mark)
1167     (setq insert-nov
1168           (lambda (article)
1169             (setq nov (nnmaildir--update-nov nnmaildir--cur-server group
1170                                              article))
1171             (when nov
1172               (nnmaildir--cache-nov group article nov)
1173               (setq num (nnmaildir--art-num article))
1174               (princ num nntp-server-buffer)
1175               (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1176                       (nnmaildir--art-msgid article) "\t"
1177                       (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir "
1178                       gname ":")
1179               (princ num nntp-server-buffer)
1180               (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1181     (catch 'return
1182       (unless group
1183         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1184               (if gname (concat "No such group: " gname) "No current group"))
1185         (throw 'return nil))
1186       (nnmaildir--with-nntp-buffer
1187         (erase-buffer)
1188         (setq mlist (nnmaildir--grp-mlist group)
1189               nlist (nnmaildir--grp-nlist group)
1190               gname (nnmaildir--grp-name group)
1191               srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1192               dir (nnmaildir--srvgrp-dir srv-dir gname))
1193         (cond
1194          ((null nlist))
1195          ((and fetch-old (not (numberp fetch-old)))
1196           (nnmaildir--nlist-iterate nlist 'all insert-nov))
1197          ((null articles))
1198          ((stringp (car articles))
1199           (mapcar
1200            (lambda (msgid)
1201              (setq article (nnmaildir--mlist-art mlist msgid))
1202              (if article (funcall insert-nov article)))
1203            articles))
1204          (t
1205           (if fetch-old
1206               ;; Assume the article range list is sorted ascending
1207               (setq stop (car articles)
1208                     start (car (last articles))
1209                     stop  (if (numberp stop)  stop  (car stop))
1210                     start (if (numberp start) start (cdr start))
1211                     stop (- stop fetch-old)
1212                     stop (if (< stop 1) 1 stop)
1213                     articles (list (cons stop start))))
1214           (nnmaildir--nlist-iterate nlist articles insert-nov)))
1215         (sort-numeric-fields 1 (point-min) (point-max))
1216         'nov))))
1217
1218 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1219   (let ((group (nnmaildir--prepare server gname))
1220         (case-fold-search t)
1221         list article dir pgname deactivate-mark)
1222     (catch 'return
1223       (unless group
1224         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1225               (if gname (concat "No such group: " gname) "No current group"))
1226         (throw 'return nil))
1227       (if (numberp num-msgid)
1228           (setq article (nnmaildir--nlist-art group num-msgid))
1229         (setq list (nnmaildir--grp-mlist group)
1230               article (nnmaildir--mlist-art list num-msgid))
1231         (if article (setq num-msgid (nnmaildir--art-num article))
1232           (catch 'found
1233             (mapatoms
1234               (lambda (group-sym)
1235                 (setq group (symbol-value group-sym)
1236                       list (nnmaildir--grp-mlist group)
1237                       article (nnmaildir--mlist-art list num-msgid))
1238                 (when article
1239                   (setq num-msgid (nnmaildir--art-num article))
1240                   (throw 'found nil)))
1241               (nnmaildir--srv-groups nnmaildir--cur-server))))
1242         (unless article
1243           (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1244           (throw 'return nil)))
1245       (setq gname (nnmaildir--grp-name group)
1246             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1247             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1248             dir (nnmaildir--srvgrp-dir dir gname)
1249             dir (if (nnmaildir--param pgname 'read-only)
1250                     (nnmaildir--new dir) (nnmaildir--cur dir))
1251             nnmaildir-article-file-name
1252             (concat dir
1253                     (nnmaildir--art-prefix article)
1254                     (nnmaildir--art-suffix article)))
1255       (unless (file-exists-p nnmaildir-article-file-name)
1256         (nnmaildir--expired-article group article)
1257         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1258               "Article has expired")
1259         (throw 'return nil))
1260       (save-excursion
1261         (set-buffer (or to-buffer nntp-server-buffer))
1262         (erase-buffer)
1263         (nnheader-insert-file-contents nnmaildir-article-file-name))
1264       (cons gname num-msgid))))
1265
1266 (defun nnmaildir-request-post (&optional server)
1267   (let (message-required-mail-headers)
1268     (funcall message-send-mail-function)))
1269
1270 (defun nnmaildir-request-replace-article (number gname buffer)
1271   (let ((group (nnmaildir--prepare nil gname))
1272         (coding-system-for-write nnheader-file-coding-system)
1273         (buffer-file-coding-system nil)
1274         (file-coding-system-alist nil)
1275         dir file article suffix tmpfile deactivate-mark)
1276     (catch 'return
1277       (unless group
1278         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1279               (concat "No such group: " gname))
1280         (throw 'return nil))
1281       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1282                               'read-only)
1283         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1284               (concat "Read-only group: " group))
1285         (throw 'return nil))
1286       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1287             dir (nnmaildir--srvgrp-dir dir gname)
1288             article (nnmaildir--nlist-art group number))
1289       (unless article
1290         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1291               (concat "No such article: " (number-to-string number)))
1292         (throw 'return nil))
1293       (setq suffix (nnmaildir--art-suffix article)
1294             file (nnmaildir--art-prefix article)
1295             tmpfile (concat (nnmaildir--tmp dir) file))
1296       (when (file-exists-p tmpfile)
1297         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1298               (concat "File exists: " tmpfile))
1299         (throw 'return nil))
1300       (save-excursion
1301         (set-buffer buffer)
1302         (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1303                           'excl))
1304       (unix-sync) ;; no fsync :(
1305       (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1306       t)))
1307
1308 (defun nnmaildir-request-move-article (article gname server accept-form
1309                                                &optional last move-is-internal)
1310   (let ((group (nnmaildir--prepare server gname))
1311         pgname suffix result nnmaildir--file deactivate-mark)
1312     (catch 'return
1313       (unless group
1314         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1315               (concat "No such group: " gname))
1316         (throw 'return nil))
1317       (setq gname (nnmaildir--grp-name group)
1318             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1319             article (nnmaildir--nlist-art group article))
1320       (unless article
1321         (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1322         (throw 'return nil))
1323       (setq suffix (nnmaildir--art-suffix article)
1324             nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1325             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1326             nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1327                                 (nnmaildir--new nnmaildir--file)
1328                               (nnmaildir--cur nnmaildir--file))
1329             nnmaildir--file (concat nnmaildir--file
1330                                     (nnmaildir--art-prefix article)
1331                                     suffix))
1332       (unless (file-exists-p nnmaildir--file)
1333         (nnmaildir--expired-article group article)
1334         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1335               "Article has expired")
1336         (throw 'return nil))
1337       (nnmaildir--with-move-buffer
1338         (erase-buffer)
1339         (nnheader-insert-file-contents nnmaildir--file)
1340         (setq result (eval accept-form)))
1341       (unless (or (null result) (nnmaildir--param pgname 'read-only))
1342         (nnmaildir--unlink nnmaildir--file)
1343         (nnmaildir--expired-article group article))
1344       result)))
1345
1346 (defun nnmaildir-request-accept-article (gname &optional server last)
1347   (let ((group (nnmaildir--prepare server gname))
1348         (coding-system-for-write nnheader-file-coding-system)
1349         (buffer-file-coding-system nil)
1350         (file-coding-system-alist nil)
1351         srv-dir dir file time tmpfile curfile 24h article)
1352     (catch 'return
1353       (unless group
1354         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1355               (concat "No such group: " gname))
1356         (throw 'return nil))
1357       (setq gname (nnmaildir--grp-name group))
1358       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1359                               'read-only)
1360         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1361               (concat "Read-only group: " gname))
1362         (throw 'return nil))
1363       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1364             dir (nnmaildir--srvgrp-dir srv-dir gname)
1365             time (current-time)
1366             file (format-time-string "%s." time))
1367       (unless (string-equal nnmaildir--delivery-time file)
1368         (setq nnmaildir--delivery-time file
1369               nnmaildir--delivery-count 0))
1370       (when (and (consp (cdr time))
1371                  (consp (cddr time)))
1372         (setq file (concat file "M" (number-to-string (caddr time)))))
1373       (setq file (concat file nnmaildir--delivery-pid)
1374             file (concat file "Q" (number-to-string nnmaildir--delivery-count))
1375             file (concat file "." (nnmaildir--system-name))
1376             tmpfile (concat (nnmaildir--tmp dir) file)
1377             curfile (concat (nnmaildir--cur dir) file ":2,"))
1378       (when (file-exists-p tmpfile)
1379         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1380               (concat "File exists: " tmpfile))
1381         (throw 'return nil))
1382       (when (file-exists-p curfile)
1383         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1384               (concat "File exists: " curfile))
1385         (throw 'return nil))
1386       (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count)
1387             24h (run-with-timer 86400 nil
1388                                 (lambda ()
1389                                   (nnmaildir--unlink tmpfile)
1390                                   (setf (nnmaildir--srv-error
1391                                           nnmaildir--cur-server)
1392                                         "24-hour timer expired")
1393                                   (throw 'return nil))))
1394       (condition-case nil (add-name-to-file nnmaildir--file tmpfile)
1395         (error
1396          (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1397                            'excl)
1398          (unix-sync))) ;; no fsync :(
1399       (nnheader-cancel-timer 24h)
1400       (condition-case err
1401           (add-name-to-file tmpfile curfile)
1402         (error
1403          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1404                (concat "Error linking: " (prin1-to-string err)))
1405          (nnmaildir--unlink tmpfile)
1406          (throw 'return nil)))
1407       (nnmaildir--unlink tmpfile)
1408       (setq article (make-nnmaildir--art :prefix file :suffix ":2,"))
1409       (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1410           (cons gname (nnmaildir--art-num article))))))
1411
1412 (defun nnmaildir-save-mail (group-art)
1413   (catch 'return
1414     (unless group-art
1415       (throw 'return nil))
1416     (let (ga gname x groups nnmaildir--file deactivate-mark)
1417       (save-excursion
1418         (goto-char (point-min))
1419         (save-match-data
1420           (while (looking-at "From ")
1421             (replace-match "X-From-Line: ")
1422             (forward-line 1))))
1423       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1424             ga (car group-art) group-art (cdr group-art)
1425             gname (car ga))
1426       (or (intern-soft gname groups)
1427           (nnmaildir-request-create-group gname)
1428           (throw 'return nil)) ;; not that nnmail bothers to check :(
1429       (unless (nnmaildir-request-accept-article gname)
1430         (throw 'return nil))
1431       (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1432             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1433             x (nnmaildir--prepare nil gname)
1434             x (nnmaildir--grp-nlist x)
1435             x (cdar x)
1436             nnmaildir--file (concat nnmaildir--file
1437                                     (nnmaildir--art-prefix x)
1438                                     (nnmaildir--art-suffix x)))
1439       (delq nil
1440             (mapcar
1441              (lambda (ga)
1442                (setq gname (car ga))
1443                (and (or (intern-soft gname groups)
1444                         (nnmaildir-request-create-group gname))
1445                     (nnmaildir-request-accept-article gname)
1446                     ga))
1447              group-art)))))
1448
1449 (defun nnmaildir-active-number (gname)
1450   0)
1451
1452 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1453   (let ((no-force (not force))
1454         (group (nnmaildir--prepare server gname))
1455         pgname time boundary bound-iter high low target dir nlist nlist2
1456         stop article didnt nnmaildir--file nnmaildir-article-file-name
1457         deactivate-mark)
1458     (catch 'return
1459       (unless group
1460         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1461               (if gname (concat "No such group: " gname) "No current group"))
1462         (throw 'return (gnus-uncompress-range ranges)))
1463       (setq gname (nnmaildir--grp-name group)
1464             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1465       (if (nnmaildir--param pgname 'read-only)
1466           (throw 'return (gnus-uncompress-range ranges)))
1467       (setq time (nnmaildir--param pgname 'expire-age))
1468       (unless time
1469         (setq time (or (and nnmail-expiry-wait-function
1470                             (funcall nnmail-expiry-wait-function gname))
1471                        nnmail-expiry-wait))
1472         (if (eq time 'immediate)
1473             (setq time 0)
1474           (if (numberp time)
1475               (setq time (* time 86400)))))
1476       (when no-force
1477         (unless (integerp time) ;; handle 'never
1478           (throw 'return (gnus-uncompress-range ranges)))
1479         (setq boundary (current-time)
1480               high (- (car boundary) (/ time 65536))
1481               low (- (cadr boundary) (% time 65536)))
1482         (if (< low 0)
1483             (setq low (+ low 65536)
1484                   high (1- high)))
1485         (setcar (cdr boundary) low)
1486         (setcar boundary high))
1487       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1488             dir (nnmaildir--srvgrp-dir dir gname)
1489             dir (nnmaildir--cur dir)
1490             nlist (nnmaildir--grp-nlist group)
1491             ranges (reverse ranges))
1492       (nnmaildir--with-move-buffer
1493         (nnmaildir--nlist-iterate
1494          nlist ranges
1495          (lambda (article)
1496            (setq nnmaildir--file (nnmaildir--art-prefix article)
1497                  nnmaildir--file (concat dir nnmaildir--file
1498                                          (nnmaildir--art-suffix article))
1499                  time (file-attributes nnmaildir--file))
1500            (cond
1501             ((null time)
1502              (nnmaildir--expired-article group article))
1503             ((and no-force
1504                   (progn
1505                     (setq time (nth 5 time)
1506                           bound-iter boundary)
1507                     (while (and bound-iter time
1508                                 (= (car bound-iter) (car time)))
1509                       (setq bound-iter (cdr bound-iter)
1510                             time (cdr time)))
1511                     (and bound-iter time
1512                          (car-less-than-car bound-iter time))))
1513              (setq didnt (cons (nnmaildir--art-num article) didnt)))
1514             (t
1515              (setq nnmaildir-article-file-name nnmaildir--file
1516                    target (if force nil
1517                             (save-excursion
1518                               (save-restriction
1519                                 (nnmaildir--param pgname 'expire-group)))))
1520              (when (and (stringp target)
1521                         (not (string-equal target pgname))) ;; Move it.
1522                (erase-buffer)
1523                (nnheader-insert-file-contents nnmaildir--file)
1524                (let ((group-art (gnus-request-accept-article
1525                                  target nil nil 'no-encode)))
1526                  (when (consp group-art)
1527                    ;; Maybe also copy: dormant forward reply save tick
1528                    ;; (gnus-add-mark? gnus-request-set-mark?)
1529                    (gnus-group-mark-article-read target (cdr group-art)))))
1530              (if (equal target pgname)
1531                  ;; Leave it here.
1532                  (setq didnt (cons (nnmaildir--art-num article) didnt))
1533                (nnmaildir--unlink nnmaildir--file)
1534                (nnmaildir--expired-article group article))))))
1535         (erase-buffer))
1536       didnt)))
1537
1538 (defun nnmaildir-request-set-mark (gname actions &optional server)
1539   (let ((group (nnmaildir--prepare server gname))
1540         (coding-system-for-write nnheader-file-coding-system)
1541         (buffer-file-coding-system nil)
1542         (file-coding-system-alist nil)
1543         del-mark del-action add-action set-action marksdir nlist
1544         ranges begin end article all-marks todo-marks mdir mfile
1545         pgname ls permarkfile deactivate-mark)
1546     (setq del-mark
1547           (lambda (mark)
1548             (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
1549                   mfile (concat mfile (nnmaildir--art-prefix article)))
1550             (nnmaildir--unlink mfile))
1551           del-action (lambda (article) (mapcar del-mark todo-marks))
1552           add-action
1553           (lambda (article)
1554             (mapcar
1555              (lambda (mark)
1556                (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
1557                      permarkfile (concat mdir ":")
1558                      mfile (concat mdir (nnmaildir--art-prefix article)))
1559                (nnmaildir--condcase err (add-name-to-file permarkfile mfile)
1560                  (cond
1561                   ((nnmaildir--eexist-p err))
1562                   ((nnmaildir--enoent-p err)
1563                    (nnmaildir--mkdir mdir)
1564                    (nnmaildir--mkfile permarkfile)
1565                    (add-name-to-file permarkfile mfile))
1566                   ((nnmaildir--emlink-p err)
1567                    (let ((permarkfilenew (concat permarkfile "{new}")))
1568                      (nnmaildir--mkfile permarkfilenew)
1569                      (rename-file permarkfilenew permarkfile 'replace)
1570                      (add-name-to-file permarkfile mfile)))
1571                   (t (signal (car err) (cdr err))))))
1572              todo-marks))
1573           set-action (lambda (article)
1574                        (funcall add-action)
1575                        (mapcar (lambda (mark)
1576                                  (unless (memq mark todo-marks)
1577                                    (funcall del-mark mark)))
1578                                all-marks)))
1579     (catch 'return
1580       (unless group
1581         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1582               (concat "No such group: " gname))
1583         (mapcar (lambda (action)
1584                   (setq ranges (gnus-range-add ranges (car action))))
1585                 actions)
1586         (throw 'return ranges))
1587       (setq nlist (nnmaildir--grp-nlist group)
1588             marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1589             marksdir (nnmaildir--srvgrp-dir marksdir gname)
1590             marksdir (nnmaildir--nndir marksdir)
1591             marksdir (nnmaildir--marks-dir marksdir)
1592             gname (nnmaildir--grp-name group)
1593             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1594             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1595             all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1596             all-marks (mapcar 'intern all-marks))
1597       (mapcar
1598        (lambda (action)
1599          (setq ranges (car action)
1600                todo-marks (caddr action))
1601          (mapcar (lambda (mark) (add-to-list 'all-marks mark)) todo-marks)
1602          (if (numberp (cdr ranges)) (setq ranges (list ranges)))
1603          (nnmaildir--nlist-iterate nlist ranges
1604                                    (cond ((eq 'del (cadr action)) del-action)
1605                                          ((eq 'add (cadr action)) add-action)
1606                                          (t set-action))))
1607        actions)
1608       nil)))
1609
1610 (defun nnmaildir-close-group (gname &optional server)
1611   (let ((group (nnmaildir--prepare server gname))
1612         pgname ls dir msgdir files flist dirs)
1613     (if (null group)
1614         (progn
1615           (setf (nnmaildir--srv-error nnmaildir--cur-server)
1616                 (concat "No such group: " gname))
1617           nil)
1618       (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1619             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1620             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1621             dir (nnmaildir--srvgrp-dir dir gname)
1622             msgdir (if (nnmaildir--param pgname 'read-only)
1623                        (nnmaildir--new dir) (nnmaildir--cur dir))
1624             dir (nnmaildir--nndir dir)
1625             dirs (cons (nnmaildir--nov-dir dir)
1626                        (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1627                                 'nosort))
1628             dirs (mapcar
1629                   (lambda (dir)
1630                     (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
1631                   dirs)
1632             files (funcall ls msgdir nil "\\`[^.]" 'nosort)
1633             flist (nnmaildir--up2-1 (length files))
1634             flist (make-vector flist 0))
1635       (save-match-data
1636         (mapcar
1637          (lambda (file)
1638            (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1639            (intern (match-string 1 file) flist))
1640          files))
1641       (mapcar
1642        (lambda (dir)
1643          (setq files (cdr dir)
1644                dir (file-name-as-directory (car dir)))
1645          (mapcar
1646           (lambda (file)
1647             (unless (or (intern-soft file flist) (string= file ":"))
1648               (setq file (concat dir file))
1649               (delete-file file)))
1650           files))
1651        dirs)
1652       t)))
1653
1654 (defun nnmaildir-close-server (&optional server)
1655   (let (flist ls dirs dir files file x)
1656     (nnmaildir--prepare server nil)
1657     (when nnmaildir--cur-server
1658       (setq server nnmaildir--cur-server
1659             nnmaildir--cur-server nil)
1660       (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
1661   t)
1662
1663 (defun nnmaildir-request-close ()
1664   (let (servers buffer)
1665     (mapatoms (lambda (server)
1666                 (setq servers (cons (symbol-name server) servers)))
1667               nnmaildir--servers)
1668     (mapcar 'nnmaildir-close-server servers)
1669     (setq buffer (get-buffer " *nnmaildir work*"))
1670     (if buffer (kill-buffer buffer))
1671     (setq buffer (get-buffer " *nnmaildir nov*"))
1672     (if buffer (kill-buffer buffer))
1673     (setq buffer (get-buffer " *nnmaildir move*"))
1674     (if buffer (kill-buffer buffer)))
1675   t)
1676
1677 (provide 'nnmaildir)
1678
1679 ;; Local Variables:
1680 ;; indent-tabs-mode: t
1681 ;; fill-column: 77
1682 ;; End:
1683
1684 ;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849
1685 ;;; nnmaildir.el ends here