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 (eval-when-compile (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 nil) ;; "*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     (or (and nnimap-server-buffer
 562              (imap-opened nnimap-server-buffer))
 563         (nnimap-open-connection server))))
 564
 565 (deffoo nnimap-server-opened (&optional server)
 566   "If SERVER is the current virtual server, and the connection to the
 567 physical server is alive, this function return a non-nil value. If
 568 SERVER is nil, it is treated as the current server."
 569   ;; clean up autologouts??
 570   (and (or server nnimap-current-server)
 571        (nnoo-server-opened 'nnimap (or server nnimap-current-server))
 572        (imap-opened (nnimap-get-server-buffer server))))
 573
 574 (deffoo nnimap-close-server (&optional server)
 575   "Close connection to server and free all resources connected to
 576 it. Return nil if the server couldn't be closed for some reason."
 577   (let ((server (or server nnimap-current-server)))
 578     (when (or (nnimap-server-opened server)
 579               (imap-opened (nnimap-get-server-buffer server)))
 580       (imap-close (nnimap-get-server-buffer server))
 581       (kill-buffer (nnimap-get-server-buffer server))
 582       (setq nnimap-server-buffer nil
 583             nnimap-current-server nil
 584             nnimap-server-buffer-alist
 585             (delq server nnimap-server-buffer-alist)))
 586     (nnoo-close-server 'nnimap server)))
 587
 588 (deffoo nnimap-request-close ()
 589   "Close connection to all servers and free all resources that the
 590 backend have reserved. All buffers that have been created by that
 591 backend should be killed. (Not the nntp-server-buffer, though.) This
 592 function is generally only called when Gnus is shutting down."
 593   (mapcar (lambda (server) (nnimap-close-server (car server)))
 594           nnimap-server-buffer-alist)
 595   (setq nnimap-server-buffer-alist nil))
 596
 597 (deffoo nnimap-status-message (&optional server)
 598   "This function returns the last error message from server."
 599   (when (nnimap-possibly-change-server server)
 600     (nnoo-status-message 'nnimap server)))
 601
 602 (defun nnimap-demule (string)
 603   (funcall (if (and (fboundp 'string-as-multibyte)
 604                     (subrp (symbol-function 'string-as-multibyte)))
 605                'string-as-multibyte
 606              'identity)
 607            (or string "")))
 608
 609 (defun nnimap-callback ()
 610   (remove-hook 'imap-fetch-data-hook 'nnimap-callback)
 611   (with-current-buffer nnimap-callback-buffer
 612     (insert
 613      (with-current-buffer nnimap-server-buffer
 614        (nnimap-demule (imap-message-get (imap-current-message) 'RFC822)))) ;xxx
 615     (nnheader-ms-strip-cr)
 616     (funcall nnimap-callback-callback-function t)))
 617
 618 (defun nnimap-request-article-part (article part prop
 619                                             &optional group server to-buffer)
 620   (when (nnimap-possibly-change-group group server)
 621     (let ((article (if (stringp article)
 622                        (car-safe (imap-search
 623                                   (format "HEADER Message-Id %s" article)
 624                                   nnimap-server-buffer))
 625                      article)))
 626       (when article
 627         (gnus-message 9 "nnimap: Fetching (part of) article %d..." article)
 628         (if (not nnheader-callback-function)
 629             (with-current-buffer (or to-buffer nntp-server-buffer)
 630               (erase-buffer)
 631               (insert (nnimap-demule (imap-fetch article part prop nil
 632                                                  nnimap-server-buffer)))
 633               (nnheader-ms-strip-cr)
 634               (gnus-message 9 "nnimap: Fetching (part of) article %d...done"
 635                             article)
 636               (if (bobp)
 637                   (nnheader-report 'nnimap "No such article: %s"
 638                                    (imap-error-text nnimap-server-buffer))
 639                 (cons group article)))
 640           (add-hook 'imap-fetch-data-hook 'nnimap-callback)
 641           (setq nnimap-callback-callback-function nnheader-callback-function
 642                 nnimap-callback-buffer nntp-server-buffer)
 643           (imap-fetch-asynch article part nil nnimap-server-buffer)
 644           (cons group article))))))
 645
 646 (deffoo nnimap-asynchronous-p ()
 647   t)
 648
 649 (deffoo nnimap-request-article (article &optional group server to-buffer)
 650   (nnimap-request-article-part
 651    article "RFC822.PEEK" 'RFC822 group server to-buffer))
 652
 653 (deffoo nnimap-request-head (article &optional group server to-buffer)
 654   (nnimap-request-article-part
 655    article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer))
 656
 657 (deffoo nnimap-request-body (article &optional group server to-buffer)
 658   (nnimap-request-article-part
 659    article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer))
 660
 661 (deffoo nnimap-request-group (group &optional server fast)
 662   (nnimap-request-update-info-internal
 663    group
 664    (gnus-get-info (gnus-group-prefixed-name
 665                    group (gnus-server-to-method (format "nnimap:%s" server))))
 666    server)
 667   (when (nnimap-possibly-change-group group server)
 668     (let (info)
 669       (cond (fast group)
 670             ((null (setq info (nnimap-find-minmax-uid group t)))
 671              (nnheader-report 'nnimap "Could not get active info for %s"
 672                               group))
 673             (t
 674              (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0)
 675                               (max 1 (or (nth 1 info) 1))
 676                               (or (nth 2 info) 0) group)
 677              (nnheader-report 'nnimap "Group %s selected" group)
 678              t)))))
 679
 680 (defun nnimap-close-group (group &optional server)
 681   (with-current-buffer nnimap-server-buffer
 682     (when (and (imap-opened)
 683                (nnimap-possibly-change-group group server))
 684       (case nnimap-expunge-on-close
 685         ('always (imap-mailbox-expunge)
 686                  (imap-mailbox-close))
 687         ('ask (if (and (imap-search "DELETED")
 688                        (gnus-y-or-n-p (format
 689                                        "Expunge articles in group `%s'? "
 690                                        imap-current-mailbox)))
 691                   (progn (imap-mailbox-expunge)
 692                          (imap-mailbox-close))
 693                 (imap-mailbox-unselect)))
 694         (t (imap-mailbox-unselect)))
 695       (not imap-current-mailbox))))
 696
 697 (defun nnimap-pattern-to-list-arguments (pattern)
 698   (mapcar (lambda (p)
 699             (cons (car-safe p) (or (cdr-safe p) p)))
 700           (if (and (listp pattern)
 701                    (listp (cdr pattern)))
 702               pattern
 703             (list pattern))))
 704
 705 (deffoo nnimap-request-list (&optional server)
 706   (when (nnimap-possibly-change-server server)
 707     (with-current-buffer nntp-server-buffer
 708       (erase-buffer))
 709     (gnus-message 5 "nnimap: Generating active list%s..."
 710                   (if (> (length server) 0) (concat " for " server) ""))
 711     (with-current-buffer nnimap-server-buffer
 712       (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern))
 713         (dolist (mbx (funcall nnimap-request-list-method
 714                               (cdr pattern) (car pattern)))
 715           (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx))
 716               (let ((info (nnimap-find-minmax-uid mbx 'examine)))
 717                 (when info
 718                   ;; Escape SPC in mailboxes xxx relies on gnus internals
 719                   (with-current-buffer nntp-server-buffer
 720                     (insert (format "%s %d %d y\n"
 721                                     (nnimap-replace-in-string mbx " " "\\ ")
 722                                     (or (nth 2 info) 0)
 723                                     (max 1 (or (nth 1 info) 1)))))))))))
 724     (gnus-message 5 "nnimap: Generating active list%s...done"
 725                   (if (> (length server) 0) (concat " for " server) ""))
 726     t))
 727
 728 (deffoo nnimap-request-post (&optional server)
 729   (let ((success t))
 730     (dolist  (mbx (message-tokenize-header
 731                    (message-fetch-field "Newsgroups")) success)
 732       (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method)))
 733         (or (gnus-active to-newsgroup)
 734             (gnus-activate-group to-newsgroup)
 735             (if (gnus-y-or-n-p (format "No such group: %s.  Create it? "
 736                                        to-newsgroup))
 737                 (or (and (gnus-request-create-group
 738                           to-newsgroup gnus-command-method)
 739                          (gnus-activate-group to-newsgroup nil nil
 740                                               gnus-command-method))
 741                     (error "Couldn't create group %s" to-newsgroup)))
 742             (error "No such group: %s" to-newsgroup))
 743         (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method))
 744           (setq success nil))))))
 745
 746 ;; Optional backend functions
 747
 748 (deffoo nnimap-retrieve-groups (groups &optional server)
 749   (when (nnimap-possibly-change-server server)
 750     (gnus-message 5 "nnimap: Checking mailboxes...")
 751     (with-current-buffer nntp-server-buffer
 752       (erase-buffer)
 753       (dolist (group groups)
 754         (gnus-message 7 "nnimap: Checking mailbox %s" group)
 755         (or (member "\\NoSelect"
 756                     (imap-mailbox-get 'list-flags group nnimap-server-buffer))
 757             (let ((info (nnimap-find-minmax-uid group 'examine)))
 758               ;; Escape SPC in mailboxes xxx relies on gnus internals
 759               (insert (format "211 %d %d %d %s\n" (or (nth 0 info) 0)
 760                               (max 1 (or (nth 1 info) 1))
 761                               (or (nth 2 info) 0)
 762                               (nnimap-replace-in-string group " " "\\ ")))))))
 763     (gnus-message 5 "nnimap: Checking mailboxes...done")
 764     'groups))
 765
 766 (deffoo nnimap-request-update-info-internal (group info &optional server)
 767   (when (nnimap-possibly-change-group group server)
 768     (when info ;; xxx what does this mean? should we create a info?
 769       (with-current-buffer nnimap-server-buffer
 770         (gnus-message 5 "nnimap: Updating info for %s..."
 771                       (gnus-info-group info))
 772
 773         (when (nnimap-mark-permanent-p 'read)
 774           (let (seen unseen)
 775             ;; read info could contain articles marked unread by other
 776             ;; imap clients!  we correct this
 777             (setq seen (gnus-uncompress-range (gnus-info-read info))
 778                   unseen (imap-search "UNSEEN UNDELETED")
 779                   seen (gnus-set-difference seen unseen)
 780                   ;; seen might lack articles marked as read by other
 781                   ;; imap clients! we correct this
 782                   seen (append seen (imap-search "SEEN"))
 783                   ;; remove dupes
 784                   seen (sort seen '<)
 785                   seen (gnus-compress-sequence seen t)
 786                   ;; we can't return '(1) since this isn't a "list of ranges",
 787                   ;; and we can't return '((1)) since g-list-of-unread-articles
 788                   ;; is buggy so we return '((1 . 1)).
 789                   seen (if (and (integerp (car seen))
 790                                 (null (cdr seen)))
 791                            (list (cons (car seen) (car seen)))
 792                          seen))
 793             (gnus-info-set-read info seen)))
 794
 795         (mapc (lambda (pred)
 796                 (when (and (nnimap-mark-permanent-p (cdr pred))
 797                            (member (nnimap-mark-to-flag (cdr pred))
 798                                    (imap-mailbox-get 'flags)))
 799                   (gnus-info-set-marks
 800                    info
 801                    (nnimap-update-alist-soft
 802                     (cdr pred)
 803                     (gnus-compress-sequence
 804                      (imap-search (nnimap-mark-to-predicate (cdr pred))))
 805                     (gnus-info-marks info))
 806                    t)))
 807               gnus-article-mark-lists)
 808
 809         (gnus-message 5 "nnimap: Updating info for %s...done"
 810                       (gnus-info-group info))
 811
 812         info))))
 813
 814 (deffoo nnimap-request-type (group &optional article)
 815   (if (and nnimap-news-groups (string-match nnimap-news-groups group))
 816       'news
 817     'mail))
 818
 819 (deffoo nnimap-request-set-mark (group actions &optional server)
 820   (when (nnimap-possibly-change-group group server)
 821     (with-current-buffer nnimap-server-buffer
 822       (let (action)
 823         (gnus-message 7 "nnimap: Setting marks in %s..." group)
 824         (while (setq action (pop actions))
 825           (let ((range (nth 0 action))
 826                 (what  (nth 1 action))
 827                 (cmdmarks (nth 2 action))
 828                 marks)
 829             ;; cache flags are pointless on the server
 830             (setq cmdmarks (delq 'cache cmdmarks))
 831             ;; flag dormant articles as ticked
 832             (if (memq 'dormant cmdmarks)
 833                 (setq cmdmarks (cons 'tick cmdmarks)))
 834             ;; remove stuff we are forbidden to store
 835             (mapcar (lambda (mark)
 836                       (if (imap-message-flag-permanent-p
 837                            (nnimap-mark-to-flag mark))
 838                           (setq marks (cons mark marks))))
 839                     cmdmarks)
 840             (when (and range marks)
 841               (cond ((eq what 'del)
 842                      (imap-message-flags-del
 843                       (nnimap-range-to-string range)
 844                       (nnimap-mark-to-flag marks nil t)))
 845                     ((eq what 'add)
 846                      (imap-message-flags-add
 847                       (nnimap-range-to-string range)
 848                       (nnimap-mark-to-flag marks nil t)))
 849                     ((eq what 'set)
 850                      (imap-message-flags-set
 851                       (nnimap-range-to-string range)
 852                       (nnimap-mark-to-flag marks nil t)))))))
 853         (gnus-message 7 "nnimap: Setting marks in %s...done" group))))
 854   nil)
 855
 856 (defun nnimap-split-to-groups (rules)
 857   ;; tries to match all rules in nnimap-split-rule against content of
 858   ;; nntp-server-buffer, returns a list of groups that matched.
 859   (with-current-buffer nntp-server-buffer
 860     ;; Fold continuation lines.
 861     (goto-char (point-min))
 862     (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 863       (replace-match " " t t))
 864     (if (functionp rules)
 865         (funcall rules)
 866       (let (to-groups regrepp)
 867         (catch 'split-done
 868           (dolist (rule rules to-groups)
 869             (let ((group (car rule))
 870                   (regexp (cadr rule)))
 871               (goto-char (point-min))
 872               (when (and (if (stringp regexp)
 873                              (progn
 874                                (setq regrepp (string-match "\\\\[0-9&]" group))
 875                                (re-search-forward regexp nil t))
 876                            (funcall regexp group))
 877                          ;; Don't enter the article into the same group twice.
 878                          (not (assoc group to-groups)))
 879                 (push (if regrepp
 880                           (nnmail-expand-newtext group)
 881                         group)
 882                       to-groups)
 883                 (or nnimap-split-crosspost
 884                     (throw 'split-done to-groups))))))))))
 885
 886 (defun nnimap-split-find-rule (server inbox)
 887   nnimap-split-rule)
 888
 889 (defun nnimap-split-find-inbox (server)
 890   (if (listp nnimap-split-inbox)
 891       nnimap-split-inbox
 892     (list nnimap-split-inbox)))
 893
 894 (defun nnimap-split-articles (&optional group server)
 895   (when (nnimap-possibly-change-server server)
 896     (with-current-buffer nnimap-server-buffer
 897       (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server)))
 898         ;; iterate over inboxes
 899         (while (and (setq inbox (pop inboxes))
 900                     (nnimap-possibly-change-group inbox)) ;; SELECT
 901           ;; find split rule for this server / inbox
 902           (when (setq rule (nnimap-split-find-rule server inbox))
 903             ;; iterate over articles
 904             (dolist (article (imap-search "UNSEEN UNDELETED"))
 905               (when (nnimap-request-head article)
 906                 ;; copy article to right group(s)
 907                 (setq removeorig nil)
 908                 (dolist (to-group (nnimap-split-to-groups rule))
 909                   (if (imap-message-copy (number-to-string article)
 910                                          to-group nil 'nocopyuid)
 911                       (progn
 912                         (message "IMAP split moved %s:%s:%d to %s" server inbox
 913                                  article to-group)
 914                         (setq removeorig t)
 915                         ;; Add the group-art list to the history list.
 916                         (push (list (cons to-group 0)) nnmail-split-history))
 917                     (message "IMAP split failed to move %s:%s:%d to %s" server
 918                              inbox article to-group)))
 919                 ;; remove article if it was successfully copied somewhere
 920                 (and removeorig
 921                      (imap-message-flags-add (format "%d" article)
 922                                              "\\Seen \\Deleted")))))
 923           (when (imap-mailbox-select inbox) ;; just in case
 924             ;; todo: UID EXPUNGE (if available) to remove splitted articles
 925             (imap-mailbox-expunge)
 926             (imap-mailbox-close)))
 927         t))))
 928
 929 (deffoo nnimap-request-scan (&optional group server)
 930   (nnimap-split-articles group server))
 931
 932 (deffoo nnimap-request-newgroups (date &optional server)
 933   (when (nnimap-possibly-change-server server)
 934     (with-current-buffer nntp-server-buffer
 935       (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..."
 936                     (if (> (length server) 0) " on " "") server)
 937       (erase-buffer)
 938       (dolist (pattern (nnimap-pattern-to-list-arguments
 939                         nnimap-list-pattern))
 940         (dolist (mbx (imap-mailbox-lsub "*" (car pattern) nil
 941                                         nnimap-server-buffer))
 942           (or (let ((mailboxes (imap-mailbox-get 'list-flags mbx
 943                                                  nnimap-server-buffer)))
 944                 (while (and mailboxes
 945                             (not (string-equal (downcase (car mailboxes))
 946                                                "\\noselect")))
 947                   (pop mailboxes))
 948                 mailboxes)
 949               ;; Escape SPC in mailboxes xxx relies on gnus internals
 950               (let ((info (nnimap-find-minmax-uid mbx 'examine)))
 951                 (when info
 952                   (insert (format "%s %d %d y\n"
 953                                   (nnimap-replace-in-string mbx " " "\\ ")
 954                                   (or (nth 2 info) 0)
 955                                   (max 1 (or (nth 1 info) 1)))))))))
 956       (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done"
 957                     (if (> (length server) 0) " on " "") server))
 958     t))
 959
 960 (deffoo nnimap-request-create-group (group &optional server args)
 961   (when (nnimap-possibly-change-server server)
 962     (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer)
 963         (imap-mailbox-create group nnimap-server-buffer))))
 964
 965 (defun nnimap-time-substract (time1 time2)
 966   "Return TIME for TIME1 - TIME2."
 967   (let* ((ms (- (car time1) (car time2)))
 968          (ls (- (nth 1 time1) (nth 1 time2))))
 969     (if (< ls 0)
 970         (list (- ms 1) (+ (expt 2 16) ls))
 971       (list ms ls))))
 972
 973 (defun nnimap-date-days-ago (daysago)
 974   "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago."
 975   (let ((date (format-time-string "%d-%b-%Y"
 976                                   (nnimap-time-substract
 977                                    (current-time)
 978                                    (days-to-time daysago)))))
 979     (if (eq ?0 (string-to-char date))
 980         (substring date 1)
 981       date)))
 982
 983 (defun nnimap-request-expire-articles-progress ()
 984   (gnus-message 5 "nnimap: Marking article %d for deletion..."
 985                 imap-current-message))
 986
 987 ;; Notice that we don't actually delete anything, we just mark them deleted.
 988 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 989   (let ((artseq (gnus-compress-sequence articles)))
 990     (when (and artseq (nnimap-possibly-change-group group server))
 991       (with-current-buffer nnimap-server-buffer
 992         (if force
 993             (and (imap-message-flags-add
 994                   (nnimap-range-to-string artseq) "\\Deleted")
 995                  (setq articles nil))
 996           (let ((days (or (and nnmail-expiry-wait-function
 997                                (funcall nnmail-expiry-wait-function group))
 998                           nnmail-expiry-wait)))
 999             (cond ((eq days 'immediate)
1000                    (and (imap-message-flags-add
1001                          (nnimap-range-to-string artseq) "\\Deleted")
1002                         (setq articles nil)))
1003                   ((numberp days)
1004                    (let ((oldarts (imap-search
1005                                    (format "UID %s NOT SINCE %s"
1006                                            (nnimap-range-to-string artseq)
1007                                            (nnimap-date-days-ago days))))
1008                          (imap-fetch-data-hook
1009                           '(nnimap-request-expire-articles-progress)))
1010                      (and oldarts
1011                           (imap-message-flags-add
1012                            (nnimap-range-to-string
1013                             (gnus-compress-sequence oldarts))
1014                            "\\Deleted")
1015                           (setq articles (gnus-set-difference
1016                                           articles oldarts)))))))))))
1017   ;; return articles not deleted
1018   articles)
1019
1020 (deffoo nnimap-request-move-article (article group server
1021                                              accept-form &optional last)
1022   (when (nnimap-possibly-change-server server)
1023     (save-excursion
1024       (let ((buf (get-buffer-create " *nnimap move*"))
1025             (nnimap-current-move-article article)
1026             (nnimap-current-move-group group)
1027             (nnimap-current-move-server nnimap-current-server)
1028             result)
1029         (and (nnimap-request-article article group server)
1030              (save-excursion
1031                (set-buffer buf)
1032                (buffer-disable-undo (current-buffer))
1033                (insert-buffer-substring nntp-server-buffer)
1034                (setq result (eval accept-form))
1035                (kill-buffer buf)
1036                result)
1037              (nnimap-request-expire-articles (list article) group server t))
1038         result))))
1039
1040 (deffoo nnimap-request-accept-article (group &optional server last)
1041   (when (nnimap-possibly-change-server server)
1042     (let (uid)
1043       (if (setq uid
1044                 (if (string= nnimap-current-server nnimap-current-move-server)
1045                     ;; moving article within same server, speed it up...
1046                     (and (nnimap-possibly-change-group
1047                           nnimap-current-move-group)
1048                          (imap-message-copy (number-to-string
1049                                              nnimap-current-move-article)
1050                                             group 'dontcreate nil
1051                                             nnimap-server-buffer))
1052                   ;; turn into rfc822 format (\r\n eol's)
1053                   (with-current-buffer (current-buffer)
1054                     (goto-char (point-min))
1055                     (while (search-forward "\n" nil t)
1056                       (replace-match "\r\n")))
1057                   ;; next line for Cyrus server bug
1058                   (imap-mailbox-unselect nnimap-server-buffer)
1059                   (imap-message-append group (current-buffer) nil nil
1060                                        nnimap-server-buffer)))
1061           (cons group (nth 1 uid))
1062         (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer))))))
1063
1064 (deffoo nnimap-request-delete-group (group force &optional server)
1065   (when (nnimap-possibly-change-server server)
1066     (with-current-buffer nnimap-server-buffer
1067       (if force
1068           (or (null (imap-mailbox-status group 'uidvalidity))
1069               (imap-mailbox-delete group))
1070         ;; UNSUBSCRIBE?
1071         t))))
1072
1073 (deffoo nnimap-request-rename-group (group new-name &optional server)
1074   (when (nnimap-possibly-change-server server)
1075     (imap-mailbox-rename group new-name nnimap-server-buffer)))
1076
1077 (defun nnimap-expunge (mailbox server)
1078   (when (nnimap-possibly-change-group mailbox server)
1079     (imap-mailbox-expunge nnimap-server-buffer)))
1080
1081 (defun nnimap-acl-get (mailbox server)
1082   (when (nnimap-possibly-change-server server)
1083     (imap-mailbox-acl-get mailbox nnimap-server-buffer)))
1084
1085 (defun nnimap-acl-edit (mailbox method old-acls new-acls)
1086   (when (nnimap-possibly-change-server (cadr method))
1087     (unless (imap-capability 'ACL nnimap-server-buffer)
1088       (error "Your server does not support ACL editing"))
1089     (with-current-buffer nnimap-server-buffer
1090       ;; delete all removed identifiers
1091       (mapcar (lambda (old-acl)
1092                 (unless (assoc (car old-acl) new-acls)
1093                     (or (imap-mailbox-acl-delete (car old-acl) mailbox)
1094                         (error "Can't delete ACL for %s" (car old-acl)))))
1095               old-acls)
1096       ;; set all changed acl's
1097       (mapcar (lambda (new-acl)
1098                 (let ((new-rights (cdr new-acl))
1099                       (old-rights (cdr (assoc (car new-acl) old-acls))))
1100                 (unless (and old-rights new-rights
1101                              (string= old-rights new-rights))
1102                   (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
1103                       (error "Can't set ACL for %s to %s" (car new-acl)
1104                              new-rights)))))
1105               new-acls)
1106       t)))
1107
1108 \f
1109 ;;; Internal functions
1110
1111 ;;
1112 ;; This is confusing.
1113 ;;
1114 ;; mark      => read, tick, draft, reply etc
1115 ;; flag      => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc
1116 ;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc
1117 ;;
1118 ;; Mark should not really contain 'read since it's not a "mark" in the Gnus
1119 ;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read).
1120 ;;
1121
1122 (defconst nnimap-mark-to-predicate-alist
1123   (mapcar
1124    (lambda (pair) ; cdr is the mark
1125      (or (assoc (cdr pair)
1126                 '((read . "SEEN")
1127                   (tick . "FLAGGED")
1128                   (draft . "DRAFT")
1129                   (reply . "ANSWERED")))
1130          (cons (cdr pair)
1131                (format "KEYWORD gnus-%s" (symbol-name (cdr pair))))))
1132    (cons '(read . read) gnus-article-mark-lists)))
1133
1134 (defun nnimap-mark-to-predicate (pred)
1135   "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP
1136 predicate (a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD
1137 gnus-expire\") to be used within a IMAP SEARCH query."
1138   (cdr (assq pred nnimap-mark-to-predicate-alist)))
1139
1140 (defconst nnimap-mark-to-flag-alist
1141   (mapcar
1142    (lambda (pair)
1143      (or (assoc (cdr pair)
1144                 '((read . "\\Seen")
1145                   (tick . "\\Flagged")
1146                   (draft . "\\Draft")
1147                   (reply . "\\Answered")))
1148          (cons (cdr pair)
1149                (format "gnus-%s" (symbol-name (cdr pair))))))
1150    (cons '(read . read) gnus-article-mark-lists)))
1151
1152 (defun nnimap-mark-to-flag-1 (preds)
1153   (if (and (not (null preds)) (listp preds))
1154       (cons (nnimap-mark-to-flag (car preds))
1155             (nnimap-mark-to-flag (cdr preds)))
1156     (cdr (assoc preds nnimap-mark-to-flag-alist))))
1157
1158 (defun nnimap-mark-to-flag (preds &optional always-list make-string)
1159   "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP
1160 flag (a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\") to
1161 be used in a STORE FLAGS command."
1162   (let ((result (nnimap-mark-to-flag-1 preds)))
1163     (setq result (if (and (or make-string always-list)
1164                           (not (listp result)))
1165                      (list result)
1166                    result))
1167     (if make-string
1168         (mapconcat (lambda (flag)
1169                      (if (listp flag)
1170                          (mapconcat 'identity flag " ")
1171                        flag))
1172                    result " ")
1173       result)))
1174
1175 (defun nnimap-mark-permanent-p (mark &optional group)
1176   "Return t iff MARK can be permanently (between IMAP sessions) saved
1177 on articles, in GROUP."
1178   (imap-message-flag-permanent-p (nnimap-mark-to-flag mark)))
1179
1180 (defun nnimap-remassoc (key alist)
1181   "Delete by side effect any elements of LIST whose car is
1182 `equal' to KEY.  The modified LIST is returned.  If the first member
1183 of LIST has a car that is `equal' to KEY, there is no way to remove it
1184 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
1185 sure of changing the value of `foo'."
1186   (when alist
1187     (if (equal key (caar alist))
1188         (cdr alist)
1189       (setcdr alist (nnimap-remassoc key (cdr alist)))
1190       alist)))
1191
1192 (defun nnimap-update-alist-soft (key value alist)
1193   (if value
1194       (cons (cons key value) (nnimap-remassoc key alist))
1195     (nnimap-remassoc key alist)))
1196
1197 (defun nnimap-range-to-string (range)
1198   (mapconcat
1199    (lambda (item)
1200      (if (consp item)
1201          (format "%d:%d"
1202                  (car item) (cdr item))
1203        (format "%d" item)))
1204    (if (and (listp range) (not (listp (cdr range))))
1205        (list range) ;; make (1 . 2) into ((1 . 2))
1206      range)
1207    ","))
1208
1209 (when nnimap-debug
1210   (require 'trace)
1211   (buffer-disable-undo (get-buffer-create nnimap-debug))
1212   (mapc (lambda (f) (trace-function-background f nnimap-debug))
1213         '(
1214 nnimap-replace-in-string
1215 nnimap-possibly-change-server
1216 nnimap-verify-uidvalidity
1217 nnimap-find-minmax-uid
1218 nnimap-possibly-change-group
1219 ;nnimap-replace-whitespace
1220 nnimap-retrieve-headers-progress
1221 nnimap-retrieve-which-headers
1222 nnimap-group-overview-filename
1223 nnimap-retrieve-headers-from-file
1224 nnimap-retrieve-headers-from-server
1225 nnimap-retrieve-headers
1226 nnimap-open-connection
1227 nnimap-open-server
1228 nnimap-server-opened
1229 nnimap-close-server
1230 nnimap-request-close
1231 nnimap-status-message
1232 ;nnimap-demule
1233 nnimap-request-article-part
1234 nnimap-request-article
1235 nnimap-request-head
1236 nnimap-request-body
1237 nnimap-request-group
1238 nnimap-close-group
1239 nnimap-pattern-to-list-arguments
1240 nnimap-request-list
1241 nnimap-request-post
1242 nnimap-retrieve-groups
1243 nnimap-request-update-info-internal
1244 nnimap-request-type
1245 nnimap-request-set-mark
1246 nnimap-split-to-groups
1247 nnimap-split-find-rule
1248 nnimap-split-find-inbox
1249 nnimap-split-articles
1250 nnimap-request-scan
1251 nnimap-request-newgroups
1252 nnimap-request-create-group
1253 nnimap-time-substract
1254 nnimap-date-days-ago
1255 nnimap-request-expire-articles-progress
1256 nnimap-request-expire-articles
1257 nnimap-request-move-article
1258 nnimap-request-accept-article
1259 nnimap-request-delete-group
1260 nnimap-request-rename-group
1261 gnus-group-nnimap-expunge
1262 gnus-group-nnimap-edit-acl
1263 gnus-group-nnimap-edit-acl-done
1264 nnimap-group-mode-hook
1265 nnimap-mark-to-predicate
1266 nnimap-mark-to-flag-1
1267 nnimap-mark-to-flag
1268 nnimap-mark-permanent-p
1269 nnimap-remassoc
1270 nnimap-update-alist-soft
1271 nnimap-range-to-string
1272           )))
1273
1274 (provide 'nnimap)
1275
1276 ;;; nnimap.el ends here