code.delx.au - gnu-emacs/blob - lisp/gnus/nnmaildir.el

   1 ;;; nnmaildir.el --- maildir backend for Gnus
   2
   3 ;; This file is in the public domain.
   4
   5 ;; Author: Paul Jarc <prj@po.cwru.edu>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>
  25 ;; and in the maildir(5) man page from qmail (available at
  26 ;; <URL:http://www.qmail.org/man/man5/maildir.html>).  nnmaildir also stores
  27 ;; extra information in the .nnmaildir/ directory within a maildir.
  28 ;;
  29 ;; Some goals of nnmaildir:
  30 ;; * Everything Just Works, and correctly.  E.g., NOV data is automatically
  31 ;;   regenerated when stale; no need for manually running
  32 ;;   *-generate-nov-databases.
  33 ;; * Perfect reliability: [C-g] will never corrupt its data in memory, and
  34 ;;   SIGKILL will never corrupt its data in the filesystem.
  35 ;; * Allow concurrent operation as much as possible.  If files change out
  36 ;;   from under us, adapt to the changes or degrade gracefully.
  37 ;; * We use the filesystem as a database, so that, e.g., it's easy to
  38 ;;   manipulate marks from outside Gnus.
  39 ;; * All information about a group is stored in the maildir, for easy backup,
  40 ;;   copying, restoring, etc.
  41 ;;
  42 ;; Todo:
  43 ;; * When moving an article for expiry, copy all the marks except 'expire
  44 ;;   from the original article.
  45 ;; * Add a hook for when moving messages from new/ to cur/, to support
  46 ;;   nnmail's duplicate detection.
  47 ;; * Improve generated Xrefs, so crossposts are detectable.
  48 ;; * Improve code readability.
  49
  50 ;;; Code:
  51
  52 ;; eval this before editing
  53 [(progn
  54    (put 'nnmaildir--with-nntp-buffer 'lisp-indent-function 0)
  55    (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0)
  56    (put 'nnmaildir--with-nov-buffer  'lisp-indent-function 0)
  57    (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0)
  58    (put 'nnmaildir--condcase         'lisp-indent-function 2)
  59    )
  60 ]
  61
  62 ;; For Emacs <22.2 and XEmacs.
  63 (eval-and-compile
  64   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  65
  66 (require 'nnheader)
  67 (require 'gnus)
  68 (require 'gnus-util)
  69 (require 'gnus-range)
  70 (require 'gnus-start)
  71 (require 'gnus-int)
  72 (require 'message)
  73 (require 'nnmail)
  74
  75 (eval-when-compile
  76   (require 'cl))
  77
  78 (defconst nnmaildir-version "Gnus")
  79
  80 (defconst nnmaildir-flag-mark-mapping
  81   '((?F . tick)
  82     (?R . reply)
  83     (?S . read))
  84   "Alist mapping Maildir filename flags to Gnus marks.
  85 Maildir filenames are of the form \"unique-id:2,FLAGS\",
  86 where FLAGS are a string of characters in ASCII order.
  87 Some of the FLAGS correspond to Gnus marks.")
  88
  89 (defsubst nnmaildir--mark-to-flag (mark)
  90   "Find the Maildir flag that corresponds to MARK (an atom).
  91 Return a character, or `nil' if not found.
  92 See `nnmaildir-flag-mark-mapping'."
  93   (car (rassq mark nnmaildir-flag-mark-mapping)))
  94
  95 (defsubst nnmaildir--flag-to-mark (flag)
  96   "Find the Gnus mark that corresponds to FLAG (a character).
  97 Return an atom, or `nil' if not found.
  98 See `nnmaildir-flag-mark-mapping'."
  99   (cdr (assq flag nnmaildir-flag-mark-mapping)))
 100
 101 (defun nnmaildir--ensure-suffix (filename)
 102   "Ensure that FILENAME contains the suffix \":2,\"."
 103   (if (gnus-string-match-p ":2," filename)
 104       filename
 105     (concat filename ":2,")))
 106
 107 (defun nnmaildir--add-flag (flag suffix)
 108   "Return a copy of SUFFIX where FLAG is set.
 109 SUFFIX should start with \":2,\"."
 110   (unless (gnus-string-match-p "^:2," suffix)
 111     (error "Invalid suffix `%s'" suffix))
 112   (let* ((flags (substring suffix 3))
 113          (flags-as-list (append flags nil))
 114          (new-flags
 115           (concat (gnus-delete-duplicates
 116                    ;; maildir flags must be sorted
 117                    (sort (cons flag flags-as-list) '<)))))
 118     (concat ":2," new-flags)))
 119
 120 (defun nnmaildir--remove-flag (flag suffix)
 121   "Return a copy of SUFFIX where FLAG is cleared.
 122 SUFFIX should start with \":2,\"."
 123   (unless (gnus-string-match-p "^:2," suffix)
 124     (error "Invalid suffix `%s'" suffix))
 125   (let* ((flags (substring suffix 3))
 126          (flags-as-list (append flags nil))
 127          (new-flags (concat (delq flag flags-as-list))))
 128     (concat ":2," new-flags)))
 129
 130 (defvar nnmaildir-article-file-name nil
 131   "*The filename of the most recently requested article.  This variable is set
 132 by nnmaildir-request-article.")
 133
 134 ;; The filename of the article being moved/copied:
 135 (defvar nnmaildir--file nil)
 136
 137 ;; Variables to generate filenames of messages being delivered:
 138 (defvar   nnmaildir--delivery-time "")
 139 (defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
 140 (defvar   nnmaildir--delivery-count nil)
 141
 142 ;; An obarry containing symbols whose names are server names and whose values
 143 ;; are servers:
 144 (defvar nnmaildir--servers (make-vector 3 0))
 145 ;; The current server:
 146 (defvar nnmaildir--cur-server nil)
 147
 148 ;; A copy of nnmail-extra-headers
 149 (defvar nnmaildir--extra nil)
 150
 151 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
 152 ["subject\tfrom\tdate"
 153  "references\tchars\lines"
 154  "To: you\tIn-Reply-To: <your.mess@ge>"
 155  (12345 67890)     ;; modtime of the corresponding article file
 156  (to in-reply-to)] ;; contemporary value of nnmail-extra-headers
 157 (defconst nnmaildir--novlen 5)
 158 (defmacro nnmaildir--nov-new (beg mid end mtime extra)
 159   `(vector ,beg ,mid ,end ,mtime ,extra))
 160 (defmacro nnmaildir--nov-get-beg   (nov) `(aref ,nov 0))
 161 (defmacro nnmaildir--nov-get-mid   (nov) `(aref ,nov 1))
 162 (defmacro nnmaildir--nov-get-end   (nov) `(aref ,nov 2))
 163 (defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3))
 164 (defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4))
 165 (defmacro nnmaildir--nov-set-beg   (nov value) `(aset ,nov 0 ,value))
 166 (defmacro nnmaildir--nov-set-mid   (nov value) `(aset ,nov 1 ,value))
 167 (defmacro nnmaildir--nov-set-end   (nov value) `(aset ,nov 2 ,value))
 168 (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value))
 169 (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value))
 170
 171 (defstruct nnmaildir--art
 172   (prefix nil :type string)  ;; "time.pid.host"
 173   (suffix nil :type string)  ;; ":2,flags"
 174   (num    nil :type natnum)  ;; article number
 175   (msgid  nil :type string)  ;; "<mess.age@id>"
 176   (nov    nil :type vector)) ;; cached nov structure, or nil
 177
 178 (defstruct nnmaildir--grp
 179   (name  nil :type string)  ;; "group.name"
 180   (new   nil :type list)    ;; new/ modtime
 181   (cur   nil :type list)    ;; cur/ modtime
 182   (min   1   :type natnum)  ;; minimum article number
 183   (count 0   :type natnum)  ;; count of articles
 184   (nlist nil :type list)    ;; list of articles, ordered descending by number
 185   (flist nil :type vector)  ;; obarray mapping filename prefix->article
 186   (mlist nil :type vector)  ;; obarray mapping message-id->article
 187   (cache nil :type vector)  ;; nov cache
 188   (index nil :type natnum)  ;; index of next cache entry to replace
 189   (mmth  nil :type vector)) ;; obarray mapping mark name->dir modtime
 190                                         ; ("Mark Mod Time Hash")
 191
 192 (defstruct nnmaildir--srv
 193   (address       nil :type string)         ;; server address string
 194   (method        nil :type list)           ;; (nnmaildir "address" ...)
 195   (prefix        nil :type string)         ;; "nnmaildir+address:"
 196   (dir           nil :type string)         ;; "/expanded/path/to/server/dir/"
 197   (ls            nil :type function)       ;; directory-files function
 198   (groups        nil :type vector)         ;; obarray mapping group name->group
 199   (curgrp        nil :type nnmaildir--grp) ;; current group, or nil
 200   (error         nil :type string)         ;; last error message, or nil
 201   (mtime         nil :type list)           ;; modtime of dir
 202   (gnm           nil)                      ;; flag: split from mail-sources?
 203   (target-prefix nil :type string))        ;; symlink target prefix
 204
 205 (defun nnmaildir--article-set-flags (article new-suffix curdir)
 206   (let* ((prefix (nnmaildir--art-prefix article))
 207          (suffix (nnmaildir--art-suffix article))
 208          (article-file (concat curdir prefix suffix))
 209          (new-name (concat curdir prefix new-suffix)))
 210     (unless (file-exists-p article-file)
 211       (error "Couldn't find article file %s" article-file))
 212     (rename-file article-file new-name 'replace)
 213     (setf (nnmaildir--art-suffix article) new-suffix)))
 214
 215 (defun nnmaildir--expired-article (group article)
 216   (setf (nnmaildir--art-nov article) nil)
 217   (let ((flist  (nnmaildir--grp-flist group))
 218         (mlist  (nnmaildir--grp-mlist group))
 219         (min    (nnmaildir--grp-min   group))
 220         (count  (1- (nnmaildir--grp-count group)))
 221         (prefix (nnmaildir--art-prefix article))
 222         (msgid  (nnmaildir--art-msgid  article))
 223         (new-nlist nil)
 224         (nlist-pre '(nil . nil))
 225         nlist-post num)
 226     (unless (zerop count)
 227       (setq nlist-post (nnmaildir--grp-nlist group)
 228             num (nnmaildir--art-num article))
 229       (if (eq num (caar nlist-post))
 230           (setq new-nlist (cdr nlist-post))
 231         (setq new-nlist nlist-post
 232               nlist-pre nlist-post
 233               nlist-post (cdr nlist-post))
 234         (while (/= num (caar nlist-post))
 235           (setq nlist-pre nlist-post
 236                 nlist-post (cdr nlist-post)))
 237         (setq nlist-post (cdr nlist-post))
 238         (if (eq num min)
 239             (setq min (caar nlist-pre)))))
 240     (let ((inhibit-quit t))
 241       (setf (nnmaildir--grp-min   group) min)
 242       (setf (nnmaildir--grp-count group) count)
 243       (setf (nnmaildir--grp-nlist group) new-nlist)
 244       (setcdr nlist-pre nlist-post)
 245       (unintern prefix flist)
 246       (unintern msgid mlist))))
 247
 248 (defun nnmaildir--nlist-art (group num)
 249   (let ((entry (assq num (nnmaildir--grp-nlist group))))
 250     (if entry
 251         (cdr entry))))
 252 (defmacro nnmaildir--flist-art (list file)
 253   `(symbol-value (intern-soft ,file ,list)))
 254 (defmacro nnmaildir--mlist-art (list msgid)
 255   `(symbol-value (intern-soft ,msgid ,list)))
 256
 257 (defun nnmaildir--pgname (server gname)
 258   (let ((prefix (nnmaildir--srv-prefix server)))
 259     (if prefix (concat prefix gname)
 260       (setq gname (gnus-group-prefixed-name gname
 261                                             (nnmaildir--srv-method server)))
 262       (setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname))
 263       gname)))
 264
 265 (defun nnmaildir--param (pgname param)
 266   (setq param (gnus-group-find-parameter pgname param 'allow-list))
 267   (if (vectorp param) (setq param (aref param 0)))
 268   (eval param))
 269
 270 (defmacro nnmaildir--with-nntp-buffer (&rest body)
 271   (declare (debug (body)))
 272   `(with-current-buffer nntp-server-buffer
 273      ,@body))
 274 (defmacro nnmaildir--with-work-buffer (&rest body)
 275   (declare (debug (body)))
 276   `(with-current-buffer (get-buffer-create " *nnmaildir work*")
 277      ,@body))
 278 (defmacro nnmaildir--with-nov-buffer (&rest body)
 279   (declare (debug (body)))
 280   `(with-current-buffer (get-buffer-create " *nnmaildir nov*")
 281      ,@body))
 282 (defmacro nnmaildir--with-move-buffer (&rest body)
 283   (declare (debug (body)))
 284   `(with-current-buffer (get-buffer-create " *nnmaildir move*")
 285      ,@body))
 286
 287 (defsubst nnmaildir--subdir (dir subdir)
 288   (file-name-as-directory (concat dir subdir)))
 289 (defsubst nnmaildir--srvgrp-dir (srv-dir gname)
 290   (nnmaildir--subdir srv-dir gname))
 291 (defsubst nnmaildir--tmp       (dir) (nnmaildir--subdir dir "tmp"))
 292 (defsubst nnmaildir--new       (dir) (nnmaildir--subdir dir "new"))
 293 (defsubst nnmaildir--cur       (dir) (nnmaildir--subdir dir "cur"))
 294 (defsubst nnmaildir--nndir     (dir) (nnmaildir--subdir dir ".nnmaildir"))
 295 (defsubst nnmaildir--nov-dir   (dir) (nnmaildir--subdir dir "nov"))
 296 (defsubst nnmaildir--marks-dir (dir) (nnmaildir--subdir dir "marks"))
 297 (defsubst nnmaildir--num-dir   (dir) (nnmaildir--subdir dir "num"))
 298
 299 (defmacro nnmaildir--unlink (file-arg)
 300   `(let ((file ,file-arg))
 301      (if (file-attributes file) (delete-file file))))
 302 (defun nnmaildir--mkdir (dir)
 303   (or (file-exists-p (file-name-as-directory dir))
 304       (make-directory-internal (directory-file-name dir))))
 305 (defun nnmaildir--mkfile (file)
 306   (write-region "" nil file nil 'no-message))
 307 (defun nnmaildir--delete-dir-files (dir ls)
 308   (when (file-attributes dir)
 309     (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
 310     (delete-directory dir)))
 311
 312 (defun nnmaildir--group-maxnum (server group)
 313   (catch 'return
 314     (if (zerop (nnmaildir--grp-count group)) (throw 'return 0))
 315     (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server)
 316                                     (nnmaildir--grp-name group)))
 317           (number-opened 1)
 318           attr ino-opened nlink number-linked)
 319       (setq dir (nnmaildir--nndir dir)
 320             dir (nnmaildir--num-dir dir))
 321       (while t
 322         (setq attr (file-attributes
 323                     (concat dir (number-to-string number-opened))))
 324         (or attr (throw 'return (1- number-opened)))
 325         (setq ino-opened (nth 10 attr)
 326               nlink (nth 1 attr)
 327               number-linked (+ number-opened nlink))
 328         (if (or (< nlink 1) (< number-linked nlink))
 329             (signal 'error '("Arithmetic overflow")))
 330         (setq attr (file-attributes
 331                     (concat dir (number-to-string number-linked))))
 332         (or attr (throw 'return (1- number-linked)))
 333         (unless (equal ino-opened (nth 10 attr))
 334           (setq number-opened number-linked))))))
 335
 336 ;; Make the given server, if non-nil, be the current server.  Then make the
 337 ;; given group, if non-nil, be the current group of the current server.  Then
 338 ;; return the group object for the current group.
 339 (defun nnmaildir--prepare (server group)
 340   (let (x groups)
 341     (catch 'return
 342       (if (null server)
 343           (unless (setq server nnmaildir--cur-server)
 344             (throw 'return nil))
 345         (unless (setq server (intern-soft server nnmaildir--servers))
 346           (throw 'return nil))
 347         (setq server (symbol-value server)
 348               nnmaildir--cur-server server))
 349       (unless (setq groups (nnmaildir--srv-groups server))
 350         (throw 'return nil))
 351       (unless (nnmaildir--srv-method server)
 352         (setq x (concat "nnmaildir:" (nnmaildir--srv-address server))
 353               x (gnus-server-to-method x))
 354         (unless x (throw 'return nil))
 355         (setf (nnmaildir--srv-method server) x))
 356       (if (null group)
 357           (unless (setq group (nnmaildir--srv-curgrp server))
 358             (throw 'return nil))
 359         (unless (setq group (intern-soft group groups))
 360           (throw 'return nil))
 361         (setq group (symbol-value group)))
 362       group)))
 363
 364 (defun nnmaildir--tab-to-space (string)
 365   (let ((pos 0))
 366     (while (string-match "\t" string pos)
 367       (aset string (match-beginning 0) ? )
 368       (setq pos (match-end 0))))
 369   string)
 370
 371 (defmacro nnmaildir--condcase (errsym body &rest handler)
 372   (declare (debug (sexp form body)))
 373   `(condition-case ,errsym
 374        (let ((system-messages-locale "C")) ,body)
 375      (error . ,handler)))
 376
 377 (defun nnmaildir--emlink-p (err)
 378   (and (eq (car err) 'file-error)
 379        (string= (downcase (caddr err)) "too many links")))
 380
 381 (defun nnmaildir--enoent-p (err)
 382   (and (eq (car err) 'file-error)
 383        (string= (downcase (caddr err)) "no such file or directory")))
 384
 385 (defun nnmaildir--eexist-p (err)
 386   (eq (car err) 'file-already-exists))
 387
 388 (defun nnmaildir--new-number (nndir)
 389   "Allocate a new article number by atomically creating a file under NNDIR."
 390   (let ((numdir (nnmaildir--num-dir nndir))
 391         (make-new-file t)
 392         (number-open 1)
 393         number-link previous-number-link path-open path-link ino-open)
 394     (nnmaildir--mkdir numdir)
 395     (catch 'return
 396       (while t
 397         (setq path-open (concat numdir (number-to-string number-open)))
 398         (if (not make-new-file)
 399             (setq previous-number-link number-link)
 400           (nnmaildir--mkfile path-open)
 401           ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
 402           (setq make-new-file nil
 403                 previous-number-link 0))
 404         (let* ((attr (file-attributes path-open))
 405                (nlink (nth 1 attr)))
 406           (setq ino-open (nth 10 attr)
 407                 number-link (+ number-open nlink))
 408           (if (or (< nlink 1) (< number-link nlink))
 409               (signal 'error '("Arithmetic overflow"))))
 410         (if (= number-link previous-number-link)
 411             ;; We've already tried this number, in the previous loop iteration,
 412             ;; and failed.
 413             (signal 'error `("Corrupt internal nnmaildir data" ,path-open)))
 414         (setq path-link (concat numdir (number-to-string number-link)))
 415         (nnmaildir--condcase err
 416             (progn
 417               (add-name-to-file path-open path-link)
 418               (throw 'return number-link))
 419           (cond
 420            ((nnmaildir--emlink-p err)
 421             (setq make-new-file t
 422                   number-open number-link))
 423            ((nnmaildir--eexist-p err)
 424             (let ((attr (file-attributes path-link)))
 425               (unless (equal (nth 10 attr) ino-open)
 426                 (setq number-open number-link
 427                       number-link 0))))
 428            (t (signal (car err) (cdr err)))))))))
 429
 430 (defun nnmaildir--update-nov (server group article)
 431   (let ((nnheader-file-coding-system 'binary)
 432         (srv-dir (nnmaildir--srv-dir server))
 433         (storage-version 1) ;; [version article-number msgid [...nov...]]
 434         dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
 435         nov msgid nov-beg nov-mid nov-end field val old-extra num numdir
 436         deactivate-mark)
 437     (catch 'return
 438       (setq gname (nnmaildir--grp-name group)
 439             pgname (nnmaildir--pgname server gname)
 440             dir (nnmaildir--srvgrp-dir srv-dir gname)
 441             msgdir (if (nnmaildir--param pgname 'read-only)
 442                        (nnmaildir--new dir) (nnmaildir--cur dir))
 443             prefix (nnmaildir--art-prefix article)
 444             suffix (nnmaildir--art-suffix article)
 445             file (concat msgdir prefix suffix)
 446             attr (file-attributes file))
 447       (unless attr
 448         (nnmaildir--expired-article group article)
 449         (throw 'return nil))
 450       (setq mtime (nth 5 attr)
 451             attr (nth 7 attr)
 452             nov (nnmaildir--art-nov article)
 453             dir (nnmaildir--nndir dir)
 454             novdir (nnmaildir--nov-dir dir)
 455             novfile (concat novdir prefix))
 456       (unless (equal nnmaildir--extra nnmail-extra-headers)
 457         (setq nnmaildir--extra (copy-sequence nnmail-extra-headers)))
 458       (nnmaildir--with-nov-buffer
 459         ;; First we'll check for already-parsed NOV data.
 460         (cond ((not (file-exists-p novfile))
 461                ;; The NOV file doesn't exist; we have to parse the message.
 462                (setq nov nil))
 463               ((not nov)
 464                ;; The file exists, but the data isn't in memory; read the file.
 465                (erase-buffer)
 466                (nnheader-insert-file-contents novfile)
 467                (setq nov (read (current-buffer)))
 468                (if (not (and (vectorp nov)
 469                              (/= 0 (length nov))
 470                              (equal storage-version (aref nov 0))))
 471                    ;; This NOV data seems to be in the wrong format.
 472                    (setq nov nil)
 473                  (unless (nnmaildir--art-num   article)
 474                    (setf (nnmaildir--art-num   article) (aref nov 1)))
 475                  (unless (nnmaildir--art-msgid article)
 476                    (setf (nnmaildir--art-msgid article) (aref nov 2)))
 477                  (setq nov (aref nov 3)))))
 478         ;; Now check whether the already-parsed data (if we have any) is
 479         ;; usable: if the message has been edited or if nnmail-extra-headers
 480         ;; has been augmented since this data was parsed from the message,
 481         ;; then we have to reparse.  Otherwise it's up-to-date.
 482         (when (and nov (equal mtime (nnmaildir--nov-get-mtime nov)))
 483           ;; The timestamp matches.  Now check nnmail-extra-headers.
 484           (setq old-extra (nnmaildir--nov-get-extra nov))
 485           (when (equal nnmaildir--extra old-extra) ;; common case
 486             ;; Save memory; use a single copy of the list value.
 487             (nnmaildir--nov-set-extra nov nnmaildir--extra)
 488             (throw 'return nov))
 489           ;; They're not equal, but maybe the new is a subset of the old.
 490           (if (null nnmaildir--extra)
 491               ;; The empty set is a subset of every set.
 492               (throw 'return nov))
 493           (if (not (memq nil (mapcar (lambda (e) (memq e old-extra))
 494                                      nnmaildir--extra)))
 495               (throw 'return nov)))
 496         ;; Parse the NOV data out of the message.
 497         (erase-buffer)
 498         (nnheader-insert-file-contents file)
 499         (insert "\n")
 500         (goto-char (point-min))
 501         (save-restriction
 502           (if (search-forward "\n\n" nil 'noerror)
 503               (progn
 504                 (setq nov-mid (count-lines (point) (point-max)))
 505                 (narrow-to-region (point-min) (1- (point))))
 506             (setq nov-mid 0))
 507           (goto-char (point-min))
 508           (delete-char 1)
 509           (setq nov (nnheader-parse-naked-head)
 510                 field (or (mail-header-lines nov) 0)))
 511         (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
 512           (setq nov-mid field))
 513         (setq nov-mid (number-to-string nov-mid)
 514               nov-mid (concat (number-to-string attr) "\t" nov-mid))
 515         (save-match-data
 516           (setq field (or (mail-header-references nov) ""))
 517           (nnmaildir--tab-to-space field)
 518           (setq nov-mid (concat field "\t" nov-mid)
 519                 nov-beg (mapconcat
 520                           (lambda (f) (nnmaildir--tab-to-space (or f "")))
 521                           (list (mail-header-subject nov)
 522                                 (mail-header-from nov)
 523                                 (mail-header-date nov)) "\t")
 524                 nov-end (mapconcat
 525                           (lambda (extra)
 526                             (setq field (symbol-name (car extra))
 527                                   val (cdr extra))
 528                             (nnmaildir--tab-to-space field)
 529                             (nnmaildir--tab-to-space val)
 530                             (concat field ": " val))
 531                           (mail-header-extra nov) "\t")))
 532         (setq msgid (mail-header-id nov))
 533         (if (or (null msgid) (nnheader-fake-message-id-p msgid))
 534             (setq msgid (concat "<" prefix "@nnmaildir>")))
 535         (nnmaildir--tab-to-space msgid)
 536         ;; The data is parsed; create an nnmaildir NOV structure.
 537         (setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime
 538                                       nnmaildir--extra)
 539               num (nnmaildir--art-num article))
 540         (unless num
 541           (setq num (nnmaildir--new-number dir))
 542           (setf (nnmaildir--art-num article) num))
 543         ;; Store this new NOV data in a file
 544         (erase-buffer)
 545         (prin1 (vector storage-version num msgid nov) (current-buffer))
 546         (setq file (concat novfile ":"))
 547         (nnmaildir--unlink file)
 548         (gmm-write-region (point-min) (point-max) file nil 'no-message nil
 549                           'excl))
 550       (rename-file file novfile 'replace)
 551       (setf (nnmaildir--art-msgid article) msgid)
 552       nov)))
 553
 554 (defun nnmaildir--cache-nov (group article nov)
 555   (let ((cache (nnmaildir--grp-cache group))
 556         (index (nnmaildir--grp-index group))
 557         goner)
 558     (unless (nnmaildir--art-nov article)
 559       (setq goner (aref cache index))
 560       (if goner (setf (nnmaildir--art-nov goner) nil))
 561       (aset cache index article)
 562       (setf (nnmaildir--grp-index group) (% (1+ index) (length cache))))
 563     (setf (nnmaildir--art-nov article) nov)))
 564
 565 (defun nnmaildir--grp-add-art (server group article)
 566   (let ((nov (nnmaildir--update-nov server group article))
 567         count num min nlist nlist-cdr insert-nlist)
 568     (when nov
 569       (setq count (1+ (nnmaildir--grp-count group))
 570             num (nnmaildir--art-num article)
 571             min (if (= count 1) num
 572                   (min num (nnmaildir--grp-min group)))
 573             nlist (nnmaildir--grp-nlist group))
 574       (if (or (null nlist) (> num (caar nlist)))
 575           (setq nlist (cons (cons num article) nlist))
 576         (setq insert-nlist t
 577               nlist-cdr (cdr nlist))
 578         (while (and nlist-cdr (< num (caar nlist-cdr)))
 579           (setq nlist nlist-cdr
 580                 nlist-cdr (cdr nlist))))
 581       (let ((inhibit-quit t))
 582         (setf (nnmaildir--grp-count group) count)
 583         (setf (nnmaildir--grp-min group) min)
 584         (if insert-nlist
 585             (setcdr nlist (cons (cons num article) nlist-cdr))
 586           (setf (nnmaildir--grp-nlist group) nlist))
 587         (set (intern (nnmaildir--art-prefix article)
 588                      (nnmaildir--grp-flist group))
 589              article)
 590         (set (intern (nnmaildir--art-msgid article)
 591                      (nnmaildir--grp-mlist group))
 592              article)
 593         (set (intern (nnmaildir--grp-name group)
 594                      (nnmaildir--srv-groups server))
 595              group))
 596       (nnmaildir--cache-nov group article nov)
 597       t)))
 598
 599 (defun nnmaildir--group-ls (server pgname)
 600   (or (nnmaildir--param pgname 'directory-files)
 601       (nnmaildir--srv-ls server)))
 602
 603 (defun nnmaildir-article-number-to-file-name
 604   (number group-name server-address-string)
 605   (let ((group (nnmaildir--prepare server-address-string group-name))
 606         article dir pgname)
 607     (catch 'return
 608       (unless group
 609         ;; The given group or server does not exist.
 610         (throw 'return nil))
 611       (setq article (nnmaildir--nlist-art group number))
 612       (unless article
 613         ;; The given article number does not exist in this group.
 614         (throw 'return nil))
 615       (setq pgname (nnmaildir--pgname nnmaildir--cur-server group-name)
 616             dir (nnmaildir--srv-dir nnmaildir--cur-server)
 617             dir (nnmaildir--srvgrp-dir dir group-name)
 618             dir (if (nnmaildir--param pgname 'read-only)
 619                     (nnmaildir--new dir) (nnmaildir--cur dir)))
 620       (concat dir (nnmaildir--art-prefix article)
 621               (nnmaildir--art-suffix article)))))
 622
 623 (defun nnmaildir-article-number-to-base-name
 624   (number group-name server-address-string)
 625   (let ((x (nnmaildir--prepare server-address-string group-name)))
 626     (when x
 627       (setq x (nnmaildir--nlist-art x number))
 628       (and x (cons (nnmaildir--art-prefix x)
 629                    (nnmaildir--art-suffix x))))))
 630
 631 (defun nnmaildir-base-name-to-article-number
 632   (base-name group-name server-address-string)
 633   (let ((x (nnmaildir--prepare server-address-string group-name)))
 634     (when x
 635       (setq x (nnmaildir--grp-flist x)
 636             x (nnmaildir--flist-art x base-name))
 637       (and x (nnmaildir--art-num x)))))
 638
 639 (defun nnmaildir--nlist-iterate (nlist ranges func)
 640   (let (entry high low nlist2)
 641     (if (eq ranges 'all)
 642         (setq ranges `((1 . ,(caar nlist)))))
 643     (while ranges
 644       (setq entry (car ranges) ranges (cdr ranges))
 645       (while (and ranges (eq entry (car ranges)))
 646         (setq ranges (cdr ranges))) ;; skip duplicates
 647       (if (numberp entry)
 648           (setq low entry
 649                 high entry)
 650         (setq low (car entry)
 651               high (cdr entry)))
 652       (setq nlist2 nlist) ;; Don't assume any sorting of ranges
 653       (catch 'iterate-loop
 654         (while nlist2
 655           (if (<= (caar nlist2) high) (throw 'iterate-loop nil))
 656           (setq nlist2 (cdr nlist2))))
 657       (catch 'iterate-loop
 658         (while nlist2
 659           (setq entry (car nlist2) nlist2 (cdr nlist2))
 660           (if (< (car entry) low) (throw 'iterate-loop nil))
 661           (funcall func (cdr entry)))))))
 662
 663 (defun nnmaildir--up2-1 (n)
 664   (if (zerop n) 1 (1- (lsh 1 (1+ (logb n))))))
 665
 666 (defun nnmaildir--system-name ()
 667   (gnus-replace-in-string
 668    (gnus-replace-in-string
 669     (gnus-replace-in-string
 670      (system-name)
 671      "\\\\" "\\134" 'literal)
 672     "/" "\\057" 'literal)
 673    ":" "\\072" 'literal))
 674
 675 (defun nnmaildir-request-type (group &optional article)
 676   'mail)
 677
 678 (defun nnmaildir-status-message (&optional server)
 679   (nnmaildir--prepare server nil)
 680   (nnmaildir--srv-error nnmaildir--cur-server))
 681
 682 (defun nnmaildir-server-opened (&optional server)
 683   (and nnmaildir--cur-server
 684        (if server
 685            (string-equal server (nnmaildir--srv-address nnmaildir--cur-server))
 686          t)
 687        (nnmaildir--srv-groups nnmaildir--cur-server)
 688        t))
 689
 690 (defun nnmaildir-open-server (server &optional defs)
 691   (let ((x server)
 692         dir size)
 693     (catch 'return
 694       (setq server (intern-soft x nnmaildir--servers))
 695       (if server
 696           (and (setq server (symbol-value server))
 697                (nnmaildir--srv-groups server)
 698                (setq nnmaildir--cur-server server)
 699                (throw 'return t))
 700         (setq server (make-nnmaildir--srv :address x))
 701         (let ((inhibit-quit t))
 702           (set (intern x nnmaildir--servers) server)))
 703       (setq dir (assq 'directory defs))
 704       (unless dir
 705         (setf (nnmaildir--srv-error server)
 706               "You must set \"directory\" in the select method")
 707         (throw 'return nil))
 708       (setq dir (cadr dir)
 709             dir (eval dir)
 710             dir (expand-file-name dir)
 711             dir (file-name-as-directory dir))
 712       (unless (file-exists-p dir)
 713         (setf (nnmaildir--srv-error server) (concat "No such directory: " dir))
 714         (throw 'return nil))
 715       (setf (nnmaildir--srv-dir server) dir)
 716       (setq x (assq 'directory-files defs))
 717       (if (null x)
 718           (setq x (if nnheader-directory-files-is-safe 'directory-files
 719                     'nnheader-directory-files-safe))
 720         (setq x (cadr x))
 721         (unless (functionp x)
 722           (setf (nnmaildir--srv-error server)
 723                 (concat "Not a function: " (prin1-to-string x)))
 724           (throw 'return nil)))
 725       (setf (nnmaildir--srv-ls server) x)
 726       (setq size (length (funcall x dir nil "\\`[^.]" 'nosort))
 727             size (nnmaildir--up2-1 size))
 728       (and (setq x (assq 'get-new-mail defs))
 729            (setq x (cdr x))
 730            (car x)
 731            (setf (nnmaildir--srv-gnm server) t)
 732            (require 'nnmail))
 733       (setq x (assq 'target-prefix defs))
 734       (if x
 735           (progn
 736             (setq x (cadr x)
 737                   x (eval x))
 738             (setf (nnmaildir--srv-target-prefix server) x))
 739         (setq x (assq 'create-directory defs))
 740         (if x
 741             (progn
 742               (setq x (cadr x)
 743                     x (eval x)
 744                     x (file-name-as-directory x))
 745               (setf (nnmaildir--srv-target-prefix server) x))
 746           (setf (nnmaildir--srv-target-prefix server) "")))
 747       (setf (nnmaildir--srv-groups server) (make-vector size 0))
 748       (setq nnmaildir--cur-server server)
 749       t)))
 750
 751 (defun nnmaildir--parse-filename (file)
 752   (let ((prefix (car file))
 753         timestamp len)
 754     (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix)
 755         (progn
 756           (setq timestamp (concat "0000" (match-string 1 prefix))
 757                 len (- (length timestamp) 4))
 758           (vector (string-to-number (substring timestamp 0 len))
 759                   (string-to-number (substring timestamp len))
 760                   (match-string 2 prefix)
 761                   file))
 762       file)))
 763
 764 (defun nnmaildir--sort-files (a b)
 765   (catch 'return
 766     (if (consp a)
 767         (throw 'return (and (consp b) (string-lessp (car a) (car b)))))
 768     (if (consp b) (throw 'return t))
 769     (if (< (aref a 0) (aref b 0)) (throw 'return t))
 770     (if (> (aref a 0) (aref b 0)) (throw 'return nil))
 771     (if (< (aref a 1) (aref b 1)) (throw 'return t))
 772     (if (> (aref a 1) (aref b 1)) (throw 'return nil))
 773     (string-lessp (aref a 2) (aref b 2))))
 774
 775 (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls)
 776   (catch 'return
 777     (let ((36h-ago (- (car (current-time)) 2))
 778           absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
 779           files num dir flist group x)
 780       (setq absdir (nnmaildir--srvgrp-dir srv-dir gname)
 781             nndir (nnmaildir--nndir absdir))
 782       (unless (file-exists-p absdir)
 783         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 784               (concat "No such directory: " absdir))
 785         (throw 'return nil))
 786       (setq tdir (nnmaildir--tmp absdir)
 787             ndir (nnmaildir--new absdir)
 788             cdir (nnmaildir--cur absdir)
 789             nattr (file-attributes ndir)
 790             cattr (file-attributes cdir))
 791       (unless (and (file-exists-p tdir) nattr cattr)
 792         (setf (nnmaildir--srv-error nnmaildir--cur-server)
 793               (concat "Not a maildir: " absdir))
 794         (throw 'return nil))
 795       (setq group (nnmaildir--prepare nil gname)
 796             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
 797       (if group
 798           (setq isnew nil)
 799         (setq isnew t
 800               group (make-nnmaildir--grp :name gname :index 0))
 801         (nnmaildir--mkdir nndir)
 802         (nnmaildir--mkdir (nnmaildir--nov-dir   nndir))
 803         (nnmaildir--mkdir (nnmaildir--marks-dir nndir)))
 804       (setq read-only (nnmaildir--param pgname 'read-only)
 805             ls (or (nnmaildir--param pgname 'directory-files) srv-ls))
 806       (unless read-only
 807         (setq x (nth 11 (file-attributes tdir)))
 808         (unless (and (equal x (nth 11 nattr)) (equal x (nth 11 cattr)))
 809           (setf (nnmaildir--srv-error nnmaildir--cur-server)
 810                 (concat "Maildir spans filesystems: " absdir))
 811           (throw 'return nil))
 812         (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort))
 813           (setq x (file-attributes file))
 814           (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago))
 815               (delete-file file))))
 816       (or scan-msgs
 817           isnew
 818           (throw 'return t))
 819       (setq nattr (nth 5 nattr))
 820       (if (equal nattr (nnmaildir--grp-new group))
 821           (setq nattr nil))
 822       (if read-only (setq dir (and (or isnew nattr) ndir))
 823         (when (or isnew nattr)
 824           (dolist (file  (funcall ls ndir nil "\\`[^.]" 'nosort))
 825             (setq x (concat ndir file))
 826             (and (time-less-p (nth 5 (file-attributes x)) (current-time))
 827                  (rename-file x (concat cdir (nnmaildir--ensure-suffix file)))))
 828           (setf (nnmaildir--grp-new group) nattr))
 829         (setq cattr (nth 5 (file-attributes cdir)))
 830         (if (equal cattr (nnmaildir--grp-cur group))
 831             (setq cattr nil))
 832         (setq dir (and (or isnew cattr) cdir)))
 833       (unless dir (throw 'return t))
 834       (setq files (funcall ls dir nil "\\`[^.]" 'nosort)
 835             files (save-match-data
 836                     (mapcar
 837                      (lambda (f)
 838                        (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f)
 839                        (cons (match-string 1 f) (match-string 2 f)))
 840                      files)))
 841       (when isnew
 842         (setq num (nnmaildir--up2-1 (length files)))
 843         (setf (nnmaildir--grp-flist group) (make-vector num 0))
 844         (setf (nnmaildir--grp-mlist group) (make-vector num 0))
 845         (setf (nnmaildir--grp-mmth group) (make-vector 1 0))
 846         (setq num (nnmaildir--param pgname 'nov-cache-size))
 847         (if (numberp num) (if (< num 1) (setq num 1))
 848           (setq num 16
 849                 cdir (nnmaildir--marks-dir nndir)
 850                 ndir (nnmaildir--subdir cdir "tick")
 851                 cdir (nnmaildir--subdir cdir "read"))
 852           (dolist (prefix-suffix files)
 853             (let ((prefix (car prefix-suffix))
 854                   (suffix (cdr prefix-suffix)))
 855               ;; increase num for each unread or ticked article
 856               (when (or
 857                      ;; first look for marks in suffix, if it's valid...
 858                      (when (and (stringp suffix)
 859                                 (gnus-string-prefix-p ":2," suffix))
 860                        (or
 861                         (not (gnus-string-match-p
 862                               (string (nnmaildir--mark-to-flag 'read)) suffix))
 863                         (gnus-string-match-p
 864                          (string (nnmaildir--mark-to-flag 'tick)) suffix)))
 865                      ;; then look in marks directories
 866                      (not (file-exists-p (concat cdir prefix)))
 867                      (file-exists-p (concat ndir prefix)))
 868                 (incf num)))))
 869         (setf (nnmaildir--grp-cache group) (make-vector num nil))
 870         (let ((inhibit-quit t))
 871           (set (intern gname groups) group))
 872         (or scan-msgs (throw 'return t)))
 873       (setq flist (nnmaildir--grp-flist group)
 874             files (mapcar
 875                    (lambda (file)
 876                      (and (null (nnmaildir--flist-art flist (car file)))
 877                           file))
 878                    files)
 879             files (delq nil files)
 880             files (mapcar 'nnmaildir--parse-filename files)
 881             files (sort files 'nnmaildir--sort-files))
 882       (dolist (file files)
 883         (setq file (if (consp file) file (aref file 3))
 884               x (make-nnmaildir--art :prefix (car file) :suffix (cdr file)))
 885         (nnmaildir--grp-add-art nnmaildir--cur-server group x))
 886       (if read-only (setf (nnmaildir--grp-new group) nattr)
 887         (setf (nnmaildir--grp-cur group) cattr)))
 888     t))
 889
 890 (defun nnmaildir-request-scan (&optional scan-group server)
 891   (let ((coding-system-for-write nnheader-file-coding-system)
 892         (buffer-file-coding-system nil)
 893         (file-coding-system-alist nil)
 894         (nnmaildir-get-new-mail t)
 895         (nnmaildir-group-alist nil)
 896         (nnmaildir-active-file nil)
 897         x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen
 898         deactivate-mark)
 899     (nnmaildir--prepare server nil)
 900     (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server)
 901           srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
 902           method (nnmaildir--srv-method nnmaildir--cur-server)
 903           groups (nnmaildir--srv-groups nnmaildir--cur-server)
 904           target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
 905     (nnmaildir--with-work-buffer
 906       (save-match-data
 907         (if (stringp scan-group)
 908             (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
 909                 (if (nnmaildir--srv-gnm nnmaildir--cur-server)
 910                     (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
 911               (unintern scan-group groups))
 912           (setq x (nth 5 (file-attributes srv-dir))
 913                 scan-group (null scan-group))
 914           (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
 915               (if scan-group
 916                   (mapatoms (lambda (sym)
 917                               (nnmaildir--scan (symbol-name sym) t groups
 918                                                method srv-dir srv-ls))
 919                             groups))
 920             (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
 921                   dirs (if (zerop (length target-prefix))
 922                            dirs
 923                          (gnus-remove-if
 924                           (lambda (dir)
 925                             (and (>= (length dir) (length target-prefix))
 926                                  (string= (substring dir 0
 927                                                      (length target-prefix))
 928                                           target-prefix)))
 929                           dirs))
 930                   seen (nnmaildir--up2-1 (length dirs))
 931                   seen (make-vector seen 0))
 932             (dolist (grp-dir dirs)
 933               (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
 934                                    srv-ls)
 935                   (intern grp-dir seen)))
 936             (setq x nil)
 937             (mapatoms (lambda (group)
 938                         (setq group (symbol-name group))
 939                         (unless (intern-soft group seen)
 940                           (setq x (cons group x))))
 941                       groups)
 942             (dolist (grp x)
 943               (unintern grp groups))
 944             (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
 945                   (nth 5 (file-attributes srv-dir))))
 946           (and scan-group
 947                (nnmaildir--srv-gnm nnmaildir--cur-server)
 948                (nnmail-get-new-mail 'nnmaildir nil nil))))))
 949   t)
 950
 951 (defun nnmaildir-request-list (&optional server)
 952   (nnmaildir-request-scan 'find-new-groups server)
 953   (let (pgname ro deactivate-mark)
 954     (nnmaildir--prepare server nil)
 955     (nnmaildir--with-nntp-buffer
 956       (erase-buffer)
 957       (mapatoms (lambda (group)
 958                   (setq pgname (symbol-name group)
 959                         pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
 960                         group (symbol-value group)
 961                         ro (nnmaildir--param pgname 'read-only))
 962                   (insert (gnus-replace-in-string
 963                            (nnmaildir--grp-name group) " " "\\ " t)
 964                           " ")
 965                   (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 966                          nntp-server-buffer)
 967                   (insert " ")
 968                   (princ (nnmaildir--grp-min group) nntp-server-buffer)
 969                   (insert " " (if ro "n" "y") "\n"))
 970                 (nnmaildir--srv-groups nnmaildir--cur-server))))
 971   t)
 972
 973 (defun nnmaildir-request-newgroups (date &optional server)
 974   (nnmaildir-request-list server))
 975
 976 (defun nnmaildir-retrieve-groups (groups &optional server)
 977   (let (group deactivate-mark)
 978     (nnmaildir--prepare server nil)
 979     (nnmaildir--with-nntp-buffer
 980       (erase-buffer)
 981       (dolist (gname groups)
 982         (setq group (nnmaildir--prepare nil gname))
 983         (if (null group) (insert "411 no such news group\n")
 984           (insert "211 ")
 985           (princ (nnmaildir--grp-count group) nntp-server-buffer)
 986           (insert " ")
 987           (princ (nnmaildir--grp-min   group) nntp-server-buffer)
 988           (insert " ")
 989           (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
 990                  nntp-server-buffer)
 991           (insert " "
 992                   (gnus-replace-in-string gname " " "\\ " t)
 993                   "\n")))))
 994   'group)
 995
 996 (defun nnmaildir-request-update-info (gname info &optional server)
 997   (let* ((group (nnmaildir--prepare server gname))
 998          (curdir (nnmaildir--cur
 999                   (nnmaildir--srvgrp-dir
1000                    (nnmaildir--srv-dir nnmaildir--cur-server) gname)))
1001          (curdir-mtime (nth 5 (file-attributes curdir)))
1002          pgname flist always-marks never-marks old-marks dotfile num dir
1003          all-marks marks mark ranges markdir read end new-marks ls
1004          old-mmth new-mmth mtime mark-sym existing missing deactivate-mark)
1005     (catch 'return
1006       (unless group
1007         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1008               (concat "No such group: " gname))
1009         (throw 'return nil))
1010       (setq gname (nnmaildir--grp-name group)
1011             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1012             flist (nnmaildir--grp-flist group))
1013       (when (zerop (nnmaildir--grp-count group))
1014         (gnus-info-set-read info nil)
1015         (gnus-info-set-marks info nil 'extend)
1016         (throw 'return info))
1017       (setq old-marks (cons 'read (gnus-info-read info))
1018             old-marks (cons old-marks (gnus-info-marks info))
1019             always-marks (nnmaildir--param pgname 'always-marks)
1020             never-marks (nnmaildir--param pgname 'never-marks)
1021             existing (nnmaildir--grp-nlist group)
1022             existing (mapcar 'car existing)
1023             existing (nreverse existing)
1024             existing (gnus-compress-sequence existing 'always-list)
1025             missing (list (cons 1 (nnmaildir--group-maxnum
1026                                    nnmaildir--cur-server group)))
1027             missing (gnus-range-difference missing existing)
1028             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1029             dir (nnmaildir--srvgrp-dir dir gname)
1030             dir (nnmaildir--nndir dir)
1031             dir (nnmaildir--marks-dir dir)
1032             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1033             all-marks (gnus-delete-duplicates
1034                        ;; get mark names from mark dirs and from flag
1035                        ;; mappings
1036                        (append
1037                         (mapcar 'cdr nnmaildir-flag-mark-mapping)
1038                         (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort))))
1039             new-mmth (nnmaildir--up2-1 (length all-marks))
1040             new-mmth (make-vector new-mmth 0)
1041             old-mmth (nnmaildir--grp-mmth group))
1042       (dolist (mark all-marks)
1043         (setq markdir (nnmaildir--subdir dir (symbol-name mark))
1044               ranges nil)
1045         (catch 'got-ranges
1046           (if (memq mark never-marks) (throw 'got-ranges nil))
1047           (when (memq mark always-marks)
1048             (setq ranges existing)
1049             (throw 'got-ranges nil))
1050           ;; Find the mtime for this mark.  If this mark can be expressed as
1051           ;; a filename flag, get the later of the mtimes for markdir and
1052           ;; curdir, otherwise only the markdir counts.
1053           (setq mtime
1054                 (let ((markdir-mtime (nth 5 (file-attributes markdir))))
1055                   (cond
1056                    ((null (nnmaildir--mark-to-flag mark))
1057                     markdir-mtime)
1058                    ((null markdir-mtime)
1059                     curdir-mtime)
1060                    ((null curdir-mtime)
1061                     ;; this should never happen...
1062                     markdir-mtime)
1063                    ((time-less-p markdir-mtime curdir-mtime)
1064                     curdir-mtime)
1065                    (t
1066                     markdir-mtime))))
1067           (set (intern (symbol-name mark) new-mmth) mtime)
1068           (when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth)))
1069             (setq ranges (assq mark old-marks))
1070             (if ranges (setq ranges (cdr ranges)))
1071             (throw 'got-ranges nil))
1072           (let ((article-list nil))
1073             ;; Consider the article marked if it either has the flag in the
1074             ;; filename, or is in the markdir.  As you'd rarely remove a
1075             ;; flag/mark, this should avoid losing information in the most
1076             ;; common usage pattern.
1077             (or
1078              (let ((flag (nnmaildir--mark-to-flag mark)))
1079                ;; If this mark has a corresponding maildir flag...
1080                (when flag
1081                  (let ((regexp
1082                         (concat "\\`[^.].*:2,[A-Z]*" (string flag))))
1083                    ;; ...then find all files with that flag.
1084                    (dolist (filename (funcall ls curdir nil regexp 'nosort))
1085                      (let* ((prefix (car (split-string filename ":2,")))
1086                             (article (nnmaildir--flist-art flist prefix)))
1087                        (when article
1088                          (push (nnmaildir--art-num article) article-list)))))))
1089              ;; Also check Gnus-specific mark directory, if it exists.
1090              (when (file-directory-p markdir)
1091                (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort))
1092                  (let ((article (nnmaildir--flist-art flist prefix)))
1093                    (when article
1094                      (push (nnmaildir--art-num article) article-list))))))
1095             (setq ranges (gnus-add-to-range ranges (sort article-list '<)))))
1096         (if (eq mark 'read) (setq read ranges)
1097           (if ranges (setq marks (cons (cons mark ranges) marks)))))
1098       (gnus-info-set-read info (gnus-range-add read missing))
1099       (gnus-info-set-marks info marks 'extend)
1100       (setf (nnmaildir--grp-mmth group) new-mmth)
1101       info)))
1102
1103 (defun nnmaildir-request-group (gname &optional server fast info)
1104   (let ((group (nnmaildir--prepare server gname))
1105         deactivate-mark)
1106     (catch 'return
1107       (unless group
1108         ;; (insert "411 no such news group\n")
1109         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1110               (concat "No such group: " gname))
1111         (throw 'return nil))
1112       (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
1113       (if fast (throw 'return t))
1114       (nnmaildir--with-nntp-buffer
1115         (erase-buffer)
1116         (insert "211 ")
1117         (princ (nnmaildir--grp-count group) nntp-server-buffer)
1118         (insert " ")
1119         (princ (nnmaildir--grp-min   group) nntp-server-buffer)
1120         (insert " ")
1121         (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
1122                nntp-server-buffer)
1123         (insert " " (gnus-replace-in-string gname " " "\\ " t) "\n")
1124         t))))
1125
1126 (defun nnmaildir-request-create-group (gname &optional server args)
1127   (nnmaildir--prepare server nil)
1128   (catch 'return
1129     (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
1130           srv-dir dir groups)
1131       (when (zerop (length gname))
1132         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1133               "Invalid (empty) group name")
1134         (throw 'return nil))
1135       (when (eq (aref "." 0) (aref gname 0))
1136         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1137               "Group names may not start with \".\"")
1138         (throw 'return nil))
1139       (when (save-match-data (string-match "[\0/\t]" gname))
1140         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1141               (concat "Invalid characters (null, tab, or /) in group name: "
1142                       gname))
1143         (throw 'return nil))
1144       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
1145       (when (intern-soft gname groups)
1146         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1147               (concat "Group already exists: " gname))
1148         (throw 'return nil))
1149       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1150       (if (file-name-absolute-p target-prefix)
1151           (setq dir (expand-file-name target-prefix))
1152         (setq dir srv-dir
1153               dir (file-truename dir)
1154               dir (concat dir target-prefix)))
1155       (setq dir (nnmaildir--subdir dir gname))
1156       (nnmaildir--mkdir dir)
1157       (nnmaildir--mkdir (nnmaildir--tmp dir))
1158       (nnmaildir--mkdir (nnmaildir--new dir))
1159       (nnmaildir--mkdir (nnmaildir--cur dir))
1160       (unless (string= target-prefix "")
1161         (make-symbolic-link (concat target-prefix gname)
1162                             (concat srv-dir gname)))
1163       (nnmaildir-request-scan 'find-new-groups))))
1164
1165 (defun nnmaildir-request-rename-group (gname new-name &optional server)
1166   (let ((group (nnmaildir--prepare server gname))
1167         (coding-system-for-write nnheader-file-coding-system)
1168         (buffer-file-coding-system nil)
1169         (file-coding-system-alist nil)
1170         srv-dir x groups)
1171     (catch 'return
1172       (unless group
1173         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1174               (concat "No such group: " gname))
1175         (throw 'return nil))
1176       (when (zerop (length new-name))
1177         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1178               "Invalid (empty) group name")
1179         (throw 'return nil))
1180       (when (eq (aref "." 0) (aref new-name 0))
1181         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1182               "Group names may not start with \".\"")
1183         (throw 'return nil))
1184       (when (save-match-data (string-match "[\0/\t]" new-name))
1185         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1186               (concat "Invalid characters (null, tab, or /) in group name: "
1187                       new-name))
1188         (throw 'return nil))
1189       (if (string-equal gname new-name) (throw 'return t))
1190       (when (intern-soft new-name
1191                          (nnmaildir--srv-groups nnmaildir--cur-server))
1192         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1193               (concat "Group already exists: " new-name))
1194         (throw 'return nil))
1195       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1196       (condition-case err
1197           (rename-file (concat srv-dir gname)
1198                        (concat srv-dir new-name))
1199         (error
1200          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1201                (concat "Error renaming link: " (prin1-to-string err)))
1202          (throw 'return nil)))
1203       (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
1204             groups (make-vector (length x) 0))
1205       (mapatoms (lambda (sym)
1206                   (unless (eq (symbol-value sym) group)
1207                     (set (intern (symbol-name sym) groups)
1208                          (symbol-value sym))))
1209                 x)
1210       (setq group (copy-sequence group))
1211       (setf (nnmaildir--grp-name group) new-name)
1212       (set (intern new-name groups) group)
1213       (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
1214       t)))
1215
1216 (defun nnmaildir-request-delete-group (gname force &optional server)
1217   (let ((group (nnmaildir--prepare server gname))
1218         pgname grp-dir target dir ls deactivate-mark)
1219     (catch 'return
1220       (unless group
1221         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1222               (concat "No such group: " gname))
1223         (throw 'return nil))
1224       (setq gname (nnmaildir--grp-name group)
1225             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1226             grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1227             target (car (file-attributes (concat grp-dir gname)))
1228             grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
1229       (unless (or force (stringp target))
1230         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1231               (concat "Not a symlink: " gname))
1232         (throw 'return nil))
1233       (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
1234           (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
1235       (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
1236       (if (not force)
1237           (progn
1238             (setq grp-dir (directory-file-name grp-dir))
1239             (nnmaildir--unlink grp-dir))
1240         (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname))
1241         (if (nnmaildir--param pgname 'read-only)
1242             (progn (delete-directory  (nnmaildir--tmp grp-dir))
1243                    (nnmaildir--unlink (nnmaildir--new grp-dir))
1244                    (delete-directory  (nnmaildir--cur grp-dir)))
1245           (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls)
1246           (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls)
1247           (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls))
1248         (setq dir (nnmaildir--nndir grp-dir))
1249         (dolist (subdir `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir)
1250                           ,@(funcall ls (nnmaildir--marks-dir dir)
1251                                      'full "\\`[^.]" 'nosort)))
1252           (nnmaildir--delete-dir-files subdir ls))
1253         (setq dir (nnmaildir--nndir grp-dir))
1254         (nnmaildir--unlink (concat dir "markfile"))
1255         (nnmaildir--unlink (concat dir "markfile{new}"))
1256         (delete-directory (nnmaildir--marks-dir dir))
1257         (delete-directory dir)
1258         (if (not (stringp target))
1259             (delete-directory grp-dir)
1260           (setq grp-dir (directory-file-name grp-dir)
1261                 dir target)
1262           (unless (eq (aref "/" 0) (aref dir 0))
1263             (setq dir (concat (file-truename
1264                                (nnmaildir--srv-dir nnmaildir--cur-server))
1265                               dir)))
1266           (delete-directory dir)
1267           (nnmaildir--unlink grp-dir)))
1268       t)))
1269
1270 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1271   (let ((group (nnmaildir--prepare server gname))
1272         srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1273         deactivate-mark)
1274     (setq insert-nov
1275           (lambda (article)
1276             (setq nov (nnmaildir--update-nov nnmaildir--cur-server group
1277                                              article))
1278             (when nov
1279               (nnmaildir--cache-nov group article nov)
1280               (setq num (nnmaildir--art-num article))
1281               (princ num nntp-server-buffer)
1282               (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1283                       (nnmaildir--art-msgid article) "\t"
1284                       (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir "
1285                       (gnus-replace-in-string gname " " "\\ " t) ":")
1286               (princ num nntp-server-buffer)
1287               (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1288     (catch 'return
1289       (unless group
1290         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1291               (if gname (concat "No such group: " gname) "No current group"))
1292         (throw 'return nil))
1293       (nnmaildir--with-nntp-buffer
1294         (erase-buffer)
1295         (setq mlist (nnmaildir--grp-mlist group)
1296               nlist (nnmaildir--grp-nlist group)
1297               gname (nnmaildir--grp-name group)
1298               srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1299               dir (nnmaildir--srvgrp-dir srv-dir gname))
1300         (cond
1301          ((null nlist))
1302          ((and fetch-old (not (numberp fetch-old)))
1303           (nnmaildir--nlist-iterate nlist 'all insert-nov))
1304          ((null articles))
1305          ((stringp (car articles))
1306           (dolist (msgid articles)
1307             (setq article (nnmaildir--mlist-art mlist msgid))
1308             (if article (funcall insert-nov article))))
1309          (t
1310           (if fetch-old
1311               ;; Assume the article range list is sorted ascending
1312               (setq stop (car articles)
1313                     start (car (last articles))
1314                     stop  (if (numberp stop)  stop  (car stop))
1315                     start (if (numberp start) start (cdr start))
1316                     stop (- stop fetch-old)
1317                     stop (if (< stop 1) 1 stop)
1318                     articles (list (cons stop start))))
1319           (nnmaildir--nlist-iterate nlist articles insert-nov)))
1320         (sort-numeric-fields 1 (point-min) (point-max))
1321         'nov))))
1322
1323 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1324   (let ((group (nnmaildir--prepare server gname))
1325         (case-fold-search t)
1326         list article dir pgname deactivate-mark)
1327     (catch 'return
1328       (unless group
1329         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1330               (if gname (concat "No such group: " gname) "No current group"))
1331         (throw 'return nil))
1332       (if (numberp num-msgid)
1333           (setq article (nnmaildir--nlist-art group num-msgid))
1334         (setq list (nnmaildir--grp-mlist group)
1335               article (nnmaildir--mlist-art list num-msgid))
1336         (if article (setq num-msgid (nnmaildir--art-num article))
1337           (catch 'found
1338             (mapatoms
1339               (lambda (group-sym)
1340                 (setq group (symbol-value group-sym)
1341                       list (nnmaildir--grp-mlist group)
1342                       article (nnmaildir--mlist-art list num-msgid))
1343                 (when article
1344                   (setq num-msgid (nnmaildir--art-num article))
1345                   (throw 'found nil)))
1346               (nnmaildir--srv-groups nnmaildir--cur-server))))
1347         (unless article
1348           (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1349           (throw 'return nil)))
1350       (setq gname (nnmaildir--grp-name group)
1351             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1352             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1353             dir (nnmaildir--srvgrp-dir dir gname)
1354             dir (if (nnmaildir--param pgname 'read-only)
1355                     (nnmaildir--new dir) (nnmaildir--cur dir))
1356             nnmaildir-article-file-name
1357             (concat dir
1358                     (nnmaildir--art-prefix article)
1359                     (nnmaildir--art-suffix article)))
1360       (unless (file-exists-p nnmaildir-article-file-name)
1361         (nnmaildir--expired-article group article)
1362         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1363               "Article has expired")
1364         (throw 'return nil))
1365       (with-current-buffer (or to-buffer nntp-server-buffer)
1366         (erase-buffer)
1367         (nnheader-insert-file-contents nnmaildir-article-file-name))
1368       (cons gname num-msgid))))
1369
1370 (defun nnmaildir-request-post (&optional server)
1371   (let (message-required-mail-headers)
1372     (funcall message-send-mail-function)))
1373
1374 (defun nnmaildir-request-replace-article (number gname buffer)
1375   (let ((group (nnmaildir--prepare nil gname))
1376         (coding-system-for-write nnheader-file-coding-system)
1377         (buffer-file-coding-system nil)
1378         (file-coding-system-alist nil)
1379         dir file article suffix tmpfile deactivate-mark)
1380     (catch 'return
1381       (unless group
1382         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1383               (concat "No such group: " gname))
1384         (throw 'return nil))
1385       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1386                               'read-only)
1387         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1388               (concat "Read-only group: " group))
1389         (throw 'return nil))
1390       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1391             dir (nnmaildir--srvgrp-dir dir gname)
1392             article (nnmaildir--nlist-art group number))
1393       (unless article
1394         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1395               (concat "No such article: " (number-to-string number)))
1396         (throw 'return nil))
1397       (setq suffix (nnmaildir--art-suffix article)
1398             file (nnmaildir--art-prefix article)
1399             tmpfile (concat (nnmaildir--tmp dir) file))
1400       (when (file-exists-p tmpfile)
1401         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1402               (concat "File exists: " tmpfile))
1403         (throw 'return nil))
1404       (with-current-buffer buffer
1405         (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1406                           'excl))
1407       (unix-sync) ;; no fsync :(
1408       (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1409       t)))
1410
1411 (defun nnmaildir-request-move-article (article gname server accept-form
1412                                                &optional last move-is-internal)
1413   (let ((group (nnmaildir--prepare server gname))
1414         pgname suffix result nnmaildir--file deactivate-mark)
1415     (catch 'return
1416       (unless group
1417         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1418               (concat "No such group: " gname))
1419         (throw 'return nil))
1420       (setq gname (nnmaildir--grp-name group)
1421             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1422             article (nnmaildir--nlist-art group article))
1423       (unless article
1424         (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1425         (throw 'return nil))
1426       (setq suffix (nnmaildir--art-suffix article)
1427             nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1428             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1429             nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1430                                 (nnmaildir--new nnmaildir--file)
1431                               (nnmaildir--cur nnmaildir--file))
1432             nnmaildir--file (concat nnmaildir--file
1433                                     (nnmaildir--art-prefix article)
1434                                     suffix))
1435       (unless (file-exists-p nnmaildir--file)
1436         (nnmaildir--expired-article group article)
1437         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1438               "Article has expired")
1439         (throw 'return nil))
1440       (nnmaildir--with-move-buffer
1441         (erase-buffer)
1442         (nnheader-insert-file-contents nnmaildir--file)
1443         (setq result (eval accept-form)))
1444       (unless (or (null result) (nnmaildir--param pgname 'read-only))
1445         (nnmaildir--unlink nnmaildir--file)
1446         (nnmaildir--expired-article group article))
1447       result)))
1448
1449 (defun nnmaildir-request-accept-article (gname &optional server last)
1450   (let ((group (nnmaildir--prepare server gname))
1451         (coding-system-for-write nnheader-file-coding-system)
1452         (buffer-file-coding-system nil)
1453         (file-coding-system-alist nil)
1454         srv-dir dir file time tmpfile curfile 24h article)
1455     (catch 'return
1456       (unless group
1457         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1458               (concat "No such group: " gname))
1459         (throw 'return nil))
1460       (setq gname (nnmaildir--grp-name group))
1461       (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1462                               'read-only)
1463         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1464               (concat "Read-only group: " gname))
1465         (throw 'return nil))
1466       (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1467             dir (nnmaildir--srvgrp-dir srv-dir gname)
1468             time (current-time)
1469             file (format-time-string "%s." time))
1470       (unless (string-equal nnmaildir--delivery-time file)
1471         (setq nnmaildir--delivery-time file
1472               nnmaildir--delivery-count 0))
1473       (when (and (consp (cdr time))
1474                  (consp (cddr time)))
1475         (setq file (concat file "M" (number-to-string (caddr time)))))
1476       (setq file (concat file nnmaildir--delivery-pid)
1477             file (concat file "Q" (number-to-string nnmaildir--delivery-count))
1478             file (concat file "." (nnmaildir--system-name))
1479             tmpfile (concat (nnmaildir--tmp dir) file)
1480             curfile (concat (nnmaildir--cur dir) file ":2,"))
1481       (when (file-exists-p tmpfile)
1482         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1483               (concat "File exists: " tmpfile))
1484         (throw 'return nil))
1485       (when (file-exists-p curfile)
1486         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1487               (concat "File exists: " curfile))
1488         (throw 'return nil))
1489       (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count)
1490             24h (run-with-timer 86400 nil
1491                                 (lambda ()
1492                                   (nnmaildir--unlink tmpfile)
1493                                   (setf (nnmaildir--srv-error
1494                                           nnmaildir--cur-server)
1495                                         "24-hour timer expired")
1496                                   (throw 'return nil))))
1497       (condition-case nil (add-name-to-file nnmaildir--file tmpfile)
1498         (error
1499          (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1500                            'excl)
1501          (when (fboundp 'unix-sync)
1502            (unix-sync)))) ;; no fsync :(
1503       (nnheader-cancel-timer 24h)
1504       (condition-case err
1505           (add-name-to-file tmpfile curfile)
1506         (error
1507          (setf (nnmaildir--srv-error nnmaildir--cur-server)
1508                (concat "Error linking: " (prin1-to-string err)))
1509          (nnmaildir--unlink tmpfile)
1510          (throw 'return nil)))
1511       (nnmaildir--unlink tmpfile)
1512       (setq article (make-nnmaildir--art :prefix file :suffix ":2,"))
1513       (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1514           (cons gname (nnmaildir--art-num article))))))
1515
1516 (defun nnmaildir-save-mail (group-art)
1517   (catch 'return
1518     (unless group-art
1519       (throw 'return nil))
1520     (let (ga gname x groups nnmaildir--file deactivate-mark)
1521       (save-excursion
1522         (goto-char (point-min))
1523         (save-match-data
1524           (while (looking-at "From ")
1525             (replace-match "X-From-Line: ")
1526             (forward-line 1))))
1527       (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1528             ga (car group-art) group-art (cdr group-art)
1529             gname (car ga))
1530       (or (intern-soft gname groups)
1531           (nnmaildir-request-create-group gname)
1532           (throw 'return nil)) ;; not that nnmail bothers to check :(
1533       (unless (nnmaildir-request-accept-article gname)
1534         (throw 'return nil))
1535       (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1536             nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1537             x (nnmaildir--prepare nil gname)
1538             x (nnmaildir--grp-nlist x)
1539             x (cdar x)
1540             nnmaildir--file (concat nnmaildir--file
1541                                     (nnmaildir--art-prefix x)
1542                                     (nnmaildir--art-suffix x)))
1543       (delq nil
1544             (mapcar
1545              (lambda (ga)
1546                (setq gname (car ga))
1547                (and (or (intern-soft gname groups)
1548                         (nnmaildir-request-create-group gname))
1549                     (nnmaildir-request-accept-article gname)
1550                     ga))
1551              group-art)))))
1552
1553 (defun nnmaildir-active-number (gname)
1554   0)
1555
1556 (declare-function gnus-group-mark-article-read "gnus-group" (group article))
1557
1558 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1559   (let ((no-force (not force))
1560         (group (nnmaildir--prepare server gname))
1561         pgname time boundary bound-iter high low target dir nlist nlist2
1562         stop article didnt nnmaildir--file nnmaildir-article-file-name
1563         deactivate-mark)
1564     (catch 'return
1565       (unless group
1566         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1567               (if gname (concat "No such group: " gname) "No current group"))
1568         (throw 'return (gnus-uncompress-range ranges)))
1569       (setq gname (nnmaildir--grp-name group)
1570             pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1571       (if (nnmaildir--param pgname 'read-only)
1572           (throw 'return (gnus-uncompress-range ranges)))
1573       (setq time (nnmaildir--param pgname 'expire-age))
1574       (unless time
1575         (setq time (or (and nnmail-expiry-wait-function
1576                             (funcall nnmail-expiry-wait-function gname))
1577                        nnmail-expiry-wait))
1578         (if (eq time 'immediate)
1579             (setq time 0)
1580           (if (numberp time)
1581               (setq time (round (* time 86400))))))
1582       (when no-force
1583         (unless (integerp time) ;; handle 'never
1584           (throw 'return (gnus-uncompress-range ranges)))
1585         (setq boundary (current-time)
1586               high (- (car boundary) (/ time 65536))
1587               low (- (cadr boundary) (% time 65536)))
1588         (if (< low 0)
1589             (setq low (+ low 65536)
1590                   high (1- high)))
1591         (setcar (cdr boundary) low)
1592         (setcar boundary high))
1593       (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1594             dir (nnmaildir--srvgrp-dir dir gname)
1595             dir (nnmaildir--cur dir)
1596             nlist (nnmaildir--grp-nlist group)
1597             ranges (reverse ranges))
1598       (nnmaildir--with-move-buffer
1599         (nnmaildir--nlist-iterate
1600          nlist ranges
1601          (lambda (article)
1602            (setq nnmaildir--file (nnmaildir--art-prefix article)
1603                  nnmaildir--file (concat dir nnmaildir--file
1604                                          (nnmaildir--art-suffix article))
1605                  time (file-attributes nnmaildir--file))
1606            (cond
1607             ((null time)
1608              (nnmaildir--expired-article group article))
1609             ((and no-force
1610                   (progn
1611                     (setq time (nth 5 time)
1612                           bound-iter boundary)
1613                     (while (and bound-iter time
1614                                 (= (car bound-iter) (car time)))
1615                       (setq bound-iter (cdr bound-iter)
1616                             time (cdr time)))
1617                     (and bound-iter time
1618                          (car-less-than-car bound-iter time))))
1619              (setq didnt (cons (nnmaildir--art-num article) didnt)))
1620             (t
1621              (setq nnmaildir-article-file-name nnmaildir--file
1622                    target (if force nil
1623                             (save-excursion
1624                               (save-restriction
1625                                 (nnmaildir--param pgname 'expire-group)))))
1626              (when (and (stringp target)
1627                         (not (string-equal target pgname))) ;; Move it.
1628                (erase-buffer)
1629                (nnheader-insert-file-contents nnmaildir--file)
1630                (let ((group-art (gnus-request-accept-article
1631                                  target nil nil 'no-encode)))
1632                  (when (consp group-art)
1633                    ;; Maybe also copy: dormant forward reply save tick
1634                    ;; (gnus-add-mark? gnus-request-set-mark?)
1635                    (gnus-group-mark-article-read target (cdr group-art)))))
1636              (if (equal target pgname)
1637                  ;; Leave it here.
1638                  (setq didnt (cons (nnmaildir--art-num article) didnt))
1639                (nnmaildir--unlink nnmaildir--file)
1640                (nnmaildir--expired-article group article))))))
1641         (erase-buffer))
1642       didnt)))
1643
1644 (defun nnmaildir-request-set-mark (gname actions &optional server)
1645   (let* ((group (nnmaildir--prepare server gname))
1646          (curdir (nnmaildir--cur
1647                   (nnmaildir--srvgrp-dir
1648                    (nnmaildir--srv-dir nnmaildir--cur-server)
1649                    gname)))
1650          (coding-system-for-write nnheader-file-coding-system)
1651          (buffer-file-coding-system nil)
1652          (file-coding-system-alist nil)
1653          del-mark del-action add-action set-action marksdir nlist
1654          ranges begin end article all-marks todo-marks mdir mfile
1655          pgname ls permarkfile deactivate-mark)
1656     (setq del-mark
1657           (lambda (mark)
1658             (let ((prefix (nnmaildir--art-prefix article))
1659                   (suffix (nnmaildir--art-suffix article))
1660                   (flag (nnmaildir--mark-to-flag mark)))
1661               (when flag
1662                 ;; If this mark corresponds to a flag, remove the flag from
1663                 ;; the file name.
1664                 (nnmaildir--article-set-flags
1665                  article (nnmaildir--remove-flag flag suffix) curdir))
1666               ;; We still want to delete the hardlink in the marks dir if
1667               ;; present, regardless of whether this mark has a maildir flag or
1668               ;; not, to avoid getting out of sync.
1669               (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
1670                     mfile (concat mfile prefix))
1671               (nnmaildir--unlink mfile)))
1672           del-action (lambda (article) (mapcar del-mark todo-marks))
1673           add-action
1674           (lambda (article)
1675             (mapcar
1676              (lambda (mark)
1677                (let ((prefix (nnmaildir--art-prefix article))
1678                      (suffix (nnmaildir--art-suffix article))
1679                      (flag (nnmaildir--mark-to-flag mark)))
1680                  (if flag
1681                      ;; If there is a corresponding maildir flag, just rename
1682                      ;; the file.
1683                      (nnmaildir--article-set-flags
1684                       article (nnmaildir--add-flag flag suffix) curdir)
1685                    ;; Otherwise, use nnmaildir-specific marks dir.
1686                    (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
1687                          permarkfile (concat mdir ":")
1688                          mfile (concat mdir prefix))
1689                    (nnmaildir--condcase err (add-name-to-file permarkfile mfile)
1690                      (cond
1691                       ((nnmaildir--eexist-p err))
1692                       ((nnmaildir--enoent-p err)
1693                        (nnmaildir--mkdir mdir)
1694                        (nnmaildir--mkfile permarkfile)
1695                        (add-name-to-file permarkfile mfile))
1696                       ((nnmaildir--emlink-p err)
1697                        (let ((permarkfilenew (concat permarkfile "{new}")))
1698                          (nnmaildir--mkfile permarkfilenew)
1699                          (rename-file permarkfilenew permarkfile 'replace)
1700                          (add-name-to-file permarkfile mfile)))
1701                       (t (signal (car err) (cdr err))))))))
1702              todo-marks))
1703           set-action (lambda (article)
1704                        (funcall add-action article)
1705                        (mapcar (lambda (mark)
1706                                  (unless (memq mark todo-marks)
1707                                    (funcall del-mark mark)))
1708                                all-marks)))
1709     (catch 'return
1710       (unless group
1711         (setf (nnmaildir--srv-error nnmaildir--cur-server)
1712               (concat "No such group: " gname))
1713         (dolist (action actions)
1714           (setq ranges (gnus-range-add ranges (car action))))
1715         (throw 'return ranges))
1716       (setq nlist (nnmaildir--grp-nlist group)
1717             marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1718             marksdir (nnmaildir--srvgrp-dir marksdir gname)
1719             marksdir (nnmaildir--nndir marksdir)
1720             marksdir (nnmaildir--marks-dir marksdir)
1721             gname (nnmaildir--grp-name group)
1722             pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1723             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1724             all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1725             all-marks (gnus-delete-duplicates
1726                        ;; get mark names from mark dirs and from flag
1727                        ;; mappings
1728                        (append
1729                         (mapcar 'cdr nnmaildir-flag-mark-mapping)
1730                         (mapcar 'intern all-marks))))
1731       (dolist (action actions)
1732         (setq ranges (car action)
1733               todo-marks (caddr action))
1734         (dolist (mark todo-marks)
1735           (add-to-list 'all-marks mark))
1736         (if (numberp (cdr ranges)) (setq ranges (list ranges)))
1737         (nnmaildir--nlist-iterate nlist ranges
1738                                   (cond ((eq 'del (cadr action)) del-action)
1739                                         ((eq 'add (cadr action)) add-action)
1740                                         ((eq 'set (cadr action)) set-action))))
1741       nil)))
1742
1743 (defun nnmaildir-close-group (gname &optional server)
1744   (let ((group (nnmaildir--prepare server gname))
1745         pgname ls dir msgdir files flist dirs)
1746     (if (null group)
1747         (progn
1748           (setf (nnmaildir--srv-error nnmaildir--cur-server)
1749                 (concat "No such group: " gname))
1750           nil)
1751       (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1752             ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1753             dir (nnmaildir--srv-dir nnmaildir--cur-server)
1754             dir (nnmaildir--srvgrp-dir dir gname)
1755             msgdir (if (nnmaildir--param pgname 'read-only)
1756                        (nnmaildir--new dir) (nnmaildir--cur dir))
1757             dir (nnmaildir--nndir dir)
1758             dirs (cons (nnmaildir--nov-dir dir)
1759                        (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1760                                 'nosort))
1761             dirs (mapcar
1762                   (lambda (dir)
1763                     (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
1764                   dirs)
1765             files (funcall ls msgdir nil "\\`[^.]" 'nosort)
1766             flist (nnmaildir--up2-1 (length files))
1767             flist (make-vector flist 0))
1768       (save-match-data
1769         (dolist (file files)
1770           (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1771           (intern (match-string 1 file) flist)))
1772       (dolist (dir dirs)
1773         (setq files (cdr dir)
1774               dir (file-name-as-directory (car dir)))
1775         (dolist (file files)
1776           (unless (or (intern-soft file flist) (string= file ":"))
1777             (setq file (concat dir file))
1778             (delete-file file))))
1779       t)))
1780
1781 (defun nnmaildir-close-server (&optional server)
1782   (let (flist ls dirs dir files file x)
1783     (nnmaildir--prepare server nil)
1784     (when nnmaildir--cur-server
1785       (setq server nnmaildir--cur-server
1786             nnmaildir--cur-server nil)
1787       (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
1788   t)
1789
1790 (defun nnmaildir-request-close ()
1791   (let (servers buffer)
1792     (mapatoms (lambda (server)
1793                 (setq servers (cons (symbol-name server) servers)))
1794               nnmaildir--servers)
1795     (mapc 'nnmaildir-close-server servers)
1796     (setq buffer (get-buffer " *nnmaildir work*"))
1797     (if buffer (kill-buffer buffer))
1798     (setq buffer (get-buffer " *nnmaildir nov*"))
1799     (if buffer (kill-buffer buffer))
1800     (setq buffer (get-buffer " *nnmaildir move*"))
1801     (if buffer (kill-buffer buffer)))
1802   t)
1803
1804 (provide 'nnmaildir)
1805
1806 ;; Local Variables:
1807 ;; indent-tabs-mode: t
1808 ;; fill-column: 77
1809 ;; End:
1810
1811 ;;; nnmaildir.el ends here