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

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