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