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

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