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

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