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 (nnmaildir--grp-name group) " ")
 887                   (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 888                          nntp-server-buffer)
 889                   (insert " ")
 890                   (princ (nnmaildir--grp-min group) nntp-server-buffer)
 891                   (insert " " (if ro "n" "y") "\n"))
 892                 (nnmaildir--srv-groups nnmaildir--cur-server))))
 893   t)
 894
 895 (defun nnmaildir-request-newgroups (date &optional server)
 896   (nnmaildir-request-list server))
 897
 898 (defun nnmaildir-retrieve-groups (groups &optional server)
 899   (let (group deactivate-mark)
 900     (nnmaildir--prepare server nil)
 901     (nnmaildir--with-nntp-buffer
 902       (erase-buffer)
 903       (dolist (gname groups)
 904         (setq group (nnmaildir--prepare nil gname))
 905         (if (null group) (insert "411 no such news group\n")
 906           (insert "211 ")
 907           (princ (nnmaildir--grp-count group) nntp-server-buffer)
 908           (insert " ")
 909           (princ (nnmaildir--grp-min   group) nntp-server-buffer)
 910           (insert " ")
 911           (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 912                  nntp-server-buffer)
 913           (insert " " gname "\n")))))
 914   'group)
 915
 916 (defun nnmaildir-request-update-info (gname info &optional server)
 917   (let ((group (nnmaildir--prepare server gname))
 918         pgname flist always-marks never-marks old-marks dotfile num dir
 919         markdirs marks mark ranges markdir article read end new-marks ls
 920         old-mmth new-mmth mtime mark-sym existing missing deactivate-mark)
 921     (catch 'return
 922       (unless group
 923         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 924               (concat "No such group: " gname))
 925         (throw 'return nil))
 926       (setq gname (nnmaildir--grp-name group)
 927             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
 928             flist (nnmaildir--grp-flist group))
 929       (when (zerop (nnmaildir--grp-count group))
 930         (gnus-info-set-read info nil)
 931         (gnus-info-set-marks info nil 'extend)
 932         (throw 'return info))
 933       (setq old-marks (cons 'read (gnus-info-read info))
 934             old-marks (cons old-marks (gnus-info-marks info))
 935             always-marks (nnmaildir--param pgname 'always-marks)
 936             never-marks (nnmaildir--param pgname 'never-marks)
 937             existing (nnmaildir--grp-nlist group)
 938             existing (mapcar 'car existing)
 939             existing (nreverse existing)
 940             existing (gnus-compress-sequence existing 'always-list)
 941             missing (list (cons 1 (nnmaildir--group-maxnum
 942                                    nnmaildir--cur-server group)))
 943             missing (gnus-range-difference missing existing)
 944             dir (nnmaildir--srv-dir nnmaildir--cur-server)
 945             dir (nnmaildir--srvgrp-dir dir gname)
 946             dir (nnmaildir--nndir dir)
 947             dir (nnmaildir--marks-dir dir)
 948             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
 949             markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
 950             new-mmth (nnmaildir--up2-1 (length markdirs))
 951             new-mmth (make-vector new-mmth 0)
 952             old-mmth (nnmaildir--grp-mmth group))
 953       (dolist (mark markdirs)
 954         (setq markdir (nnmaildir--subdir dir mark)
 955               mark-sym (intern mark)
 956               ranges nil)
 957         (catch 'got-ranges
 958           (if (memq mark-sym never-marks) (throw 'got-ranges nil))
 959           (when (memq mark-sym always-marks)
 960             (setq ranges existing)
 961             (throw 'got-ranges nil))
 962           (setq mtime (nth 5 (file-attributes markdir)))
 963           (set (intern mark new-mmth) mtime)
 964           (when (equal mtime (symbol-value (intern-soft mark old-mmth)))
 965             (setq ranges (assq mark-sym old-marks))
 966             (if ranges (setq ranges (cdr ranges)))
 967             (throw 'got-ranges nil))
 968           (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort))
 969             (setq article (nnmaildir--flist-art flist prefix))
 970             (if article
 971                 (setq ranges
 972                       (gnus-add-to-range ranges
 973                                          `(,(nnmaildir--art-num article)))))))
 974         (if (eq mark-sym 'read) (setq read ranges)
 975           (if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
 976       (gnus-info-set-read info (gnus-range-add read missing))
 977       (gnus-info-set-marks info marks 'extend)
 978       (setf (nnmaildir--grp-mmth group) new-mmth)
 979       info)))
 980
 981 (defun nnmaildir-request-group (gname &optional server fast)
 982   (let ((group (nnmaildir--prepare server gname))
 983         deactivate-mark)
 984     (catch 'return
 985       (unless group
 986         ;; (insert "411 no such news group\n")
 987         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 988               (concat "No such group: " gname))
 989         (throw 'return nil))
 990       (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
 991       (if fast (throw 'return t))
 992       (nnmaildir--with-nntp-buffer
 993         (erase-buffer)
 994         (insert "211 ")
 995         (princ (nnmaildir--grp-count group) nntp-server-buffer)
 996         (insert " ")
 997         (princ (nnmaildir--grp-min   group) nntp-server-buffer)
 998         (insert " ")
 999         (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
1000                nntp-server-buffer)
1001         (insert " " gname "\n")
1002         t))))
1003
1004 (defun nnmaildir-request-create-group (gname &optional server args)
1005   (nnmaildir--prepare server nil)
1006   (catch 'return
1007     (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
1008           srv-dir dir groups)
1009       (when (zerop (length gname))
1010         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1011               "Invalid (empty) group name")
1012         (throw 'return nil))
1013       (when (eq (aref "." 0) (aref gname 0))
1014         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1015               "Group names may not start with \".\"")
1016         (throw 'return nil))
1017       (when (save-match-data (string-match "[\0/\t]" gname))
1018         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1019               (concat "Invalid characters (null, tab, or /) in group name: "
1020                       gname))
1021         (throw 'return nil))
1022       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
1023       (when (intern-soft gname groups)
1024         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1025               (concat "Group already exists: " gname))
1026         (throw 'return nil))
1027       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1028       (if (file-name-absolute-p target-prefix)
1029           (setq dir (expand-file-name target-prefix))
1030         (setq dir srv-dir
1031               dir (file-truename dir)
1032               dir (concat dir target-prefix)))
1033       (setq dir (nnmaildir--subdir dir gname))
1034       (nnmaildir--mkdir dir)
1035       (nnmaildir--mkdir (nnmaildir--tmp dir))
1036       (nnmaildir--mkdir (nnmaildir--new dir))
1037       (nnmaildir--mkdir (nnmaildir--cur dir))
1038       (unless (string= target-prefix "")
1039         (make-symbolic-link (concat target-prefix gname)
1040                             (concat srv-dir gname)))
1041       (nnmaildir-request-scan 'find-new-groups))))
1042
1043 (defun nnmaildir-request-rename-group (gname new-name &optional server)
1044   (let ((group (nnmaildir--prepare server gname))
1045         (coding-system-for-write nnheader-file-coding-system)
1046         (buffer-file-coding-system nil)
1047         (file-coding-system-alist nil)
1048         srv-dir x groups)
1049     (catch 'return
1050       (unless group
1051         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1052               (concat "No such group: " gname))
1053         (throw 'return nil))
1054       (when (zerop (length new-name))
1055         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1056               "Invalid (empty) group name")
1057         (throw 'return nil))
1058       (when (eq (aref "." 0) (aref new-name 0))
1059         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1060               "Group names may not start with \".\"")
1061         (throw 'return nil))
1062       (when (save-match-data (string-match "[\0/\t]" new-name))
1063         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1064               (concat "Invalid characters (null, tab, or /) in group name: "
1065                       new-name))
1066         (throw 'return nil))
1067       (if (string-equal gname new-name) (throw 'return t))
1068       (when (intern-soft new-name
1069                          (nnmaildir--srv-groups nnmaildir--cur-server))
1070         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1071               (concat "Group already exists: " new-name))
1072         (throw 'return nil))
1073       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1074       (condition-case err
1075           (rename-file (concat srv-dir gname)
1076                        (concat srv-dir new-name))
1077         (error
1078          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1079                (concat "Error renaming link: " (prin1-to-string err)))
1080          (throw 'return nil)))
1081       (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
1082             groups (make-vector (length x) 0))
1083       (mapatoms (lambda (sym)
1084                   (unless (eq (symbol-value sym) group)
1085                     (set (intern (symbol-name sym) groups)
1086                          (symbol-value sym))))
1087                 x)
1088       (setq group (copy-sequence group))
1089       (setf (nnmaildir--grp-name group) new-name)
1090       (set (intern new-name groups) group)
1091       (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
1092       t)))
1093
1094 (defun nnmaildir-request-delete-group (gname force &optional server)
1095   (let ((group (nnmaildir--prepare server gname))
1096         pgname grp-dir target dir ls deactivate-mark)
1097     (catch 'return
1098       (unless group
1099         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1100               (concat "No such group: " gname))
1101         (throw 'return nil))
1102       (setq gname (nnmaildir--grp-name group)
1103             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1104             grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1105             target (car (file-attributes (concat grp-dir gname)))
1106             grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
1107       (unless (or force (stringp target))
1108         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1109               (concat "Not a symlink: " gname))
1110         (throw 'return nil))
1111       (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
1112           (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
1113       (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
1114       (if (not force)
1115           (progn
1116             (setq grp-dir (directory-file-name grp-dir))
1117             (nnmaildir--unlink grp-dir))
1118         (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname))
1119         (if (nnmaildir--param pgname 'read-only)
1120             (progn (delete-directory  (nnmaildir--tmp grp-dir))
1121                    (nnmaildir--unlink (nnmaildir--new grp-dir))
1122                    (delete-directory  (nnmaildir--cur grp-dir)))
1123           (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls)
1124           (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls)
1125           (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls))
1126         (setq dir (nnmaildir--nndir grp-dir))
1127         (dolist (subdir `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir)
1128                           ,@(funcall ls (nnmaildir--marks-dir dir)
1129                                      'full "\\`[^.]" 'nosort)))
1130           (nnmaildir--delete-dir-files subdir ls))
1131         (setq dir (nnmaildir--nndir grp-dir))
1132         (nnmaildir--unlink (concat dir "markfile"))
1133         (nnmaildir--unlink (concat dir "markfile{new}"))
1134         (delete-directory (nnmaildir--marks-dir dir))
1135         (delete-directory dir)
1136         (if (not (stringp target))
1137             (delete-directory grp-dir)
1138           (setq grp-dir (directory-file-name grp-dir)
1139                 dir target)
1140           (unless (eq (aref "/" 0) (aref dir 0))
1141             (setq dir (concat (file-truename
1142                                (nnmaildir--srv-dir nnmaildir--cur-server))
1143                               dir)))
1144           (delete-directory dir)
1145           (nnmaildir--unlink grp-dir)))
1146       t)))
1147
1148 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1149   (let ((group (nnmaildir--prepare server gname))
1150         srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1151         deactivate-mark)
1152     (setq insert-nov
1153           (lambda (article)
1154             (setq nov (nnmaildir--update-nov nnmaildir--cur-server group
1155                                              article))
1156             (when nov
1157               (nnmaildir--cache-nov group article nov)
1158               (setq num (nnmaildir--art-num article))
1159               (princ num nntp-server-buffer)
1160               (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1161                       (nnmaildir--art-msgid article) "\t"
1162                       (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir "
1163                       gname ":")
1164               (princ num nntp-server-buffer)
1165               (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1166     (catch 'return
1167       (unless group
1168         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1169               (if gname (concat "No such group: " gname) "No current group"))
1170         (throw 'return nil))
1171       (nnmaildir--with-nntp-buffer
1172         (erase-buffer)
1173         (setq mlist (nnmaildir--grp-mlist group)
1174               nlist (nnmaildir--grp-nlist group)
1175               gname (nnmaildir--grp-name group)
1176               srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1177               dir (nnmaildir--srvgrp-dir srv-dir gname))
1178         (cond
1179          ((null nlist))
1180          ((and fetch-old (not (numberp fetch-old)))
1181           (nnmaildir--nlist-iterate nlist 'all insert-nov))
1182          ((null articles))
1183          ((stringp (car articles))
1184           (dolist (msgid articles)
1185             (setq article (nnmaildir--mlist-art mlist msgid))
1186             (if article (funcall insert-nov article))))
1187          (t
1188           (if fetch-old
1189               ;; Assume the article range list is sorted ascending
1190               (setq stop (car articles)
1191                     start (car (last articles))
1192                     stop  (if (numberp stop)  stop  (car stop))
1193                     start (if (numberp start) start (cdr start))
1194                     stop (- stop fetch-old)
1195                     stop (if (< stop 1) 1 stop)
1196                     articles (list (cons stop start))))
1197           (nnmaildir--nlist-iterate nlist articles insert-nov)))
1198         (sort-numeric-fields 1 (point-min) (point-max))
1199         'nov))))
1200
1201 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1202   (let ((group (nnmaildir--prepare server gname))
1203         (case-fold-search t)
1204         list article dir pgname deactivate-mark)
1205     (catch 'return
1206       (unless group
1207         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1208               (if gname (concat "No such group: " gname) "No current group"))
1209         (throw 'return nil))
1210       (if (numberp num-msgid)
1211           (setq article (nnmaildir--nlist-art group num-msgid))
1212         (setq list (nnmaildir--grp-mlist group)
1213               article (nnmaildir--mlist-art list num-msgid))
1214         (if article (setq num-msgid (nnmaildir--art-num article))
1215           (catch 'found
1216             (mapatoms
1217               (lambda (group-sym)
1218                 (setq group (symbol-value group-sym)
1219                       list (nnmaildir--grp-mlist group)
1220                       article (nnmaildir--mlist-art list num-msgid))
1221                 (when article
1222                   (setq num-msgid (nnmaildir--art-num article))
1223                   (throw 'found nil)))
1224               (nnmaildir--srv-groups nnmaildir--cur-server))))
1225         (unless article
1226           (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1227           (throw 'return nil)))
1228       (setq gname (nnmaildir--grp-name group)
1229             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1230             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1231             dir (nnmaildir--srvgrp-dir dir gname)
1232             dir (if (nnmaildir--param pgname 'read-only)
1233                     (nnmaildir--new dir) (nnmaildir--cur dir))
1234             nnmaildir-article-file-name
1235             (concat dir
1236                     (nnmaildir--art-prefix article)
1237                     (nnmaildir--art-suffix article)))
1238       (unless (file-exists-p nnmaildir-article-file-name)
1239         (nnmaildir--expired-article group article)
1240         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1241               "Article has expired")
1242         (throw 'return nil))
1243       (save-excursion
1244         (set-buffer (or to-buffer nntp-server-buffer))
1245         (erase-buffer)
1246         (nnheader-insert-file-contents nnmaildir-article-file-name))
1247       (cons gname num-msgid))))
1248
1249 (defun nnmaildir-request-post (&optional server)
1250   (let (message-required-mail-headers)
1251     (funcall message-send-mail-function)))
1252
1253 (defun nnmaildir-request-replace-article (number gname buffer)
1254   (let ((group (nnmaildir--prepare nil gname))
1255         (coding-system-for-write nnheader-file-coding-system)
1256         (buffer-file-coding-system nil)
1257         (file-coding-system-alist nil)
1258         dir file article suffix tmpfile deactivate-mark)
1259     (catch 'return
1260       (unless group
1261         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1262               (concat "No such group: " gname))
1263         (throw 'return nil))
1264       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1265                               'read-only)
1266         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1267               (concat "Read-only group: " group))
1268         (throw 'return nil))
1269       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1270             dir (nnmaildir--srvgrp-dir dir gname)
1271             article (nnmaildir--nlist-art group number))
1272       (unless article
1273         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1274               (concat "No such article: " (number-to-string number)))
1275         (throw 'return nil))
1276       (setq suffix (nnmaildir--art-suffix article)
1277             file (nnmaildir--art-prefix article)
1278             tmpfile (concat (nnmaildir--tmp dir) file))
1279       (when (file-exists-p tmpfile)
1280         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1281               (concat "File exists: " tmpfile))
1282         (throw 'return nil))
1283       (save-excursion
1284         (set-buffer buffer)
1285         (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1286                           'excl))
1287       (unix-sync) ;; no fsync :(
1288       (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1289       t)))
1290
1291 (defun nnmaildir-request-move-article (article gname server accept-form
1292                                                &optional last move-is-internal)
1293   (let ((group (nnmaildir--prepare server gname))
1294         pgname suffix result nnmaildir--file deactivate-mark)
1295     (catch 'return
1296       (unless group
1297         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1298               (concat "No such group: " gname))
1299         (throw 'return nil))
1300       (setq gname (nnmaildir--grp-name group)
1301             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1302             article (nnmaildir--nlist-art group article))
1303       (unless article
1304         (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1305         (throw 'return nil))
1306       (setq suffix (nnmaildir--art-suffix article)
1307             nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1308             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1309             nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1310                                 (nnmaildir--new nnmaildir--file)
1311                               (nnmaildir--cur nnmaildir--file))
1312             nnmaildir--file (concat nnmaildir--file
1313                                     (nnmaildir--art-prefix article)
1314                                     suffix))
1315       (unless (file-exists-p nnmaildir--file)
1316         (nnmaildir--expired-article group article)
1317         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1318               "Article has expired")
1319         (throw 'return nil))
1320       (nnmaildir--with-move-buffer
1321         (erase-buffer)
1322         (nnheader-insert-file-contents nnmaildir--file)
1323         (setq result (eval accept-form)))
1324       (unless (or (null result) (nnmaildir--param pgname 'read-only))
1325         (nnmaildir--unlink nnmaildir--file)
1326         (nnmaildir--expired-article group article))
1327       result)))
1328
1329 (defun nnmaildir-request-accept-article (gname &optional server last)
1330   (let ((group (nnmaildir--prepare server gname))
1331         (coding-system-for-write nnheader-file-coding-system)
1332         (buffer-file-coding-system nil)
1333         (file-coding-system-alist nil)
1334         srv-dir dir file time tmpfile curfile 24h article)
1335     (catch 'return
1336       (unless group
1337         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1338               (concat "No such group: " gname))
1339         (throw 'return nil))
1340       (setq gname (nnmaildir--grp-name group))
1341       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1342                               'read-only)
1343         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1344               (concat "Read-only group: " gname))
1345         (throw 'return nil))
1346       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1347             dir (nnmaildir--srvgrp-dir srv-dir gname)
1348             time (current-time)
1349             file (format-time-string "%s." time))
1350       (unless (string-equal nnmaildir--delivery-time file)
1351         (setq nnmaildir--delivery-time file
1352               nnmaildir--delivery-count 0))
1353       (when (and (consp (cdr time))
1354                  (consp (cddr time)))
1355         (setq file (concat file "M" (number-to-string (caddr time)))))
1356       (setq file (concat file nnmaildir--delivery-pid)
1357             file (concat file "Q" (number-to-string nnmaildir--delivery-count))
1358             file (concat file "." (nnmaildir--system-name))
1359             tmpfile (concat (nnmaildir--tmp dir) file)
1360             curfile (concat (nnmaildir--cur dir) file ":2,"))
1361       (when (file-exists-p tmpfile)
1362         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1363               (concat "File exists: " tmpfile))
1364         (throw 'return nil))
1365       (when (file-exists-p curfile)
1366         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1367               (concat "File exists: " curfile))
1368         (throw 'return nil))
1369       (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count)
1370             24h (run-with-timer 86400 nil
1371                                 (lambda ()
1372                                   (nnmaildir--unlink tmpfile)
1373                                   (setf (nnmaildir--srv-error
1374                                           nnmaildir--cur-server)
1375                                         "24-hour timer expired")
1376                                   (throw 'return nil))))
1377       (condition-case nil (add-name-to-file nnmaildir--file tmpfile)
1378         (error
1379          (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1380                            'excl)
1381          (unix-sync))) ;; no fsync :(
1382       (nnheader-cancel-timer 24h)
1383       (condition-case err
1384           (add-name-to-file tmpfile curfile)
1385         (error
1386          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1387                (concat "Error linking: " (prin1-to-string err)))
1388          (nnmaildir--unlink tmpfile)
1389          (throw 'return nil)))
1390       (nnmaildir--unlink tmpfile)
1391       (setq article (make-nnmaildir--art :prefix file :suffix ":2,"))
1392       (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1393           (cons gname (nnmaildir--art-num article))))))
1394
1395 (defun nnmaildir-save-mail (group-art)
1396   (catch 'return
1397     (unless group-art
1398       (throw 'return nil))
1399     (let (ga gname x groups nnmaildir--file deactivate-mark)
1400       (save-excursion
1401         (goto-char (point-min))
1402         (save-match-data
1403           (while (looking-at "From ")
1404             (replace-match "X-From-Line: ")
1405             (forward-line 1))))
1406       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1407             ga (car group-art) group-art (cdr group-art)
1408             gname (car ga))
1409       (or (intern-soft gname groups)
1410           (nnmaildir-request-create-group gname)
1411           (throw 'return nil)) ;; not that nnmail bothers to check :(
1412       (unless (nnmaildir-request-accept-article gname)
1413         (throw 'return nil))
1414       (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1415             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1416             x (nnmaildir--prepare nil gname)
1417             x (nnmaildir--grp-nlist x)
1418             x (cdar x)
1419             nnmaildir--file (concat nnmaildir--file
1420                                     (nnmaildir--art-prefix x)
1421                                     (nnmaildir--art-suffix x)))
1422       (delq nil
1423             (mapcar
1424              (lambda (ga)
1425                (setq gname (car ga))
1426                (and (or (intern-soft gname groups)
1427                         (nnmaildir-request-create-group gname))
1428                     (nnmaildir-request-accept-article gname)
1429                     ga))
1430              group-art)))))
1431
1432 (defun nnmaildir-active-number (gname)
1433   0)
1434
1435 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1436   (let ((no-force (not force))
1437         (group (nnmaildir--prepare server gname))
1438         pgname time boundary bound-iter high low target dir nlist nlist2
1439         stop article didnt nnmaildir--file nnmaildir-article-file-name
1440         deactivate-mark)
1441     (catch 'return
1442       (unless group
1443         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1444               (if gname (concat "No such group: " gname) "No current group"))
1445         (throw 'return (gnus-uncompress-range ranges)))
1446       (setq gname (nnmaildir--grp-name group)
1447             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1448       (if (nnmaildir--param pgname 'read-only)
1449           (throw 'return (gnus-uncompress-range ranges)))
1450       (setq time (nnmaildir--param pgname 'expire-age))
1451       (unless time
1452         (setq time (or (and nnmail-expiry-wait-function
1453                             (funcall nnmail-expiry-wait-function gname))
1454                        nnmail-expiry-wait))
1455         (if (eq time 'immediate)
1456             (setq time 0)
1457           (if (numberp time)
1458               (setq time (* time 86400)))))
1459       (when no-force
1460         (unless (integerp time) ;; handle 'never
1461           (throw 'return (gnus-uncompress-range ranges)))
1462         (setq boundary (current-time)
1463               high (- (car boundary) (/ time 65536))
1464               low (- (cadr boundary) (% time 65536)))
1465         (if (< low 0)
1466             (setq low (+ low 65536)
1467                   high (1- high)))
1468         (setcar (cdr boundary) low)
1469         (setcar boundary high))
1470       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1471             dir (nnmaildir--srvgrp-dir dir gname)
1472             dir (nnmaildir--cur dir)
1473             nlist (nnmaildir--grp-nlist group)
1474             ranges (reverse ranges))
1475       (nnmaildir--with-move-buffer
1476         (nnmaildir--nlist-iterate
1477          nlist ranges
1478          (lambda (article)
1479            (setq nnmaildir--file (nnmaildir--art-prefix article)
1480                  nnmaildir--file (concat dir nnmaildir--file
1481                                          (nnmaildir--art-suffix article))
1482                  time (file-attributes nnmaildir--file))
1483            (cond
1484             ((null time)
1485              (nnmaildir--expired-article group article))
1486             ((and no-force
1487                   (progn
1488                     (setq time (nth 5 time)
1489                           bound-iter boundary)
1490                     (while (and bound-iter time
1491                                 (= (car bound-iter) (car time)))
1492                       (setq bound-iter (cdr bound-iter)
1493                             time (cdr time)))
1494                     (and bound-iter time
1495                          (car-less-than-car bound-iter time))))
1496              (setq didnt (cons (nnmaildir--art-num article) didnt)))
1497             (t
1498              (setq nnmaildir-article-file-name nnmaildir--file
1499                    target (if force nil
1500                             (save-excursion
1501                               (save-restriction
1502                                 (nnmaildir--param pgname 'expire-group)))))
1503              (when (and (stringp target)
1504                         (not (string-equal target pgname))) ;; Move it.
1505                (erase-buffer)
1506                (nnheader-insert-file-contents nnmaildir--file)
1507                (let ((group-art (gnus-request-accept-article
1508                                  target nil nil 'no-encode)))
1509                  (when (consp group-art)
1510                    ;; Maybe also copy: dormant forward reply save tick
1511                    ;; (gnus-add-mark? gnus-request-set-mark?)
1512                    (gnus-group-mark-article-read target (cdr group-art)))))
1513              (if (equal target pgname)
1514                  ;; Leave it here.
1515                  (setq didnt (cons (nnmaildir--art-num article) didnt))
1516                (nnmaildir--unlink nnmaildir--file)
1517                (nnmaildir--expired-article group article))))))
1518         (erase-buffer))
1519       didnt)))
1520
1521 (defun nnmaildir-request-set-mark (gname actions &optional server)
1522   (let ((group (nnmaildir--prepare server gname))
1523         (coding-system-for-write nnheader-file-coding-system)
1524         (buffer-file-coding-system nil)
1525         (file-coding-system-alist nil)
1526         del-mark del-action add-action set-action marksdir nlist
1527         ranges begin end article all-marks todo-marks mdir mfile
1528         pgname ls permarkfile deactivate-mark)
1529     (setq del-mark
1530           (lambda (mark)
1531             (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
1532                   mfile (concat mfile (nnmaildir--art-prefix article)))
1533             (nnmaildir--unlink mfile))
1534           del-action (lambda (article) (mapcar del-mark todo-marks))
1535           add-action
1536           (lambda (article)
1537             (mapcar
1538              (lambda (mark)
1539                (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
1540                      permarkfile (concat mdir ":")
1541                      mfile (concat mdir (nnmaildir--art-prefix article)))
1542                (nnmaildir--condcase err (add-name-to-file permarkfile mfile)
1543                  (cond
1544                   ((nnmaildir--eexist-p err))
1545                   ((nnmaildir--enoent-p err)
1546                    (nnmaildir--mkdir mdir)
1547                    (nnmaildir--mkfile permarkfile)
1548                    (add-name-to-file permarkfile mfile))
1549                   ((nnmaildir--emlink-p err)
1550                    (let ((permarkfilenew (concat permarkfile "{new}")))
1551                      (nnmaildir--mkfile permarkfilenew)
1552                      (rename-file permarkfilenew permarkfile 'replace)
1553                      (add-name-to-file permarkfile mfile)))
1554                   (t (signal (car err) (cdr err))))))
1555              todo-marks))
1556           set-action (lambda (article)
1557                        (funcall add-action)
1558                        (mapcar (lambda (mark)
1559                                  (unless (memq mark todo-marks)
1560                                    (funcall del-mark mark)))
1561                                all-marks)))
1562     (catch 'return
1563       (unless group
1564         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1565               (concat "No such group: " gname))
1566         (dolist (action actions)
1567           (setq ranges (gnus-range-add ranges (car action))))
1568         (throw 'return ranges))
1569       (setq nlist (nnmaildir--grp-nlist group)
1570             marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1571             marksdir (nnmaildir--srvgrp-dir marksdir gname)
1572             marksdir (nnmaildir--nndir marksdir)
1573             marksdir (nnmaildir--marks-dir marksdir)
1574             gname (nnmaildir--grp-name group)
1575             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1576             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1577             all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1578             all-marks (mapcar 'intern all-marks))
1579       (dolist (action actions)
1580         (setq ranges (car action)
1581               todo-marks (caddr action))
1582         (dolist (mark todo-marks)
1583           (add-to-list 'all-marks mark))
1584         (if (numberp (cdr ranges)) (setq ranges (list ranges)))
1585         (nnmaildir--nlist-iterate nlist ranges
1586                                   (cond ((eq 'del (cadr action)) del-action)
1587                                         ((eq 'add (cadr action)) add-action)
1588                                         (t set-action))))
1589       nil)))
1590
1591 (defun nnmaildir-close-group (gname &optional server)
1592   (let ((group (nnmaildir--prepare server gname))
1593         pgname ls dir msgdir files flist dirs)
1594     (if (null group)
1595         (progn
1596           (setf (nnmaildir--srv-error nnmaildir--cur-server)
1597                 (concat "No such group: " gname))
1598           nil)
1599       (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1600             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1601             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1602             dir (nnmaildir--srvgrp-dir dir gname)
1603             msgdir (if (nnmaildir--param pgname 'read-only)
1604                        (nnmaildir--new dir) (nnmaildir--cur dir))
1605             dir (nnmaildir--nndir dir)
1606             dirs (cons (nnmaildir--nov-dir dir)
1607                        (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1608                                 'nosort))
1609             dirs (mapcar
1610                   (lambda (dir)
1611                     (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
1612                   dirs)
1613             files (funcall ls msgdir nil "\\`[^.]" 'nosort)
1614             flist (nnmaildir--up2-1 (length files))
1615             flist (make-vector flist 0))
1616       (save-match-data
1617         (dolist (file files)
1618           (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1619           (intern (match-string 1 file) flist)))
1620       (dolist (dir dirs)
1621         (setq files (cdr dir)
1622               dir (file-name-as-directory (car dir)))
1623         (dolist (file files)
1624           (unless (or (intern-soft file flist) (string= file ":"))
1625             (setq file (concat dir file))
1626             (delete-file file))))
1627       t)))
1628
1629 (defun nnmaildir-close-server (&optional server)
1630   (let (flist ls dirs dir files file x)
1631     (nnmaildir--prepare server nil)
1632     (when nnmaildir--cur-server
1633       (setq server nnmaildir--cur-server
1634             nnmaildir--cur-server nil)
1635       (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
1636   t)
1637
1638 (defun nnmaildir-request-close ()
1639   (let (servers buffer)
1640     (mapatoms (lambda (server)
1641                 (setq servers (cons (symbol-name server) servers)))
1642               nnmaildir--servers)
1643     (mapc 'nnmaildir-close-server servers)
1644     (setq buffer (get-buffer " *nnmaildir work*"))
1645     (if buffer (kill-buffer buffer))
1646     (setq buffer (get-buffer " *nnmaildir nov*"))
1647     (if buffer (kill-buffer buffer))
1648     (setq buffer (get-buffer " *nnmaildir move*"))
1649     (if buffer (kill-buffer buffer)))
1650   t)
1651
1652 (provide 'nnmaildir)
1653
1654 ;; Local Variables:
1655 ;; indent-tabs-mode: t
1656 ;; fill-column: 77
1657 ;; End:
1658
1659 ;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849
1660 ;;; nnmaildir.el ends here