git.chise.org Git - elisp/gnus.git-/blob - lisp/nnimap.el

   1 ;;; nnimap.el --- imap backend for Gnus
   2 ;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
   3
   4 ;; Author: Simon Josefsson <jas@pdc.kth.se>
   5 ;;         Jim Radford <radford@robby.caltech.edu>
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Todo, major things:
  28 ;;
  29 ;;   o Fix Gnus to view correct number of unread/total articles in group buffer
  30 ;;   o Fix Gnus to handle leading '.' in group names (fixed?)
  31 ;;   o Finish disconnected mode (moving articles between mailboxes unplugged)
  32 ;;   o Sieve
  33 ;;   o MIME (partial article fetches)
  34 ;;   o Split to other backends, different split rules for different
  35 ;;     servers/inboxes
  36 ;;
  37 ;; Todo, minor things:
  38 ;;
  39 ;;   o Support escape characters in `message-tokenize-header'
  40 ;;   o Split-fancy.
  41 ;;   o Support NOV nnmail-extra-headers.
  42 ;;   o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B)
  43 ;;   o Dont uid fetch 1,* in nnimap-retrive-groups (slow)
  44 ;;   o Split up big fetches (1,* header especially) in smaller chunks
  45 ;;   o What do I do with gnus-newsgroup-*?
  46 ;;   o Tell Gnus about new groups (how can we tell?)
  47 ;;   o Respooling (fix Gnus?) (unnecessery?)
  48 ;;   o Add support for the following: (if applicable)
  49 ;;       request-list-newsgroups, request-regenerate
  50 ;;       list-active-group,
  51 ;;       request-associate-buffer, request-restore-buffer,
  52 ;;   o Do The Right Thing when UIDVALIDITY changes (what's the right thing?)
  53 ;;   o Support RFC2221 (Login referrals)
  54 ;;   o IMAP2BIS compatibility? (RFC2061)
  55 ;;   o ACAP stuff (perhaps a different project, would be nice to ACAPify
  56 ;;     .newsrc.eld)
  57 ;;   o What about Gnus's article editing, can we support it?
  58 ;;   o Use \Draft to support the draft group??
  59
  60 ;;; Code:
  61
  62 (require 'cl)
  63 (eval-and-compile (require 'imap))
  64
  65 (require 'nnoo)
  66 (require 'nnmail)
  67 (require 'nnheader)
  68 (require 'gnus)
  69 (require 'gnus-async)
  70 (require 'gnus-range)
  71 (require 'gnus-start)
  72 (require 'gnus-int)
  73
  74 (nnoo-declare nnimap)
  75
  76 (defconst nnimap-version "nnimap 0.131")
  77
  78 (defvoo nnimap-address nil
  79   "Address of physical IMAP server.  If nil, use the virtual server's name.")
  80
  81 (defvoo nnimap-server-port nil
  82   "Port number on physical IMAP server.
  83 If nil, defaults to 993 for SSL connections and 143 otherwise.")
  84
  85 ;; Splitting variables
  86
  87 (defvar nnimap-split-crosspost t
  88   "If non-nil, do crossposting if several split methods match the mail.
  89 If nil, the first match found will be used.")
  90
  91 (defvar nnimap-split-inbox nil
  92   "*Name of mailbox to split mail from.
  93
  94 Mail is read from this mailbox and split according to rules in
  95 `nnimap-split-rules'.
  96
  97 This can be a string or a list of strings.")
  98
  99 (defvar nnimap-split-rule nil
 100   "*Mail will be split according to theese rules.
 101
 102 Mail is read from mailbox(es) specified in `nnimap-split-inbox'.
 103
 104 If you'd like, for instance, one mail group for mail from the
 105 \"gnus-imap\" mailing list, one group for junk mail and leave
 106 everything else in the incoming mailbox, you could do something like
 107 this:
 108
 109 (setq nnimap-split-rule '((\"INBOX.gnus-imap\"   \"From:.*gnus-imap\")
 110                           (\"INBOX.junk\"        \"Subject:.*buy\")))
 111
 112 As you can see, `nnimap-split-rule' is a list of lists, where the first
 113 element in each \"rule\" is the name of the IMAP mailbox, and the
 114 second is a regexp that nnimap will try to match on the header to find
 115 a fit.
 116
 117 The first element can also be a list. In that case, the first element
 118 is the server the second element is the group on that server in which
 119 the matching article will be stored.
 120
 121 The second element can also be a function.  In that case, it will be
 122 called narrowed to the headers with the first element of the rule as
 123 the argument.  It should return a non-nil value if it thinks that the
 124 mail belongs in that group.")
 125
 126 ;; Authorization / Privacy variables
 127
 128 (defvoo nnimap-auth-method nil
 129   "Obsolete.")
 130
 131 (defvoo nnimap-stream nil
 132   "How nnimap will connect to the server.
 133
 134 The default, nil, will try to use the \"best\" method the server can
 135 handle.
 136
 137 Change this if
 138
 139 1) you want to connect with SSL. The SSL integration with IMAP is
 140    brain-dead so you'll have to tell it specifically.
 141
 142 2) your server is more capable than your environment -- i.e. your
 143    server accept Kerberos login's but you haven't installed the
 144    `imtest' program or your machine isn't configured for Kerberos.
 145
 146 Possible choices: kerberos4, ssl, network")
 147
 148 (defvoo nnimap-authenticator nil
 149   "How nnimap authenticate itself to the server.
 150
 151 The default, nil, will try to use the \"best\" method the server can
 152 handle.
 153
 154 There is only one reason for fiddling with this variable, and that is
 155 if your server is more capable than your environment -- i.e. you
 156 connect to a server that accept Kerberos login's but you haven't
 157 installed the `imtest' program or your machine isn't configured for
 158 Kerberos.
 159
 160 Possible choices: kerberos4, cram-md5, login, anonymous.")
 161
 162 (defvoo nnimap-directory (nnheader-concat gnus-directory "overview/")
 163   "Directory to keep NOV cache files for nnimap groups. See also
 164 `nnimap-nov-file-name'.")
 165
 166 (defvoo nnimap-nov-file-name "nnimap."
 167   "NOV cache base filename. The group name and
 168 `nnimap-nov-file-name-suffix' will be appended. A typical complete
 169 file name would be ~/News/overview/nnimap.pdc.INBOX.ding.nov, or
 170 ~/News/overview/nnimap/pdc/INBOX/ding/nov if
 171 `nnmail-use-long-file-names' is nil")
 172
 173 (defvoo nnimap-nov-file-name-suffix ".novcache"
 174   "Suffix for NOV cache base filename.")
 175
 176 (defvoo nnimap-nov-is-evil nil
 177   "If non-nil, nnimap will never generate or use a local nov database
 178 for this backend.  Using nov databases will speed up header fetching
 179 considerably. Unlike other backends, you do not need to take special
 180 care if you flip this variable.")
 181
 182 (defvoo nnimap-expunge-on-close 'always ; 'ask, 'never
 183   "When a IMAP group with articles marked for deletion is closed, this
 184 variable determine if nnimap should actually remove the articles or
 185 not.
 186
 187 If always, nnimap always perform a expunge when closing the group.
 188 If never, nnimap never expunges articles marked for deletion.
 189 If ask, nnimap will ask you if you wish to expunge marked articles.
 190
 191 When setting this variable to `never', you can only expunge articles
 192 by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.")
 193
 194 (defvoo nnimap-list-pattern "*"
 195   "A string LIMIT or list of strings with mailbox wildcards used to
 196 limit available groups. Se below for available wildcards.
 197
 198 The LIMIT string can be a cons cell (REFERENCE . LIMIT), where
 199 REFERENCE will be passed as the first parameter to LIST/LSUB. The
 200 semantics of this are server specific, on the University of Washington
 201 server you can specify a directory.
 202
 203 Example:
 204  '(\"INBOX\" \"mail/*\" (\"~friend/mail/\" . \"list/*\"))
 205
 206 There are two wildcards * and %. * matches everything, % matches
 207 everything in the current hierarchy.")
 208
 209 (defvoo nnimap-news-groups nil
 210   "IMAP support a news-like mode, also known as bulletin board mode,
 211 where replies is sent via IMAP instead of SMTP.
 212
 213 This variable should contain a regexp matching groups where you wish
 214 replies to be stored to the mailbox directly.
 215
 216 Example:
 217   '(\"^[^I][^N][^B][^O][^X].*$\")
 218
 219 This will match all groups not beginning with \"INBOX\".
 220
 221 Note that there is nothing technically different between mail-like and
 222 news-like mailboxes. If you wish to have a group with todo items or
 223 similar which you wouldn't want to set up a mailing list for, you can
 224 use this to make replies go directly to the group.")
 225
 226 (defvoo nnimap-server-address nil
 227   "Obsolete. Use `nnimap-address'.")
 228
 229 (defcustom nnimap-authinfo-file "~/.authinfo"
 230   "Authorization information for IMAP servers.  In .netrc format."
 231   :type
 232   '(choice file
 233            (repeat :tag "Entries"
 234                    :menu-tag "Inline"
 235                    (list :format "%v"
 236                          :value ("" ("login" . "") ("password" . ""))
 237                          (string :tag "Host")
 238                          (checklist :inline t
 239                                     (cons :format "%v"
 240                                           (const :format "" "login")
 241                                           (string :format "Login: %v"))
 242                                     (cons :format "%v"
 243                                           (const :format "" "password")
 244                                           (string :format "Password: %v")))))))
 245
 246 (defcustom nnimap-prune-cache t
 247   "If non-nil, nnimap check wheter articles still exist on server
 248 before using data stored in NOV cache."
 249   :type 'boolean)
 250
 251 (defvar nnimap-request-list-method 'imap-mailbox-list
 252   "Method to use to request a list of all folders from the server.
 253 If this is 'imap-mailbox-lsub, then use a server-side subscription list to
 254 restrict visible folders.")
 255
 256 ;; Internal variables:
 257
 258 (defvar nnimap-debug "*nnimap-debug*")
 259 (defvar nnimap-current-move-server nil)
 260 (defvar nnimap-current-move-group nil)
 261 (defvar nnimap-current-move-article nil)
 262 (defvar nnimap-length)
 263 (defvar nnimap-progress-chars '(?| ?/ ?- ?\\))
 264 (defvar nnimap-progress-how-often 20)
 265 (defvar nnimap-counter)
 266 (defvar nnimap-callback-callback-function nil
 267   "Gnus callback the nnimap asynchronous callback should call.")
 268 (defvar nnimap-callback-buffer nil
 269   "Which buffer the asynchronous article prefetch callback should work in.")
 270
 271 ;; Various server variables.
 272
 273 \f
 274 ;; Internal variables.
 275 (defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers.
 276 (defvar nnimap-current-server nil)      ;; Current server
 277 (defvar nnimap-server-buffer nil)       ;; Current servers' buffer
 278
 279 (nnoo-define-basics nnimap)
 280
 281 ;; Utility functions:
 282
 283 (defun nnimap-replace-in-string (string regexp to)
 284   "Replace substrings in STRING matching REGEXP with TO."
 285   (if (string-match regexp string)
 286       (concat (substring string 0 (match-beginning 0))
 287               to
 288               (nnimap-replace-in-string (substring string (match-end 0))
 289                                  regexp to))
 290     string))
 291
 292 (defsubst nnimap-get-server-buffer (server)
 293   "Return buffer for SERVER, if nil use current server."
 294   (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist)))
 295
 296 (defun nnimap-possibly-change-server (server)
 297   "Return buffer for SERVER, changing the current server as a side-effect.
 298 If SERVER is nil, uses the current server."
 299   (setq nnimap-current-server (or server nnimap-current-server)
 300         nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server)))
 301
 302 (defun nnimap-verify-uidvalidity (group server)
 303   "Verify stored uidvalidity match current one in GROUP on SERVER."
 304   (let* ((gnusgroup (gnus-group-prefixed-name
 305                      group (gnus-server-to-method
 306                             (format "nnimap:%s" server))))
 307          (new-uidvalidity (imap-mailbox-get 'uidvalidity))
 308          (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)))
 309     (if old-uidvalidity
 310         (if (not (equal old-uidvalidity new-uidvalidity))
 311             nil ;; uidvalidity clash
 312           (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity)
 313           t)
 314       (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity))
 315       t)))
 316
 317 (defun nnimap-find-minmax-uid (group &optional examine)
 318   "Find lowest and highest active article nummber in GROUP.
 319 If EXAMINE is non-nil the group is selected read-only."
 320   (with-current-buffer nnimap-server-buffer
 321     (when (imap-mailbox-select group examine)
 322       (let (minuid maxuid)
 323         (when (> (imap-mailbox-get 'exists) 0)
 324           (imap-fetch "1,*" "UID" nil 'nouidfetch)
 325           (imap-message-map (lambda (uid Uid)
 326                               (setq minuid (if minuid (min minuid uid) uid)
 327                                     maxuid (if maxuid (max maxuid uid) uid)))
 328                             'UID))
 329         (list (imap-mailbox-get 'exists) minuid maxuid)))))
 330
 331 (defun nnimap-possibly-change-group (group &optional server)
 332   "Make GROUP the current group, and SERVER the current server."
 333   (when (nnimap-possibly-change-server server)
 334     (with-current-buffer nnimap-server-buffer
 335       (if (or (null group) (imap-current-mailbox-p group))
 336           imap-current-mailbox
 337         (if (imap-mailbox-select group)
 338             (if (or (nnimap-verify-uidvalidity
 339                      group (or server nnimap-current-server))
 340                     (zerop (imap-mailbox-get 'exists group))
 341                     (yes-or-no-p
 342                      (format
 343                       "nnimap: Group %s is not uidvalid. Continue? " group)))
 344                 imap-current-mailbox
 345               (imap-mailbox-unselect)
 346               (error "nnimap: Group %s is not uid-valid." group))
 347           (nnheader-report 'nnimap (imap-error-text)))))))
 348
 349 (defun nnimap-replace-whitespace (string)
 350   "Return STRING with all whitespace replaced with space."
 351   (when string
 352     (while (string-match "[\r\n\t]+" string)
 353       (setq string (replace-match " " t t string)))
 354     string))
 355
 356 ;; Required backend functions
 357
 358 (defun nnimap-retrieve-headers-progress ()
 359   "Hook to insert NOV line for current article into `nntp-server-buffer'."
 360   (and (numberp nnmail-large-newsgroup)
 361        (zerop (% (incf nnimap-counter) nnimap-progress-how-often))
 362        (> nnimap-length nnmail-large-newsgroup)
 363        (nnheader-message 6 "nnimap: Retrieving headers... %c"
 364                          (nth (/ (% nnimap-counter
 365                                     (* (length nnimap-progress-chars)
 366                                        nnimap-progress-how-often))
 367                                  nnimap-progress-how-often)
 368                               nnimap-progress-chars)))
 369   (with-current-buffer nntp-server-buffer
 370     (nnheader-insert-nov
 371      (with-current-buffer nnimap-server-buffer
 372        (make-full-mail-header
 373         imap-current-message
 374         (or (nnimap-replace-whitespace
 375              (imap-message-envelope-subject imap-current-message))
 376             "(none)")
 377         (nnimap-replace-whitespace
 378          (imap-envelope-from
 379           (car-safe (imap-message-envelope-from
 380                      imap-current-message))))
 381         (nnimap-replace-whitespace
 382          (imap-message-envelope-date imap-current-message))
 383         (nnimap-replace-whitespace
 384          (imap-message-envelope-message-id imap-current-message))
 385         (nnimap-replace-whitespace
 386          (let ((str (if (imap-capability 'IMAP4rev1)
 387                         (nth 2 (assoc
 388                                 "HEADER.FIELDS REFERENCES"
 389                                 (imap-message-get
 390                                  imap-current-message 'BODYDETAIL)))
 391                       (imap-message-get imap-current-message
 392                                         'RFC822.HEADER))))
 393            (if (> (length str) (length "References: "))
 394                (substring str (length "References: "))
 395              (if (and (setq str (imap-message-envelope-in-reply-to
 396                                  imap-current-message))
 397                       (string-match "<[^>]+>" str))
 398                  (substring str (match-beginning 0) (match-end 0))))))
 399         (imap-message-get imap-current-message 'RFC822.SIZE)
 400         (imap-body-lines (imap-message-body imap-current-message))
 401         nil ;; xref
 402         nil))))) ;; extra-headers
 403
 404 (defun nnimap-retrieve-which-headers (articles fetch-old)
 405   "Get a range of articles to fetch based on ARTICLES and FETCH-OLD."
 406   (with-current-buffer nnimap-server-buffer
 407     (if (numberp (car-safe articles))
 408         (imap-search
 409          (concat "UID "
 410                  (nnimap-range-to-string
 411                   (gnus-compress-sequence
 412                    (append (gnus-uncompress-sequence
 413                             (and fetch-old
 414                                  (cons (if (numberp fetch-old)
 415                                            (max 1 (- (car articles) fetch-old))
 416                                          1)
 417                                        (1- (car articles)))))
 418                            articles)))))
 419       (mapcar (lambda (msgid)
 420                 (imap-search
 421                  (format "HEADER Message-Id %s" msgid)))
 422               articles))))
 423
 424 (defun nnimap-group-overview-filename (group server)
 425   "Make pathname for GROUP on SERVER."
 426   (let ((dir (file-name-as-directory (expand-file-name nnimap-directory)))
 427         (file (nnheader-translate-file-chars
 428                (concat nnimap-nov-file-name
 429                        (if (equal server "")
 430                            "unnamed"
 431                          server) "." group nnimap-nov-file-name-suffix) t)))
 432     (if (or nnmail-use-long-file-names
 433             (file-exists-p (concat dir file)))
 434         (concat dir file)
 435       (concat dir (encode-coding-string
 436                    (nnheader-replace-chars-in-string file ?. ?/)
 437                    nnmail-pathname-coding-system)))))
 438
 439 (defun nnimap-retrieve-headers-from-file (group server)
 440   (with-current-buffer nntp-server-buffer
 441     (let ((nov (nnimap-group-overview-filename group server)))
 442       (when (file-exists-p nov)
 443         (nnheader-insert-file-contents nov)
 444         (set-buffer-modified-p nil)
 445         (let ((min (progn (goto-char (point-min))
 446                           (when (not (eobp))
 447                             (read (current-buffer)))))
 448               (max (progn (goto-char (point-max))
 449                           (forward-line -1)
 450                           (when (not (bobp))
 451                             (read (current-buffer))))))
 452           (if (and (numberp min) (numberp max))
 453               (cons min max)
 454             ;; junk, remove it, it's saved later
 455             (erase-buffer)
 456             nil))))))
 457
 458 (defun nnimap-retrieve-headers-from-server (articles group server)
 459   (with-current-buffer nnimap-server-buffer
 460     (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress))
 461           (nnimap-length (gnus-range-length articles))
 462           (nnimap-counter 0))
 463       (imap-fetch (nnimap-range-to-string articles)
 464                   (concat "(UID RFC822.SIZE ENVELOPE BODY "
 465                           (if (imap-capability 'IMAP4rev1)
 466                               "BODY.PEEK[HEADER.FIELDS (References)])"
 467                             "RFC822.HEADER.LINES (References))")))
 468       (and (numberp nnmail-large-newsgroup)
 469            (> nnimap-length nnmail-large-newsgroup)
 470            (nnheader-message 6 "nnimap: Retrieving headers...done")))))
 471
 472 (defun nnimap-use-nov-p (group server)
 473   (or gnus-nov-is-evil nnimap-nov-is-evil
 474       (unless (and (gnus-make-directory
 475                     (file-name-directory
 476                      (nnimap-group-overview-filename group server)))
 477                    (file-writable-p
 478                     (nnimap-group-overview-filename group server)))
 479         (message "nnimap: Nov cache not writable, %s"
 480                  (nnimap-group-overview-filename group server)))))
 481
 482 (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
 483   (when (nnimap-possibly-change-group group server)
 484     (with-current-buffer nntp-server-buffer
 485       (erase-buffer)
 486       (if (nnimap-use-nov-p group server)
 487           (nnimap-retrieve-headers-from-server
 488            (gnus-compress-sequence articles) group server)
 489         (let (uids cached low high)
 490           (when (setq uids (nnimap-retrieve-which-headers articles fetch-old)
 491                       low (car uids)
 492                       high (car (last uids)))
 493             (if (setq cached (nnimap-retrieve-headers-from-file group server))
 494                 (progn
 495                   ;; fetch articles with uids before cache block
 496                   (when (< low (car cached))
 497                     (goto-char (point-min))
 498                     (nnimap-retrieve-headers-from-server
 499                      (cons low (1- (car cached))) group server))
 500                   ;; fetch articles with uids after cache block
 501                   (when (> high (cdr cached))
 502                     (goto-char (point-max))
 503                     (nnimap-retrieve-headers-from-server
 504                      (cons (1+ (cdr cached)) high) group server))
 505                   (when nnimap-prune-cache
 506                     ;; remove nov's for articles which has expired on server
 507                     (goto-char (point-min))
 508                     (dolist (uid (gnus-set-difference articles uids))
 509                       (when (re-search-forward (format "^%d\t" uid) nil t)
 510                         (gnus-delete-line)))))
 511               ;; nothing cached, fetch whole range from server
 512               (nnimap-retrieve-headers-from-server
 513                (cons low high) group server))
 514             (when (buffer-modified-p)
 515               (nnmail-write-region
 516                1 (point-max) (nnimap-group-overview-filename group server)
 517                nil 'nomesg))
 518             (nnheader-nov-delete-outside-range low high))))
 519       'nov)))
 520
 521 (defun nnimap-open-connection (server)
 522   (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream
 523                       nnimap-authenticator nnimap-server-buffer))
 524       (nnheader-report 'nnimap "Can't open connection to server %s" server)
 525     (unless (or (imap-capability 'IMAP4 nnimap-server-buffer)
 526                 (imap-capability 'IMAP4rev1 nnimap-server-buffer))
 527       (imap-close nnimap-server-buffer)
 528       (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server))
 529     (let (list alist user passwd)
 530       (and (fboundp 'gnus-parse-netrc)
 531            (setq list (gnus-parse-netrc nnimap-authinfo-file)
 532                  alist (or (and (gnus-netrc-get
 533                                  (gnus-netrc-machine list server) "machine")
 534                                 (gnus-netrc-machine list server))
 535                            (gnus-netrc-machine list nnimap-address))
 536                  user (gnus-netrc-get alist "login")
 537                  passwd (gnus-netrc-get alist "password")))
 538       (if (imap-authenticate user passwd nnimap-server-buffer)
 539           (prog1
 540               (push (list server nnimap-server-buffer)
 541                     nnimap-server-buffer-alist)
 542             (nnimap-possibly-change-server server))
 543         (imap-close nnimap-server-buffer)
 544         (kill-buffer nnimap-server-buffer)
 545         (nnheader-report 'nnimap "Could not authenticate to %s" server)))))
 546
 547 (deffoo nnimap-open-server (server &optional defs)
 548   (nnheader-init-server-buffer)
 549   (if (nnimap-server-opened server)
 550       t
 551     (unless (assq 'nnimap-server-buffer defs)
 552       (push (list 'nnimap-server-buffer (concat " *nnimap* " server)) defs))
 553     ;; translate `nnimap-server-address' to `nnimap-address' in defs
 554     ;; for people that configured nnimap with a very old version
 555     (unless (assq 'nnimap-address defs)
 556       (if (assq 'nnimap-server-address defs)
 557           (push (list 'nnimap-address
 558                       (cadr (assq 'nnimap-server-address defs))) defs)
 559         (push (list 'nnimap-address server) defs)))
 560     (nnoo-change-server 'nnimap server defs)
 561     (if (null nnimap-server-buffer)
 562         (error "this shouldn't happen"))
 563     (or (imap-opened nnimap-server-buffer)
 564         (nnimap-open-connection server))))
 565
 566 (deffoo nnimap-server-opened (&optional server)
 567   "If SERVER is the current virtual server, and the connection to the
 568 physical server is alive, this function return a non-nil value. If
 569 SERVER is nil, it is treated as the current server."
 570   ;; clean up autologouts??
 571   (and (or server nnimap-current-server)
 572        (nnoo-server-opened 'nnimap (or server nnimap-current-server))
 573        (imap-opened (nnimap-get-server-buffer server))))
 574
 575 (deffoo nnimap-close-server (&optional server)
 576   "Close connection to server and free all resources connected to
 577 it. Return nil if the server couldn't be closed for some reason."
 578   (let ((server (or server nnimap-current-server)))
 579     (when (or (nnimap-server-opened server)
 580               (imap-opened (nnimap-get-server-buffer server)))
 581       (imap-close (nnimap-get-server-buffer server))
 582       (kill-buffer (nnimap-get-server-buffer server))
 583       (setq nnimap-server-buffer nil
 584             nnimap-current-server nil
 585             nnimap-server-buffer-alist
 586             (delq server nnimap-server-buffer-alist)))
 587     (nnoo-close-server 'nnimap server)))
 588
 589 (deffoo nnimap-request-close ()
 590   "Close connection to all servers and free all resources that the
 591 backend have reserved. All buffers that have been created by that
 592 backend should be killed. (Not the nntp-server-buffer, though.) This
 593 function is generally only called when Gnus is shutting down."
 594   (mapcar (lambda (server) (nnimap-close-server (car server)))
 595           nnimap-server-buffer-alist)
 596   (setq nnimap-server-buffer-alist nil))
 597
 598 (deffoo nnimap-status-message (&optional server)
 599   "This function returns the last error message from server."
 600   (when (nnimap-possibly-change-server server)
 601     (nnoo-status-message 'nnimap server)))
 602
 603 (defun nnimap-demule (string)
 604   (funcall (if (and (fboundp 'string-as-multibyte)
 605                     (subrp (symbol-function 'string-as-multibyte)))
 606                'string-as-multibyte
 607              'identity)
 608            (or string "")))
 609
 610 (defun nnimap-callback ()
 611   (remove-hook 'imap-fetch-data-hook 'nnimap-callback)
 612   (with-current-buffer nnimap-callback-buffer
 613     (insert
 614      (with-current-buffer nnimap-server-buffer
 615        (nnimap-demule (imap-message-get (imap-current-message) 'RFC822)))) ;xxx
 616     (nnheader-ms-strip-cr)
 617     (funcall nnimap-callback-callback-function t)))
 618
 619 (defun nnimap-request-article-part (article part prop
 620                                             &optional group server to-buffer)
 621   (when (nnimap-possibly-change-group group server)
 622     (let ((article (if (stringp article)
 623                        (car-safe (imap-search
 624                                   (format "HEADER Message-Id %s" article)
 625                                   nnimap-server-buffer))
 626                      article)))
 627       (when article
 628         (gnus-message 9 "nnimap: Fetching (part of) article %d..." article)
 629         (if (not nnheader-callback-function)
 630             (with-current-buffer (or to-buffer nntp-server-buffer)
 631               (erase-buffer)
 632               (insert (nnimap-demule (imap-fetch article part prop nil
 633                                                  nnimap-server-buffer)))
 634               (nnheader-ms-strip-cr)
 635               (gnus-message 9 "nnimap: Fetching (part of) article %d...done"
 636                             article)
 637               (if (bobp)
 638                   (nnheader-report 'nnimap "No such article: %s"
 639                                    (imap-error-text nnimap-server-buffer))
 640                 (cons group article)))
 641           (add-hook 'imap-fetch-data-hook 'nnimap-callback)
 642           (setq nnimap-callback-callback-function nnheader-callback-function
 643                 nnimap-callback-buffer nntp-server-buffer)
 644           (imap-fetch-asynch article part nil nnimap-server-buffer)
 645           (cons group article))))))
 646
 647 (deffoo nnimap-asynchronous-p ()
 648   t)
 649
 650 (deffoo nnimap-request-article (article &optional group server to-buffer)
 651   (nnimap-request-article-part
 652    article "RFC822.PEEK" 'RFC822 group server to-buffer))
 653
 654 (deffoo nnimap-request-head (article &optional group server to-buffer)
 655   (nnimap-request-article-part
 656    article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer))
 657
 658 (deffoo nnimap-request-body (article &optional group server to-buffer)
 659   (nnimap-request-article-part
 660    article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer))
 661
 662 (deffoo nnimap-request-group (group &optional server fast)
 663   (nnimap-request-update-info-internal
 664    group
 665    (gnus-get-info (gnus-group-prefixed-name
 666                    group (gnus-server-to-method (format "nnimap:%s" server))))
 667    server)
 668   (when (nnimap-possibly-change-group group server)
 669     (let (info)
 670       (cond (fast group)
 671             ((null (setq info (nnimap-find-minmax-uid group t)))
 672              (nnheader-report 'nnimap "Could not get active info for %s"
 673                               group))
 674             (t
 675              (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0)
 676                               (max 1 (or (nth 1 info) 1))
 677                               (or (nth 2 info) 0) group)
 678              (nnheader-report 'nnimap "Group %s selected" group)
 679              t)))))
 680
 681 (defun nnimap-close-group (group &optional server)
 682   (with-current-buffer nnimap-server-buffer
 683     (when (and (imap-opened)
 684                (nnimap-possibly-change-group group server))
 685       (case nnimap-expunge-on-close
 686         ('always (imap-mailbox-expunge)
 687                  (imap-mailbox-close))
 688         ('ask (if (and (imap-search "DELETED")
 689                        (gnus-y-or-n-p (format
 690                                        "Expunge articles in group `%s'? "
 691                                        imap-current-mailbox)))
 692                   (progn (imap-mailbox-expunge)
 693                          (imap-mailbox-close))
 694                 (imap-mailbox-unselect)))
 695         (t (imap-mailbox-unselect)))
 696       (not imap-current-mailbox))))
 697
 698 (defun nnimap-pattern-to-list-arguments (pattern)
 699   (mapcar (lambda (p)
 700             (cons (car-safe p) (or (cdr-safe p) p)))
 701           (if (and (listp pattern)
 702                    (listp (cdr pattern)))
 703               pattern
 704             (list pattern))))
 705
 706 (deffoo nnimap-request-list (&optional server)
 707   (when (nnimap-possibly-change-server server)
 708     (with-current-buffer nntp-server-buffer
 709       (erase-buffer))
 710     (gnus-message 5 "nnimap: Generating active list%s..."
 711                   (if (> (length server) 0) (concat " for " server) ""))
 712     (with-current-buffer nnimap-server-buffer
 713       (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern))
 714         (dolist (mbx (funcall nnimap-request-list-method
 715                               (cdr pattern) (car pattern)))
 716           (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx))
 717               (let ((info (nnimap-find-minmax-uid mbx 'examine)))
 718                 (when info
 719                   ;; Escape SPC in mailboxes xxx relies on gnus internals
 720                   (with-current-buffer nntp-server-buffer
 721                     (insert (format "%s %d %d y\n"
 722                                     (nnimap-replace-in-string mbx " " "\\ ")
 723                                     (or (nth 2 info) 0)
 724                                     (max 1 (or (nth 1 info) 1)))))))))))
 725     (gnus-message 5 "nnimap: Generating active list%s...done"
 726                   (if (> (length server) 0) (concat " for " server) ""))
 727     t))
 728
 729 (deffoo nnimap-request-post (&optional server)
 730   (let ((success t))
 731     (dolist  (mbx (message-tokenize-header
 732                    (message-fetch-field "Newsgroups")) success)
 733       (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method)))
 734         (or (gnus-active to-newsgroup)
 735             (gnus-activate-group to-newsgroup)
 736             (if (gnus-y-or-n-p (format "No such group: %s.  Create it? "
 737                                        to-newsgroup))
 738                 (or (and (gnus-request-create-group
 739                           to-newsgroup gnus-command-method)
 740                          (gnus-activate-group to-newsgroup nil nil
 741                                               gnus-command-method))
 742                     (error "Couldn't create group %s" to-newsgroup)))
 743             (error "No such group: %s" to-newsgroup))
 744         (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method))
 745           (setq success nil))))))
 746
 747 ;; Optional backend functions
 748
 749 (deffoo nnimap-retrieve-groups (groups &optional server)
 750   (when (nnimap-possibly-change-server server)
 751     (gnus-message 5 "nnimap: Checking mailboxes...")
 752     (with-current-buffer nntp-server-buffer
 753       (erase-buffer)
 754       (dolist (group groups)
 755         (gnus-message 7 "nnimap: Checking mailbox %s" group)
 756         (or (member "\\NoSelect"
 757                     (imap-mailbox-get 'list-flags group nnimap-server-buffer))
 758             (let ((info (nnimap-find-minmax-uid group 'examine)))
 759               ;; Escape SPC in mailboxes xxx relies on gnus internals
 760               (insert (format "211 %d %d %d %s\n" (or (nth 0 info) 0)
 761                               (max 1 (or (nth 1 info) 1))
 762                               (or (nth 2 info) 0)
 763                               (nnimap-replace-in-string group " " "\\ ")))))))
 764     (gnus-message 5 "nnimap: Checking mailboxes...done")
 765     'groups))
 766
 767 (deffoo nnimap-request-update-info-internal (group info &optional server)
 768   (when (nnimap-possibly-change-group group server)
 769     (when info ;; xxx what does this mean? should we create a info?
 770       (with-current-buffer nnimap-server-buffer
 771         (gnus-message 5 "nnimap: Updating info for %s..."
 772                       (gnus-info-group info))
 773
 774         (when (nnimap-mark-permanent-p 'read)
 775           (let (seen unseen)
 776             ;; read info could contain articles marked unread by other
 777             ;; imap clients!  we correct this
 778             (setq seen (gnus-uncompress-range (gnus-info-read info))
 779                   unseen (imap-search "UNSEEN UNDELETED")
 780                   seen (gnus-set-difference seen unseen)
 781                   ;; seen might lack articles marked as read by other
 782                   ;; imap clients! we correct this
 783                   seen (append seen (imap-search "SEEN"))
 784                   ;; remove dupes
 785                   seen (sort seen '<)
 786                   seen (gnus-compress-sequence seen t)
 787                   ;; we can't return '(1) since this isn't a "list of ranges",
 788                   ;; and we can't return '((1)) since g-list-of-unread-articles
 789                   ;; is buggy so we return '((1 . 1)).
 790                   seen (if (and (integerp (car seen))
 791                                 (null (cdr seen)))
 792                            (list (cons (car seen) (car seen)))
 793                          seen))
 794             (gnus-info-set-read info seen)))
 795
 796         (mapc (lambda (pred)
 797                 (when (and (nnimap-mark-permanent-p (cdr pred))
 798                            (member (nnimap-mark-to-flag (cdr pred))
 799                                    (imap-mailbox-get 'flags)))
 800                   (gnus-info-set-marks
 801                    info
 802                    (nnimap-update-alist-soft
 803                     (cdr pred)
 804                     (gnus-compress-sequence
 805                      (imap-search (nnimap-mark-to-predicate (cdr pred))))
 806                     (gnus-info-marks info))
 807                    t)))
 808               gnus-article-mark-lists)
 809
 810         (gnus-message 5 "nnimap: Updating info for %s...done"
 811                       (gnus-info-group info))
 812
 813         info))))
 814
 815 (deffoo nnimap-request-type (group &optional article)
 816   (if (and nnimap-news-groups (string-match nnimap-news-groups group))
 817       'news
 818     'mail))
 819
 820 (deffoo nnimap-request-set-mark (group actions &optional server)
 821   (when (nnimap-possibly-change-group group server)
 822     (with-current-buffer nnimap-server-buffer
 823       (let (action)
 824         (gnus-message 7 "nnimap: Setting marks in %s..." group)
 825         (while (setq action (pop actions))
 826           (let ((range (nth 0 action))
 827                 (what  (nth 1 action))
 828                 (cmdmarks (nth 2 action))
 829                 marks)
 830             ;; cache flags are pointless on the server
 831             (setq cmdmarks (delq 'cache cmdmarks))
 832             ;; flag dormant articles as ticked
 833             (if (memq 'dormant cmdmarks)
 834                 (setq cmdmarks (cons 'tick cmdmarks)))
 835             ;; remove stuff we are forbidden to store
 836             (mapcar (lambda (mark)
 837                       (if (imap-message-flag-permanent-p
 838                            (nnimap-mark-to-flag mark))
 839                           (setq marks (cons mark marks))))
 840                     cmdmarks)
 841             (when (and range marks)
 842               (cond ((eq what 'del)
 843                      (imap-message-flags-del
 844                       (nnimap-range-to-string range)
 845                       (nnimap-mark-to-flag marks nil t)))
 846                     ((eq what 'add)
 847                      (imap-message-flags-add
 848                       (nnimap-range-to-string range)
 849                       (nnimap-mark-to-flag marks nil t)))
 850                     ((eq what 'set)
 851                      (imap-message-flags-set
 852                       (nnimap-range-to-string range)
 853                       (nnimap-mark-to-flag marks nil t)))))))
 854         (gnus-message 7 "nnimap: Setting marks in %s...done" group))))
 855   nil)
 856
 857 (defun nnimap-split-to-groups (rules)
 858   ;; tries to match all rules in nnimap-split-rule against content of
 859   ;; nntp-server-buffer, returns a list of groups that matched.
 860   (with-current-buffer nntp-server-buffer
 861     ;; Fold continuation lines.
 862     (goto-char (point-min))
 863     (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 864       (replace-match " " t t))
 865     (if (functionp rules)
 866         (funcall rules)
 867       (let (to-groups regrepp)
 868         (catch 'split-done
 869           (dolist (rule rules to-groups)
 870             (let ((group (car rule))
 871                   (regexp (cadr rule)))
 872               (goto-char (point-min))
 873               (when (and (if (stringp regexp)
 874                              (progn
 875                                (setq regrepp (string-match "\\\\[0-9&]" group))
 876                                (re-search-forward regexp nil t))
 877                            (funcall regexp group))
 878                          ;; Don't enter the article into the same group twice.
 879                          (not (assoc group to-groups)))
 880                 (push (if regrepp
 881                           (nnmail-expand-newtext group)
 882                         group)
 883                       to-groups)
 884                 (or nnimap-split-crosspost
 885                     (throw 'split-done to-groups))))))))))
 886
 887 (defun nnimap-split-find-rule (server inbox)
 888   nnimap-split-rule)
 889
 890 (defun nnimap-split-find-inbox (server)
 891   (if (listp nnimap-split-inbox)
 892       nnimap-split-inbox
 893     (list nnimap-split-inbox)))
 894
 895 (defun nnimap-split-articles (&optional group server)
 896   (when (nnimap-possibly-change-server server)
 897     (with-current-buffer nnimap-server-buffer
 898       (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server)))
 899         ;; iterate over inboxes
 900         (while (and (setq inbox (pop inboxes))
 901                     (nnimap-possibly-change-group inbox)) ;; SELECT
 902           ;; find split rule for this server / inbox
 903           (when (setq rule (nnimap-split-find-rule server inbox))
 904             ;; iterate over articles
 905             (dolist (article (imap-search "UNSEEN UNDELETED"))
 906               (when (nnimap-request-head article)
 907                 ;; copy article to right group(s)
 908                 (setq removeorig nil)
 909                 (dolist (to-group (nnimap-split-to-groups rule))
 910                   (if (imap-message-copy (number-to-string article)
 911                                          to-group nil 'nocopyuid)
 912                       (progn
 913                         (message "IMAP split moved %s:%s:%d to %s" server inbox
 914                                  article to-group)
 915                         (setq removeorig t)
 916                         ;; Add the group-art list to the history list.
 917                         (push (list (cons to-group 0)) nnmail-split-history))
 918                     (message "IMAP split failed to move %s:%s:%d to %s" server
 919                              inbox article to-group)))
 920                 ;; remove article if it was successfully copied somewhere
 921                 (and removeorig
 922                      (imap-message-flags-add (format "%d" article)
 923                                              "\\Seen \\Deleted")))))
 924           (when (imap-mailbox-select inbox) ;; just in case
 925             ;; todo: UID EXPUNGE (if available) to remove splitted articles
 926             (imap-mailbox-expunge)
 927             (imap-mailbox-close)))
 928         t))))
 929
 930 (deffoo nnimap-request-scan (&optional group server)
 931   (nnimap-split-articles group server))
 932
 933 (deffoo nnimap-request-newgroups (date &optional server)
 934   (when (nnimap-possibly-change-server server)
 935     (with-current-buffer nntp-server-buffer
 936       (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..."
 937                     (if (> (length server) 0) " on " "") server)
 938       (erase-buffer)
 939       (dolist (pattern (nnimap-pattern-to-list-arguments
 940                         nnimap-list-pattern))
 941         (dolist (mbx (imap-mailbox-lsub "*" (car pattern) nil
 942                                         nnimap-server-buffer))
 943           (or (member-if (lambda (mailbox)
 944                            (string= (downcase mailbox) "\\noselect"))
 945                          (imap-mailbox-get 'list-flags mbx
 946                                            nnimap-server-buffer))
 947               ;; Escape SPC in mailboxes xxx relies on gnus internals
 948               (let ((info (nnimap-find-minmax-uid mbx 'examine)))
 949                 (when info
 950                   (insert (format "%s %d %d y\n"
 951                                   (nnimap-replace-in-string mbx " " "\\ ")
 952                                   (or (nth 2 info) 0)
 953                                   (max 1 (or (nth 1 info) 1)))))))))
 954       (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done"
 955                     (if (> (length server) 0) " on " "") server))
 956     t))
 957
 958 (deffoo nnimap-request-create-group (group &optional server args)
 959   (when (nnimap-possibly-change-server server)
 960     (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer)
 961         (imap-mailbox-create group nnimap-server-buffer))))
 962
 963 (defun nnimap-time-substract (time1 time2)
 964   "Return TIME for TIME1 - TIME2."
 965   (let* ((ms (- (car time1) (car time2)))
 966          (ls (- (nth 1 time1) (nth 1 time2))))
 967     (if (< ls 0)
 968         (list (- ms 1) (+ (expt 2 16) ls))
 969       (list ms ls))))
 970
 971 (defun nnimap-date-days-ago (daysago)
 972   "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago."
 973   (let ((date (format-time-string "%d-%b-%Y"
 974                                   (nnimap-time-substract
 975                                    (current-time)
 976                                    (days-to-time daysago)))))
 977     (if (eq ?0 (string-to-char date))
 978         (substring date 1)
 979       date)))
 980
 981 (defun nnimap-request-expire-articles-progress ()
 982   (gnus-message 5 "nnimap: Marking article %d for deletion..."
 983                 imap-current-message))
 984
 985 ;; Notice that we don't actually delete anything, we just mark them deleted.
 986 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 987   (let ((artseq (gnus-compress-sequence articles)))
 988     (when (and artseq (nnimap-possibly-change-group group server))
 989       (with-current-buffer nnimap-server-buffer
 990         (if force
 991             (and (imap-message-flags-add
 992                   (nnimap-range-to-string artseq) "\\Deleted")
 993                  (setq articles nil))
 994           (let ((days (or (and nnmail-expiry-wait-function
 995                                (funcall nnmail-expiry-wait-function group))
 996                           nnmail-expiry-wait)))
 997             (cond ((eq days 'immediate)
 998                    (and (imap-message-flags-add
 999                          (nnimap-range-to-string artseq) "\\Deleted")
1000                         (setq articles nil)))
1001                   ((numberp days)
1002                    (let ((oldarts (imap-search
1003                                    (format "UID %s NOT SINCE %s"
1004                                            (nnimap-range-to-string artseq)
1005                                            (nnimap-date-days-ago days))))
1006                          (imap-fetch-data-hook
1007                           '(nnimap-request-expire-articles-progress)))
1008                      (and oldarts
1009                           (imap-message-flags-add
1010                            (nnimap-range-to-string
1011                             (gnus-compress-sequence oldarts))
1012                            "\\Deleted")
1013                           (setq articles (gnus-set-difference
1014                                           articles oldarts)))))))))))
1015   ;; return articles not deleted
1016   articles)
1017
1018 (deffoo nnimap-request-move-article (article group server
1019                                              accept-form &optional last)
1020   (when (nnimap-possibly-change-server server)
1021     (save-excursion
1022       (let ((buf (get-buffer-create " *nnimap move*"))
1023             (nnimap-current-move-article article)
1024             (nnimap-current-move-group group)
1025             (nnimap-current-move-server nnimap-current-server)
1026             result)
1027         (and (nnimap-request-article article group server)
1028              (save-excursion
1029                (set-buffer buf)
1030                (buffer-disable-undo (current-buffer))
1031                (insert-buffer-substring nntp-server-buffer)
1032                (setq result (eval accept-form))
1033                (kill-buffer buf)
1034                result)
1035              (nnimap-request-expire-articles (list article) group server t))
1036         result))))
1037
1038 (deffoo nnimap-request-accept-article (group &optional server last)
1039   (when (nnimap-possibly-change-server server)
1040     (let (uid)
1041       (if (setq uid
1042                 (if (string= nnimap-current-server nnimap-current-move-server)
1043                     ;; moving article within same server, speed it up...
1044                     (and (nnimap-possibly-change-group
1045                           nnimap-current-move-group)
1046                          (imap-message-copy (number-to-string
1047                                              nnimap-current-move-article)
1048                                             group 'dontcreate nil
1049                                             nnimap-server-buffer))
1050                   ;; turn into rfc822 format (\r\n eol's)
1051                   (with-current-buffer (current-buffer)
1052                     (goto-char (point-min))
1053                     (while (search-forward "\n" nil t)
1054                       (replace-match "\r\n")))
1055                   ;; next line for Cyrus server bug
1056                   (imap-mailbox-unselect nnimap-server-buffer)
1057                   (imap-message-append group (current-buffer) nil nil
1058                                        nnimap-server-buffer)))
1059           (cons group (nth 1 uid))
1060         (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer))))))
1061
1062 (deffoo nnimap-request-delete-group (group force &optional server)
1063   (when (nnimap-possibly-change-server server)
1064     (with-current-buffer nnimap-server-buffer
1065       (if force
1066           (or (null (imap-mailbox-status group 'uidvalidity))
1067               (imap-mailbox-delete group))
1068         ;; UNSUBSCRIBE?
1069         t))))
1070
1071 (deffoo nnimap-request-rename-group (group new-name &optional server)
1072   (when (nnimap-possibly-change-server server)
1073     (imap-mailbox-rename group new-name nnimap-server-buffer)))
1074
1075 (defun nnimap-expunge (mailbox server)
1076   (when (nnimap-possibly-change-group mailbox server)
1077     (imap-mailbox-expunge nnimap-server-buffer)))
1078
1079 (defun nnimap-acl-get (mailbox server)
1080   (when (nnimap-possibly-change-server server)
1081     (imap-mailbox-acl-get mailbox nnimap-server-buffer)))
1082
1083 (defun nnimap-acl-edit (mailbox method old-acls new-acls)
1084   (when (nnimap-possibly-change-server (cadr method))
1085     (unless (imap-capability 'ACL nnimap-server-buffer)
1086       (error "Your server does not support ACL editing"))
1087     (with-current-buffer nnimap-server-buffer
1088       ;; delete all removed identifiers
1089       (mapcar (lambda (old-acl)
1090                 (unless (assoc (car old-acl) new-acls)
1091                     (or (imap-mailbox-acl-delete (car old-acl) mailbox)
1092                         (error "Can't delete ACL for %s" (car old-acl)))))
1093               old-acls)
1094       ;; set all changed acl's
1095       (mapcar (lambda (new-acl)
1096                 (let ((new-rights (cdr new-acl))
1097                       (old-rights (cdr (assoc (car new-acl) old-acls))))
1098                 (unless (and old-rights new-rights
1099                              (string= old-rights new-rights))
1100                   (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
1101                       (error "Can't set ACL for %s to %s" (car new-acl)
1102                              new-rights)))))
1103               new-acls)
1104       t)))
1105
1106 \f
1107 ;;; Internal functions
1108
1109 ;;
1110 ;; This is confusing.
1111 ;;
1112 ;; mark      => read, tick, draft, reply etc
1113 ;; flag      => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc
1114 ;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc
1115 ;;
1116 ;; Mark should not really contain 'read since it's not a "mark" in the Gnus
1117 ;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read).
1118 ;;
1119
1120 (defconst nnimap-mark-to-predicate-alist
1121   (mapcar
1122    (lambda (pair) ; cdr is the mark
1123      (or (assoc (cdr pair)
1124                 '((read . "SEEN")
1125                   (tick . "FLAGGED")
1126                   (draft . "DRAFT")
1127                   (reply . "ANSWERED")))
1128          (cons (cdr pair)
1129                (format "KEYWORD gnus-%s" (symbol-name (cdr pair))))))
1130    (cons '(read . read) gnus-article-mark-lists)))
1131
1132 (defun nnimap-mark-to-predicate (pred)
1133   "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP
1134 predicate (a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD
1135 gnus-expire\") to be used within a IMAP SEARCH query."
1136   (cdr (assq pred nnimap-mark-to-predicate-alist)))
1137
1138 (defconst nnimap-mark-to-flag-alist
1139   (mapcar
1140    (lambda (pair)
1141      (or (assoc (cdr pair)
1142                 '((read . "\\Seen")
1143                   (tick . "\\Flagged")
1144                   (draft . "\\Draft")
1145                   (reply . "\\Answered")))
1146          (cons (cdr pair)
1147                (format "gnus-%s" (symbol-name (cdr pair))))))
1148    (cons '(read . read) gnus-article-mark-lists)))
1149
1150 (defun nnimap-mark-to-flag-1 (preds)
1151   (if (and (not (null preds)) (listp preds))
1152       (cons (nnimap-mark-to-flag (car preds))
1153             (nnimap-mark-to-flag (cdr preds)))
1154     (cdr (assoc preds nnimap-mark-to-flag-alist))))
1155
1156 (defun nnimap-mark-to-flag (preds &optional always-list make-string)
1157   "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP
1158 flag (a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\") to
1159 be used in a STORE FLAGS command."
1160   (let ((result (nnimap-mark-to-flag-1 preds)))
1161     (setq result (if (and (or make-string always-list)
1162                           (not (listp result)))
1163                      (list result)
1164                    result))
1165     (if make-string
1166         (mapconcat (lambda (flag)
1167                      (if (listp flag)
1168                          (mapconcat 'identity flag " ")
1169                        flag))
1170                    result " ")
1171       result)))
1172
1173 (defun nnimap-mark-permanent-p (mark &optional group)
1174   "Return t iff MARK can be permanently (between IMAP sessions) saved
1175 on articles, in GROUP."
1176   (imap-message-flag-permanent-p (nnimap-mark-to-flag mark)))
1177
1178 (defun nnimap-remassoc (key alist)
1179   "Delete by side effect any elements of LIST whose car is
1180 `equal' to KEY.  The modified LIST is returned.  If the first member
1181 of LIST has a car that is `equal' to KEY, there is no way to remove it
1182 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
1183 sure of changing the value of `foo'."
1184   (when alist
1185     (if (equal key (caar alist))
1186         (cdr alist)
1187       (setcdr alist (nnimap-remassoc key (cdr alist)))
1188       alist)))
1189
1190 (defun nnimap-update-alist-soft (key value alist)
1191   (if value
1192       (cons (cons key value) (nnimap-remassoc key alist))
1193     (nnimap-remassoc key alist)))
1194
1195 (defun nnimap-range-to-string (range)
1196   (mapconcat
1197    (lambda (item)
1198      (if (consp item)
1199          (format "%d:%d"
1200                  (car item) (cdr item))
1201        (format "%d" item)))
1202    (if (and (listp range) (not (listp (cdr range))))
1203        (list range) ;; make (1 . 2) into ((1 . 2))
1204      range)
1205    ","))
1206
1207 (when nnimap-debug
1208   (require 'trace)
1209   (buffer-disable-undo (get-buffer-create nnimap-debug))
1210   (mapc (lambda (f) (trace-function-background f nnimap-debug))
1211         '(
1212 nnimap-replace-in-string
1213 nnimap-possibly-change-server
1214 nnimap-verify-uidvalidity
1215 nnimap-find-minmax-uid
1216 nnimap-possibly-change-group
1217 ;nnimap-replace-whitespace
1218 nnimap-retrieve-headers-progress
1219 nnimap-retrieve-which-headers
1220 nnimap-group-overview-filename
1221 nnimap-retrieve-headers-from-file
1222 nnimap-retrieve-headers-from-server
1223 nnimap-retrieve-headers
1224 nnimap-open-connection
1225 nnimap-open-server
1226 nnimap-server-opened
1227 nnimap-close-server
1228 nnimap-request-close
1229 nnimap-status-message
1230 ;nnimap-demule
1231 nnimap-request-article-part
1232 nnimap-request-article
1233 nnimap-request-head
1234 nnimap-request-body
1235 nnimap-request-group
1236 nnimap-close-group
1237 nnimap-pattern-to-list-arguments
1238 nnimap-request-list
1239 nnimap-request-post
1240 nnimap-retrieve-groups
1241 nnimap-request-update-info-internal
1242 nnimap-request-type
1243 nnimap-request-set-mark
1244 nnimap-split-to-groups
1245 nnimap-split-find-rule
1246 nnimap-split-find-inbox
1247 nnimap-split-articles
1248 nnimap-request-scan
1249 nnimap-request-newgroups
1250 nnimap-request-create-group
1251 nnimap-time-substract
1252 nnimap-date-days-ago
1253 nnimap-request-expire-articles-progress
1254 nnimap-request-expire-articles
1255 nnimap-request-move-article
1256 nnimap-request-accept-article
1257 nnimap-request-delete-group
1258 nnimap-request-rename-group
1259 gnus-group-nnimap-expunge
1260 gnus-group-nnimap-edit-acl
1261 gnus-group-nnimap-edit-acl-done
1262 nnimap-group-mode-hook
1263 nnimap-mark-to-predicate
1264 nnimap-mark-to-flag-1
1265 nnimap-mark-to-flag
1266 nnimap-mark-permanent-p
1267 nnimap-remassoc
1268 nnimap-update-alist-soft
1269 nnimap-range-to-string
1270           )))
1271
1272 (provide 'nnimap)
1273
1274 ;;; nnimap.el ends here