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

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