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