cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-imap.el

   1 ;;; vm-imap.el ---  Simple IMAP4 (RFC 2060) client for VM
   2 ;;
   3 ;; Copyright (C) 1998, 2001, 2003 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;; Copyright (C) 2006 Robert P. Goldman
   6 ;;
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2 of the License, or
  10 ;; (at your option) any later version.
  11 ;;
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License along
  18 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  19 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  20
  21 ;;; Code:
  22 (eval-when-compile
  23   (require 'sendmail))
  24
  25 (if (fboundp 'define-error)
  26     (progn
  27       (define-error 'vm-imap-protocol-error "IMAP protocol error"))
  28   (put 'vm-imap-protocol-error 'error-conditions
  29        '(vm-imap-protocol-error error))
  30   (put 'vm-imap-protocol-error 'error-message "IMAP protocol error"))
  31
  32 (defun vm-imap-capability (cap &optional process)
  33   (if process
  34       (save-excursion
  35         (set-buffer (process-buffer process))
  36         (memq cap vm-imap-capabilities))
  37     (memq cap vm-imap-capabilities)))
  38
  39 (defun vm-imap-auth-method (auth)
  40   (memq auth vm-imap-auth-methods))
  41
  42 (defsubst vm-folder-imap-maildrop-spec ()
  43   (aref vm-folder-access-data 0))
  44 (defsubst vm-folder-imap-process ()
  45   (aref vm-folder-access-data 1))
  46 (defsubst vm-folder-imap-uid-validity ()
  47   (aref vm-folder-access-data 2))
  48 (defsubst vm-folder-imap-uid-list ()
  49   (aref vm-folder-access-data 3))
  50 (defsubst vm-folder-imap-mailbox-count ()
  51   (aref vm-folder-access-data 4))
  52 (defsubst vm-folder-imap-read-write ()
  53   (aref vm-folder-access-data 5))
  54 (defsubst vm-folder-imap-can-delete ()
  55   (aref vm-folder-access-data 6))
  56 (defsubst vm-folder-imap-body-peek ()
  57   (aref vm-folder-access-data 7))
  58 (defsubst vm-folder-imap-permanent-flags ()
  59   (aref vm-folder-access-data 8))
  60
  61 (defsubst vm-set-folder-imap-maildrop-spec (val)
  62   (aset vm-folder-access-data 0 val))
  63 (defsubst vm-set-folder-imap-process (val)
  64   (aset vm-folder-access-data 1 val))
  65 (defsubst vm-set-folder-imap-uid-validity (val)
  66   (aset vm-folder-access-data 2 val))
  67 (defsubst vm-set-folder-imap-uid-list (val)
  68   (aset vm-folder-access-data 3 val))
  69 (defsubst vm-set-folder-imap-mailbox-count (val)
  70   (aset vm-folder-access-data 4 val))
  71 (defsubst vm-set-folder-imap-read-write (val)
  72   (aset vm-folder-access-data 5 val))
  73 (defsubst vm-set-folder-imap-can-delete (val)
  74   (aset vm-folder-access-data 6 val))
  75 (defsubst vm-set-folder-imap-body-peek (val)
  76   (aset vm-folder-access-data 7 val))
  77 (defsubst vm-set-folder-imap-permanent-flags (val)
  78   (aset vm-folder-access-data 8 val))
  79
  80 ;; Our goal is to drag the mail from the IMAP maildrop to the crash box.
  81 ;; just as if we were using movemail on a spool file.
  82 ;; We remember which messages we have retrieved so that we can
  83 ;; leave the message in the mailbox, and yet not retrieve the
  84 ;; same messages again and again.
  85
  86 ;;;###autoload
  87 (defun vm-imap-move-mail (source destination)
  88   (let ((process nil)
  89         (m-per-session vm-imap-messages-per-session)
  90         (b-per-session vm-imap-bytes-per-session)
  91         (handler (and (fboundp 'find-file-name-handler)
  92                       (condition-case ()
  93                           (find-file-name-handler source 'vm-imap-move-mail)
  94                         (wrong-number-of-arguments
  95                           (find-file-name-handler source)))))
  96         (imapdrop (vm-safe-imapdrop-string source))
  97         (statblob nil)
  98         (msgid (list nil nil (vm-imapdrop-sans-password source) 'uid))
  99         (imap-retrieved-messages vm-imap-retrieved-messages)
 100         (did-delete nil)
 101         (source-nopwd (vm-imapdrop-sans-password source))
 102         use-body-peek auto-expunge x select source-list uid
 103         can-delete read-write uid-validity
 104         mailbox mailbox-count message-size response
 105         n (retrieved 0) retrieved-bytes process-buffer)
 106     (setq auto-expunge (cond ((setq x (assoc source
 107                                              vm-imap-auto-expunge-alist))
 108                               (cdr x))
 109                              ((setq x (assoc (vm-imapdrop-sans-password source)
 110                                              vm-imap-auto-expunge-alist))
 111                               (cdr x))
 112                              (t vm-imap-expunge-after-retrieving)))
 113     (unwind-protect
 114         (catch 'end-of-session
 115           (if handler
 116               (throw 'end-of-session
 117                      (funcall handler 'vm-imap-move-mail source destination)))
 118           (setq process (vm-imap-make-session source))
 119           (or process (throw 'end-of-session nil))
 120           (setq process-buffer (process-buffer process))
 121           (save-excursion
 122             (set-buffer process-buffer)
 123             ;; find out how many messages are in the box.
 124             (setq source-list (vm-parse source "\\([^:]+\\):?")
 125                   mailbox (nth 3 source-list))
 126             (setq select (vm-imap-select-mailbox process mailbox))
 127             (setq mailbox-count (nth 0 select)
 128                   uid-validity (nth 1 select)
 129                   read-write (nth 2 select)
 130                   can-delete (nth 3 select)
 131                   use-body-peek (vm-imap-capability 'IMAP4REV1))
 132             ;; sweep through the retrieval list, removing entries
 133             ;; that have been invalidated by the new UIDVALIDITY
 134             ;; value.
 135             (setq imap-retrieved-messages
 136                   (vm-imap-clear-invalid-retrieval-entries
 137                    source-nopwd
 138                    imap-retrieved-messages
 139                    uid-validity))
 140             ;; loop through the maildrop retrieving and deleting
 141             ;; messages as we go.
 142             (setq n 1 retrieved-bytes 0)
 143             (setq statblob (vm-imap-start-status-timer))
 144             (vm-set-imap-stat-x-box statblob imapdrop)
 145             (vm-set-imap-stat-x-maxmsg statblob mailbox-count)
 146             (while (and (<= n mailbox-count)
 147                         (or (not (natnump m-per-session))
 148                             (< retrieved m-per-session))
 149                         (or (not (natnump b-per-session))
 150                             (< retrieved-bytes b-per-session)))
 151               (catch 'skip
 152                 (vm-set-imap-stat-x-currmsg statblob n)
 153                 (let (list)
 154                   (setq list (vm-imap-get-uid-list process n n))
 155                   (setq uid (cdr (car list)))
 156                   (setcar msgid uid)
 157                   (setcar (cdr msgid) uid-validity)
 158                   (if (member msgid imap-retrieved-messages)
 159                       (progn
 160                         (if vm-imap-ok-to-ask
 161                             (message
 162                              "Skipping message %d (of %d) from %s (retrieved already)..."
 163                              n mailbox-count imapdrop))
 164                         (throw 'skip t))))
 165                 (setq message-size (vm-imap-get-message-size process n))
 166                 (vm-set-imap-stat-x-need statblob message-size)
 167                 (if (and (integerp vm-imap-max-message-size)
 168                          (> message-size vm-imap-max-message-size)
 169                          (progn
 170                            (setq response
 171                                  (if vm-imap-ok-to-ask
 172                                      (vm-imap-ask-about-large-message
 173                                       process message-size n)
 174                                    'skip))
 175                            (not (eq response 'retrieve))))
 176                     (progn
 177                       (if (and read-write can-delete (eq response 'delete))
 178                           (progn
 179                             (message "Deleting message %d..." n)
 180                             (vm-imap-delete-message process n)
 181                             (setq did-delete t))
 182                         (if vm-imap-ok-to-ask
 183                             (message "Skipping message %d..." n)
 184                           (message
 185                            "Skipping message %d in %s, too large (%d > %d)..."
 186                            n imapdrop message-size vm-imap-max-message-size)))
 187                       (throw 'skip t)))
 188                 (message "Retrieving message %d (of %d) from %s..."
 189                          n mailbox-count imapdrop)
 190                 (if use-body-peek
 191                     (progn
 192                       (vm-imap-send-command process
 193                                             (format "FETCH %d (BODY.PEEK[])"
 194                                                     n))
 195                       (vm-imap-retrieve-to-target process destination
 196                                                   statblob t))
 197                   (progn
 198                        (vm-imap-send-command process
 199                                              (format
 200                                               "FETCH %d (RFC822.PEEK)" n))
 201                        (vm-imap-retrieve-to-target process destination
 202                                                    statblob nil)))
 203                 (message "Retrieving message %d (of %d) from %s...done"
 204                  n mailbox-count imapdrop)
 205                 (vm-increment retrieved)
 206                 (and b-per-session
 207                      (setq retrieved-bytes (+ retrieved-bytes message-size)))
 208                 (if (not auto-expunge)
 209                     (setq imap-retrieved-messages
 210                           (cons (copy-sequence msgid)
 211                                 imap-retrieved-messages))
 212                   ;; The user doesn't want the messages
 213                   ;; kept in the mailbox.
 214                   ;; Delete the message now.
 215                   (if (and read-write can-delete)
 216                       (progn
 217                         (vm-imap-delete-message process n)
 218                         (setq did-delete t)))))
 219               (vm-increment n))
 220             (if did-delete
 221                 (progn
 222                   ;; CLOSE forces an expunge and avoids the EXPUNGE
 223                   ;; responses.
 224                   (vm-imap-send-command process "CLOSE")
 225                   (vm-imap-read-ok-response process)))
 226             (not (equal retrieved 0)) ))
 227       (setq vm-imap-retrieved-messages imap-retrieved-messages)
 228       (if (and (eq vm-flush-interval t) (not (equal retrieved 0)))
 229           (vm-stuff-imap-retrieved))
 230       (and statblob (vm-imap-stop-status-timer statblob))
 231       (if process
 232           (vm-imap-end-session process)))))
 233
 234 (defun vm-imap-check-mail (source)
 235   (let ((process nil)
 236         (handler (and (fboundp 'find-file-name-handler)
 237                       (condition-case ()
 238                           (find-file-name-handler source 'vm-imap-check-mail)
 239                         (wrong-number-of-arguments
 240                          (find-file-name-handler source)))))
 241         (retrieved vm-imap-retrieved-messages)
 242         (imapdrop (vm-imapdrop-sans-password source))
 243         (count 0)
 244         msg-count uid-validity x response select mailbox source-list)
 245     (unwind-protect
 246         (prog1
 247             (save-excursion
 248               (catch 'end-of-session
 249                 (if handler
 250                     (throw 'end-of-session
 251                            (funcall handler 'vm-imap-check-mail source)))
 252                 (setq process (vm-imap-make-session source))
 253                 (or process (throw 'end-of-session nil))
 254                 (set-buffer (process-buffer process))
 255                 (setq source-list (vm-parse source "\\([^:]+\\):?")
 256                       mailbox (nth 3 source-list))
 257                 (setq select (vm-imap-select-mailbox process mailbox)
 258                       msg-count (car select)
 259                       uid-validity (nth 1 select))
 260                 (if (zerop msg-count)
 261                     (progn
 262                       (vm-store-folder-totals source '(0 0 0 0))
 263                       (throw 'end-of-session nil)))
 264                 ;; sweep through the retrieval list, removing entries
 265                 ;; that have been invalidated by the new UIDVALIDITY
 266                 ;; value.
 267                 (setq retrieved
 268                   (vm-imap-clear-invalid-retrieval-entries imapdrop
 269                                                            retrieved
 270                                                            uid-validity))
 271                 (setq response (vm-imap-get-uid-list process 1 msg-count))
 272                 (if (null response)
 273                     nil
 274                   (if (null (car response))
 275                       ;; (nil . nil) is returned if there are no
 276                       ;; messages in the mailbox.
 277                       (progn
 278                         (vm-store-folder-totals source '(0 0 0 0))
 279                         (throw 'end-of-session nil))
 280                     (while response
 281                       (if (not (and (setq x (assoc (cdr (car response))
 282                                                    retrieved))
 283                                     (equal (nth 1 x) imapdrop)
 284                                     (eq (nth 2 x) 'uid)))
 285                           (vm-increment count))
 286                       (setq response (cdr response))))
 287                   (vm-store-folder-totals source (list count 0 0 0))
 288                   (throw 'end-of-session (not (eq count 0))))
 289                 (not (equal 0 (car select)))))
 290           (setq vm-imap-retrieved-messages retrieved))
 291       (and process (vm-imap-end-session process)))))
 292
 293 (defun vm-expunge-imap-messages ()
 294   "Deletes all messages from IMAP mailbox that have already been retrieved
 295 into the current folder.  VM sets the \\Deleted flag on all such messages
 296 on all the relevant IMAP servers and then immediately expunges."
 297   (interactive)
 298   (vm-follow-summary-cursor)
 299   (vm-select-folder-buffer)
 300   (vm-check-for-killed-summary)
 301   (vm-error-if-virtual-folder)
 302   (let ((process nil)
 303         (source nil)
 304         (trouble nil)
 305         (delete-count 0)
 306         (vm-global-block-new-mail t)
 307         (vm-imap-ok-to-ask t)
 308         (did-delete nil)
 309         msg-count can-delete read-write uid-validity
 310         select-response source-list imapdrop uid-alist mailbox data mp match)
 311     (unwind-protect
 312         (save-excursion
 313           (setq vm-imap-retrieved-messages
 314                 (sort vm-imap-retrieved-messages
 315                       (function (lambda (a b)
 316                                   (cond ((string-lessp (nth 2 a) (nth 2 b)) t)
 317                                         ((string-lessp (nth 2 b)
 318                                                        (nth 2 a))
 319                                          nil)
 320                                         ((string-lessp (nth 1 a) (nth 1 b)) t)
 321                                         ((string-lessp (nth 1 b) (nth 1 a))
 322                                          nil)
 323                                         ((string-lessp (nth 0 a) (nth 0 b)) t)
 324                                         (t nil))))))
 325           (setq mp vm-imap-retrieved-messages)
 326           (while mp
 327             (catch 'replay
 328               (condition-case error-data
 329                   (progn
 330                     (setq data (car mp))
 331                     (if (not (equal source (nth 2 data)))
 332                         (progn
 333                           (if process
 334                               (progn
 335                                 (if did-delete
 336                                     (progn
 337                                       (vm-imap-send-command process "CLOSE")
 338                                       (vm-imap-read-ok-response process)))
 339                                 (vm-imap-end-session process)
 340                                 (setq process nil
 341                                       did-delete nil)))
 342                           (setq source (nth 2 data))
 343                           (setq imapdrop (vm-safe-imapdrop-string source))
 344                           (condition-case error-data
 345                               (progn
 346                                 (message "Opening IMAP session to %s..."
 347                                          imapdrop)
 348                                 (setq process (vm-imap-make-session source))
 349                                 (if (null process)
 350                                     (signal 'error nil))
 351                                 (set-buffer (process-buffer process))
 352                                 (setq source-list (vm-parse source
 353                                                             "\\([^:]+\\):?")
 354                                       mailbox (nth 3 source-list)
 355                                       select-response (vm-imap-select-mailbox
 356                                                        process mailbox)
 357                                       msg-count (car select-response)
 358                                       uid-validity (nth 1 select-response)
 359                                       read-write (nth 2 select-response)
 360                                       can-delete (nth 3 select-response))
 361                                 (setq mp
 362                                       (vm-imap-clear-invalid-retrieval-entries
 363                                        source
 364                                        mp
 365                                        uid-validity))
 366                                 (if (not (eq data (car mp)))
 367                                     ;; this entry must have been
 368                                     ;; discarded as invalid, so
 369                                     ;; skip it and process the
 370                                     ;; entry that is now at the
 371                                     ;; head of the list.
 372                                     (throw 'replay t))
 373                                 (if (not can-delete)
 374                                     (error "Can't delete messages in mailbox %s, skipping..." mailbox))
 375                                 (if (not read-write)
 376                                     (error "Mailbox %s is read-only, skipping..." mailbox))
 377                                 (message "Expunging messages in %s..." imapdrop))
 378                             (error
 379                              (if (cdr error-data)
 380                                  (apply 'message (cdr error-data))
 381                                (message
 382                                 "Couldn't open IMAP session to %s, skipping..."
 383                                 imapdrop))
 384                              (setq trouble (cons imapdrop trouble))
 385                              (sleep-for 2)
 386                              (while (equal (nth 1 (car mp)) source)
 387                                (setq mp (cdr mp)))
 388                              (throw 'replay t)))
 389                           (if (zerop msg-count)
 390                               (progn
 391                                 (while (equal (nth 1 (car mp)) source)
 392                                   (setq mp (cdr mp)))
 393                                 (throw 'replay t)))
 394                           (setq uid-alist
 395                                 (vm-imap-get-uid-list
 396                                  process 1 msg-count))))
 397                     (if (setq match (rassoc (car data) uid-alist))
 398                         (progn
 399                           (vm-imap-delete-message process (car match))
 400                           (setq did-delete t)
 401                           (vm-increment delete-count))))
 402                 (error
 403                  (setq trouble (cons imapdrop trouble))
 404                  (message "Something signaled: %s"
 405                           (prin1-to-string error-data))
 406                  (sleep-for 2)
 407                  (message "Skipping rest of mailbox %s..." imapdrop)
 408                  (sleep-for 2)
 409                  (while (equal (nth 2 (car mp)) source)
 410                    (setq mp (cdr mp)))
 411                  (throw 'replay t)))
 412               (setq mp (cdr mp))))
 413           (if did-delete
 414               (progn
 415                 (vm-imap-send-command process "CLOSE")
 416                 (vm-imap-read-ok-response process)))
 417           (if trouble
 418               (progn
 419                 (set-buffer (get-buffer-create "*IMAP Expunge Trouble*"))
 420                 (setq buffer-read-only nil)
 421                 (erase-buffer)
 422                 (insert (format "%s IMAP message%s expunged.\n\n"
 423                                 (if (zerop delete-count) "No" delete-count)
 424                                 (if (= delete-count 1) "" "s")))
 425                 (insert "VM had problems expunging messages from:\n")
 426                 (nreverse trouble)
 427                 (setq mp trouble)
 428                 (while mp
 429                   (insert "   " (car mp) "\n")
 430                   (setq mp (cdr mp)))
 431                 (setq buffer-read-only t)
 432                 (display-buffer (current-buffer)))
 433             (message "%s IMAP message%s expunged."
 434                      (if (zerop delete-count) "No" delete-count)
 435                      (if (= delete-count 1) "" "s"))))
 436       (and process (vm-imap-end-session process)))
 437     (or trouble (setq vm-imap-retrieved-messages nil))))
 438
 439 ;;;###autoload
 440 (defun vm-imap-make-session (source)
 441   (let ((process-to-shutdown nil)
 442         (folder-type vm-folder-type)
 443         process ooo
 444         (imapdrop (vm-safe-imapdrop-string source))
 445         (coding-system-for-read (vm-binary-coding-system))
 446         (coding-system-for-write (vm-binary-coding-system))
 447         (use-ssl nil)
 448         (use-ssh nil)
 449         (session-name "IMAP")
 450         (process-connection-type nil)
 451         greeting timestamp
 452         host port mailbox auth user pass source-list process-buffer
 453         source-nopwd-nombox)
 454     (unwind-protect
 455         (catch 'end-of-session
 456           ;; parse the maildrop
 457           (setq source-list (vm-parse source "\\([^:]+\\):?")
 458                 host (nth 1 source-list)
 459                 port (nth 2 source-list)
 460 ;;              mailbox (nth 3 source-list)
 461                 auth (nth 4 source-list)
 462                 user (nth 5 source-list)
 463                 pass (nth 6 source-list)
 464                 source-nopwd-nombox
 465                 (vm-imapdrop-sans-password-and-mailbox source))
 466           (cond ((equal auth "preauth") t)
 467                 ((equal "imap-ssl" (car source-list))
 468                  (setq use-ssl t
 469                        session-name "IMAP over SSL")
 470                  (if (null vm-stunnel-program)
 471                      (error "vm-stunnel-program must be non-nil to use IMAP over SSL.")))
 472                 ((equal "imap-ssh" (car source-list))
 473                  (setq use-ssh t
 474                        session-name "IMAP over SSH")
 475                  (if (null vm-ssh-program)
 476                      (error "vm-ssh-program must be non-nil to use IMAP over SSH."))))
 477           ;; carp if parts are missing
 478           (if (null host)
 479               (error "No host in IMAP maildrop specification, \"%s\""
 480                      source))
 481           (if (null port)
 482               (error "No port in IMAP maildrop specification, \"%s\""
 483                      source))
 484           (if (string-match "^[0-9]+$" port)
 485               (setq port (string-to-number port)))
 486           (if (null auth)
 487               (error "No authentication method in IMAP maildrop specification, \"%s\"" source))
 488           (if (null user)
 489               (error "No user in IMAP maildrop specification, \"%s\""
 490                      source))
 491           (if (null pass)
 492               (error "No password in IMAP maildrop specification, \"%s\""
 493                      source))
 494           (if (and (equal pass "*")
 495                    (not (equal auth "preauth")))
 496               (progn
 497                 (setq pass (car (cdr (assoc source-nopwd-nombox
 498                                             vm-imap-passwords))))
 499                 (if (null pass)
 500                     (if (null vm-imap-ok-to-ask)
 501                         (progn (message "Need password for %s" imapdrop)
 502                                (throw 'end-of-session nil))
 503                       (setq pass
 504                             (read-passwd
 505                              (format "IMAP password for %s: "
 506                                      imapdrop)))))))
 507           ;; save the password for the sake of
 508           ;; vm-expunge-imap-messages, which passes password-less
 509           ;; imapdrop specifications to vm-make-imap-session.
 510           (if (null (assoc source-nopwd-nombox vm-imap-passwords))
 511               (setq vm-imap-passwords (cons (list source-nopwd-nombox pass)
 512                                             vm-imap-passwords)))
 513           ;; get the trace buffer
 514           (setq process-buffer
 515                 (vm-make-work-buffer (format "trace of %s session to %s"
 516                                              session-name
 517                                              host)))
 518           (save-excursion
 519             (set-buffer process-buffer)
 520             (setq vm-folder-type (or folder-type vm-default-folder-type))
 521             (buffer-disable-undo process-buffer)
 522             (make-local-variable 'vm-imap-read-point)
 523             ;; clear the trace buffer of old output
 524             (erase-buffer)
 525             ;; Tell MULE not to mess with the text.
 526             (if (fboundp 'set-buffer-file-coding-system)
 527                 (set-buffer-file-coding-system (vm-binary-coding-system) t))
 528             (if (equal auth "preauth")
 529                 (setq process
 530                       (run-hook-with-args-until-success 'vm-imap-session-preauth-hook
 531                                                         host port mailbox
 532                                                         user pass)))
 533             (if (processp process)
 534                 (set-process-buffer process (current-buffer))
 535               (insert "starting " session-name
 536                       " session " (current-time-string) "\n")
 537               (insert (format "connecting to %s:%s\n" host port))
 538               ;; open the connection to the server
 539               (cond (use-ssl
 540                      (vm-setup-stunnel-random-data-if-needed)
 541                      (setq process
 542                            (apply 'start-process session-name process-buffer
 543                                   vm-stunnel-program
 544                                   (nconc (vm-stunnel-configuration-args host
 545                                                                         port)
 546                                          vm-stunnel-program-switches))))
 547                     (use-ssh
 548                      (setq process (open-network-stream
 549                                     session-name process-buffer
 550                                     "127.0.0.1"
 551                                     (vm-setup-ssh-tunnel host port))))
 552                     (t
 553                      (setq process (open-network-stream session-name
 554                                                         process-buffer
 555                                                         host port))))
 556               (and (null process) (throw 'end-of-session nil))
 557               (insert-before-markers "connected\n"))
 558             (setq vm-imap-read-point (point))
 559             (process-kill-without-query process)
 560             (if (null (setq greeting (vm-imap-read-greeting process)))
 561                 (progn (delete-process process)
 562                        (throw 'end-of-session nil)))
 563             (setq process-to-shutdown process)
 564             (set (make-local-variable 'vm-imap-session-done) nil)
 565             ;; record server capabilities
 566             (vm-imap-send-command process "CAPABILITY")
 567             (if (null (setq ooo (vm-imap-read-capability-response process)))
 568                 (throw 'end-of-session nil))
 569             (set (make-local-variable 'vm-imap-capabilities) (car ooo))
 570             (set (make-local-variable 'vm-imap-auth-methods) (nth 1 ooo))
 571             ;; authentication
 572             (cond ((equal auth "login")
 573                    ;; LOGIN must be supported by all imap servers,
 574                    ;; no need to check for it in CAPABILITIES.
 575                    (vm-imap-send-command process
 576                                          (format "LOGIN %s %s"
 577                                                  (vm-imap-quote-string user)
 578                                                  (vm-imap-quote-string pass)))
 579                    (and (null (vm-imap-read-ok-response process))
 580                         (progn
 581                           (setq vm-imap-passwords
 582                                 (delete (list source-nopwd-nombox pass)
 583                                         vm-imap-passwords))
 584                           (message "IMAP password for %s incorrect" imapdrop)
 585                           ;; don't sleep unless we're running synchronously.
 586                           (if vm-imap-ok-to-ask
 587                               (sleep-for 2))
 588                           (throw 'end-of-session nil))))
 589                   ((equal auth "cram-md5")
 590                    (if (not (vm-imap-auth-method 'CRAM-MD5))
 591                        (error "CRAM-MD5 authentication unsupported by this server"))
 592                    (let ((ipad (make-string 64 54))
 593                          (opad (make-string 64 92))
 594                          (command "AUTHENTICATE CRAM-MD5")
 595                          (secret (concat
 596                                   pass
 597                                   (make-string (max 0 (- 64 (length pass)))
 598                                                0)))
 599                          response p challenge answer)
 600                      (vm-imap-send-command process command)
 601                      (setq response (vm-imap-read-response process))
 602                      (if (vm-imap-response-matches response 'VM 'NO)
 603                          (error "server said NO to %s" command))
 604                      (if (vm-imap-response-matches response 'VM 'BAD)
 605                          (vm-imap-protocol-error "server said BAD to %s"
 606                                                  command))
 607                      (cond ((vm-imap-response-matches response '+ 'atom)
 608                             (setq p (cdr (nth 1 response))
 609                                   challenge (buffer-substring
 610                                              (nth 0 p)
 611                                              (nth 1 p))
 612                                   challenge (vm-mime-base64-decode-string
 613                                              challenge)))
 614                            (t
 615                             (error "Don't understand AUTHENTICATE response")))
 616                      (setq answer
 617                            (concat
 618                             user " "
 619                             (vm-md5-string
 620                              (concat
 621                               (vm-xor-string secret opad)
 622                               (vm-md5-raw-string
 623                                (concat
 624                                 (vm-xor-string secret ipad) challenge)))))
 625                            answer (vm-mime-base64-encode-string answer))
 626                      (vm-imap-send-command process answer nil t)
 627                      (and (null (vm-imap-read-ok-response process))
 628                           (progn
 629                             (setq vm-imap-passwords
 630                                   (delete (list source-nopwd-nombox pass)
 631                                           vm-imap-passwords))
 632                             (message "IMAP password for %s incorrect" imapdrop)
 633                             ;; don't sleep unless we're running synchronously.
 634                             (if vm-imap-ok-to-ask
 635                                 (sleep-for 2))
 636                             (throw 'end-of-session nil)))))
 637                   ((equal auth "preauth")
 638                    (if (not (eq greeting 'preauth))
 639                        (progn
 640                          (message "IMAP session was not pre-authenticated")
 641                          ;; don't sleep unless we're running synchronously.
 642                          (if vm-imap-ok-to-ask
 643                              (sleep-for 2))
 644                          (throw 'end-of-session nil))))
 645                   (t (error "Don't know how to authenticate using %s" auth)))
 646             (setq process-to-shutdown nil)
 647             process ))
 648       (if process-to-shutdown
 649           (vm-imap-end-session process-to-shutdown t))
 650       (vm-tear-down-stunnel-random-data))))
 651
 652 ;;;###autoload
 653 (defun vm-imap-end-session (process &optional keep-buffer)
 654   (if (and (memq (process-status process) '(open run))
 655            (buffer-live-p (process-buffer process)))
 656       (save-excursion
 657         (set-buffer (process-buffer process))
 658         ;; vm-imap-end-session might have already been called on
 659         ;; this process, so don't logout and schedule the killing
 660         ;; the process again if it's already been done.
 661         (if vm-imap-session-done
 662             nil
 663           (vm-imap-send-command process "LOGOUT")
 664           (setq vm-imap-session-done t)
 665           ;; we don't care about the response.
 666           ;; try reading it anyway and see who complains.
 667           (vm-imap-read-ok-response process)
 668           (if (and (not vm-imap-keep-trace-buffer) (not keep-buffer))
 669               (kill-buffer (process-buffer process))
 670             (save-excursion
 671               (set-buffer (process-buffer process))
 672               (rename-buffer (concat "saved " (buffer-name)) t)
 673               (vm-keep-some-buffers (current-buffer) 'vm-kept-imap-buffers
 674                                     vm-imap-keep-failed-trace-buffers)))
 675           (if (fboundp 'add-async-timeout)
 676               (add-async-timeout 2 'delete-process process)
 677             (run-at-time 2 nil 'delete-process process))))))
 678
 679 (defun vm-imap-stat-timer (o) (aref o 0))
 680 (defun vm-imap-stat-did-report (o) (aref o 1))
 681 (defun vm-imap-stat-x-box (o) (aref o 2))
 682 (defun vm-imap-stat-x-currmsg (o) (aref o 3))
 683 (defun vm-imap-stat-x-maxmsg (o) (aref o 4))
 684 (defun vm-imap-stat-x-got (o) (aref o 5))
 685 (defun vm-imap-stat-x-need (o) (aref o 6))
 686 (defun vm-imap-stat-y-box (o) (aref o 7))
 687 (defun vm-imap-stat-y-currmsg (o) (aref o 8))
 688 (defun vm-imap-stat-y-maxmsg (o) (aref o 9))
 689 (defun vm-imap-stat-y-got (o) (aref o 10))
 690 (defun vm-imap-stat-y-need (o) (aref o 11))
 691
 692 (defun vm-set-imap-stat-timer (o val) (aset o 0 val))
 693 (defun vm-set-imap-stat-did-report (o val) (aset o 1 val))
 694 (defun vm-set-imap-stat-x-box (o val) (aset o 2 val))
 695 (defun vm-set-imap-stat-x-currmsg (o val) (aset o 3 val))
 696 (defun vm-set-imap-stat-x-maxmsg (o val) (aset o 4 val))
 697 (defun vm-set-imap-stat-x-got (o val) (aset o 5 val))
 698 (defun vm-set-imap-stat-x-need (o val) (aset o 6 val))
 699 (defun vm-set-imap-stat-y-box (o val) (aset o 7 val))
 700 (defun vm-set-imap-stat-y-currmsg (o val) (aset o 8 val))
 701 (defun vm-set-imap-stat-y-maxmsg (o val) (aset o 9 val))
 702 (defun vm-set-imap-stat-y-got (o val) (aset o 10 val))
 703 (defun vm-set-imap-stat-y-need (o val) (aset o 11 val))
 704
 705 (defun vm-imap-start-status-timer ()
 706   (let ((blob (make-vector 12 nil))
 707         timer)
 708     (setq timer (add-timeout 5 'vm-imap-report-retrieval-status blob 5))
 709     (vm-set-imap-stat-timer blob timer)
 710     blob ))
 711
 712 (defun vm-imap-stop-status-timer (status-blob)
 713   (if (vm-imap-stat-did-report status-blob)
 714       (message ""))
 715   (if (fboundp 'disable-timeout)
 716       (disable-timeout (vm-imap-stat-timer status-blob))
 717     (cancel-timer (vm-imap-stat-timer status-blob))))
 718
 719 (defun vm-imap-report-retrieval-status (o)
 720   (vm-set-imap-stat-did-report o t)
 721   (cond ((null (vm-imap-stat-x-got o)) t)
 722         ;; should not be possible, but better safe...
 723         ((not (eq (vm-imap-stat-x-box o) (vm-imap-stat-y-box o))) t)
 724         ((not (eq (vm-imap-stat-x-currmsg o) (vm-imap-stat-y-currmsg o))) t)
 725         (t (message "Retrieving message %d (of %d) from %s, %s..."
 726                     (vm-imap-stat-x-currmsg o)
 727                     (vm-imap-stat-x-maxmsg o)
 728                     (vm-imap-stat-x-box o)
 729                     (if (vm-imap-stat-x-need o)
 730                         (format "%d%s of %d%s"
 731                                 (vm-imap-stat-x-got o)
 732                                 (if (> (vm-imap-stat-x-got o)
 733                                        (vm-imap-stat-x-need o))
 734                                     "!"
 735                                   "")
 736                                 (vm-imap-stat-x-need o)
 737                                 (if (eq (vm-imap-stat-x-got o)
 738                                         (vm-imap-stat-y-got o))
 739                                     " (stalled)"
 740                                   ""))
 741                       "post processing"))))
 742   (vm-set-imap-stat-y-box o (vm-imap-stat-x-box o))
 743   (vm-set-imap-stat-y-currmsg o (vm-imap-stat-x-currmsg o))
 744   (vm-set-imap-stat-y-maxmsg o (vm-imap-stat-x-maxmsg o))
 745   (vm-set-imap-stat-y-got o (vm-imap-stat-x-got o))
 746   (vm-set-imap-stat-y-need o (vm-imap-stat-x-need o)))
 747
 748 (defun vm-imap-check-connection (process)
 749   (cond ((not (memq (process-status process) '(open run)))
 750          (error "IMAP connection not open: %s" process))
 751         ((not (buffer-live-p (process-buffer process)))
 752          (error "IMAP process %s's buffer has been killed" process))))
 753
 754 (defun vm-imap-send-command (process command &optional tag no-tag)
 755   (vm-imap-check-connection process)
 756   (goto-char (point-max))
 757   (or no-tag (insert-before-markers (or tag "VM") " "))
 758   (let ((case-fold-search t))
 759     (if (string-match "^LOGIN" command)
 760         (insert-before-markers "LOGIN <parameters omitted>\r\n")
 761       (insert-before-markers command "\r\n")))
 762   (setq vm-imap-read-point (point))
 763   ;; previously we had a process-send-string call for each string
 764   ;; to avoid extra consing but that caused a lot of packet overhead.
 765   (if no-tag
 766       (process-send-string process (format "%s\r\n" command))
 767     (process-send-string process (format "%s %s\r\n" (or tag "VM") command))))
 768
 769 (defun vm-imap-select-mailbox (process mailbox &optional just-examine)
 770   (let ((imap-buffer (current-buffer))
 771         (command (if just-examine "EXAMINE" "SELECT"))
 772         tok response p
 773         (flags nil)
 774         (permanent-flags nil)
 775         (msg-count nil)
 776         (uid-validity nil)
 777         (read-write (not just-examine))
 778         (can-delete t)
 779         (need-ok t))
 780     (vm-imap-send-command process (format "%s %s" command mailbox))
 781     (while need-ok
 782       (setq response (vm-imap-read-response process))
 783       (if (vm-imap-response-matches response 'VM 'NO)
 784           (error "server said NO to %s" command))
 785       (if (vm-imap-response-matches response 'VM 'BAD)
 786           (vm-imap-protocol-error "server said BAD to %s" command))
 787       (cond ((vm-imap-response-matches response '* 'OK 'vector)
 788              (setq p (cdr (nth 2 response)))
 789              (cond ((vm-imap-response-matches p 'UIDVALIDITY 'atom)
 790                     (setq tok (nth 1 p))
 791                     (setq uid-validity (buffer-substring (nth 1 tok)
 792                                                          (nth 2 tok))))
 793                    ((vm-imap-response-matches p 'PERMANENTFLAGS 'list)
 794                     (setq permanent-flags (nth 1 p)))))
 795             ((vm-imap-response-matches response '* 'FLAGS 'list)
 796              (setq flags (nth 2 response)))
 797             ((vm-imap-response-matches response '* 'atom 'EXISTS)
 798              (setq tok (nth 1 response))
 799              (goto-char (nth 1 tok))
 800              (setq msg-count (read imap-buffer)))
 801             ((vm-imap-response-matches response 'VM 'OK '(vector READ-WRITE))
 802              (setq need-ok nil read-write t))
 803             ((vm-imap-response-matches response 'VM 'OK '(vector READ-ONLY))
 804              (setq need-ok nil read-write t))
 805             ((vm-imap-response-matches response 'VM 'OK)
 806              (setq need-ok nil))))
 807     (if (null flags)
 808         (vm-imap-protocol-error "FLAGS missing from SELECT responses"))
 809     (if (null msg-count)
 810         (vm-imap-protocol-error "EXISTS missing from SELECT responses"))
 811     (if (null uid-validity)
 812         (vm-imap-protocol-error "UIDVALIDITY missing from SELECT responses"))
 813     (setq can-delete (vm-imap-scan-list-for-flag flags "\\Deleted"))
 814     (list msg-count uid-validity read-write can-delete permanent-flags) ))
 815
 816 (defun vm-imap-get-uid-list (process first last)
 817   (let ((list nil)
 818         (imap-buffer (current-buffer))
 819         tok msg-num uid response p
 820         (need-ok t))
 821     (vm-imap-send-command process (format "FETCH %s:%s (UID)" first last))
 822     (while need-ok
 823       (setq response (vm-imap-read-response process))
 824       (if (vm-imap-response-matches response 'VM 'NO)
 825           (error "server said NO to UID FETCH"))
 826       (if (vm-imap-response-matches response 'VM 'BAD)
 827           (vm-imap-protocol-error "server said BAD to UID FETCH"))
 828       (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list)
 829              (setq p (cdr (nth 3 response)))
 830              (if (not (vm-imap-response-matches p 'UID 'atom))
 831                  (vm-imap-protocol-error
 832                   "expected (UID number) in FETCH response"))
 833              (setq tok (nth 1 response))
 834              (goto-char (nth 1 tok))
 835              (setq msg-num (read imap-buffer))
 836              (setq tok (nth 1 p))
 837              (setq uid (buffer-substring (nth 1 tok) (nth 2 tok))
 838                    list (cons (cons msg-num uid) list)))
 839             ((vm-imap-response-matches response 'VM 'OK)
 840              (setq need-ok nil))))
 841       ;; returning nil means the uid fetch failed so return
 842       ;; something other than nil if there aren't any messages.
 843       (if (null list)
 844           (cons nil nil)
 845         list )))
 846
 847 (defun vm-imap-get-flags-list (process first last)
 848   (let ((list nil)
 849         (imap-buffer (current-buffer))
 850         tok msg-num flag flags response p
 851         (need-ok t))
 852     (vm-imap-send-command process (format "FETCH %s:%s (FLAGS)" first last))
 853     (while need-ok
 854       (setq response (vm-imap-read-response process))
 855       (if (vm-imap-response-matches response 'VM 'NO)
 856           (error "server said NO to FLAGS FETCH"))
 857       (if (vm-imap-response-matches response 'VM 'BAD)
 858           (vm-imap-protocol-error "server said BAD to FLAGS FETCH"))
 859       (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list)
 860              (setq p (cdr (nth 3 response)))
 861              (if (not (vm-imap-response-matches p 'FLAGS 'list))
 862                  (vm-imap-protocol-error
 863                   "expected (FLAGS list) in FETCH response"))
 864              (setq tok (nth 1 response))
 865              (goto-char (nth 1 tok))
 866              (setq msg-num (read imap-buffer))
 867              (setq p (cdr (nth 1 p))
 868                    flags nil)
 869              (while p
 870                (setq tok (car p))
 871                (if (not (vm-imap-response-matches tok 'atom))
 872                    (vm-imap-protocol-error
 873                     "expected atom in FLAGS list in FETCH response"))
 874                (setq flag (buffer-substring (nth 1 tok) (nth 2 tok))
 875                      flags (cons flag flags)
 876                      p (cdr p)))
 877              (setq list (cons (cons msg-num flags) list)))
 878             ((vm-imap-response-matches response 'VM 'OK)
 879              (setq need-ok nil))))
 880       ;; returning nil means the fetch failed so return
 881       ;; something other than nil if there aren't any messages.
 882       (if (null list)
 883           (cons nil nil)
 884         list )))
 885
 886 (defun vm-imap-ask-about-large-message (process size n)
 887   (let ((work-buffer nil)
 888         (imap-buffer (current-buffer))
 889         (need-ok t)
 890         (need-header t)
 891         response fetch-response
 892         list p
 893         start end)
 894     (unwind-protect
 895         (save-excursion
 896           (save-window-excursion
 897             (vm-imap-send-command process
 898                                   (format "FETCH %d (RFC822.HEADER)" n))
 899             (while need-ok
 900               (setq response (vm-imap-read-response process))
 901               (if (vm-imap-response-matches response 'VM 'NO)
 902                   (error "server said NO to header FETCH"))
 903               (if (vm-imap-response-matches response 'VM 'BAD)
 904                   (vm-imap-protocol-error "server said BAD to header FETCH"))
 905               (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list)
 906                      (setq fetch-response response
 907                            need-header nil))
 908                     ((vm-imap-response-matches response 'VM 'OK)
 909                      (setq need-ok nil))))
 910             (if need-header
 911                 (vm-imap-protocol-error "FETCH OK sent before FETCH response"))
 912             (setq vm-imap-read-point (point-marker))
 913             (setq list (cdr (nth 3 fetch-response)))
 914             (if (not (vm-imap-response-matches list 'RFC822\.HEADER 'string))
 915                 (vm-imap-protocol-error
 916                  "expected (RFC822.HEADER string) in FETCH response"))
 917             (setq p (nth 1 list)
 918                   start (nth 1 p)
 919                   end (nth 2 p))
 920             (setq work-buffer (generate-new-buffer "*imap-glop*"))
 921             (set-buffer work-buffer)
 922             (insert-buffer-substring imap-buffer start end)
 923             (vm-imap-cleanup-region (point-min) (point-max))
 924             (vm-display-buffer work-buffer)
 925             (setq minibuffer-scroll-window (selected-window))
 926             (goto-char (point-min))
 927             (if (re-search-forward "^Received:" nil t)
 928                 (progn
 929                   (goto-char (match-beginning 0))
 930                   (vm-reorder-message-headers
 931                    nil vm-visible-headers
 932                    vm-invisible-header-regexp)))
 933             (set-window-point (selected-window) (point))
 934             (if (y-or-n-p (format "Retrieve message %d (size = %d)? " n size))
 935                 'retrieve
 936               (if (y-or-n-p (format "Delete message %d from maildrop? " n))
 937                   'delete
 938                 'skip))))
 939       (and work-buffer (kill-buffer work-buffer)))))
 940
 941 (defun vm-imap-retrieve-to-target (process target statblob bodypeek)
 942   (let ((start vm-imap-read-point)
 943         (need-msg t)
 944         end fetch-response list p)
 945     (goto-char start)
 946     (vm-set-imap-stat-x-got statblob 0)
 947     (let* ((func
 948             (function
 949              (lambda (beg end len)
 950                (if vm-imap-read-point
 951                    (progn
 952                      (vm-set-imap-stat-x-got statblob (- end start))
 953                      (if (zerop (% (random) 10))
 954                          (vm-imap-report-retrieval-status statblob)))))))
 955            (after-change-functions (cons func after-change-functions))
 956            (need-ok t)
 957            response)
 958       (while need-ok
 959         (setq response (vm-imap-read-response process))
 960         (if (vm-imap-response-matches response 'VM 'NO)
 961             (error "server said NO to message FETCH"))
 962         (if (vm-imap-response-matches response 'VM 'BAD)
 963             (vm-imap-protocol-error "server said BAD to message FETCH"))
 964         (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list)
 965                (setq fetch-response response
 966                      need-msg nil))
 967               ((vm-imap-response-matches response 'VM 'OK)
 968                (setq need-ok nil)))))
 969     (if need-msg
 970         (vm-imap-protocol-error "FETCH OK sent before FETCH response"))
 971     ;; must make the read point a marker so that it stays fixed
 972     ;; relative to the text when we modify things below.
 973     (setq vm-imap-read-point (point-marker))
 974     (setq list (cdr (nth 3 fetch-response)))
 975     (cond
 976      (bodypeek
 977       (if (not (vm-imap-response-matches list 'BODY '(vector) 'string))
 978           (vm-imap-protocol-error
 979            "expected (BODY[] string) in FETCH response"))
 980       (setq p (nth 2 list)
 981             start (nth 1 p)))
 982      (t
 983       (if (not (vm-imap-response-matches list 'RFC822 'string))
 984           (vm-imap-protocol-error
 985            "expected (RFC822 string) in FETCH response"))
 986       (setq p (nth 1 list)
 987             start (nth 1 p))))
 988     (goto-char (nth 2 p))
 989     (setq end (point-marker))
 990     (vm-set-imap-stat-x-need statblob nil)
 991     (vm-imap-cleanup-region start end)
 992     (vm-munge-message-separators vm-folder-type start end)
 993     (goto-char start)
 994     (vm-set-imap-stat-x-got statblob nil)
 995     ;; avoid the consing and stat() call for all but babyl
 996     ;; files, since this will probably slow things down.
 997     ;; only babyl files have the folder header, and we
 998     ;; should only insert it if the crash box is empty.
 999     (if (and (eq vm-folder-type 'babyl)
1000              (cond ((stringp target)
1001                     (let ((attrs (file-attributes target)))
1002                       (or (null attrs) (equal 0 (nth 7 attrs)))))
1003                    ((bufferp target)
1004                     (save-excursion
1005                       (set-buffer target)
1006                       (zerop (buffer-size))))))
1007         (let ((opoint (point)))
1008           (vm-convert-folder-header nil vm-folder-type)
1009           ;; if start is a marker, then it was moved
1010           ;; forward by the insertion.  restore it.
1011           (setq start opoint)
1012           (goto-char start)
1013           (vm-skip-past-folder-header)))
1014     (insert (vm-leading-message-separator))
1015     (save-restriction
1016       (narrow-to-region (point) end)
1017       (vm-convert-folder-type-headers 'baremessage vm-folder-type))
1018     (goto-char end)
1019     (insert-before-markers (vm-trailing-message-separator))
1020     ;; Some IMAP servers don't understand Sun's stupid
1021     ;; From_-with-Content-Length style folder and assume the last
1022     ;; newline in the message is a separator.  And so the server
1023     ;; strips it, leaving us with a message that does not end
1024     ;; with a newline.  Add the newline if needed.
1025     ;;
1026     ;; HP Openmail seems to have this problem.
1027     (if (and (not (eq ?\n (char-after (1- (point)))))
1028              (memq vm-folder-type '(From_-with-Content-Length BellFrom_)))
1029         (insert-before-markers "\n"))
1030     (if (stringp target)
1031         ;; Set file type to binary for DOS/Windows.  I don't know if
1032         ;; this is correct to do or not; it depends on whether the
1033         ;; the CRLF or the LF newline convention is used on the inbox
1034         ;; associated with this crashbox.  This setting assumes the LF
1035         ;; newline convention is used.
1036         (let ((buffer-file-type t)
1037               (selective-display nil))
1038           (write-region start end target t 0))
1039       (let ((b (current-buffer)))
1040         (save-excursion
1041           (set-buffer target)
1042           (let ((buffer-read-only nil))
1043             (insert-buffer-substring b start end)))))
1044     (delete-region start end)
1045     t ))
1046
1047 (defun vm-imap-delete-message (process n)
1048   (vm-imap-send-command process (format "STORE %d +FLAGS.SILENT (\\Deleted)"
1049                                         n))
1050   (if (null (vm-imap-read-ok-response process))
1051       (vm-imap-protocol-error "STORE ... +FLAGS.SILENT (\\Deleted) failed")))
1052
1053 (defun vm-imap-get-message-size (process n)
1054   (let ((list nil)
1055         (imap-buffer (current-buffer))
1056         tok size response p
1057         (need-size t)
1058         (need-ok t))
1059     (vm-imap-send-command process (format "FETCH %d:%d (RFC822.SIZE)" n n))
1060     (while need-ok
1061       (setq response (vm-imap-read-response process))
1062       (if (vm-imap-response-matches response 'VM 'NO)
1063           (error "server said NO to size FETCH"))
1064       (if (vm-imap-response-matches response 'VM 'BAD)
1065           (vm-imap-protocol-error "server said BAD to size FETCH"))
1066       (cond ((and need-size
1067                   (vm-imap-response-matches response '* 'atom 'FETCH 'list))
1068              (setq need-size nil)
1069              (setq p (cdr (nth 3 response)))
1070              (if (not (vm-imap-response-matches p 'RFC822\.SIZE 'atom))
1071                  (vm-imap-protocol-error
1072                   "expected (RFC822.SIZE number) in FETCH response"))
1073              (setq tok (nth 1 p))
1074              (goto-char (nth 1 tok))
1075              (setq size (read imap-buffer)))
1076             ((vm-imap-response-matches response 'VM 'OK)
1077              (setq need-ok nil))))
1078     size ))
1079
1080 (defun vm-imap-read-capability-response (process)
1081   (let (response r cap-list auth-list (need-ok t))
1082     (while need-ok
1083       (setq response (vm-imap-read-response process))
1084       (if (vm-imap-response-matches response 'VM 'NO)
1085           (error "server said NO to CAPABILITY"))
1086       (if (vm-imap-response-matches response 'VM 'BAD)
1087           (vm-imap-protocol-error "server said BAD to CAPABILITY"))
1088       (if (vm-imap-response-matches response 'VM 'OK)
1089           (setq need-ok nil)
1090         (if (not (vm-imap-response-matches response '* 'CAPABILITY))
1091             nil
1092           ;; skip * CAPABILITY
1093           (setq response (cdr (cdr response)))
1094           (while response
1095             (setq r (car response))
1096             (if (not (eq (car r) 'atom))
1097                 nil
1098               (if (save-excursion
1099                     (goto-char (nth 1 r))
1100                     (let ((case-fold-search t))
1101                       (eq (re-search-forward "AUTH=." (nth 2 r) t)
1102                           (+ 6 (nth 1 r)))))
1103                   (progn
1104                     (setq auth-list (cons (intern
1105                                            (upcase (buffer-substring
1106                                                     (+ 5 (nth 1 r))
1107                                                     (nth 2 r))))
1108                                           auth-list)))
1109                 (setq r (car response))
1110                 (if (not (eq (car r) 'atom))
1111                     nil
1112                   (setq cap-list (cons (intern
1113                                         (upcase (buffer-substring
1114                                                  (nth 1 r) (nth 2 r))))
1115                                        cap-list)))))
1116             (setq response (cdr response))))))
1117     (if (or cap-list auth-list)
1118         (list (nreverse cap-list) (nreverse auth-list))
1119       nil)))
1120
1121 (defun vm-imap-read-greeting (process)
1122   (let (response)
1123     (setq response (vm-imap-read-response process))
1124     (cond ((vm-imap-response-matches response '* 'OK)
1125            t )
1126           ((vm-imap-response-matches response '* 'PREAUTH)
1127            'preauth )
1128           (t nil))))
1129
1130 (defun vm-imap-read-ok-response (process)
1131   (let (response retval (done nil))
1132     (while (not done)
1133       (setq response (vm-imap-read-response process))
1134       (cond ((vm-imap-response-matches response '*)
1135              nil )
1136             ((vm-imap-response-matches response 'VM 'OK)
1137              (setq retval t done t))
1138             (t (setq retval nil done t))))
1139     retval ))
1140
1141 (defun vm-imap-cleanup-region (start end)
1142   (setq end (vm-marker end))
1143   (save-excursion
1144     (goto-char start)
1145     ;; CRLF -> LF
1146     (while (and (< (point) end) (search-forward "\r\n"  end t))
1147       (replace-match "\n" t t)))
1148   (set-marker end nil))
1149
1150 (defun vm-imapdrop-sans-password (source)
1151   (let (source-list)
1152     (setq source-list (vm-parse source "\\([^:]+\\):?"))
1153     (concat (nth 0 source-list) ":"
1154             (nth 1 source-list) ":"
1155             (nth 2 source-list) ":"
1156             (nth 3 source-list) ":"
1157             (nth 4 source-list) ":"
1158             (nth 5 source-list) ":*")))
1159
1160 (defun vm-imapdrop-sans-password-and-mailbox (source)
1161   (let (source-list)
1162     (setq source-list (vm-parse source "\\([^:]+\\):?"))
1163     (concat (nth 0 source-list) ":"
1164             (nth 1 source-list) ":"
1165             (nth 2 source-list) ":*:"
1166             (nth 4 source-list) ":"
1167             (nth 5 source-list) ":*")))
1168
1169 (defun vm-imap-read-response (process)
1170   (let ((list nil) tail obj)
1171     (goto-char vm-imap-read-point)
1172     (while (not (eq (car (setq obj (vm-imap-read-object process)))
1173                     'end-of-line))
1174       (if (null list)
1175           (setq list (cons obj nil)
1176                 tail list)
1177         (setcdr tail (cons obj nil))
1178         (setq tail (cdr tail))))
1179     list ))
1180
1181 (defun vm-imap-read-object (process &optional skip-eol)
1182   (let ((done nil)
1183         opoint
1184         (token nil))
1185     (while (not done)
1186       (skip-chars-forward " \t")
1187       (cond ((< (- (point-max) (point)) 2)
1188              (setq opoint (point))
1189              (vm-imap-check-connection process)
1190              (accept-process-output process)
1191              (goto-char opoint))
1192             ((looking-at "\r\n")
1193              (forward-char 2)
1194              (setq token '(end-of-line) done (not skip-eol)))
1195             ((looking-at "\\[")
1196              (forward-char 1)
1197              (let* ((list (list 'vector))
1198                     (tail list)
1199                     obj)
1200                (while (not (eq (car (setq obj (vm-imap-read-object process t)))
1201                                'close-bracket))
1202                  (if (eq (car obj) 'close-paren)
1203                      (vm-imap-protocol-error "unexpected )"))
1204                  (setcdr tail (cons obj nil))
1205                  (setq tail (cdr tail)))
1206                (setq token list done t)))
1207             ((looking-at "\\]")
1208              (forward-char 1)
1209              (setq token '(close-bracket) done t))
1210             ((looking-at "(")
1211              (forward-char 1)
1212              (let* ((list (list 'list))
1213                     (tail list)
1214                     obj)
1215                (while (not (eq (car (setq obj (vm-imap-read-object process t)))
1216                                'close-paren))
1217                  (if (eq (car obj) 'close-bracket)
1218                      (vm-imap-protocol-error "unexpected ]"))
1219                  (setcdr tail (cons obj nil))
1220                  (setq tail (cdr tail)))
1221                (setq token list done t)))
1222             ((looking-at ")")
1223              (forward-char 1)
1224              (setq token '(close-paren) done t))
1225             ((looking-at "{")
1226              (forward-char 1)
1227              (let (start obj n-octets)
1228                (setq obj (vm-imap-read-object process))
1229                (if (not (eq (car obj) 'atom))
1230                    (vm-imap-protocol-error "number expected after {"))
1231                (setq n-octets (string-to-number
1232                                (buffer-substring (nth 1 obj)
1233                                                  (nth 2 obj))))
1234                (setq obj (vm-imap-read-object process))
1235                (if (not (eq (car obj) 'close-brace))
1236                    (vm-imap-protocol-error "} expected"))
1237                (setq obj (vm-imap-read-object process))
1238                (if (not (eq (car obj) 'end-of-line))
1239                    (vm-imap-protocol-error "CRLF expected"))
1240                (setq start (point))
1241                (while (< (- (point-max) start) n-octets)
1242                  (vm-imap-check-connection process)
1243                  (accept-process-output process))
1244                (goto-char (+ start n-octets))
1245                (setq token (list 'string start (point))
1246                      done t)))
1247             ((looking-at "}")
1248              (forward-char 1)
1249              (setq token '(close-brace) done t))
1250             ((looking-at "\042") ;; double quote
1251              (forward-char 1)
1252              (let ((start (point))
1253                    (curpoint (point)))
1254                (while (not done)
1255                  (skip-chars-forward "^\042")
1256                  (setq curpoint (point))
1257                  (if (looking-at "\042")
1258                      (progn
1259                        (setq done t)
1260                        (forward-char 1))
1261                    (vm-imap-check-connection process)
1262                    (accept-process-output process)
1263                    (goto-char curpoint))
1264                (setq token (list 'string start curpoint)))))
1265             ;; should be (looking-at "[\000-\040\177-\377]")
1266             ;; but Microsoft Exchange emits 8-bit chars.
1267             ((looking-at "[\000-\040\177]")
1268              (vm-imap-protocol-error "unexpected char (%d)"
1269                                      (char-after (point))))
1270             (t
1271              (let ((start (point))
1272                    (curpoint (point))
1273                    ;; We should be considering 8-bit chars as
1274                    ;; non-word chars also but Microsoft Exchange
1275                    ;; uses them, despite the RFC 2060 prohibition.
1276                    ;; If we ever resume disallowing 8-bit chars,
1277                    ;; remember to write the range as \177-\376 ...
1278                    ;; \376 instead of \377 because Emacs 19.34 has
1279                    ;; a bug in the fastmap initialization code
1280                    ;; that causes it to infloop.
1281                    (not-word-chars "^\000-\040\177()[]{}")
1282                    (not-word-regexp "[][\000-\040\177(){}]"))
1283                (while (not done)
1284                  (skip-chars-forward not-word-chars)
1285                  (setq curpoint (point))
1286                  (if (looking-at not-word-regexp)
1287                      (setq done t)
1288                    (vm-imap-check-connection process)
1289                    (accept-process-output process)
1290                    (goto-char curpoint))
1291                  (setq token (list 'atom start curpoint)))))))
1292     (setq vm-imap-read-point (point))
1293     token ))
1294
1295 (defun vm-imap-response-matches (response &rest expr)
1296   (let ((case-fold-search t) e r)
1297     (catch 'done
1298       (while (and expr response)
1299         (setq e (car expr)
1300               r (car response))
1301         (cond ((stringp e)
1302                (if (or (not (eq (car r) 'string))
1303                        (save-excursion
1304                          (goto-char (nth 1 r))
1305                          (not (eq (search-forward e (nth 2 r) t) (nth 2 r)))))
1306                    (throw 'done nil)))
1307               ((numberp e)
1308                (if (or (not (eq (car r) 'atom))
1309                        (save-excursion
1310                          (goto-char (nth 1 r))
1311                          (not (eq (search-forward (int-to-string e)
1312                                                   (nth 2 r) t)
1313                                   (nth 2 r)))))
1314                    (throw 'done nil)))
1315               ((consp e)
1316                (if (not (eq (car e) (car r)))
1317                    (throw 'done nil))
1318                (apply 'vm-imap-response-matches (cdr r) (cdr e)))
1319               ((eq e 'atom)
1320                (if (not (eq (car r) 'atom))
1321                    (throw 'done nil)))
1322               ((eq e 'vector)
1323                (if (not (eq (car r) 'vector))
1324                    (throw 'done nil)))
1325               ((eq e 'list)
1326                (if (not (eq (car r) 'list))
1327                    (throw 'done nil)))
1328               ((eq e 'string)
1329                (if (not (eq (car r) 'string))
1330                    (throw 'done nil)))
1331               ;; this must to come after all the comparisons for
1332               ;; specific symbols.
1333               ((symbolp e)
1334                (if (or (not (eq (car r) 'atom))
1335                        (save-excursion
1336                          (goto-char (nth 1 r))
1337                          (not (eq (search-forward (symbol-name e) (nth 2 r) t)
1338                                   (nth 2 r)))))
1339                    (throw 'done nil))))
1340         (setq response (cdr response)
1341               expr (cdr expr)))
1342       t )))
1343
1344 (defun vm-imap-bail-if-server-says-farewell (response)
1345   (if (vm-imap-response-matches response '* 'BYE)
1346       (throw 'end-of-session t)))
1347
1348 (defun vm-imap-protocol-error (&rest args)
1349   (set (make-local-variable 'vm-imap-keep-trace-buffer) t)
1350   (signal 'vm-imap-protocol-error (list (apply 'format args))))
1351
1352 (defun vm-imap-scan-list-for-flag (list flag)
1353   (setq list (cdr list))
1354   (let ((case-fold-search t) e)
1355     (catch 'done
1356       (while list
1357         (setq e (car list))
1358         (if (not (eq (car e) 'atom))
1359             nil
1360           (goto-char (nth 1 e))
1361           (if (eq (search-forward flag (nth 2 e) t) (nth 2 e))
1362               (throw 'done t)))
1363         (setq list (cdr list)))
1364       nil )))
1365
1366 ;; like Lisp get but for IMAP property lists like those returned by FETCH.
1367 (defun vm-imap-plist-get (list name)
1368   (setq list (cdr list))
1369   (let ((case-fold-search t) e)
1370     (catch 'done
1371       (while list
1372         (setq e (car list))
1373         (if (not (eq (car e) 'atom))
1374             nil
1375           (goto-char (nth 1 e))
1376           (if (eq (search-forward name (nth 2 e) t) (nth 2 e))
1377               (throw 'done (car (cdr list)))))
1378         (setq list (cdr (cdr list))))
1379       nil )))
1380
1381 (defun vm-imap-clear-invalid-retrieval-entries (source-nopwd retrieved
1382                                                 uid-validity)
1383   (let ((x retrieved)
1384         (prev nil))
1385     (while x
1386       (if (and (equal source-nopwd (nth 2 (car x)))
1387                (not (equal (nth 1 (car x)) uid-validity)))
1388           (if prev
1389               (setcdr prev (cdr x))
1390             (setq retrieved (cdr retrieved))))
1391       (setq x (cdr x)))
1392     retrieved ))
1393
1394 (defun vm-imap-quote-string (string)
1395   (vm-with-string-as-temp-buffer string 'vm-imap-quote-buffer))
1396
1397 (defun vm-imap-quote-buffer ()
1398   (goto-char (point-min))
1399   (insert "\"")
1400   (while (re-search-forward "[\"\\]" nil t)
1401     (forward-char -1)
1402     (insert "\\")
1403     (forward-char 1))
1404   (goto-char (point-max))
1405   (insert "\""))
1406
1407 (defun vm-establish-new-folder-imap-session (&optional interactive)
1408   (let ((process (vm-folder-imap-process))
1409         mailbox select mailbox-count uid-validity permanent-flags
1410         read-write can-delete body-peek
1411         (vm-imap-ok-to-ask interactive))
1412     (if (processp process)
1413         (vm-imap-end-session process))
1414     (setq process (vm-imap-make-session (vm-folder-imap-maildrop-spec)))
1415     (vm-set-folder-imap-process process)
1416     (setq mailbox (vm-imap-parse-spec-to-list (vm-folder-imap-maildrop-spec))
1417           mailbox (nth 3 mailbox))
1418     (save-excursion
1419       (set-buffer (process-buffer process))
1420       (setq select (vm-imap-select-mailbox process mailbox))
1421       (setq mailbox-count (nth 0 select)
1422             uid-validity (nth 1 select)
1423             read-write (nth 2 select)
1424             can-delete (nth 3 select)
1425             permanent-flags (nth 4 select)
1426             body-peek (vm-imap-capability 'IMAP4REV1)))
1427     (vm-set-folder-imap-uid-validity uid-validity)
1428     (vm-set-folder-imap-mailbox-count mailbox-count)
1429     (vm-set-folder-imap-read-write read-write)
1430     (vm-set-folder-imap-can-delete can-delete)
1431     (vm-set-folder-imap-body-peek body-peek)
1432     (vm-set-folder-imap-permanent-flags permanent-flags)
1433     process ))
1434
1435 (defun vm-imap-get-uid-data ()
1436   (if (eq 0 (vm-folder-imap-mailbox-count))
1437       (make-vector 67 0)
1438     (let ((there (make-vector 67 0))
1439           (process (vm-folder-imap-process))
1440           (mailbox-count (vm-folder-imap-mailbox-count))
1441           list)
1442       (save-excursion
1443         (set-buffer (process-buffer process))
1444         (setq list (vm-imap-get-uid-list process 1 mailbox-count))
1445         (while list
1446           (set (intern (cdr (car list)) there) (car (car list)))
1447           (setq list (cdr list)))
1448         there ))))
1449
1450 (defun vm-imap-get-message-flags (process m &optional norecord)
1451   (let (need-ok p r flag response saw-seen)
1452     (save-excursion
1453       (set-buffer (process-buffer process))
1454       (vm-imap-send-command process
1455                             (format "UID FETCH %s (FLAGS)"
1456                                     (vm-imap-uid-of m)))
1457       (setq need-ok t)
1458       (while need-ok
1459         (setq response (vm-imap-read-response process))
1460         (if (vm-imap-response-matches response 'VM 'NO)
1461             (error "server said NO to UID FETCH (FLAGS)"))
1462         (if (vm-imap-response-matches response 'VM 'BAD)
1463             (vm-imap-protocol-error "server said BAD to UID FETCH (FLAGS)"))
1464         (if (vm-imap-response-matches response '* 'BYE)
1465             (vm-imap-protocol-error "server said BYE to UID FETCH (FLAGS)"))
1466         (cond ((vm-imap-response-matches response 'VM 'OK)
1467                (setq need-ok nil))
1468               ((vm-imap-response-matches response '* 'atom 'FETCH 'list)
1469                (setq r (nthcdr 3 response)
1470                      r (car r)
1471                      r (vm-imap-plist-get r "FLAGS")
1472                      r (cdr r))
1473                (while r
1474                  (setq p (car r))
1475                  (if (not (eq (car p) 'atom))
1476                      nil
1477                    (setq flag (downcase (buffer-substring (nth 1 p) (nth 2 p))))
1478                    (cond ((string= flag "\\answered")
1479                           (vm-set-replied-flag m t norecord))
1480                          ((string= flag "\\deleted")
1481                           (vm-set-deleted-flag m t norecord))
1482                          ((string= flag "\\seen")
1483                           (vm-set-unread-flag m nil norecord)
1484                           (vm-set-new-flag m nil norecord)
1485                           (setq saw-seen t))
1486                          ((string= flag "\\recent")
1487                           (vm-set-new-flag m t norecord))))
1488                  (setq r (cdr r)))
1489                (if (not saw-seen)
1490                    (vm-set-unread-flag m t norecord))))))))
1491
1492 (defun vm-imap-store-message-flags (process m perm-flags)
1493   (let (need-ok flags response)
1494     (save-excursion
1495       (set-buffer (process-buffer process))
1496       (if (and (vm-replied-flag m)
1497                (vm-imap-scan-list-for-flag perm-flags "\\Answered"))
1498           (setq flags (cons (intern "\\Answered") flags)))
1499       (if (and (not (vm-unread-flag m))
1500                (vm-imap-scan-list-for-flag perm-flags "\\Seen"))
1501           (setq flags (cons (intern "\\Seen") flags)))
1502       (if (and (vm-deleted-flag m)
1503                (vm-imap-scan-list-for-flag perm-flags "\\Deleted"))
1504           (setq flags (cons (intern "\\Deleted") flags)))
1505       (vm-imap-send-command process
1506                             (format "UID STORE %s FLAGS %s"
1507                                     (vm-imap-uid-of m)
1508                                     (if flags flags "()")))
1509       (setq need-ok t)
1510       (while need-ok
1511         (setq response (vm-imap-read-response process))
1512         (if (vm-imap-response-matches response 'VM 'NO)
1513             (error "server said NO to UID FETCH (FLAGS)"))
1514         (if (vm-imap-response-matches response 'VM 'BAD)
1515             (vm-imap-protocol-error "server said BAD to UID FETCH (FLAGS)"))
1516         (if (vm-imap-response-matches response '* 'BYE)
1517             (vm-imap-protocol-error "server said BYE to UID FETCH (FLAGS)"))
1518         (cond ((vm-imap-response-matches response 'VM 'OK)
1519                (setq need-ok nil))))
1520       (vm-set-attribute-modflag-of m nil))))
1521
1522 (defvar vm-imap-subst-char-in-string-buffer
1523   (get-buffer-create " *subst-char-in-string*"))
1524
1525 (defun vm-imap-subst-CRLF-for-LF (string)
1526   (with-current-buffer vm-imap-subst-char-in-string-buffer
1527     (erase-buffer)
1528     (insert string)
1529     (goto-char (point-min))
1530     (while (search-forward "\n" nil t)
1531       (replace-match "\r\n" nil t))
1532     (buffer-substring-no-properties (point-min) (point-max))))
1533
1534 ;;;###autoload
1535 (defun vm-imap-save-message (process m mailbox)
1536   (let (need-ok need-plus flags response string)
1537     ;; save the message's flag along with it.
1538     ;; don't save the deleted flag.
1539     (if (vm-replied-flag m)
1540         (setq flags (cons (intern "\\Answered") flags)))
1541     (if (not (vm-unread-flag m))
1542         (setq flags (cons (intern "\\Seen") flags)))
1543     (save-excursion
1544       (set-buffer (vm-buffer-of (vm-real-message-of m)))
1545       (save-restriction
1546         (widen)
1547         (setq string (buffer-substring (vm-headers-of m) (vm-text-end-of m))
1548               string (vm-imap-subst-CRLF-for-LF string))))
1549     (save-excursion
1550       (set-buffer (process-buffer process))
1551       (condition-case nil
1552           (vm-imap-create-mailbox process mailbox)
1553         (error nil))
1554       (vm-imap-send-command process
1555                             (format "APPEND %s %s {%d}"
1556                                     (vm-imap-quote-string mailbox)
1557                                     (if flags flags "()")
1558                                     (length string)))
1559       (setq need-plus t)
1560       (while need-plus
1561         (setq response (vm-imap-read-response process))
1562         (if (vm-imap-response-matches response 'VM 'NO)
1563             (error "server said NO to APPEND command"))
1564         (if (vm-imap-response-matches response 'VM 'BAD)
1565             (vm-imap-protocol-error "server said BAD to APPEND command"))
1566         (if (vm-imap-response-matches response '* 'BYE)
1567             (vm-imap-protocol-error "server said BYE to APPEND command"))
1568         (cond ((vm-imap-response-matches response '+)
1569                (setq need-plus nil))))
1570       (vm-imap-send-command process string nil t)
1571       (setq need-ok t)
1572       (while need-ok
1573         (setq response (vm-imap-read-response process))
1574         (if (vm-imap-response-matches response 'VM 'NO)
1575             (error "server said NO to APPEND data"))
1576         (if (vm-imap-response-matches response 'VM 'BAD)
1577             (vm-imap-protocol-error "server said BAD to APPEND data"))
1578         (if (vm-imap-response-matches response '* 'BYE)
1579             (vm-imap-protocol-error "server said BYE to APPEND data"))
1580         (cond ((vm-imap-response-matches response 'VM 'OK)
1581                (setq need-ok nil)))))))
1582
1583 (defun vm-imap-get-synchronization-data ()
1584   (let ((here (make-vector 67 0))
1585         (there (vm-imap-get-uid-data))
1586         (process (vm-folder-imap-process))
1587         (uid-validity (vm-folder-imap-uid-validity))
1588         retrieve-list expunge-list
1589         mp)
1590     (setq mp vm-message-list)
1591     (while mp
1592       (if (or (null (vm-imap-uid-of (car mp)))
1593               (not (equal (vm-imap-uid-validity-of (car mp)) uid-validity)))
1594           nil
1595         (set (intern (vm-imap-uid-of (car mp)) here) (car mp))
1596         (if (not (boundp (intern (vm-imap-uid-of (car mp)) there)))
1597             (setq expunge-list (cons (car mp) expunge-list))))
1598       (setq mp (cdr mp)))
1599     (mapatoms (function
1600                (lambda (sym)
1601                  (if (and (not (boundp (intern (symbol-name sym) here)))
1602                           (not (assoc (symbol-name sym)
1603                                       vm-imap-retrieved-messages)))
1604                      (setq retrieve-list (cons
1605                                           (cons (symbol-name sym)
1606                                                 (symbol-value sym))
1607                                           retrieve-list)))))
1608               there)
1609     (list retrieve-list expunge-list)))
1610
1611 ;;;###autoload
1612 (defun vm-imap-synchronize-folder (&optional interactive
1613                                              do-remote-expunges
1614                                              do-local-expunges
1615                                              do-retrieves
1616                                              do-attributes)
1617   (if (and do-retrieves vm-block-new-mail)
1618       (error "Can't get new mail until you save this folder."))
1619   (if (or vm-global-block-new-mail
1620           (null (vm-establish-new-folder-imap-session interactive)))
1621       nil
1622     (if do-retrieves
1623         (vm-assimilate-new-messages))
1624     (let* ((sync-data (vm-imap-get-synchronization-data))
1625            (retrieve-list (car sync-data))
1626            (local-expunge-list (nth 1 sync-data))
1627            (process (vm-folder-imap-process))
1628            (n 1)
1629            (statblob nil)
1630            (imapdrop (vm-folder-imap-maildrop-spec))
1631            (uid-validity (vm-folder-imap-uid-validity))
1632            (safe-imapdrop (vm-safe-imapdrop-string imapdrop))
1633            (use-body-peek (vm-folder-imap-body-peek))
1634            r-list mp got-some message-size
1635            (folder-buffer (current-buffer)))
1636       (if (and do-retrieves retrieve-list)
1637           (save-excursion
1638             (vm-save-restriction
1639              (widen)
1640              (goto-char (point-max))
1641              (condition-case error-data
1642                  (save-excursion
1643                    (set-buffer (process-buffer process))
1644                    (setq statblob (vm-imap-start-status-timer))
1645                    (vm-set-imap-stat-x-box statblob safe-imapdrop)
1646                    (vm-set-imap-stat-x-maxmsg statblob
1647                                               (length retrieve-list))
1648                    (setq r-list retrieve-list)
1649                    (while r-list
1650                      (vm-set-imap-stat-x-currmsg statblob n)
1651                      (setq message-size (vm-imap-get-message-size
1652                                          process (cdr (car r-list))))
1653                      (vm-set-imap-stat-x-need statblob message-size)
1654                      (if use-body-peek
1655                          (progn
1656                            (vm-imap-send-command process
1657                                                  (format
1658                                                   "FETCH %s (BODY.PEEK[])"
1659                                                   (cdr (car r-list))))
1660                            (vm-imap-retrieve-to-target process folder-buffer
1661                                                        statblob t))
1662                        (progn
1663                          (vm-imap-send-command process
1664                                                (format
1665                                                 "FETCH %s (RFC822.PEEK)"
1666                                                 (cdr (car r-list))))
1667                          (vm-imap-retrieve-to-target process folder-buffer
1668                                                      statblob nil)))
1669                      (setq r-list (cdr r-list)
1670                            n (1+ n))))
1671                (error
1672                 (message "Retrieval from %s signaled: %s" safe-imapdrop
1673                          error-data))
1674                (quit
1675                 (message "Quit received during retrieval from %s"
1676                          safe-imapdrop)))
1677              (and statblob (vm-imap-stop-status-timer statblob))
1678              ;; to make the "Mail" indicator go away
1679              (setq vm-spooled-mail-waiting nil)
1680              (intern (buffer-name) vm-buffers-needing-display-update)
1681              (vm-increment vm-modification-counter)
1682              (vm-update-summary-and-mode-line)
1683              (setq mp (vm-assimilate-new-messages t))
1684              (setq got-some mp)
1685              (setq r-list retrieve-list)
1686              (while mp
1687                (vm-set-imap-uid-of (car mp) (car (car r-list)))
1688                (vm-set-imap-uid-validity-of (car mp) uid-validity)
1689                (condition-case nil
1690                    (vm-imap-get-message-flags process (car mp) t)
1691                  (error nil))
1692                (vm-set-stuff-flag-of (car mp) t)
1693                (setq mp (cdr mp)
1694                      r-list (cdr r-list))))))
1695       (if do-attributes
1696           (let ((mp vm-message-list)
1697                 (perm-flags (vm-folder-imap-permanent-flags)))
1698             (while mp
1699               (if (not (vm-attribute-modflag-of (car mp)))
1700                   nil
1701                 (condition-case nil
1702                     (vm-imap-store-message-flags process (car mp) perm-flags)
1703                   (error nil)))
1704               (setq mp (cdr mp)))))
1705       (if do-local-expunges
1706           (vm-expunge-folder t t local-expunge-list))
1707       (if (and do-remote-expunges
1708                vm-imap-messages-to-expunge)
1709           (let ((process (vm-folder-imap-process)))
1710             (if (and (processp process)
1711                      (memq (process-status process) '(open run)))
1712                 (vm-imap-end-session process))
1713             (setq vm-imap-retrieved-messages
1714                   (mapcar (function (lambda (x) (list (car x) (cdr x)
1715                                                       imapdrop 'uid)))
1716                           vm-imap-messages-to-expunge))
1717             (vm-expunge-imap-messages)
1718             (setq vm-imap-messages-to-expunge
1719                   (mapcar (function (lambda (x) (cons (car x) (car (cdr x)))))
1720                           vm-imap-retrieved-messages))))
1721       got-some)))
1722
1723 ;;;###autoload
1724 (defun vm-imap-folder-check-for-mail (&optional interactive)
1725   (if (or vm-global-block-new-mail
1726           (null (vm-establish-new-folder-imap-session interactive)))
1727       nil
1728     (let ((result (car (vm-imap-get-synchronization-data))))
1729       (vm-imap-end-session (vm-folder-imap-process))
1730       result )))
1731
1732 ;;;###autoload
1733 (defun vm-imap-find-spec-for-buffer (buffer)
1734   (let ((list vm-imap-server-list)
1735         (done nil))
1736     (while (and (not done) list)
1737       (if (eq buffer (vm-get-file-buffer (vm-imap-make-filename-for-spec
1738                                           (car list))))
1739           (setq done t)
1740         (setq list (cdr list))))
1741     (and list (car list))))
1742
1743 ;;;###autoload
1744 (defun vm-imap-make-filename-for-spec (spec)
1745   (let (md5 list)
1746     (setq spec (vm-imap-normalize-spec spec))
1747     (setq md5 (vm-md5-string spec))
1748     (expand-file-name (concat "imap-cache-" md5)
1749                       (or vm-imap-folder-cache-directory
1750                           vm-folder-directory
1751                           (getenv "HOME")))))
1752
1753 (defun vm-imap-normalize-spec (spec)
1754   (let (list)
1755     (setq list (vm-imap-parse-spec-to-list spec))
1756     (setcar (vm-last list) "*")
1757     (setcar list "imap")
1758     (setcar (nthcdr 2 list) "*")
1759     (setcar (nthcdr 4 list) "*")
1760     (setq spec (mapconcat (function identity) list ":"))
1761     spec ))
1762
1763 ;;;###autoload
1764 (defun vm-imap-parse-spec-to-list (spec)
1765   (vm-parse spec "\\([^:]+\\):?" 1 6))
1766
1767 (defun vm-imap-spec-list-to-host-alist (spec-list)
1768   (let (host-alist)
1769     (while spec-list
1770       (setq host-alist (cons
1771                         (cons
1772                          (nth 1 (vm-imap-parse-spec-to-list (car spec-list)))
1773                          (car spec-list))
1774                         host-alist)
1775             spec-list (cdr spec-list)))
1776     host-alist ))
1777
1778 ;;;###autoload
1779 (defun vm-read-imap-folder-name (prompt spec-list &optional selectable-only newone)
1780   "Read an IMAP server and mailbox, return an IMAP mailbox spec."
1781   (let (host c-list spec process mailbox list
1782         (vm-imap-ok-to-ask t)
1783         (host-alist (vm-imap-spec-list-to-host-alist spec-list)))
1784     (if (null host-alist)
1785         (error "No known IMAP servers.  Please set vm-imap-server-list."))
1786     (setq host (if (cdr host-alist)
1787                    (completing-read "IMAP server: " host-alist nil t)
1788                  (car (car host-alist)))
1789           spec (cdr (assoc host host-alist))
1790           process (vm-imap-make-session spec)
1791           c-list (and process (vm-imap-mailbox-list process selectable-only)))
1792     (vm-imap-end-session process)
1793     (setq mailbox
1794           (completing-read prompt (mapcar (lambda (c) (list c)) c-list)
1795                            nil (not newone)))
1796     (setq list (vm-imap-parse-spec-to-list spec))
1797     (setcar (nthcdr 3 list) mailbox)
1798     (mapconcat 'identity list ":")))
1799
1800 (defun vm-imap-directory-separator (process ref)
1801   (let ((c-list nil)
1802         sep p r response need-ok)
1803     (vm-imap-check-connection process)
1804     (save-excursion
1805       (set-buffer (process-buffer process))
1806       (vm-imap-send-command process (format "LIST %s \"\""
1807                                             (vm-imap-quote-string ref)))
1808       (setq need-ok t)
1809       (while need-ok
1810         (setq response (vm-imap-read-response process))
1811         (if (vm-imap-response-matches response 'VM 'NO)
1812             (error "server said NO to LIST"))
1813         (if (vm-imap-response-matches response 'VM 'BAD)
1814             (vm-imap-protocol-error "server said BAD to LIST"))
1815         (cond ((vm-imap-response-matches response 'VM 'OK)
1816                (setq need-ok nil))
1817               ((vm-imap-response-matches response '* 'LIST 'list 'string)
1818                (setq r (nthcdr 3 response)
1819                      p (car r)
1820                      sep (buffer-substring (nth 1 p) (nth 2 p))))
1821               ((vm-imap-response-matches response '* 'LIST 'list)
1822                (vm-imap-protocol-error "unexpedcted LIST response"))))
1823       sep )))
1824
1825 (defun vm-imap-mailbox-list (process selectable-only)
1826   (let ((c-list nil)
1827         p r response need-ok)
1828     (vm-imap-check-connection process)
1829     (save-excursion
1830       (set-buffer (process-buffer process))
1831       (vm-imap-send-command process "LIST \"\" \"*\"")
1832       (setq need-ok t)
1833       (while need-ok
1834         (setq response (vm-imap-read-response process))
1835         (if (vm-imap-response-matches response 'VM 'NO)
1836             (error "server said NO to LIST"))
1837         (if (vm-imap-response-matches response 'VM 'BAD)
1838             (vm-imap-protocol-error "server said BAD to LIST"))
1839         (if (vm-imap-response-matches response '* 'BYE)
1840             (vm-imap-protocol-error "server said BYE to LIST"))
1841         (cond ((vm-imap-response-matches response 'VM 'OK)
1842                (setq need-ok nil))
1843               ((vm-imap-response-matches response '* 'LIST 'list)
1844                (setq r (nthcdr 2 response)
1845                      p (car r))
1846                (if (and selectable-only
1847                         (vm-imap-scan-list-for-flag p "\\Noselect"))
1848                    nil
1849                  (setq r (nthcdr 4 response)
1850                        p (car r))
1851                  (if (memq (car p) '(atom string))
1852                      (setq c-list (cons (buffer-substring (nth 1 p) (nth 2 p))
1853                                         c-list)))))))
1854       c-list )))
1855
1856 (defun vm-imap-read-boolean-response (process)
1857   (let ((need-ok t) retval response)
1858     (while need-ok
1859       (vm-imap-check-connection process)
1860       (setq response (vm-imap-read-response process))
1861       (cond ((vm-imap-response-matches response 'VM 'OK)
1862              (setq need-ok nil retval t))
1863             ((vm-imap-response-matches response 'VM 'NO)
1864              (setq need-ok nil retval nil))
1865             ((vm-imap-response-matches response '* 'BYE)
1866              (vm-imap-protocol-error "server said BYE"))
1867             ((vm-imap-response-matches response 'VM 'BAD)
1868              (vm-imap-protocol-error "server said BAD"))))
1869     retval ))
1870
1871 (defun vm-imap-create-mailbox (process mailbox
1872                                &optional dont-create-parent-directories)
1873   (if (not dont-create-parent-directories)
1874       (let (dir sep sep-regexp i)
1875         (setq sep (vm-imap-directory-separator process "")
1876               sep-regexp (regexp-quote sep)
1877               i 0)
1878         (while (string-match sep-regexp mailbox i)
1879           (setq dir (substring mailbox i (match-end 0)))
1880           (vm-imap-create-mailbox process dir t)
1881           ;; ignore command result since creating a directory will
1882           ;; routinely fail with "File exists".  We'll generate a
1883           ;; real error if the final mailbox creation fails.
1884           (vm-imap-read-boolean-response process)
1885           (setq i (match-end 0)))))
1886   (vm-imap-send-command process (format "CREATE %s"
1887                                         (vm-imap-quote-string mailbox)))
1888   (if (null (vm-imap-read-boolean-response process))
1889       (error "IMAP CREATE of %s failed" mailbox)))
1890
1891 (defun vm-imap-delete-mailbox (process mailbox)
1892   (vm-imap-send-command process (format "DELETE %s"
1893                                         (vm-imap-quote-string mailbox)))
1894   (if (null (vm-imap-read-boolean-response process))
1895       (error "IMAP DELETE of %s failed" mailbox)))
1896
1897 (defun vm-imap-rename-mailbox (process source dest)
1898   (vm-imap-send-command process (format "RENAME %s %s"
1899                                         (vm-imap-quote-string source)
1900                                         (vm-imap-quote-string dest)))
1901   (if (null (vm-imap-read-boolean-response process))
1902       (error "IMAP RENAME of %s to %s failed" source dest)))
1903
1904 ;;;###autoload
1905 (defun vm-create-imap-folder (folder)
1906   "Create a folder on an IMAP server.
1907 First argument FOLDER is read from the minibuffer if called
1908 interactively.  Non-interactive callers must provide an IMAP
1909 maildrop specification for the folder as described in the
1910 documentation for `vm-spool-files'."
1911   (interactive
1912    (save-excursion
1913      (vm-session-initialization)
1914      (vm-check-for-killed-folder)
1915      (vm-select-folder-buffer-if-possible)
1916      (let ((this-command this-command)
1917            (last-command last-command))
1918        (list (vm-read-imap-folder-name "Create IMAP folder: "
1919                                        vm-imap-server-list nil t)))))
1920   (let ((vm-imap-ok-to-ask t)
1921         process mailbox)
1922     (save-excursion
1923       (setq process (vm-imap-make-session folder))
1924       (if (null process)
1925           (error "Couldn't open IMAP session for %s"
1926                  (vm-safe-imapdrop-string folder)))
1927       (set-buffer (process-buffer process))
1928       (setq mailbox (nth 3 (vm-imap-parse-spec-to-list folder)))
1929       (vm-imap-create-mailbox process mailbox t)
1930       (message "Folder %s created" (vm-safe-imapdrop-string folder)))))
1931
1932 ;;;###autoload
1933 (defun vm-delete-imap-folder (folder)
1934   "Delete a folder on an IMAP server.
1935 First argument FOLDER is read from the minibuffer if called
1936 interactively.  Non-interactive callers must provide an IMAP
1937 maildrop specification for the folder as described in the
1938 documentation for `vm-spool-files'."
1939   (interactive
1940    (save-excursion
1941      (vm-session-initialization)
1942      (vm-check-for-killed-folder)
1943      (vm-select-folder-buffer-if-possible)
1944      (let ((this-command this-command)
1945            (last-command last-command))
1946        (list (vm-read-imap-folder-name "Delete IMAP folder: "
1947                                        vm-imap-server-list nil)))))
1948   (let ((vm-imap-ok-to-ask t)
1949         process mailbox)
1950     (setq process (vm-imap-make-session folder))
1951     (if (null process)
1952         (error "Couldn't open IMAP session for %s"
1953                (vm-safe-imapdrop-string folder)))
1954     (save-excursion
1955       (set-buffer (process-buffer process))
1956       (setq mailbox (nth 3 (vm-imap-parse-spec-to-list folder)))
1957       (vm-imap-delete-mailbox process mailbox)
1958       (message "Folder %s deleted" (vm-safe-imapdrop-string folder)))))
1959
1960 ;;;###autoload
1961 (defun vm-rename-imap-folder (source dest)
1962   "Rename a folder on an IMAP server.
1963 Argument SOURCE and DEST are read from the minibuffer if called
1964 interactively.  Non-interactive callers must provide full IMAP
1965 maildrop specifications for SOURCE and DEST as described in the
1966 documentation for `vm-spool-files'."
1967   (interactive
1968    (save-excursion
1969      (vm-session-initialization)
1970      (vm-check-for-killed-folder)
1971      (vm-select-folder-buffer-if-possible)
1972      (let ((this-command this-command)
1973            (last-command last-command)
1974            source dest)
1975        (setq source (vm-read-imap-folder-name "Rename IMAP folder: "
1976                                               vm-imap-server-list t))
1977        (setq dest (vm-read-imap-folder-name
1978                    (format "Rename %s to: " (vm-safe-imapdrop-string source))
1979                    (list source) nil))
1980        (list source dest))))
1981   (let ((vm-imap-ok-to-ask t)
1982         process mailbox-source mailbox-dest)
1983     (setq process (vm-imap-make-session source))
1984     (if (null process)
1985         (error "Couldn't open IMAP session for %s"
1986                (vm-safe-imapdrop-string source)))
1987     (save-excursion
1988       (set-buffer (process-buffer process))
1989       (setq mailbox-source (nth 3 (vm-imap-parse-spec-to-list source)))
1990       (setq mailbox-dest (nth 3 (vm-imap-parse-spec-to-list dest)))
1991       (vm-imap-rename-mailbox process mailbox-source mailbox-dest)
1992       (message "Folder %s renamed to %s" (vm-safe-imapdrop-string source)
1993                (vm-safe-imapdrop-string dest)))))
1994
1995 ;;; Robert Fenk's draft function for saving messages to IMAP folders.
1996 (defun vm-imap-save-composition ()
1997   "Saves the current composition in the IMAP folder given by the IMAP-FCC header.
1998
1999 Add this to your `mail-send-hook' and start composing from an IMAP folder."
2000   (let (process flags response string
2001                 (mailbox (vm-mail-get-header-contents "IMAP-FCC:")))
2002     (when mailbox
2003       (save-excursion
2004         (vm-select-folder-buffer)
2005         (vm-establish-new-folder-imap-session)
2006         (setq process (vm-folder-imap-process)))
2007       (save-excursion
2008         (vm-mail-mode-remove-header "IMAP-FCC:")
2009         (goto-char (point-min))
2010         (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
2011         (setq string (concat (buffer-substring (point-min) (match-beginning 0))
2012                              (buffer-substring
2013                               (match-end 0) (point-max))))
2014         ;; this can go awry if the process has died...
2015         (set-buffer (process-buffer process))
2016         (condition-case nil
2017              (vm-imap-create-mailbox process mailbox)
2018            (error nil))
2019         (vm-imap-send-command process
2020                               (format "APPEND %s %s {%d}"
2021                                       (vm-imap-quote-string mailbox)
2022                                       (if flags flags "()")
2023                                       (length string)))
2024         ;; could these be done with vm-imap-read-boolean-response?
2025         (let ((need-plus t))
2026           (while need-plus
2027             (let ((response (vm-imap-read-response process)))
2028               (cond ((vm-imap-response-matches response 'VM 'NO)
2029                      (error "server said NO to APPEND command"))
2030                     ((vm-imap-response-matches response 'VM 'BAD)
2031                      (vm-imap-protocol-error "server said BAD to APPEND command"))
2032                     ((vm-imap-response-matches response '* 'BYE)
2033                      (vm-imap-protocol-error "server said BYE to APPEND command"))
2034                     ((vm-imap-response-matches response '+)
2035                      (setq need-plus nil))))))
2036         (vm-imap-send-command process string nil t)
2037         (let ((need-ok t))
2038           (while need-ok
2039             (let ((response (vm-imap-read-response process)))
2040               (cond ((vm-imap-response-matches response 'VM 'NO)
2041                      (error "server said NO to APPEND data"))
2042                     ((vm-imap-response-matches response 'VM 'BAD)
2043                      (vm-imap-protocol-error "server said BAD to APPEND data"))
2044                     ((vm-imap-response-matches response '* 'BYE)
2045                      (vm-imap-protocol-error "server said BYE to APPEND data"))
2046                     ((vm-imap-response-matches response 'VM 'OK)
2047                      (setq need-ok nil))))))
2048         (when (and (processp process)
2049                      (memq (process-status process) '(open run)))
2050           (vm-imap-end-session process))
2051         ))))
2052
2053 (provide 'vm-imap)
2054
2055 ;;; vm-imap.el ends here