git.chise.org Git - elisp/gnus.git-/blob - lisp/nnmaildir.el

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