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         (nnmaildir-request-scan gname server)
 789         (setq group (nnmaildir--prepare nil gname))
 790         (if (null group) (insert "411 no such news group\n")
 791           (setq ct-min (nnmaildir--article-count group))
 792           (insert "211 ")
 793           (princ (car ct-min) nntp-server-buffer)
 794           (insert " ")
 795           (princ (cdr ct-min) nntp-server-buffer)
 796           (insert " ")
 797           (princ (nnmaildir--nlist-last-num
 798                    (nnmaildir--lists-nlist
 799                      (nnmaildir--grp-lists group)))
 800                  nntp-server-buffer)
 801           (insert " " gname "\n")))))
 802   'group)
 803
 804 (defun nnmaildir-request-update-info (gname info &optional server)
 805   (nnmaildir-request-scan gname server)
 806   (let ((group (nnmaildir--prepare server gname))
 807         pgname nlist flist last always-marks never-marks old-marks dotfile num
 808         dir markdirs marks mark ranges articles article read end new-marks ls
 809         old-mmth new-mmth mtime mark-sym deactivate-mark)
 810     (catch 'return
 811       (if group nil
 812         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 813               (concat "No such group: " gname))
 814         (throw 'return nil))
 815       (setq gname (nnmaildir--grp-name group)
 816             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
 817             nlist (nnmaildir--grp-lists group)
 818             flist (nnmaildir--lists-flist nlist)
 819             nlist (nnmaildir--lists-nlist nlist))
 820       (if nlist nil
 821         (gnus-info-set-read info nil)
 822         (gnus-info-set-marks info nil 'extend)
 823         (throw 'return info))
 824       (setq old-marks (cons 'read (gnus-info-read info))
 825             old-marks (cons old-marks (gnus-info-marks info))
 826             last (nnmaildir--nlist-last-num nlist)
 827             always-marks (nnmaildir--param pgname 'always-marks)
 828             never-marks (nnmaildir--param pgname 'never-marks)
 829             dir (nnmaildir--srv-dir nnmaildir--cur-server)
 830             dir (nnmaildir--srvgrp-dir dir gname)
 831             dir (nnmaildir--nndir dir)
 832             dir (nnmaildir--marks-dir dir)
 833             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
 834             markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
 835             num (length markdirs)
 836             new-mmth 1)
 837       (while (<= new-mmth num) (setq new-mmth (* 2 new-mmth)))
 838       (if (/= new-mmth 1) (setq new-mmth (1- new-mmth)))
 839       (setq new-mmth (make-vector new-mmth 0)
 840             old-mmth (nnmaildir--grp-mmth group))
 841       (while markdirs
 842         (setq mark (car markdirs) markdirs (cdr markdirs)
 843               articles (nnmaildir--subdir dir mark)
 844               mark-sym (intern mark)
 845               ranges nil)
 846         (catch 'got-ranges
 847           (if (memq mark-sym never-marks) (throw 'got-ranges nil))
 848           (when (memq mark-sym always-marks)
 849             (setq ranges (list (cons 1 last)))
 850             (throw 'got-ranges nil))
 851           (setq mtime (nth 5 (file-attributes articles)))
 852           (set (intern mark new-mmth) mtime)
 853           (when (equal mtime (symbol-value (intern-soft mark old-mmth)))
 854             (setq ranges (assq mark-sym old-marks))
 855             (if ranges (setq ranges (cdr ranges)))
 856             (throw 'got-ranges nil))
 857           (setq articles (funcall ls articles nil "\\`[^.]" 'nosort))
 858           (while articles
 859             (setq article (car articles) articles (cdr articles)
 860                   article (nnmaildir--flist-art flist article))
 861             (if article
 862                 (setq num (nnmaildir--art-num article)
 863                       ranges (gnus-add-to-range ranges (list num))))))
 864         (if (eq mark-sym 'read) (setq read ranges)
 865           (if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
 866       (gnus-info-set-read info read)
 867       (gnus-info-set-marks info marks 'extend)
 868       (setf (nnmaildir--grp-mmth group) new-mmth)
 869       info)))
 870
 871 (defun nnmaildir-request-group (gname &optional server fast)
 872   (nnmaildir-request-scan gname server)
 873   (let ((group (nnmaildir--prepare server gname))
 874         ct-min deactivate-mark)
 875     (nnmaildir--with-nntp-buffer
 876       (erase-buffer)
 877       (catch 'return
 878         (if group nil
 879           (insert "411 no such news group\n")
 880           (setf (nnmaildir--srv-error nnmaildir--cur-server)
 881                 (concat "No such group: " gname))
 882           (throw 'return nil))
 883         (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
 884         (if fast (throw 'return t))
 885         (setq ct-min (nnmaildir--article-count group))
 886         (insert "211 ")
 887         (princ (car ct-min) nntp-server-buffer)
 888         (insert " ")
 889         (princ (cdr ct-min) nntp-server-buffer)
 890         (insert " ")
 891         (princ (nnmaildir--nlist-last-num
 892                 (nnmaildir--lists-nlist
 893                  (nnmaildir--grp-lists group)))
 894                nntp-server-buffer)
 895         (insert " " gname "\n")
 896         t))))
 897
 898 (defun nnmaildir-request-create-group (gname &optional server args)
 899   (nnmaildir--prepare server nil)
 900   (catch 'return
 901     (let ((create-dir (nnmaildir--srv-create-dir nnmaildir--cur-server))
 902           srv-dir dir groups)
 903       (when (zerop (length gname))
 904         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 905               "Invalid (empty) group name")
 906         (throw 'return nil))
 907       (when (eq (aref "." 0) (aref gname 0))
 908         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 909               "Group names may not start with \".\"")
 910         (throw 'return nil))
 911       (when (save-match-data (string-match "[\0/\t]" gname))
 912         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 913               (concat "Illegal characters (null, tab, or /) in group name: "
 914                       gname))
 915         (throw 'return nil))
 916       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
 917       (when (intern-soft gname groups)
 918         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 919               (concat "Group already exists: " gname))
 920         (throw 'return nil))
 921       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
 922       (if (file-name-absolute-p create-dir)
 923           (setq dir (expand-file-name create-dir))
 924         (setq dir srv-dir
 925               dir (file-truename dir)
 926               dir (concat dir create-dir)))
 927       (setq dir (nnmaildir--subdir (file-name-as-directory dir) gname))
 928       (nnmaildir--mkdir dir)
 929       (nnmaildir--mkdir (nnmaildir--tmp dir))
 930       (nnmaildir--mkdir (nnmaildir--new dir))
 931       (nnmaildir--mkdir (nnmaildir--cur dir))
 932       (setq create-dir (file-name-as-directory create-dir))
 933       (make-symbolic-link (concat create-dir gname) (concat srv-dir gname))
 934       (nnmaildir-request-scan 'find-new-groups))))
 935
 936 (defun nnmaildir-request-rename-group (gname new-name &optional server)
 937   (let ((group (nnmaildir--prepare server gname))
 938         (coding-system-for-write nnheader-file-coding-system)
 939         (buffer-file-coding-system nil)
 940         (file-coding-system-alist nil)
 941         srv-dir x groups)
 942     (catch 'return
 943       (if group nil
 944         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 945               (concat "No such group: " gname))
 946         (throw 'return nil))
 947       (when (zerop (length new-name))
 948         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 949               "Invalid (empty) group name")
 950         (throw 'return nil))
 951       (when (eq (aref "." 0) (aref new-name 0))
 952         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 953               "Group names may not start with \".\"")
 954         (throw 'return nil))
 955       (when (save-match-data (string-match "[\0/\t]" new-name))
 956         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 957               (concat "Illegal characters (null, tab, or /) in group name: "
 958                       new-name))
 959         (throw 'return nil))
 960       (if (string-equal gname new-name) (throw 'return t))
 961       (when (intern-soft new-name
 962                          (nnmaildir--srv-groups nnmaildir--cur-server))
 963         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 964               (concat "Group already exists: " new-name))
 965         (throw 'return nil))
 966       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
 967       (condition-case err
 968           (rename-file (concat srv-dir gname)
 969                        (concat srv-dir new-name))
 970         (error
 971          (setf (nnmaildir--srv-error nnmaildir--cur-server)
 972                (concat "Error renaming link: " (prin1-to-string err)))
 973          (throw 'return nil)))
 974       (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
 975             groups (make-vector (length x) 0))
 976       (mapatoms (lambda (sym)
 977                   (if (eq (symbol-value sym) group) nil
 978                     (set (intern (symbol-name sym) groups)
 979                          (symbol-value sym))))
 980                 x)
 981       (setq group (copy-sequence group))
 982       (setf (nnmaildir--grp-name group) new-name)
 983       (set (intern new-name groups) group)
 984       (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
 985       t)))
 986
 987 (defun nnmaildir-request-delete-group (gname force &optional server)
 988   (let ((group (nnmaildir--prepare server gname))
 989         pgname grp-dir dir dirs files ls deactivate-mark)
 990     (catch 'return
 991       (if group nil
 992         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 993               (concat "No such group: " gname))
 994         (throw 'return nil))
 995       (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
 996           (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
 997       (setq gname (nnmaildir--grp-name group)
 998             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
 999       (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
1000       (setq grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1001             grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
1002       (if (not force) (setq grp-dir (directory-file-name grp-dir))
1003         (if (nnmaildir--param pgname 'read-only)
1004             (progn (delete-directory  (nnmaildir--tmp grp-dir))
1005                    (nnmaildir--unlink (nnmaildir--new grp-dir))
1006                    (delete-directory  (nnmaildir--cur grp-dir)))
1007           (nnmaildir--with-work-buffer
1008             (erase-buffer)
1009             (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1010                   files (funcall ls (nnmaildir--tmp grp-dir) 'full "\\`[^.]"
1011                                  'nosort))
1012             (while files
1013               (delete-file (car files))
1014               (setq files (cdr files)))
1015             (delete-directory (nnmaildir--tmp grp-dir))
1016             (setq files (funcall ls (nnmaildir--new grp-dir) 'full "\\`[^.]"
1017                                  'nosort))
1018             (while files
1019               (delete-file (car files))
1020               (setq files (cdr files)))
1021             (delete-directory (nnmaildir--new grp-dir))
1022             (setq files (funcall ls (nnmaildir--cur grp-dir) 'full "\\`[^.]"
1023                                  'nosort))
1024             (while files
1025               (delete-file (car files))
1026               (setq files (cdr files)))
1027             (delete-directory (nnmaildir--cur grp-dir))))
1028         (setq dir (nnmaildir--nndir grp-dir)
1029               dirs (cons (nnmaildir--nov-dir dir)
1030                          (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1031                                   'nosort)))
1032         (while dirs
1033           (setq dir (car dirs) dirs (cdr dirs)
1034                 files (funcall ls dir 'full "\\`[^.]" 'nosort))
1035           (while files
1036             (delete-file (car files))
1037             (setq files (cdr files)))
1038           (delete-directory dir))
1039         (setq dir (nnmaildir--nndir grp-dir))
1040         (nnmaildir--unlink (concat dir "markfile"))
1041         (nnmaildir--unlink (concat dir "markfile{new}"))
1042         (delete-directory (nnmaildir--marks-dir dir))
1043         (delete-directory dir)
1044         (setq grp-dir (directory-file-name grp-dir)
1045               dir (car (file-attributes grp-dir)))
1046         (if (eq (aref "/" 0) (aref dir 0)) nil
1047           (setq dir (concat (file-truename
1048                              (nnmaildir--srv-dir nnmaildir--cur-server))
1049                             dir)))
1050         (delete-directory dir))
1051       (nnmaildir--unlink grp-dir)
1052       t)))
1053
1054 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1055   (let ((group (nnmaildir--prepare server gname))
1056         srv-dir dir nlist mlist article num stop nov nlist2 deactivate-mark)
1057     (catch 'return
1058       (if group nil
1059         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1060               (if gname (concat "No such group: " gname) "No current group"))
1061         (throw 'return nil))
1062       (nnmaildir--with-nntp-buffer
1063         (erase-buffer)
1064         (setq nlist (nnmaildir--grp-lists group)
1065               mlist (nnmaildir--lists-mlist nlist)
1066               nlist (nnmaildir--lists-nlist nlist)
1067               gname (nnmaildir--grp-name group)
1068               srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1069               dir (nnmaildir--srvgrp-dir srv-dir gname))
1070         (cond
1071          ((null nlist))
1072          ((and fetch-old (not (numberp fetch-old)))
1073           (while nlist
1074             (setq article (car nlist) nlist (cdr nlist)
1075                   nov (nnmaildir--update-nov nnmaildir--cur-server group
1076                                              article))
1077             (when nov
1078               (nnmaildir--cache-nov group article nov)
1079               (setq num (nnmaildir--art-num article))
1080               (princ num nntp-server-buffer)
1081               (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1082                       (nnmaildir--art-msgid article) "\t"
1083                       (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname
1084                       ":")
1085               (princ num nntp-server-buffer)
1086               (insert "\t" (nnmaildir--nov-get-end nov) "\n")
1087               (goto-char (point-min)))))
1088          ((null articles))
1089          ((stringp (car articles))
1090           (while articles
1091             (setq article (car articles) articles (cdr articles)
1092                   article (nnmaildir--mlist-art mlist article))
1093             (when (and article
1094                        (setq nov (nnmaildir--update-nov nnmaildir--cur-server
1095                                                         group article)))
1096               (nnmaildir--cache-nov group article nov)
1097               (setq num (nnmaildir--art-num article))
1098               (princ num nntp-server-buffer)
1099               (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1100                       (nnmaildir--art-msgid article) "\t"
1101                       (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname
1102                       ":")
1103               (princ num nntp-server-buffer)
1104               (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1105          (t
1106           (if fetch-old
1107               ;; Assume the article range is sorted ascending
1108               (setq stop (car articles)
1109                     num  (car (last articles))
1110                     stop (if (numberp stop) stop (car stop))
1111                     num  (if (numberp num)  num  (cdr num))
1112                     stop (- stop fetch-old)
1113                     stop (if (< stop 1) 1 stop)
1114                     articles (list (cons stop num))))
1115           (while articles
1116             (setq stop (car articles) articles (cdr articles))
1117             (while (eq stop (car articles))
1118               (setq articles (cdr articles)))
1119             (if (numberp stop) (setq num stop)
1120               (setq num (cdr stop) stop (car stop)))
1121             (setq nlist2 (nthcdr (- (nnmaildir--art-num (car nlist)) num)
1122                                  nlist))
1123             (while (and nlist2
1124                         (setq article (car nlist2)
1125                               num (nnmaildir--art-num article))
1126                         (>= num stop))
1127               (setq nlist2 (cdr nlist2)
1128                     nov (nnmaildir--update-nov nnmaildir--cur-server group
1129                                                article))
1130               (when nov
1131                 (nnmaildir--cache-nov group article nov)
1132                 (princ num nntp-server-buffer)
1133                 (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1134                         (nnmaildir--art-msgid article) "\t"
1135                         (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname
1136                         ":")
1137                 (princ num nntp-server-buffer)
1138                 (insert "\t" (nnmaildir--nov-get-end nov) "\n")
1139                 (goto-char (point-min)))))))
1140         (sort-numeric-fields 1 (point-min) (point-max))
1141         'nov))))
1142
1143 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1144   (let ((group (nnmaildir--prepare server gname))
1145         (case-fold-search t)
1146         list article suffix dir pgname deactivate-mark)
1147     (catch 'return
1148       (if group nil
1149         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1150               (if gname (concat "No such group: " gname) "No current group"))
1151         (throw 'return nil))
1152       (setq list (nnmaildir--grp-lists group))
1153       (if (numberp num-msgid)
1154           (setq list (nnmaildir--lists-nlist list)
1155                 article (nnmaildir--nlist-art list num-msgid))
1156         (setq list (nnmaildir--lists-mlist list)
1157               article (nnmaildir--mlist-art list num-msgid))
1158         (if article (setq num-msgid (nnmaildir--art-num article))
1159           (catch 'found
1160             (mapatoms
1161               (lambda (grp)
1162                 (setq group (symbol-value grp)
1163                       list (nnmaildir--grp-lists group)
1164                       list (nnmaildir--lists-mlist list)
1165                       article (nnmaildir--mlist-art list num-msgid))
1166                 (when article
1167                   (setq num-msgid (nnmaildir--art-num article))
1168                   (throw 'found nil)))
1169               (nnmaildir--srv-groups nnmaildir--cur-server)))))
1170       (if article nil
1171         (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1172         (throw 'return nil))
1173       (if (stringp (setq suffix (nnmaildir--art-suffix article))) nil
1174         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1175               "Article has expired")
1176         (throw 'return nil))
1177       (setq gname (nnmaildir--grp-name group)
1178             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1179             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1180             dir (nnmaildir--srvgrp-dir dir gname)
1181             group (if (nnmaildir--param pgname 'read-only)
1182                       (nnmaildir--new dir) (nnmaildir--cur dir))
1183             nnmaildir-article-file-name (concat group
1184                                                 (nnmaildir--art-prefix
1185                                                  article)
1186                                                 suffix))
1187       (if (file-exists-p nnmaildir-article-file-name) nil
1188         (setf (nnmaildir--art-suffix article) 'expire)
1189         (setf (nnmaildir--art-nov    article) nil)
1190         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1191               "Article has expired")
1192         (throw 'return nil))
1193       (save-excursion
1194         (set-buffer (or to-buffer nntp-server-buffer))
1195         (erase-buffer)
1196         (nnheader-insert-file-contents nnmaildir-article-file-name))
1197       (cons gname num-msgid))))
1198
1199 (defun nnmaildir-request-post (&optional server)
1200   (let (message-required-mail-headers)
1201     (funcall message-send-mail-function)))
1202
1203 (defun nnmaildir-request-replace-article (article gname buffer)
1204   (let ((group (nnmaildir--prepare nil gname))
1205         (coding-system-for-write nnheader-file-coding-system)
1206         (buffer-file-coding-system nil)
1207         (file-coding-system-alist nil)
1208         file dir suffix tmpfile deactivate-mark)
1209     (catch 'return
1210       (if group nil
1211         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1212               (concat "No such group: " gname))
1213         (throw 'return nil))
1214       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1215                               'read-only)
1216         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1217               (concat "Read-only group: " group))
1218         (throw 'return nil))
1219       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1220             dir (nnmaildir--srvgrp-dir dir gname)
1221             file (nnmaildir--grp-lists group)
1222             file (nnmaildir--lists-nlist file)
1223             file (nnmaildir--nlist-art file article))
1224       (if (and file (stringp (setq suffix (nnmaildir--art-suffix file))))
1225           nil
1226         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1227               (format "No such article: %d" article))
1228         (throw 'return nil))
1229       (save-excursion
1230         (set-buffer buffer)
1231         (setq article file
1232               file (nnmaildir--art-prefix article)
1233               tmpfile (concat (nnmaildir--tmp dir) file))
1234         (when (file-exists-p tmpfile)
1235           (setf (nnmaildir--srv-error nnmaildir--cur-server)
1236                 (concat "File exists: " tmpfile))
1237           (throw 'return nil))
1238         (write-region (point-min) (point-max) tmpfile nil 'no-message nil
1239                       'confirm-overwrite)) ;; error would be preferred :(
1240       (unix-sync) ;; no fsync :(
1241       (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1242       t)))
1243
1244 (defun nnmaildir-request-move-article (article gname server accept-form
1245                                                &optional last)
1246   (let ((group (nnmaildir--prepare server gname))
1247         pgname list suffix result nnmaildir--file deactivate-mark)
1248     (catch 'return
1249       (if group nil
1250         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1251               (concat "No such group: " gname))
1252         (throw 'return nil))
1253       (setq gname (nnmaildir--grp-name group)
1254             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1255             list (nnmaildir--grp-lists group)
1256             list (nnmaildir--lists-nlist list)
1257             article (nnmaildir--nlist-art list article))
1258       (if article nil
1259         (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1260         (throw 'return nil))
1261       (if (stringp (setq suffix (nnmaildir--art-suffix article))) nil
1262         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1263               "Article has expired")
1264         (throw 'return nil))
1265       (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1266             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1267             nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1268                                 (nnmaildir--new nnmaildir--file)
1269                               (nnmaildir--cur nnmaildir--file))
1270             nnmaildir--file (concat nnmaildir--file
1271                                     (nnmaildir--art-prefix article)
1272                                     suffix))
1273       (if (file-exists-p nnmaildir--file) nil
1274         (setf (nnmaildir--art-suffix article) 'expire)
1275         (setf (nnmaildir--art-nov    article) nil)
1276         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1277               "Article has expired")
1278         (throw 'return nil))
1279       (nnmaildir--with-move-buffer
1280         (erase-buffer)
1281         (nnheader-insert-file-contents nnmaildir--file)
1282         (setq result (eval accept-form)))
1283       (if (or (null result) (nnmaildir--param pgname 'read-only)) nil
1284         (nnmaildir--unlink nnmaildir--file)
1285         (setf (nnmaildir--art-suffix article) 'expire)
1286         (setf (nnmaildir--art-nov    article) nil))
1287       result)))
1288
1289 (defun nnmaildir-request-accept-article (gname &optional server last)
1290   (let ((group (nnmaildir--prepare server gname))
1291         (coding-system-for-write nnheader-file-coding-system)
1292         (buffer-file-coding-system nil)
1293         (file-coding-system-alist nil)
1294         srv-dir dir file tmpfile curfile 24h num article)
1295     (catch 'return
1296       (if group nil
1297         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1298               (concat "No such group: " gname))
1299         (throw 'return nil))
1300       (setq gname (nnmaildir--grp-name group))
1301       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1302                               'read-only)
1303         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1304               (concat "Read-only group: " gname))
1305         (throw 'return nil))
1306       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1307             dir (nnmaildir--srvgrp-dir srv-dir gname)
1308             file (format-time-string "%s" nil))
1309       (if (string-equal nnmaildir--delivery-time file) nil
1310         (setq nnmaildir--delivery-time file
1311               nnmaildir--delivery-ct 0))
1312       (setq file (concat file "." nnmaildir--delivery-pid))
1313       (if (zerop nnmaildir--delivery-ct) nil
1314         (setq file (concat file "_"
1315                            (number-to-string nnmaildir--delivery-ct))))
1316       (setq file (concat file "." (system-name))
1317             tmpfile (concat (nnmaildir--tmp dir) file)
1318             curfile (concat (nnmaildir--cur dir) file ":2,"))
1319       (when (file-exists-p tmpfile)
1320         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1321               (concat "File exists: " tmpfile))
1322         (throw 'return nil))
1323       (when (file-exists-p curfile)
1324         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1325               (concat "File exists: " curfile))
1326         (throw 'return nil))
1327       (setq nnmaildir--delivery-ct (1+ nnmaildir--delivery-ct)
1328             24h (run-with-timer 86400 nil
1329                                 (lambda ()
1330                                   (nnmaildir--unlink tmpfile)
1331                                   (setf (nnmaildir--srv-error
1332                                           nnmaildir--cur-server)
1333                                         "24-hour timer expired")
1334                                   (throw 'return nil))))
1335       (condition-case nil
1336           (add-name-to-file nnmaildir--file tmpfile)
1337         (error
1338          (write-region (point-min) (point-max) tmpfile nil 'no-message nil
1339                        'confirm-overwrite) ;; error would be preferred :(
1340          (unix-sync))) ;; no fsync :(
1341       (cancel-timer 24h)
1342       (condition-case err
1343           (add-name-to-file tmpfile curfile)
1344         (error
1345          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1346                (concat "Error linking: " (prin1-to-string err)))
1347          (nnmaildir--unlink tmpfile)
1348          (throw 'return nil)))
1349       (nnmaildir--unlink tmpfile)
1350       (setq num (nnmaildir--grp-lists group)
1351             num (nnmaildir--lists-nlist num)
1352             num (1+ (nnmaildir--nlist-last-num num))
1353             article (make-nnmaildir--art :prefix file :suffix ":2," :num num))
1354       (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1355           (cons gname num)))))
1356
1357 (defun nnmaildir-save-mail (group-art)
1358   (catch 'return
1359     (if group-art nil
1360       (throw 'return nil))
1361     (let ((ret group-art)
1362           ga gname x groups nnmaildir--file deactivate-mark)
1363       (save-excursion
1364         (goto-char (point-min))
1365         (save-match-data
1366           (while (looking-at "From ")
1367             (replace-match "X-From-Line: ")
1368             (forward-line 1))))
1369       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1370             ga (car group-art) group-art (cdr group-art)
1371             gname (car ga))
1372       (or (intern-soft gname groups)
1373           (nnmaildir-request-create-group gname)
1374           (throw 'return nil)) ;; not that nnmail bothers to check :(
1375       (if (nnmaildir-request-accept-article gname) nil
1376         (throw 'return nil))
1377       (setq x (nnmaildir--prepare nil gname)
1378             nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1379             nnmaildir--file (nnmaildir--subdir nnmaildir--file
1380                                                (nnmaildir--grp-name x))
1381             x (nnmaildir--grp-lists x)
1382             x (nnmaildir--lists-nlist x)
1383             x (car x)
1384             nnmaildir--file (concat nnmaildir--file
1385                                     (nnmaildir--art-prefix x)
1386                                     (nnmaildir--art-suffix x)))
1387       (while group-art
1388         (setq ga (car group-art) group-art (cdr group-art)
1389               gname (car ga))
1390         (if (and (or (intern-soft gname groups)
1391                      (nnmaildir-request-create-group gname))
1392                  (nnmaildir-request-accept-article gname)) nil
1393           (setq ret (delq ga ret)))) ;; We'll still try the other groups
1394       ret)))
1395
1396 (defun nnmaildir-active-number (group)
1397   (let ((x (nnmaildir--prepare nil group)))
1398     (catch 'return
1399       (if x nil
1400         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1401               (concat "No such group: " group))
1402         (throw 'return nil))
1403       (setq x (nnmaildir--grp-lists x)
1404             x (nnmaildir--lists-nlist x))
1405       (if x
1406           (setq x (car x)
1407                 x (nnmaildir--art-num x)
1408                 x (1+ x))
1409         1))))
1410
1411 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1412   (let ((no-force (not force))
1413         (group (nnmaildir--prepare server gname))
1414         pgname time boundary time-iter bound-iter high low target dir nlist
1415         stop number article didnt suffix nnmaildir--file
1416         nnmaildir-article-file-name deactivate-mark)
1417     (catch 'return
1418       (if group nil
1419         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1420               (if gname (concat "No such group: " gname) "No current group"))
1421         (throw 'return (gnus-uncompress-range ranges)))
1422       (setq gname (nnmaildir--grp-name group)
1423             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1424       (if (nnmaildir--param pgname 'read-only)
1425           (throw 'return (gnus-uncompress-range ranges)))
1426       (setq time (or (nnmaildir--param pgname 'expire-age)
1427                      (* 86400 ;; seconds per day
1428                         (or (and nnmail-expiry-wait-function
1429                                  (funcall nnmail-expiry-wait-function gname))
1430                             nnmail-expiry-wait))))
1431       (if (or force (integerp time)) nil
1432         (throw 'return (gnus-uncompress-range ranges)))
1433       (setq boundary (current-time)
1434             high (- (car boundary) (/ time 65536))
1435             low (- (cadr boundary) (% time 65536)))
1436       (if (< low 0)
1437           (setq low (+ low 65536)
1438                 high (1- high)))
1439       (setcar (cdr boundary) low)
1440       (setcar boundary high)
1441       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1442             dir (nnmaildir--srvgrp-dir dir gname)
1443             dir (nnmaildir--cur dir)
1444             nlist (nnmaildir--grp-lists group)
1445             nlist (nnmaildir--lists-nlist nlist)
1446             ranges (reverse ranges))
1447       (nnmaildir--with-move-buffer
1448         (while ranges
1449           (setq number (car ranges) ranges (cdr ranges))
1450           (while (eq number (car ranges))
1451             (setq ranges (cdr ranges)))
1452           (if (numberp number) (setq stop number)
1453             (setq stop (car number) number (cdr number)))
1454           (setq nlist (nthcdr (- (nnmaildir--art-num (car nlist)) number)
1455                               nlist))
1456           (while (and nlist
1457                       (setq article (car nlist)
1458                             number (nnmaildir--art-num article))
1459                       (>= number stop))
1460             (setq nlist (cdr nlist)
1461                   suffix (nnmaildir--art-suffix article))
1462             (catch 'continue
1463               (if (stringp suffix) nil
1464                 (setf (nnmaildir--art-suffix article) 'expire)
1465                 (setf (nnmaildir--art-nov    article) nil)
1466                 (throw 'continue nil))
1467               (setq nnmaildir--file (nnmaildir--art-prefix article)
1468                     nnmaildir--file (concat dir nnmaildir--file suffix)
1469                     time (file-attributes nnmaildir--file))
1470               (if time nil
1471                 (setf (nnmaildir--art-suffix article) 'expire)
1472                 (setf (nnmaildir--art-nov    article) nil)
1473                 (throw 'continue nil))
1474               (setq time (nth 5 time)
1475                     time-iter time
1476                     bound-iter boundary)
1477               (if (and no-force
1478                        (progn
1479                          (while (and bound-iter time-iter
1480                                      (= (car bound-iter) (car time-iter)))
1481                            (setq bound-iter (cdr bound-iter)
1482                                  time-iter (cdr time-iter)))
1483                          (and bound-iter time-iter
1484                               (car-less-than-car bound-iter time-iter))))
1485                   (setq didnt (cons number didnt))
1486                 (save-excursion
1487                   (setq nnmaildir-article-file-name nnmaildir--file
1488                         target (nnmaildir--param pgname 'expire-group)))
1489                 (when (and (stringp target)
1490                            (not (string-equal target pgname))) ;; Move it.
1491                   (erase-buffer)
1492                   (nnheader-insert-file-contents nnmaildir--file)
1493                   (gnus-request-accept-article target nil nil 'no-encode))
1494                 (if (equal target pgname)
1495                     (setq didnt (cons number didnt)) ;; Leave it here.
1496                   (nnmaildir--unlink nnmaildir--file)
1497                   (setf (nnmaildir--art-suffix article) 'expire)
1498                   (setf (nnmaildir--art-nov    article) nil))))))
1499         (erase-buffer))
1500       didnt)))
1501
1502 (defun nnmaildir-request-set-mark (gname actions &optional server)
1503   (let ((group (nnmaildir--prepare server gname))
1504         (coding-system-for-write nnheader-file-coding-system)
1505         (buffer-file-coding-system nil)
1506         (file-coding-system-alist nil)
1507         del-mark add-marks marksdir markfile action group-nlist nlist ranges
1508         begin end article all-marks todo-marks did-marks marks form mdir mfile
1509         pgname ls markfilenew deactivate-mark)
1510     (setq del-mark
1511           (lambda ()
1512             (setq mfile (nnmaildir--subdir marksdir (symbol-name (car marks)))
1513                   mfile (concat mfile (nnmaildir--art-prefix article)))
1514             (nnmaildir--unlink mfile))
1515           add-marks
1516           (lambda ()
1517             (while marks
1518               (setq mdir (nnmaildir--subdir marksdir (symbol-name (car marks)))
1519                     mfile (concat mdir (nnmaildir--art-prefix article)))
1520               (if (memq (car marks) did-marks) nil
1521                 (nnmaildir--mkdir mdir)
1522                 (setq did-marks (cons (car marks) did-marks)))
1523               (if (file-exists-p mfile) nil
1524                 (condition-case nil
1525                     (add-name-to-file markfile mfile)
1526                   (file-error
1527                    (if (file-exists-p mfile) nil
1528                      ;; too many links, maybe
1529                      (write-region "" nil markfilenew nil 'no-message)
1530                      (add-name-to-file markfilenew mfile 'ok-if-already-exists)
1531                      (rename-file markfilenew markfile 'replace)))))
1532               (setq marks (cdr marks)))))
1533     (catch 'return
1534       (if group nil
1535         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1536               (concat "No such group: " gname))
1537         (while actions
1538           (setq ranges (gnus-range-add ranges (caar actions))
1539                 actions (cdr actions)))
1540         (throw 'return ranges))
1541       (setq group-nlist (nnmaildir--grp-lists group)
1542             group-nlist (nnmaildir--lists-nlist group-nlist)
1543             marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1544             marksdir (nnmaildir--srvgrp-dir marksdir gname)
1545             marksdir (nnmaildir--nndir marksdir)
1546             markfile (concat marksdir "markfile")
1547             markfilenew (concat markfile "{new}")
1548             marksdir (nnmaildir--marks-dir marksdir)
1549             gname (nnmaildir--grp-name group)
1550             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1551             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1552             all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1553             marks all-marks)
1554       (while marks
1555         (setcar marks (intern (car marks)))
1556         (setq marks (cdr marks)))
1557       (while actions
1558         (setq action (car actions) actions (cdr actions)
1559               nlist group-nlist
1560               ranges (car action)
1561               todo-marks (caddr action)
1562               marks todo-marks)
1563         (while marks
1564           (if (memq (car marks) all-marks) nil
1565             (setq all-marks (cons (car marks) all-marks)))
1566           (setq marks (cdr marks)))
1567         (setq form
1568               (cond
1569                ((eq 'del (cadr action))
1570                 '(while marks
1571                    (funcall del-mark)
1572                    (setq marks (cdr marks))))
1573                ((eq 'add (cadr action)) '(funcall add-marks))
1574                (t
1575                 '(progn
1576                    (funcall add-marks)
1577                    (setq marks all-marks)
1578                    (while marks
1579                      (if (memq (car marks) todo-marks) nil
1580                        (funcall del-mark))
1581                      (setq marks (cdr marks)))))))
1582         (if (numberp (cdr ranges)) (setq ranges (list ranges))
1583           (setq ranges (reverse ranges)))
1584         (while ranges
1585           (setq begin (car ranges) ranges (cdr ranges))
1586           (while (eq begin (car ranges))
1587             (setq ranges (cdr ranges)))
1588           (if (numberp begin) (setq end begin)
1589             (setq end (cdr begin) begin (car begin)))
1590           (setq nlist (nthcdr (- (nnmaildir--art-num (car nlist)) end)
1591                               nlist))
1592           (while (and nlist
1593                       (setq article (car nlist))
1594                       (>= (nnmaildir--art-num article) begin))
1595             (setq nlist (cdr nlist))
1596             (when (stringp (nnmaildir--art-suffix article))
1597               (setq marks todo-marks)
1598               (eval form)))))
1599       nil)))
1600
1601 (defun nnmaildir-close-group (group &optional server)
1602   t)
1603
1604 (defun nnmaildir-close-server (&optional server)
1605   (let (flist ls dirs dir files file x)
1606     (nnmaildir--prepare server nil)
1607     (setq server nnmaildir--cur-server)
1608     (when server
1609       (setq nnmaildir--cur-server nil)
1610       (save-match-data
1611         (mapatoms
1612           (lambda (group)
1613             (setq x (nnmaildir--pgname server (symbol-name group))
1614                   group (symbol-value group)
1615                   ls (nnmaildir--group-ls server x)
1616                   dir (nnmaildir--srv-dir server)
1617                   dir (nnmaildir--srvgrp-dir dir (nnmaildir--grp-name group))
1618                   x (nnmaildir--param x 'read-only)
1619                   x (if x (nnmaildir--new dir) (nnmaildir--cur dir))
1620                   files (funcall ls x nil "\\`[^.]" 'nosort)
1621                   x (length files)
1622                   flist 1)
1623             (while (<= flist x) (setq flist (* 2 flist)))
1624             (if (/= flist 1) (setq flist (1- flist)))
1625             (setq flist (make-vector flist 0))
1626             (while files
1627               (setq file (car files) files (cdr files))
1628               (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1629               (intern (match-string 1 file) flist))
1630             (setq dir (nnmaildir--nndir dir)
1631                   dirs (cons (nnmaildir--nov-dir dir)
1632                              (funcall ls (nnmaildir--marks-dir dir) 'full
1633                                       "\\`[^.]" 'nosort)))
1634             (while dirs
1635               (setq dir (car dirs) dirs (cdr dirs)
1636                     files (funcall ls dir nil "\\`[^.]" 'nosort)
1637                     dir (file-name-as-directory dir))
1638               (while files
1639                 (setq file (car files) files (cdr files))
1640                 (if (intern-soft file flist) nil
1641                   (setq file (concat dir file))
1642                   (delete-file file)))))
1643           (nnmaildir--srv-groups server)))
1644       (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
1645   t)
1646
1647 (defun nnmaildir-request-close ()
1648   (let (servers buffer)
1649     (mapatoms (lambda (server)
1650                 (setq servers (cons (symbol-name server) servers)))
1651               nnmaildir--servers)
1652     (while servers
1653       (nnmaildir-close-server (car servers))
1654       (setq servers (cdr servers)))
1655     (setq buffer (get-buffer " *nnmaildir work*"))
1656     (if buffer (kill-buffer buffer))
1657     (setq buffer (get-buffer " *nnmaildir nov*"))
1658     (if buffer (kill-buffer buffer))
1659     (setq buffer (get-buffer " *nnmaildir move*"))
1660     (if buffer (kill-buffer buffer)))
1661   t)
1662
1663 (defun nnmaildir--edit-prep ()
1664   (let ((extras '(mapcar mapatoms))
1665         name)
1666     (mapatoms
1667       (lambda (sym)
1668         (when (or (memq sym extras)
1669                   (and (fboundp sym)
1670                        (setq name (symbol-name sym))
1671                        (>= (length name) 10)
1672                        (or (string-equal "nnmaildir-" (substring name 0 10))
1673                            (and (>= (length name) 15)
1674                                 (string-equal "make-nnmaildir-"
1675                                               (substring name 0 15))))))
1676           (put sym 'lisp-indent-function 0))))
1677     'done))
1678
1679 (provide 'nnmaildir)
1680
1681 ;; Local Variables:
1682 ;; indent-tabs-mode: t
1683 ;; fill-column: 77
1684 ;; eval: (progn (require 'nnmaildir) (nnmaildir--edit-prep))
1685 ;; End:
1686
1687 ;;; nnmaildir.el ends here