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

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