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