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