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

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