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

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