elmo/elmo-imap4.el

   1 ;;; elmo-imap4.el -- IMAP4 Interface for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4 ;; Copyright (C) 1999,2000      Kenichi OKADA <okada@opaopa.org>
   5 ;; Copyright (C) 2000           OKAZAKI Tetsurou <okazaki@be.to>
   6 ;; Copyright (C) 2000           Daiki Ueno <ueno@unixuser.org>
   7
   8 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   9 ;;      Kenichi OKADA <okada@opaopa.org>
  10 ;;      OKAZAKI Tetsurou <okazaki@be.to>
  11 ;;      Daiki Ueno <ueno@unixuser.org>
  12 ;; Keywords: mail, net news
  13
  14 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  15
  16 ;; This program is free software; you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation; either version 2, or (at your option)
  19 ;; any later version.
  20 ;;
  21 ;; This program is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25 ;;
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29 ;; Boston, MA 02111-1307, USA.
  30 ;;
  31
  32 ;;; Commentary:
  33 ;;
  34 ;; Origin of IMAP parser part is imap.el, included in Gnus.
  35 ;;
  36 ;;    Copyright (C) 1998, 1999, 2000
  37 ;;    Free Software Foundation, Inc.
  38 ;;    Author: Simon Josefsson <jas@pdc.kth.se>
  39 ;;
  40
  41 (require 'elmo-vars)
  42 (require 'elmo-util)
  43 (require 'elmo-date)
  44 (require 'elmo-msgdb)
  45 (require 'elmo-cache)
  46 (require 'elmo)
  47 (require 'elmo-net)
  48 (require 'utf7)
  49 (require 'elmo-mime)
  50
  51 ;;; Code:
  52 (eval-when-compile (require 'cl))
  53
  54 (defvar elmo-imap4-disuse-server-flag-mailbox-regexp "^#mh" ; UW imapd
  55   "Regexp to match IMAP4 mailbox names whose message flags on server should be ignored.
  56 (Except `\\Deleted' flag).")
  57
  58 (defvar elmo-imap4-overview-fetch-chop-length 200
  59   "*Number of overviews to fetch in one request in imap4.")
  60
  61 (defvar elmo-imap4-force-login nil
  62   "*Non-nil forces to try 'login' if there is no 'auth' capability in imapd.")
  63
  64 (defvar elmo-imap4-use-select-to-update-status nil
  65   "*Some imapd have to send select command to update status.
  66 (ex. UW imapd 4.5-BETA?).  For these imapd, you must set this variable t.")
  67
  68 (defvar elmo-imap4-use-modified-utf7 nil
  69   "*Use mofidied UTF-7 (rfc2060) encoding for IMAP4 folder name.")
  70
  71 (defvar elmo-imap4-use-cache t
  72   "Use cache in imap4 folder.")
  73
  74 (defvar elmo-imap4-extra-namespace-alist
  75   '(("^{.*/nntp}.*$" . ".")) ; Default is for UW's remote nntp mailbox...
  76   "Extra namespace alist.  A list of cons cell like: (REGEXP . DELIMITER).")
  77 ;;
  78 ;;; internal variables
  79 ;;
  80 (defvar elmo-imap4-seq-prefix "elmo-imap4")
  81 (defvar elmo-imap4-seqno 0)
  82 (defvar elmo-imap4-use-uid t
  83   "Use UID as message number.")
  84
  85 (defvar elmo-imap4-current-response nil)
  86 (defvar elmo-imap4-status nil)
  87 (defvar elmo-imap4-reached-tag "elmo-imap40")
  88
  89 ;;; buffer local variables
  90 (defvar elmo-imap4-default-hierarchy-delimiter "/")
  91
  92 (defvar elmo-imap4-server-capability nil)
  93 (defvar elmo-imap4-server-namespace nil)
  94
  95 (defvar elmo-imap4-parsing nil) ; indicates parsing.
  96
  97 (defvar elmo-imap4-fetch-callback nil)
  98 (defvar elmo-imap4-fetch-callback-data nil)
  99 (defvar elmo-imap4-status-callback nil)
 100 (defvar elmo-imap4-status-callback-data nil)
 101
 102 (defvar elmo-imap4-server-diff-async-callback nil)
 103 (defvar elmo-imap4-server-diff-async-callback-data nil)
 104
 105 ;;; progress...(no use?)
 106 (defvar elmo-imap4-count-progress nil)
 107 (defvar elmo-imap4-count-progress-message nil)
 108 (defvar elmo-imap4-progress-count nil)
 109
 110 ;;; XXX Temporal implementation
 111 (defvar elmo-imap4-current-msgdb nil)
 112
 113 (defvar elmo-imap4-local-variables
 114   '(elmo-imap4-status
 115     elmo-imap4-current-response
 116     elmo-imap4-seqno
 117     elmo-imap4-parsing
 118     elmo-imap4-reached-tag
 119     elmo-imap4-count-progress
 120     elmo-imap4-count-progress-message
 121     elmo-imap4-progress-count
 122     elmo-imap4-fetch-callback
 123     elmo-imap4-fetch-callback-data
 124     elmo-imap4-status-callback
 125     elmo-imap4-status-callback-data
 126     elmo-imap4-current-msgdb))
 127
 128 ;;;;
 129
 130 (defconst elmo-imap4-quoted-specials-list '(?\\ ?\"))
 131
 132 (defconst elmo-imap4-non-atom-char-regex
 133   (eval-when-compile
 134     (concat "[^" "]!#$&'+,./0-9:;<=>?@A-Z[^_`a-z|}~-" "]")))
 135
 136 (defconst elmo-imap4-non-text-char-regex
 137   (eval-when-compile
 138     (concat "[^"
 139             "]\x01-\x09\x0b\x0c\x0e-\x1f\x7f !\"#$%&'()*+,./0-9:;<=>?@A-Z[\\^_`a-z{|}~-"
 140             "]")))
 141
 142 (defconst elmo-imap4-literal-threshold 1024
 143  "Limitation of characters that can be used in a quoted string.")
 144
 145 ;; For debugging.
 146 (defvar elmo-imap4-debug nil
 147   "Non-nil forces IMAP4 folder as debug mode.
 148 Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"")
 149
 150 (defvar elmo-imap4-debug-inhibit-logging nil)
 151
 152 ;;; ELMO IMAP4 folder
 153 (eval-and-compile
 154   (luna-define-class elmo-imap4-folder (elmo-net-folder)
 155                      (mailbox))
 156   (luna-define-internal-accessors 'elmo-imap4-folder))
 157
 158 ;;; Session
 159 (eval-and-compile
 160   (luna-define-class elmo-imap4-session (elmo-network-session)
 161                      (capability current-mailbox read-only))
 162   (luna-define-internal-accessors 'elmo-imap4-session))
 163
 164 ;;; MIME-ELMO-IMAP Location
 165 (eval-and-compile
 166   (luna-define-class mime-elmo-imap-location
 167                      (mime-imap-location)
 168                      (folder number rawbuf strategy))
 169   (luna-define-internal-accessors 'mime-elmo-imap-location))
 170
 171 ;;; Debug
 172 (defsubst elmo-imap4-debug (message &rest args)
 173   (if elmo-imap4-debug
 174       (with-current-buffer (get-buffer-create "*IMAP4 DEBUG*")
 175         (goto-char (point-max))
 176         (if elmo-imap4-debug-inhibit-logging
 177             (insert "NO LOGGING\n")
 178           (insert (apply 'format message args) "\n")))))
 179
 180
 181 (defsubst elmo-imap4-decode-folder-string (string)
 182   (if elmo-imap4-use-modified-utf7
 183       (utf7-decode-string string 'imap)
 184     string))
 185
 186 (defsubst elmo-imap4-encode-folder-string (string)
 187   (if elmo-imap4-use-modified-utf7
 188       (utf7-encode-string string 'imap)
 189     string))
 190
 191 ;;; Response
 192
 193 (defmacro elmo-imap4-response-continue-req-p (response)
 194   "Returns non-nil if RESPONSE is '+' response."
 195   (` (assq 'continue-req (, response))))
 196
 197 (defmacro elmo-imap4-response-ok-p (response)
 198   "Returns non-nil if RESPONSE is an 'OK' response."
 199   (` (assq 'ok (, response))))
 200
 201 (defmacro elmo-imap4-response-bye-p (response)
 202   "Returns non-nil if RESPONSE is an 'BYE' response."
 203   (` (assq 'bye (, response))))
 204
 205 (defmacro elmo-imap4-response-value (response symbol)
 206   "Get value of the SYMBOL from RESPONSE."
 207   (` (nth 1 (assq (, symbol) (, response)))))
 208
 209 (defsubst elmo-imap4-response-value-all (response symbol)
 210   "Get all value of the SYMBOL from RESPONSE."
 211   (let (matched)
 212     (while response
 213       (if (eq (car (car response)) symbol)
 214           (setq matched (nconc matched (nth 1 (car response)))))
 215       (setq response (cdr response)))
 216     matched))
 217
 218 (defmacro elmo-imap4-response-error-text (response)
 219   "Returns text of NO, BAD, BYE response."
 220   (` (nth 1 (or (elmo-imap4-response-value (, response) 'no)
 221                 (elmo-imap4-response-value (, response) 'bad)
 222                 (elmo-imap4-response-value (, response) 'bye)))))
 223
 224 (defmacro elmo-imap4-response-bodydetail-text (response)
 225   "Returns text of BODY[section]<partial>."
 226   (` (nth 3 (assq 'bodydetail (, response)))))
 227
 228 ;;; Session commands.
 229
 230 ; (defun elmo-imap4-send-command-wait (session command)
 231 ;   "Send COMMAND to the SESSION and wait for response.
 232 ; Returns RESPONSE (parsed lisp object) of IMAP session."
 233 ;   (elmo-imap4-read-response session
 234 ;                           (elmo-imap4-send-command
 235 ;                            session
 236 ;                            command)))
 237
 238 (defun elmo-imap4-send-command-wait (session command)
 239   "Send COMMAND to the SESSION.
 240 Returns RESPONSE (parsed lisp object) of IMAP session.
 241 If response is not `OK', causes error with IMAP response text."
 242   (elmo-imap4-accept-ok session
 243                         (elmo-imap4-send-command
 244                          session
 245                          command)))
 246
 247 (defun elmo-imap4-send-command (session command)
 248   "Send COMMAND to the SESSION.
 249 Returns a TAG string which is assigned to the COMAND."
 250   (let* ((command-args (if (listp command)
 251                            command
 252                          (list command)))
 253          (process (elmo-network-session-process-internal session))
 254          cmdstr tag token kind)
 255     (with-current-buffer (process-buffer process)
 256       (setq tag (concat elmo-imap4-seq-prefix
 257                         (number-to-string
 258                          (setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno)))))
 259       (setq cmdstr (concat tag " "))
 260       ;; (erase-buffer) No need.
 261       (goto-char (point-min))
 262       (if (elmo-imap4-response-bye-p elmo-imap4-current-response)
 263           (signal 'elmo-imap4-bye-error
 264                   (list (elmo-imap4-response-error-text
 265                          elmo-imap4-current-response))))
 266       (setq elmo-imap4-current-response nil)
 267       (if elmo-imap4-parsing
 268           (error "IMAP process is running. Please wait (or plug again.)"))
 269       (setq elmo-imap4-parsing t)
 270       (elmo-imap4-debug "<-(%s)- %s" tag command)
 271       (while (setq token (car command-args))
 272         (cond ((stringp token)   ; formatted
 273                (setq cmdstr (concat cmdstr token)))
 274               ((listp token)     ; unformatted
 275                (setq kind (car token))
 276                (cond ((eq kind 'atom)
 277                       (setq cmdstr (concat cmdstr (nth 1 token))))
 278                      ((eq kind 'quoted)
 279                       (setq cmdstr (concat
 280                                     cmdstr
 281                                     (elmo-imap4-format-quoted (nth 1 token)))))
 282                      ((eq kind 'literal)
 283                       (setq cmdstr (concat cmdstr
 284                                            (format "{%d}" (nth 2 token))))
 285                       (process-send-string process cmdstr)
 286                       (process-send-string process "\r\n")
 287                       (setq cmdstr nil)
 288                       (elmo-imap4-accept-continue-req session)
 289                       (cond ((stringp (nth 1 token))
 290                              (setq cmdstr (nth 1 token)))
 291                             ((bufferp (nth 1 token))
 292                              (with-current-buffer (nth 1 token)
 293                                (process-send-region
 294                                 process
 295                                 (point-min)
 296                                 (+ (point-min) (nth 2 token)))))
 297                             (t
 298                              (error "Wrong argument for literal"))))
 299                      (t
 300                       (error "Unknown token kind %s" kind))))
 301               (t
 302                (error "Invalid argument")))
 303         (setq command-args (cdr command-args)))
 304       (if cmdstr
 305           (process-send-string process cmdstr))
 306       (process-send-string process "\r\n")
 307       tag)))
 308
 309 (defun elmo-imap4-send-string (session string)
 310   "Send STRING to the SESSION."
 311   (with-current-buffer (process-buffer
 312                         (elmo-network-session-process-internal session))
 313     (setq elmo-imap4-current-response nil)
 314     (goto-char (point-min))
 315     (elmo-imap4-debug "<-- %s" string)
 316     (process-send-string (elmo-network-session-process-internal session)
 317                          string)
 318     (process-send-string (elmo-network-session-process-internal session)
 319                          "\r\n")))
 320
 321 (defun elmo-imap4-read-response (session tag)
 322   "Read parsed response from SESSION.
 323 TAG is the tag of the command"
 324   (with-current-buffer (process-buffer
 325                         (elmo-network-session-process-internal session))
 326     (while (not (or (string= tag elmo-imap4-reached-tag)
 327                     (elmo-imap4-response-bye-p elmo-imap4-current-response)))
 328       (when (memq (process-status
 329                    (elmo-network-session-process-internal session))
 330                   '(open run))
 331         (accept-process-output (elmo-network-session-process-internal session)
 332                                1)))
 333     (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
 334     (setq elmo-imap4-parsing nil)
 335     elmo-imap4-current-response))
 336
 337 (defsubst elmo-imap4-read-untagged (process)
 338   (with-current-buffer (process-buffer process)
 339     (while (not elmo-imap4-current-response)
 340       (accept-process-output process 1))
 341     (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
 342     elmo-imap4-current-response))
 343
 344 (defun elmo-imap4-read-continue-req (session)
 345   "Returns a text following to continue-req in SESSION.
 346 If response is not `+' response, returns nil."
 347   (elmo-imap4-response-value
 348    (elmo-imap4-read-untagged
 349     (elmo-network-session-process-internal session))
 350    'continue-req))
 351
 352 (defun elmo-imap4-accept-continue-req (session)
 353   "Returns non-nil if `+' (continue-req) response is arrived in SESSION.
 354 If response is not `+' response, cause an error."
 355   (let (response)
 356     (setq response
 357           (elmo-imap4-read-untagged
 358            (elmo-network-session-process-internal session)))
 359     (or (elmo-imap4-response-continue-req-p response)
 360         (error "IMAP error: %s"
 361                (or (elmo-imap4-response-error-text response)
 362                    "No continut-req from server.")))))
 363
 364 (defun elmo-imap4-read-ok (session tag)
 365   "Returns non-nil if `OK' response of the command with TAG is arrived
 366 in SESSION. If response is not `OK' response, returns nil."
 367   (elmo-imap4-response-ok-p
 368    (elmo-imap4-read-response session tag)))
 369
 370 (defun elmo-imap4-accept-ok (session tag)
 371   "Accept only `OK' response from SESSION.
 372 If response is not `OK' response, causes error with IMAP response text."
 373   (let ((response (elmo-imap4-read-response session tag)))
 374     (if (elmo-imap4-response-ok-p response)
 375         response
 376       (if (elmo-imap4-response-bye-p response)
 377           (signal 'elmo-imap4-bye-error
 378                   (list (elmo-imap4-response-error-text response)))
 379         (error "IMAP error: %s"
 380                (or (elmo-imap4-response-error-text response)
 381                    "No `OK' response from server."))))))
 382
 383
 384
 385 ;;; MIME-ELMO-IMAP Location
 386 (luna-define-method mime-imap-location-section-body ((location
 387                                                       mime-elmo-imap-location)
 388                                                      section)
 389   (if (and (stringp section)
 390            (string= section "HEADER"))
 391       ;; Even in the section mode, header fields should be saved to the
 392       ;; raw buffer .
 393       (with-current-buffer (mime-elmo-imap-location-rawbuf-internal location)
 394         (erase-buffer)
 395         (elmo-message-fetch
 396          (mime-elmo-imap-location-folder-internal location)
 397          (mime-elmo-imap-location-number-internal location)
 398          (mime-elmo-imap-location-strategy-internal location)
 399          section
 400          (current-buffer)
 401          'unseen)
 402         (buffer-string))
 403     (elmo-message-fetch
 404      (mime-elmo-imap-location-folder-internal location)
 405      (mime-elmo-imap-location-number-internal location)
 406      (mime-elmo-imap-location-strategy-internal location)
 407      section
 408      nil 'unseen)))
 409
 410
 411 (luna-define-method mime-imap-location-bodystructure
 412   ((location mime-elmo-imap-location))
 413   (elmo-imap4-fetch-bodystructure
 414    (mime-elmo-imap-location-folder-internal location)
 415    (mime-elmo-imap-location-number-internal location)
 416    (mime-elmo-imap-location-strategy-internal location)))
 417
 418 ;;;
 419
 420 (defun elmo-imap4-session-check (session)
 421   (with-current-buffer (elmo-network-session-buffer session)
 422     (setq elmo-imap4-fetch-callback nil)
 423     (setq elmo-imap4-fetch-callback-data nil))
 424   (elmo-imap4-send-command-wait session "check"))
 425
 426 (defun elmo-imap4-atom-p (string)
 427   "Return t if STRING is an atom defined in rfc2060."
 428   (if (string= string "")
 429       nil
 430     (save-match-data
 431       (not (string-match elmo-imap4-non-atom-char-regex string)))))
 432
 433 (defun elmo-imap4-quotable-p (string)
 434   "Return t if STRING can be formatted as a quoted defined in rfc2060."
 435   (save-match-data
 436     (not (string-match elmo-imap4-non-text-char-regex string))))
 437
 438 (defun elmo-imap4-nil (string)
 439   "Return a list represents the special atom \"NIL\" defined in rfc2060, \
 440 if STRING is nil.
 441 Otherwise return nil."
 442   (if (eq string nil)
 443       (list 'atom "NIL")))
 444
 445 (defun elmo-imap4-atom (string)
 446   "Return a list represents STRING as an atom defined in rfc2060.
 447 Return nil if STRING is not an atom.  See `elmo-imap4-atom-p'."
 448   (if (elmo-imap4-atom-p string)
 449       (list 'atom string)))
 450
 451 (defun elmo-imap4-quoted (string)
 452   "Return a list represents STRING as a quoted defined in rfc2060.
 453 Return nil if STRING can not be formatted as a quoted.  See `elmo-imap4-quotable-p'."
 454   (if (elmo-imap4-quotable-p string)
 455       (list 'quoted string)))
 456
 457 (defun elmo-imap4-literal-1 (string-or-buffer length)
 458   "Internal function for `elmo-imap4-literal' and `elmo-imap4-buffer-literal'.
 459 Return a list represents STRING-OR-BUFFER as a literal defined in rfc2060.
 460 STRING-OR-BUFFER must be an encoded string or a single-byte string or a single-byte buffer.
 461 LENGTH must be the number of octets for STRING-OR-BUFFER."
 462   (list 'literal string-or-buffer length))
 463
 464 (defun elmo-imap4-literal (string)
 465   "Return a list represents STRING as a literal defined in rfc2060.
 466 STRING must be an encoded or a single-byte string."
 467   (elmo-imap4-literal-1 string (length string)))
 468
 469 (defun elmo-imap4-buffer-literal (buffer)
 470   "Return a list represents BUFFER as a literal defined in rfc2060.
 471 BUFFER must be a single-byte buffer."
 472   (elmo-imap4-literal-1 buffer (with-current-buffer buffer
 473                                  (buffer-size))))
 474
 475 (defun elmo-imap4-string-1 (string length)
 476   "Internal function for `elmo-imap4-string' and `elmo-imap4-buffer-string'.
 477 Return a list represents STRING as a string defined in rfc2060.
 478 STRING must be an encoded or a single-byte string.
 479 LENGTH must be the number of octets for STRING."
 480   (or (elmo-imap4-quoted string)
 481       (elmo-imap4-literal-1 string length)))
 482
 483 (defun elmo-imap4-string (string)
 484   "Return a list represents STRING as a string defined in rfc2060.
 485 STRING must be an encoded or a single-byte string."
 486   (let ((length (length string)))
 487     (if (< elmo-imap4-literal-threshold length)
 488         (elmo-imap4-literal-1 string length)
 489       (elmo-imap4-string-1 string length))))
 490
 491 (defun elmo-imap4-buffer-string (buffer)
 492   "Return a list represents BUFFER as a string defined in rfc2060.
 493 BUFFER must be a single-byte buffer."
 494   (let ((length (with-current-buffer buffer
 495                   (buffer-size))))
 496     (if (< elmo-imap4-literal-threshold length)
 497         (elmo-imap4-literal-1 buffer length)
 498       (elmo-imap4-string-1 (with-current-buffer buffer
 499                              (buffer-string))
 500                            length))))
 501
 502 (defun elmo-imap4-astring-1 (string length)
 503   "Internal function for `elmo-imap4-astring' and `elmo-imap4-buffer-astring'.
 504 Return a list represents STRING as an astring defined in rfc2060.
 505 STRING must be an encoded or a single-byte string.
 506 LENGTH must be the number of octets for STRING."
 507   (or (elmo-imap4-atom string)
 508       (elmo-imap4-string-1 string length)))
 509
 510 (defun elmo-imap4-astring (string)
 511   "Return a list represents STRING as an astring defined in rfc2060.
 512 STRING must be an encoded or a single-byte string."
 513   (let ((length (length string)))
 514     (if (< elmo-imap4-literal-threshold length)
 515         (elmo-imap4-literal-1 string length)
 516       (elmo-imap4-astring-1 string length))))
 517
 518 (defun elmo-imap4-buffer-astring (buffer)
 519   "Return a list represents BUFFER as an astring defined in rfc2060.
 520 BUFFER must be a single-byte buffer."
 521   (let ((length (with-current-buffer buffer
 522                   (buffer-size))))
 523     (if (< elmo-imap4-literal-threshold length)
 524         (elmo-imap4-literal-1 buffer length)
 525       (elmo-imap4-astring-1 (with-current-buffer buffer
 526                               (buffer-string))
 527                             length))))
 528
 529 (defun elmo-imap4-nstring (string)
 530   "Return a list represents STRING as a nstring defined in rfc2060.
 531 STRING must be an encoded or a single-byte string."
 532    (or (elmo-imap4-nil string)
 533        (elmo-imap4-string string)))
 534
 535 (defun elmo-imap4-buffer-nstring (buffer)
 536   "Return a list represents BUFFER as a nstring defined in rfc2060.
 537 BUFFER must be a single-byte buffer."
 538    (or (elmo-imap4-nil buffer)
 539        (elmo-imap4-buffer-string buffer)))
 540
 541 (defalias 'elmo-imap4-mailbox 'elmo-imap4-astring)
 542 (defalias 'elmo-imap4-field-body 'elmo-imap4-astring)
 543 (defalias 'elmo-imap4-userid 'elmo-imap4-astring)
 544 (defalias 'elmo-imap4-password 'elmo-imap4-astring)
 545
 546 (defun elmo-imap4-format-quoted (string)
 547   "Return STRING in a form of the quoted-string defined in rfc2060."
 548   (concat "\""
 549           (std11-wrap-as-quoted-pairs string elmo-imap4-quoted-specials-list)
 550           "\""))
 551
 552 (defsubst elmo-imap4-response-get-selectable-mailbox-list (response)
 553   (delq nil
 554         (mapcar
 555          (lambda (entry)
 556            (if (and (eq 'list (car entry))
 557                     (not (member "\\NoSelect" (nth 1 (nth 1 entry)))))
 558                (car (nth 1 entry))))
 559          response)))
 560
 561 (defun elmo-imap4-fetch-bodystructure (folder number strategy)
 562   "Fetch BODYSTRUCTURE for the message in the FOLDER with NUMBER using STRATEGY."
 563   (if (elmo-fetch-strategy-use-cache strategy)
 564       (elmo-object-load
 565        (elmo-file-cache-expand-path
 566         (elmo-fetch-strategy-cache-path strategy)
 567         "bodystructure"))
 568     (let ((session (elmo-imap4-get-session folder))
 569           bodystructure)
 570       (elmo-imap4-session-select-mailbox
 571        session
 572        (elmo-imap4-folder-mailbox-internal folder))
 573       (with-current-buffer (elmo-network-session-buffer session)
 574         (setq elmo-imap4-fetch-callback nil)
 575         (setq elmo-imap4-fetch-callback-data nil))
 576       (prog1 (setq bodystructure
 577                    (elmo-imap4-response-value
 578                     (elmo-imap4-response-value
 579                      (elmo-imap4-send-command-wait
 580                       session
 581                       (format
 582                        (if elmo-imap4-use-uid
 583                            "uid fetch %s bodystructure"
 584                          "fetch %s bodystructure")
 585                        number))
 586                      'fetch)
 587                     'bodystructure))
 588         (when (elmo-fetch-strategy-save-cache strategy)
 589           (elmo-file-cache-delete
 590            (elmo-fetch-strategy-cache-path strategy))
 591           (elmo-object-save
 592            (elmo-file-cache-expand-path
 593             (elmo-fetch-strategy-cache-path strategy)
 594             "bodystructure")
 595            bodystructure))))))
 596
 597 ;;; Backend methods.
 598 (luna-define-method elmo-create-folder-plugged ((folder elmo-imap4-folder))
 599   (elmo-imap4-send-command-wait
 600    (elmo-imap4-get-session folder)
 601    (list "create " (elmo-imap4-mailbox
 602                     (elmo-imap4-folder-mailbox-internal folder)))))
 603
 604 (defun elmo-imap4-get-session (folder &optional if-exists)
 605   (elmo-network-get-session 'elmo-imap4-session "IMAP" folder if-exists))
 606
 607 (defun elmo-imap4-session-select-mailbox (session mailbox
 608                                                   &optional force no-error)
 609   "Select MAILBOX in SESSION.
 610 If optional argument FORCE is non-nil, select mailbox even if current mailbox
 611 is same as MAILBOX.
 612 If second optional argument NO-ERROR is non-nil, don't cause an error when
 613 selecting folder was failed.
 614 Returns response value if selecting folder succeed. "
 615   (when (or force
 616             (not (string=
 617                   (elmo-imap4-session-current-mailbox-internal session)
 618                   mailbox)))
 619     (let (response result)
 620       (unwind-protect
 621           (setq response
 622                 (elmo-imap4-read-response
 623                  session
 624                  (elmo-imap4-send-command
 625                   session
 626                   (list
 627                    "select "
 628                    (elmo-imap4-mailbox mailbox)))))
 629         (if (setq result (elmo-imap4-response-ok-p response))
 630             (progn
 631               (elmo-imap4-session-set-current-mailbox-internal session mailbox)
 632               (elmo-imap4-session-set-read-only-internal
 633                session
 634                (nth 1 (assq 'read-only (assq 'ok response)))))
 635           (elmo-imap4-session-set-current-mailbox-internal session nil)
 636           (unless no-error
 637             (error (or
 638                     (elmo-imap4-response-error-text response)
 639                     (format "Select %s failed" mailbox))))))
 640       (and result response))))
 641
 642 (defun elmo-imap4-check-validity (spec validity-file)
 643 ;;; Not used.
 644 ;;;(elmo-imap4-send-command-wait
 645 ;;;(elmo-imap4-get-session spec)
 646 ;;;(list "status "
 647 ;;;      (elmo-imap4-mailbox
 648 ;;;       (elmo-imap4-spec-mailbox spec))
 649 ;;;      " (uidvalidity)")))
 650   )
 651
 652 (defun elmo-imap4-sync-validity  (spec validity-file)
 653   ;; Not used.
 654   )
 655
 656 (defun elmo-imap4-list (folder flag)
 657   (let ((session (elmo-imap4-get-session folder)))
 658     (elmo-imap4-session-select-mailbox
 659      session
 660      (elmo-imap4-folder-mailbox-internal folder))
 661     (elmo-imap4-response-value
 662      (elmo-imap4-send-command-wait
 663       session
 664       (format (if elmo-imap4-use-uid "uid search %s"
 665                 "search %s") flag))
 666      'search)))
 667
 668 (static-cond
 669  ((fboundp 'float)
 670   ;; Emacs can parse dot symbol.
 671   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 672   (defvar elmo-imap4-rfc822-text "RFC822\.TEXT")
 673   (defvar elmo-imap4-rfc822-header "RFC822\.HEADER")
 674   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 675   (defvar elmo-imap4-header-fields "HEADER\.FIELDS")
 676   (defmacro elmo-imap4-replace-dot-symbols ()) ;; noop
 677   (defalias 'elmo-imap4-fetch-read 'read)
 678   )
 679  (t
 680   ;;; For Nemacs.
 681   ;; Cannot parse dot symbol.
 682   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 683   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 684   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 685   (defvar elmo-imap4-rfc822-text "RFC822_TEXT")
 686   (defvar elmo-imap4-rfc822-header "RFC822_HEADER")
 687   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 688   (defun elmo-imap4-fetch-read (buffer)
 689     (with-current-buffer buffer
 690       (let ((beg (point))
 691             token)
 692         (when (re-search-forward "[[ ]" nil t)
 693           (goto-char (match-beginning 0))
 694           (setq token (buffer-substring beg (point)))
 695           (cond ((string= token "RFC822.SIZE")
 696                  (intern elmo-imap4-rfc822-size))
 697                 ((string= token "RFC822.HEADER")
 698                  (intern elmo-imap4-rfc822-header))
 699                 ((string= token "RFC822.TEXT")
 700                  (intern elmo-imap4-rfc822-text))
 701                 ((string= token "HEADER\.FIELDS")
 702                  (intern elmo-imap4-header-fields))
 703                 (t (goto-char beg)
 704                    (elmo-read (current-buffer))))))))))
 705
 706 (defun elmo-imap4-make-number-set-list (msg-list &optional chop-length)
 707   "Make RFC2060's message set specifier from MSG-LIST.
 708 Returns a list of (NUMBER . SET-STRING).
 709 SET-STRING is the message set specifier described in RFC2060.
 710 NUMBER is contained message number in SET-STRING.
 711 Every SET-STRING does not contain number of messages longer than CHOP-LENGTH.
 712 If CHOP-LENGTH is not specified, message set is not chopped."
 713   (let (count cont-list set-list)
 714     (setq msg-list (sort (copy-sequence msg-list) '<))
 715     (while msg-list
 716       (setq cont-list nil)
 717       (setq count 0)
 718       (unless chop-length
 719         (setq chop-length (length msg-list)))
 720       (while (and (not (null msg-list))
 721                   (< count chop-length))
 722         (setq cont-list
 723               (elmo-number-set-append
 724                cont-list (car msg-list)))
 725         (incf count)
 726         (setq msg-list (cdr msg-list)))
 727       (setq set-list
 728             (cons
 729              (cons
 730               count
 731               (mapconcat
 732                (lambda (x)
 733                  (cond ((consp x)
 734                         (format "%s:%s" (car x) (cdr x)))
 735                        ((integerp x)
 736                         (int-to-string x))))
 737                cont-list
 738                ","))
 739              set-list)))
 740     (nreverse set-list)))
 741
 742 ;;
 743 ;; app-data:
 744 ;; cons of list
 745 ;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark
 746 ;; 4: seen-list
 747 ;; and result of use-flag-p.
 748 (defsubst elmo-imap4-fetch-callback-1-subr (entity flags app-data)
 749   "A msgdb entity callback function."
 750   (let* ((use-flag (cdr app-data))
 751          (app-data (car app-data))
 752          (seen (member (car entity) (nth 4 app-data)))
 753          mark)
 754     (if (member "\\Flagged" flags)
 755         (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data)))
 756     (setq mark (or (elmo-msgdb-global-mark-get (car entity))
 757                    (if (elmo-file-cache-status
 758                         (elmo-file-cache-get (car entity)))
 759                        (if (or seen
 760                                (and use-flag
 761                                     (member "\\Seen" flags)))
 762                            nil
 763                          (nth 1 app-data))
 764                      (if (or seen
 765                              (and use-flag
 766                                   (member "\\Seen" flags)))
 767                          (if elmo-imap4-use-cache
 768                              (nth 2 app-data))
 769                        (nth 0 app-data)))))
 770     (setq elmo-imap4-current-msgdb
 771           (elmo-msgdb-append
 772            elmo-imap4-current-msgdb
 773            (list (list entity)
 774                  (list (cons (elmo-msgdb-overview-entity-get-number entity)
 775                              (car entity)))
 776                  (if mark
 777                      (list
 778                       (list (elmo-msgdb-overview-entity-get-number entity)
 779                             mark))))))))
 780
 781 ;; Current buffer is process buffer.
 782 (defun elmo-imap4-fetch-callback-1 (element app-data)
 783   (elmo-imap4-fetch-callback-1-subr
 784    (with-temp-buffer
 785      (insert (or (elmo-imap4-response-bodydetail-text element)
 786                  ""))
 787      ;; Delete CR.
 788      (goto-char (point-min))
 789      (while (search-forward "\r\n" nil t)
 790        (replace-match "\n"))
 791      (elmo-msgdb-create-overview-from-buffer
 792       (elmo-imap4-response-value element 'uid)
 793       (elmo-imap4-response-value element 'rfc822size)))
 794    (elmo-imap4-response-value element 'flags)
 795    app-data))
 796
 797 (defun elmo-imap4-parse-capability (string)
 798   (if (string-match "^\\*\\(.*\\)$" string)
 799       (elmo-read
 800        (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
 801
 802 (defun elmo-imap4-clear-login (session)
 803   (let ((elmo-imap4-debug-inhibit-logging t))
 804     (or
 805      (elmo-imap4-read-ok
 806       session
 807       (elmo-imap4-send-command
 808        session
 809        (list "login "
 810              (elmo-imap4-userid (elmo-network-session-user-internal session))
 811              " "
 812              (elmo-imap4-password
 813               (elmo-get-passwd (elmo-network-session-password-key session))))))
 814      (signal 'elmo-authenticate-error '(elmo-imap4-clear-login)))))
 815
 816 (defun elmo-imap4-auth-login (session)
 817   (let ((tag (elmo-imap4-send-command session "authenticate login"))
 818         (elmo-imap4-debug-inhibit-logging t))
 819     (or (elmo-imap4-read-continue-req session)
 820         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 821     (elmo-imap4-send-string session
 822                             (elmo-base64-encode-string
 823                              (elmo-network-session-user-internal session)))
 824     (or (elmo-imap4-read-continue-req session)
 825         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 826     (elmo-imap4-send-string session
 827                             (elmo-base64-encode-string
 828                              (elmo-get-passwd
 829                               (elmo-network-session-password-key session))))
 830     (or (elmo-imap4-read-ok session tag)
 831         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 832     (setq elmo-imap4-status 'auth)))
 833
 834 (luna-define-method
 835   elmo-network-initialize-session-buffer :after ((session
 836                                                   elmo-imap4-session) buffer)
 837   (with-current-buffer buffer
 838     (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
 839     (setq elmo-imap4-seqno 0)
 840     (setq elmo-imap4-status 'initial)))
 841
 842 (luna-define-method elmo-network-initialize-session ((session
 843                                                       elmo-imap4-session))
 844   (let ((process (elmo-network-session-process-internal session)))
 845     (with-current-buffer (process-buffer process)
 846       ;; Skip garbage output from process before greeting.
 847       (while (and (memq (process-status process) '(open run))
 848                   (goto-char (point-max))
 849                   (forward-line -1)
 850                   (not (elmo-imap4-parse-greeting)))
 851         (accept-process-output process 1))
 852       (set-process-filter process 'elmo-imap4-arrival-filter)
 853       (set-process-sentinel process 'elmo-imap4-sentinel)
 854 ;;;   (while (and (memq (process-status process) '(open run))
 855 ;;;               (eq elmo-imap4-status 'initial))
 856 ;;;     (message "Waiting for server response...")
 857 ;;;     (accept-process-output process 1))
 858 ;;;   (message "")
 859       (unless (memq elmo-imap4-status '(nonauth auth))
 860         (signal 'elmo-open-error
 861                 (list 'elmo-network-initialize-session)))
 862       (elmo-imap4-session-set-capability-internal
 863        session
 864        (elmo-imap4-response-value
 865         (elmo-imap4-send-command-wait session "capability")
 866         'capability))
 867       (when (eq (elmo-network-stream-type-symbol
 868                  (elmo-network-session-stream-type-internal session))
 869                 'starttls)
 870         (or (memq 'starttls
 871                   (elmo-imap4-session-capability-internal session))
 872             (signal 'elmo-open-error
 873                     '(elmo-imap4-starttls-error)))
 874         (elmo-imap4-send-command-wait session "starttls")
 875         (starttls-negotiate process)))))
 876
 877 (luna-define-method elmo-network-authenticate-session ((session
 878                                                         elmo-imap4-session))
 879   (with-current-buffer (process-buffer
 880                         (elmo-network-session-process-internal session))
 881     (let* ((auth (elmo-network-session-auth-internal session))
 882            (auth (if (listp auth) auth (list auth))))
 883       (unless (or (eq elmo-imap4-status 'auth)
 884                   (null auth))
 885         (cond
 886          ((eq 'clear (car auth))
 887           (elmo-imap4-clear-login session))
 888          ((eq 'login (car auth))
 889           (elmo-imap4-auth-login session))
 890          (t
 891           (let* ((elmo-imap4-debug-inhibit-logging t)
 892                  (sasl-mechanisms
 893                   (delq nil
 894                         (mapcar
 895                          '(lambda (cap)
 896                             (if (string-match "^auth=\\(.*\\)$"
 897                                               (symbol-name cap))
 898                                 (match-string 1 (upcase (symbol-name cap)))))
 899                          (elmo-imap4-session-capability-internal session))))
 900                  (mechanism
 901                   (sasl-find-mechanism
 902                    (delq nil
 903                          (mapcar '(lambda (cap) (upcase (symbol-name cap)))
 904                                  (if (listp auth)
 905                                      auth
 906                                    (list auth)))))) ;)
 907                  client name step response tag
 908                  sasl-read-passphrase)
 909             (unless mechanism
 910               (if (or elmo-imap4-force-login
 911                       (y-or-n-p
 912                        (format
 913                         "There's no %s capability in server. continue?"
 914                         (elmo-list-to-string
 915                          (elmo-network-session-auth-internal session)))))
 916                   (setq mechanism (sasl-find-mechanism
 917                                    sasl-mechanisms))
 918                 (signal 'elmo-authenticate-error
 919                         '(elmo-imap4-auth-no-mechanisms))))
 920             (setq client
 921                   (sasl-make-client
 922                    mechanism
 923                    (elmo-network-session-user-internal session)
 924                    "imap"
 925                    (elmo-network-session-server-internal session)))
 926 ;;;         (if elmo-imap4-auth-user-realm
 927 ;;;             (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
 928             (setq name (sasl-mechanism-name mechanism)
 929                   step (sasl-next-step client nil))
 930             (elmo-network-session-set-auth-internal
 931              session
 932              (intern (downcase name)))
 933             (setq sasl-read-passphrase
 934                   (function
 935                    (lambda (prompt)
 936                      (elmo-get-passwd
 937                       (elmo-network-session-password-key session)))))
 938             (setq tag
 939                   (elmo-imap4-send-command
 940                    session
 941                    (concat "AUTHENTICATE " name
 942                            (and (sasl-step-data step)
 943                                 (concat
 944                                  " "
 945                                  (elmo-base64-encode-string
 946                                   (sasl-step-data step)
 947                                   'no-lin-break))))))
 948             (catch 'done
 949               (while t
 950                 (setq response
 951                       (elmo-imap4-read-untagged
 952                        (elmo-network-session-process-internal session)))
 953                 (if (elmo-imap4-response-ok-p response)
 954                     (if (sasl-next-step client step)
 955                         ;; Bogus server?
 956                         (signal 'elmo-authenticate-error
 957                                 (list (intern
 958                                        (concat "elmo-imap4-auth-"
 959                                                (downcase name)))))
 960                       ;; The authentication process is finished.
 961                       (throw 'done nil)))
 962                 (unless (elmo-imap4-response-continue-req-p response)
 963                   ;; response is NO or BAD.
 964                   (signal 'elmo-authenticate-error
 965                           (list (intern
 966                                  (concat "elmo-imap4-auth-"
 967                                          (downcase name))))))
 968                 (sasl-step-set-data
 969                  step
 970                  (elmo-base64-decode-string
 971                   (elmo-imap4-response-value response 'continue-req)))
 972                 (setq step (sasl-next-step client step))
 973                 (setq tag
 974                       (elmo-imap4-send-string
 975                        session
 976                        (if (sasl-step-data step)
 977                            (elmo-base64-encode-string (sasl-step-data step)
 978                                                       'no-line-break)
 979                          ""))))))))))))
 980
 981 (luna-define-method elmo-network-setup-session ((session
 982                                                  elmo-imap4-session))
 983   (with-current-buffer (elmo-network-session-buffer session)
 984     (when (memq 'namespace (elmo-imap4-session-capability-internal session))
 985       (setq elmo-imap4-server-namespace
 986             (elmo-imap4-response-value
 987              (elmo-imap4-send-command-wait session "namespace")
 988              'namespace)))))
 989
 990 (defun elmo-imap4-setup-send-buffer (&optional string)
 991   (let ((send-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*"))
 992         (source-buf (unless string (current-buffer))))
 993     (save-excursion
 994       (save-match-data
 995         (set-buffer send-buf)
 996         (erase-buffer)
 997         (elmo-set-buffer-multibyte nil)
 998         (if string
 999             (insert string)
1000           (with-current-buffer source-buf
1001             (copy-to-buffer send-buf (point-min) (point-max))))
1002         (goto-char (point-min))
1003         (if (eq (re-search-forward "^$" nil t)
1004                 (point-max))
1005             (insert "\n"))
1006         (goto-char (point-min))
1007         (while (search-forward "\n" nil t)
1008           (replace-match "\r\n"))))
1009     send-buf))
1010
1011 (defun elmo-imap4-setup-send-buffer-from-file (file)
1012   (let ((tmp-buf (get-buffer-create
1013                   " *elmo-imap4-setup-send-buffer-from-file*")))
1014     (save-excursion
1015       (save-match-data
1016         (set-buffer tmp-buf)
1017         (erase-buffer)
1018         (as-binary-input-file
1019          (insert-file-contents file))
1020         (goto-char (point-min))
1021         (if (eq (re-search-forward "^$" nil t)
1022                 (point-max))
1023             (insert "\n"))
1024         (goto-char (point-min))
1025         (while (search-forward "\n" nil t)
1026           (replace-match "\r\n"))))
1027     tmp-buf))
1028
1029 (luna-define-method elmo-delete-message-safe ((folder elmo-imap4-folder)
1030                                               number msgid)
1031   (let ((session (elmo-imap4-get-session folder))
1032         candidates)
1033     (elmo-imap4-session-select-mailbox
1034      session
1035      (elmo-imap4-folder-mailbox-internal folder))
1036     (setq candidates
1037           (elmo-imap4-response-value
1038            (elmo-imap4-send-command-wait session
1039                                          (list
1040                                           (if elmo-imap4-use-uid
1041                                               "uid search header message-id "
1042                                             "search header message-id ")
1043                                           (elmo-imap4-field-body msgid)))
1044            'search))
1045     (if (memq number candidates)
1046         (elmo-folder-delete-messages folder (list number)))))
1047
1048 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1049   (funcall elmo-imap4-server-diff-async-callback
1050            (cons (elmo-imap4-response-value status 'unseen)
1051                  (elmo-imap4-response-value status 'messages))
1052            data))
1053
1054 (defun elmo-imap4-server-diff-async (folder)
1055   (let ((session (elmo-imap4-get-session folder)))
1056     ;; We should `check' folder to obtain newest information here.
1057     ;; But since there's no asynchronous check mechanism in elmo yet,
1058     ;; checking is not done here.
1059     (with-current-buffer (elmo-network-session-buffer session)
1060       (setq elmo-imap4-status-callback
1061             'elmo-imap4-server-diff-async-callback-1)
1062       (setq elmo-imap4-status-callback-data
1063             elmo-imap4-server-diff-async-callback-data))
1064     (elmo-imap4-send-command session
1065                              (list
1066                               "status "
1067                               (elmo-imap4-mailbox
1068                                (elmo-imap4-folder-mailbox-internal folder))
1069                               " (unseen messages)"))))
1070
1071 (luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder))
1072   (let ((session (elmo-imap4-get-session folder)))
1073     ;; commit.
1074     ;; (elmo-imap4-commit spec)
1075     (with-current-buffer (elmo-network-session-buffer session)
1076       (setq elmo-imap4-status-callback
1077             'elmo-imap4-server-diff-async-callback-1)
1078       (setq elmo-imap4-status-callback-data
1079             elmo-imap4-server-diff-async-callback-data))
1080     (elmo-imap4-send-command session
1081                              (list
1082                               "status "
1083                               (elmo-imap4-mailbox
1084                                (elmo-imap4-folder-mailbox-internal folder))
1085                               " (unseen messages)"))))
1086
1087 ;;; IMAP parser.
1088
1089 (defvar elmo-imap4-server-eol "\r\n"
1090   "The EOL string sent from the server.")
1091
1092 (defvar elmo-imap4-client-eol "\r\n"
1093   "The EOL string we send to the server.")
1094
1095 (defvar elmo-imap4-display-literal-progress nil)
1096
1097 (defun elmo-imap4-find-next-line ()
1098   "Return point at end of current line, taking into account literals.
1099 Return nil if no complete line has arrived."
1100   (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1101                                    elmo-imap4-server-eol)
1102                            nil t)
1103     (if (match-string 1)
1104         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1105             (progn
1106               (if (and elmo-imap4-display-literal-progress
1107                        (> (string-to-number (match-string 1))
1108                           (min elmo-display-retrieval-progress-threshold 100)))
1109                   (elmo-display-progress
1110                    'elmo-imap4-display-literal-progress
1111                    (format "Retrieving (%d/%d bytes)..."
1112                            (- (point-max) (point))
1113                            (string-to-number (match-string 1)))
1114                    (/ (- (point-max) (point))
1115                       (/ (string-to-number (match-string 1)) 100))))
1116               nil)
1117           (goto-char (+ (point) (string-to-number (match-string 1))))
1118           (elmo-imap4-find-next-line))
1119       (point))))
1120
1121 (defun elmo-imap4-sentinel (process string)
1122   (delete-process process))
1123
1124 (defun elmo-imap4-arrival-filter (proc string)
1125   "IMAP process filter."
1126   (when (buffer-live-p (process-buffer proc))
1127   (with-current-buffer (process-buffer proc)
1128     (elmo-imap4-debug "-> %s" string)
1129     (goto-char (point-max))
1130     (insert string)
1131     (let (end)
1132       (goto-char (point-min))
1133       (while (setq end (elmo-imap4-find-next-line))
1134         (save-restriction
1135           (narrow-to-region (point-min) end)
1136           (delete-backward-char (length elmo-imap4-server-eol))
1137           (goto-char (point-min))
1138           (unwind-protect
1139               (cond ((eq elmo-imap4-status 'initial)
1140                      (setq elmo-imap4-current-response
1141                            (list
1142                             (list 'greeting (elmo-imap4-parse-greeting)))))
1143                     ((or (eq elmo-imap4-status 'auth)
1144                          (eq elmo-imap4-status 'nonauth)
1145                          (eq elmo-imap4-status 'selected)
1146                          (eq elmo-imap4-status 'examine))
1147                      (setq elmo-imap4-current-response
1148                            (cons
1149                             (elmo-imap4-parse-response)
1150                             elmo-imap4-current-response)))
1151                     (t
1152                      (message "Unknown state %s in arrival filter"
1153                               elmo-imap4-status))))
1154           (delete-region (point-min) (point-max))))))))
1155
1156 ;; IMAP parser.
1157
1158 (defsubst elmo-imap4-forward ()
1159   (or (eobp) (forward-char 1)))
1160
1161 (defsubst elmo-imap4-parse-number ()
1162   (when (looking-at "[0-9]+")
1163     (prog1
1164         (string-to-number (match-string 0))
1165       (goto-char (match-end 0)))))
1166
1167 (defsubst elmo-imap4-parse-literal ()
1168   (when (looking-at "{\\([0-9]+\\)}\r\n")
1169     (let ((pos (match-end 0))
1170           (len (string-to-number (match-string 1))))
1171       (if (< (point-max) (+ pos len))
1172           nil
1173         (goto-char (+ pos len))
1174         (buffer-substring pos (+ pos len))))))
1175 ;;;     (list ' pos (+ pos len))))))
1176
1177 (defsubst elmo-imap4-parse-string ()
1178   (cond ((eq (char-after (point)) ?\")
1179          (forward-char 1)
1180          (let ((p (point)) (name ""))
1181            (skip-chars-forward "^\"\\\\")
1182            (setq name (buffer-substring p (point)))
1183            (while (eq (char-after (point)) ?\\)
1184              (setq p (1+ (point)))
1185              (forward-char 2)
1186              (skip-chars-forward "^\"\\\\")
1187              (setq name (concat name (buffer-substring p (point)))))
1188            (forward-char 1)
1189            name))
1190         ((eq (char-after (point)) ?{)
1191          (elmo-imap4-parse-literal))))
1192
1193 (defsubst elmo-imap4-parse-nil ()
1194   (if (looking-at "NIL")
1195       (goto-char (match-end 0))))
1196
1197 (defsubst elmo-imap4-parse-nstring ()
1198   (or (elmo-imap4-parse-string)
1199       (and (elmo-imap4-parse-nil)
1200            nil)))
1201
1202 (defsubst elmo-imap4-parse-astring ()
1203   (or (elmo-imap4-parse-string)
1204       (buffer-substring (point)
1205                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1206                             (goto-char (1- (match-end 0)))
1207                           (end-of-line)
1208                           (point)))))
1209
1210 (defsubst elmo-imap4-parse-address ()
1211   (let (address)
1212     (when (eq (char-after (point)) ?\()
1213       (elmo-imap4-forward)
1214       (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1215                               (elmo-imap4-forward))
1216                             (prog1 (elmo-imap4-parse-nstring)
1217                               (elmo-imap4-forward))
1218                             (prog1 (elmo-imap4-parse-nstring)
1219                               (elmo-imap4-forward))
1220                             (elmo-imap4-parse-nstring)))
1221       (when (eq (char-after (point)) ?\))
1222         (elmo-imap4-forward)
1223         address))))
1224
1225 (defsubst elmo-imap4-parse-address-list ()
1226   (if (eq (char-after (point)) ?\()
1227       (let (address addresses)
1228         (elmo-imap4-forward)
1229         (while (and (not (eq (char-after (point)) ?\)))
1230                     ;; next line for MS Exchange bug
1231                     (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1232                     (setq address (elmo-imap4-parse-address)))
1233           (setq addresses (cons address addresses)))
1234         (when (eq (char-after (point)) ?\))
1235           (elmo-imap4-forward)
1236           (nreverse addresses)))
1237     (assert (elmo-imap4-parse-nil))))
1238
1239 (defsubst elmo-imap4-parse-mailbox ()
1240   (let ((mailbox (elmo-imap4-parse-astring)))
1241     (if (string-equal "INBOX" (upcase mailbox))
1242         "INBOX"
1243       mailbox)))
1244
1245 (defun elmo-imap4-parse-greeting ()
1246   "Parse a IMAP greeting."
1247   (cond ((looking-at "\\* OK ")
1248          (setq elmo-imap4-status 'nonauth))
1249         ((looking-at "\\* PREAUTH ")
1250          (setq elmo-imap4-status 'auth))
1251         ((looking-at "\\* BYE ")
1252          (setq elmo-imap4-status 'closed))))
1253
1254 (defun elmo-imap4-parse-response ()
1255   "Parse a IMAP command response."
1256   (let (token)
1257     (case (setq token (elmo-read (current-buffer)))
1258       (+ (progn
1259            (skip-chars-forward " ")
1260            (list 'continue-req (buffer-substring (point) (point-max)))))
1261       (* (case (prog1 (setq token (elmo-read (current-buffer)))
1262                  (elmo-imap4-forward))
1263            (OK         (elmo-imap4-parse-resp-text-code))
1264            (NO         (elmo-imap4-parse-resp-text-code))
1265            (BAD        (elmo-imap4-parse-resp-text-code))
1266            (BYE        (elmo-imap4-parse-bye))
1267            (FLAGS      (list 'flags
1268                              (elmo-imap4-parse-flag-list)))
1269            (LIST       (list 'list (elmo-imap4-parse-data-list)))
1270            (LSUB       (list 'lsub (elmo-imap4-parse-data-list)))
1271            (SEARCH     (list
1272                         'search
1273                         (elmo-read (concat "("
1274                                       (buffer-substring (point) (point-max))
1275                                       ")"))))
1276            (STATUS     (elmo-imap4-parse-status))
1277            ;; Added
1278            (NAMESPACE  (elmo-imap4-parse-namespace))
1279            (CAPABILITY (list 'capability
1280                              (elmo-read
1281                               (concat "(" (downcase (buffer-substring
1282                                                      (point) (point-max)))
1283                                       ")"))))
1284            (ACL        (elmo-imap4-parse-acl))
1285            (t       (case (prog1 (elmo-read (current-buffer))
1286                             (elmo-imap4-forward))
1287                       (EXISTS  (list 'exists token))
1288                       (RECENT  (list 'recent token))
1289                       (EXPUNGE (list 'expunge token))
1290                       (FETCH   (elmo-imap4-parse-fetch token))
1291                       (t       (list 'garbage (buffer-string)))))))
1292       (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1293              (list 'garbage (buffer-string))
1294            (case (prog1 (elmo-read (current-buffer))
1295                    (elmo-imap4-forward))
1296              (OK  (progn
1297                     (setq elmo-imap4-parsing nil)
1298                     (setq token (symbol-name token))
1299                     (elmo-unintern token)
1300                     (elmo-imap4-debug "*%s* OK arrived" token)
1301                     (setq elmo-imap4-reached-tag token)
1302                     (list 'ok (elmo-imap4-parse-resp-text-code))))
1303              (NO  (progn
1304                     (setq elmo-imap4-parsing nil)
1305                     (setq token (symbol-name token))
1306                     (elmo-unintern token)
1307                     (elmo-imap4-debug "*%s* NO arrived" token)
1308                     (setq elmo-imap4-reached-tag token)
1309                     (let (code text)
1310                       (when (eq (char-after (point)) ?\[)
1311                         (setq code (buffer-substring (point)
1312                                                      (search-forward "]")))
1313                         (elmo-imap4-forward))
1314                       (setq text (buffer-substring (point) (point-max)))
1315                       (list 'no (list code text)))))
1316              (BAD (progn
1317                     (setq elmo-imap4-parsing nil)
1318                     (elmo-imap4-debug "*%s* BAD arrived" token)
1319                     (setq token (symbol-name token))
1320                     (elmo-unintern token)
1321                     (setq elmo-imap4-reached-tag token)
1322                     (let (code text)
1323                       (when (eq (char-after (point)) ?\[)
1324                         (setq code (buffer-substring (point)
1325                                                      (search-forward "]")))
1326                         (elmo-imap4-forward))
1327                       (setq text (buffer-substring (point) (point-max)))
1328                       (list 'bad (list code text)))))
1329              (t   (list 'garbage (buffer-string)))))))))
1330
1331 (defun elmo-imap4-parse-bye ()
1332   (let (code text)
1333     (when (eq (char-after (point)) ?\[)
1334       (setq code (buffer-substring (point)
1335                                    (search-forward "]")))
1336       (elmo-imap4-forward))
1337     (setq text (buffer-substring (point) (point-max)))
1338     (list 'bye (list code text))))
1339
1340 (defun elmo-imap4-parse-text ()
1341   (goto-char (point-min))
1342   (when (search-forward "[" nil t)
1343     (search-forward "]")
1344     (elmo-imap4-forward))
1345   (list 'text (buffer-substring (point) (point-max))))
1346
1347 (defun elmo-imap4-parse-resp-text-code ()
1348   (when (eq (char-after (point)) ?\[)
1349     (elmo-imap4-forward)
1350     (cond ((search-forward "PERMANENTFLAGS " nil t)
1351            (list 'permanentflags (elmo-imap4-parse-flag-list)))
1352           ((search-forward "UIDNEXT " nil t)
1353            (list 'uidnext (elmo-read (current-buffer))))
1354           ((search-forward "UNSEEN " nil t)
1355            (list 'unseen (elmo-read (current-buffer))))
1356           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1357            (list 'uidvalidity (match-string 1)))
1358           ((search-forward "READ-ONLY" nil t)
1359            (list 'read-only t))
1360           ((search-forward "READ-WRITE" nil t)
1361            (list 'read-write t))
1362           ((search-forward "NEWNAME " nil t)
1363            (let (oldname newname)
1364              (setq oldname (elmo-imap4-parse-string))
1365              (elmo-imap4-forward)
1366              (setq newname (elmo-imap4-parse-string))
1367              (list 'newname newname oldname)))
1368           ((search-forward "TRYCREATE" nil t)
1369            (list 'trycreate t))
1370           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1371            (list 'appenduid
1372                  (list (match-string 1)
1373                        (string-to-number (match-string 2)))))
1374           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1375            (list 'copyuid (list (match-string 1)
1376                                 (match-string 2)
1377                                 (match-string 3))))
1378           ((search-forward "ALERT] " nil t)
1379            (message "IMAP server information: %s"
1380                     (buffer-substring (point) (point-max))))
1381           (t (list 'unknown)))))
1382
1383 (defun elmo-imap4-parse-data-list ()
1384   (let (flags delimiter mailbox)
1385     (setq flags (elmo-imap4-parse-flag-list))
1386     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1387       (setq delimiter (match-string 1))
1388       (goto-char (1+ (match-end 0)))
1389       (when (setq mailbox (elmo-imap4-parse-mailbox))
1390         (list mailbox flags delimiter)))))
1391
1392 (defsubst elmo-imap4-parse-header-list ()
1393   (when (eq (char-after (point)) ?\()
1394     (let (strlist)
1395       (while (not (eq (char-after (point)) ?\)))
1396         (elmo-imap4-forward)
1397         (push (elmo-imap4-parse-astring) strlist))
1398       (elmo-imap4-forward)
1399       (nreverse strlist))))
1400
1401 (defsubst elmo-imap4-parse-fetch-body-section ()
1402   (let ((section
1403          (buffer-substring (point)
1404                            (1-
1405                             (progn (re-search-forward "[] ]" nil t)
1406                                    (point))))))
1407     (if (eq (char-before) ? )
1408         (prog1
1409             (mapconcat 'identity
1410                        (cons section (elmo-imap4-parse-header-list)) " ")
1411           (search-forward "]" nil t))
1412       section)))
1413
1414 (defun elmo-imap4-parse-fetch (response)
1415   (when (eq (char-after (point)) ?\()
1416     (let (element list)
1417       (while (not (eq (char-after (point)) ?\)))
1418         (elmo-imap4-forward)
1419         (let ((token (elmo-imap4-fetch-read (current-buffer))))
1420           (elmo-imap4-forward)
1421           (setq element
1422                 (cond ((eq token 'UID)
1423                        (list 'uid (condition-case nil
1424                                       (elmo-read (current-buffer))
1425                                     (error nil))))
1426                       ((eq token 'FLAGS)
1427                        (list 'flags (elmo-imap4-parse-flag-list)))
1428                       ((eq token 'ENVELOPE)
1429                        (list 'envelope (elmo-imap4-parse-envelope)))
1430                       ((eq token 'INTERNALDATE)
1431                        (list 'internaldate (elmo-imap4-parse-string)))
1432                       ((eq token 'RFC822)
1433                        (list 'rfc822 (elmo-imap4-parse-nstring)))
1434                       ((eq token (intern elmo-imap4-rfc822-header))
1435                        (list 'rfc822header (elmo-imap4-parse-nstring)))
1436                       ((eq token (intern elmo-imap4-rfc822-text))
1437                        (list 'rfc822text (elmo-imap4-parse-nstring)))
1438                       ((eq token (intern elmo-imap4-rfc822-size))
1439                        (list 'rfc822size (elmo-read (current-buffer))))
1440                       ((eq token 'BODY)
1441                        (if (eq (char-before) ?\[)
1442                            (list
1443                             'bodydetail
1444                             (upcase (elmo-imap4-parse-fetch-body-section))
1445                             (and
1446                              (eq (char-after (point)) ?<)
1447                              (buffer-substring (1+ (point))
1448                                                (progn
1449                                                  (search-forward ">" nil t)
1450                                                  (point))))
1451                             (progn (elmo-imap4-forward)
1452                                    (elmo-imap4-parse-nstring)))
1453                          (list 'body (elmo-imap4-parse-body))))
1454                       ((eq token 'BODYSTRUCTURE)
1455                        (list 'bodystructure (elmo-imap4-parse-body)))))
1456           (setq list (cons element list))))
1457       (and elmo-imap4-fetch-callback
1458            (funcall elmo-imap4-fetch-callback
1459                     list elmo-imap4-fetch-callback-data))
1460       (list 'fetch list))))
1461
1462 (defun elmo-imap4-parse-status ()
1463   (let ((mailbox (elmo-imap4-parse-mailbox))
1464         status)
1465     (when (and mailbox (search-forward "(" nil t))
1466       (while (not (eq (char-after (point)) ?\)))
1467         (setq status
1468               (cons
1469                (let ((token (elmo-read (current-buffer))))
1470                  (cond ((eq token 'MESSAGES)
1471                         (list 'messages (elmo-read (current-buffer))))
1472                        ((eq token 'RECENT)
1473                         (list 'recent (elmo-read (current-buffer))))
1474                        ((eq token 'UIDNEXT)
1475                         (list 'uidnext (elmo-read (current-buffer))))
1476                        ((eq token 'UIDVALIDITY)
1477                         (and (looking-at " \\([0-9]+\\)")
1478                              (prog1 (list 'uidvalidity (match-string 1))
1479                                (goto-char (match-end 1)))))
1480                        ((eq token 'UNSEEN)
1481                         (list 'unseen (elmo-read (current-buffer))))
1482                        (t
1483                         (message
1484                          "Unknown status data %s in mailbox %s ignored"
1485                          token mailbox))))
1486                status))))
1487     (and elmo-imap4-status-callback
1488          (funcall elmo-imap4-status-callback
1489                   status
1490                   elmo-imap4-status-callback-data))
1491     (list 'status status)))
1492
1493
1494 (defmacro elmo-imap4-value (value)
1495   (` (if (eq (, value) 'NIL) nil
1496        (, value))))
1497
1498 (defmacro elmo-imap4-nth (pos list)
1499   (` (let ((value (nth (, pos) (, list))))
1500        (elmo-imap4-value value))))
1501
1502 (defun elmo-imap4-parse-namespace ()
1503   (list 'namespace
1504         (nconc
1505          (copy-sequence elmo-imap4-extra-namespace-alist)
1506          (elmo-imap4-parse-namespace-subr
1507           (elmo-read (concat "(" (buffer-substring
1508                                   (point) (point-max))
1509                              ")"))))))
1510
1511 (defun elmo-imap4-parse-namespace-subr (ns)
1512   (let (prefix delim namespace-alist default-delim)
1513     ;; 0: personal, 1: other, 2: shared
1514     (dotimes (i 3)
1515       (setq namespace-alist
1516             (nconc namespace-alist
1517                    (delq nil
1518                          (mapcar
1519                           (lambda (namespace)
1520                             (setq prefix (elmo-imap4-nth 0 namespace)
1521                                   delim (elmo-imap4-nth 1 namespace))
1522                             (if (and prefix delim
1523                                      (string-match
1524                                       (concat (regexp-quote delim) "\\'")
1525                                       prefix))
1526                                 (setq prefix (substring prefix 0
1527                                                         (match-beginning 0))))
1528                             (if (eq (length prefix) 0)
1529                                 (progn (setq default-delim delim) nil)
1530                               (cons
1531                                (concat "^"
1532                                        (if (string= (downcase prefix) "inbox")
1533                                            "[Ii][Nn][Bb][Oo][Xx]"
1534                                          (regexp-quote prefix))
1535                                        ".*$")
1536                                delim)))
1537                           (elmo-imap4-nth i ns))))))
1538     (if default-delim
1539         (setq namespace-alist
1540               (nconc namespace-alist
1541                      (list (cons "^.*$" default-delim)))))
1542     namespace-alist))
1543
1544 (defun elmo-imap4-parse-acl ()
1545   (let ((mailbox (elmo-imap4-parse-mailbox))
1546         identifier rights acl)
1547     (while (eq (char-after (point)) ?\ )
1548       (elmo-imap4-forward)
1549       (setq identifier (elmo-imap4-parse-astring))
1550       (elmo-imap4-forward)
1551       (setq rights (elmo-imap4-parse-astring))
1552       (setq acl (append acl (list (cons identifier rights)))))
1553     (list 'acl acl mailbox)))
1554
1555 (defun elmo-imap4-parse-flag-list ()
1556   (let ((str (buffer-substring (+ (point) 1)
1557                                (progn (search-forward ")" nil t)
1558                                       (- (point) 1)))))
1559     (unless (eq (length str) 0)
1560       (split-string str))))
1561
1562 (defun elmo-imap4-parse-envelope ()
1563   (when (eq (char-after (point)) ?\()
1564     (elmo-imap4-forward)
1565     (vector (prog1 (elmo-imap4-parse-nstring);; date
1566               (elmo-imap4-forward))
1567             (prog1 (elmo-imap4-parse-nstring);; subject
1568               (elmo-imap4-forward))
1569             (prog1 (elmo-imap4-parse-address-list);; from
1570               (elmo-imap4-forward))
1571             (prog1 (elmo-imap4-parse-address-list);; sender
1572               (elmo-imap4-forward))
1573             (prog1 (elmo-imap4-parse-address-list);; reply-to
1574               (elmo-imap4-forward))
1575             (prog1 (elmo-imap4-parse-address-list);; to
1576               (elmo-imap4-forward))
1577             (prog1 (elmo-imap4-parse-address-list);; cc
1578               (elmo-imap4-forward))
1579             (prog1 (elmo-imap4-parse-address-list);; bcc
1580               (elmo-imap4-forward))
1581             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
1582               (elmo-imap4-forward))
1583             (prog1 (elmo-imap4-parse-nstring);; message-id
1584               (elmo-imap4-forward)))))
1585
1586 (defsubst elmo-imap4-parse-string-list ()
1587   (cond ((eq (char-after (point)) ?\();; body-fld-param
1588          (let (strlist str)
1589            (elmo-imap4-forward)
1590            (while (setq str (elmo-imap4-parse-string))
1591              (push str strlist)
1592              (elmo-imap4-forward))
1593            (nreverse strlist)))
1594         ((elmo-imap4-parse-nil)
1595          nil)))
1596
1597 (defun elmo-imap4-parse-body-extension ()
1598   (if (eq (char-after (point)) ?\()
1599       (let (b-e)
1600         (elmo-imap4-forward)
1601         (push (elmo-imap4-parse-body-extension) b-e)
1602         (while (eq (char-after (point)) ?\ )
1603           (elmo-imap4-forward)
1604           (push (elmo-imap4-parse-body-extension) b-e))
1605         (assert (eq (char-after (point)) ?\)))
1606         (elmo-imap4-forward)
1607         (nreverse b-e))
1608     (or (elmo-imap4-parse-number)
1609         (elmo-imap4-parse-nstring))))
1610
1611 (defsubst elmo-imap4-parse-body-ext ()
1612   (let (ext)
1613     (when (eq (char-after (point)) ?\ );; body-fld-dsp
1614       (elmo-imap4-forward)
1615       (let (dsp)
1616         (if (eq (char-after (point)) ?\()
1617             (progn
1618               (elmo-imap4-forward)
1619               (push (elmo-imap4-parse-string) dsp)
1620               (elmo-imap4-forward)
1621               (push (elmo-imap4-parse-string-list) dsp)
1622               (elmo-imap4-forward))
1623           (assert (elmo-imap4-parse-nil)))
1624         (push (nreverse dsp) ext))
1625       (when (eq (char-after (point)) ?\ );; body-fld-lang
1626         (elmo-imap4-forward)
1627         (if (eq (char-after (point)) ?\()
1628             (push (elmo-imap4-parse-string-list) ext)
1629           (push (elmo-imap4-parse-nstring) ext))
1630         (while (eq (char-after (point)) ?\ );; body-extension
1631           (elmo-imap4-forward)
1632           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
1633     ext))
1634
1635 (defun elmo-imap4-parse-body ()
1636   (let (body)
1637     (when (eq (char-after (point)) ?\()
1638       (elmo-imap4-forward)
1639       (if (eq (char-after (point)) ?\()
1640           (let (subbody)
1641             (while (and (eq (char-after (point)) ?\()
1642                         (setq subbody (elmo-imap4-parse-body)))
1643               (push subbody body))
1644             (elmo-imap4-forward)
1645             (push (elmo-imap4-parse-string) body);; media-subtype
1646             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
1647               (elmo-imap4-forward)
1648               (if (eq (char-after (point)) ?\();; body-fld-param
1649                   (push (elmo-imap4-parse-string-list) body)
1650                 (push (and (elmo-imap4-parse-nil) nil) body))
1651               (setq body
1652                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
1653             (assert (eq (char-after (point)) ?\)))
1654             (elmo-imap4-forward)
1655             (nreverse body))
1656
1657         (push (elmo-imap4-parse-string) body);; media-type
1658         (elmo-imap4-forward)
1659         (push (elmo-imap4-parse-string) body);; media-subtype
1660         (elmo-imap4-forward)
1661         ;; next line for Sun SIMS bug
1662         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
1663         (if (eq (char-after (point)) ?\();; body-fld-param
1664             (push (elmo-imap4-parse-string-list) body)
1665           (push (and (elmo-imap4-parse-nil) nil) body))
1666         (elmo-imap4-forward)
1667         (push (elmo-imap4-parse-nstring) body);; body-fld-id
1668         (elmo-imap4-forward)
1669         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
1670         (elmo-imap4-forward)
1671         (push (elmo-imap4-parse-string) body);; body-fld-enc
1672         (elmo-imap4-forward)
1673         (push (elmo-imap4-parse-number) body);; body-fld-octets
1674
1675         ;; ok, we're done parsing the required parts, what comes now is one
1676         ;; of three things:
1677         ;;
1678         ;; envelope       (then we're parsing body-type-msg)
1679         ;; body-fld-lines (then we're parsing body-type-text)
1680         ;; body-ext-1part (then we're parsing body-type-basic)
1681         ;;
1682         ;; the problem is that the two first are in turn optionally followed
1683         ;; by the third.  So we parse the first two here (if there are any)...
1684
1685         (when (eq (char-after (point)) ?\ )
1686           (elmo-imap4-forward)
1687           (let (lines)
1688             (cond ((eq (char-after (point)) ?\();; body-type-msg:
1689                    (push (elmo-imap4-parse-envelope) body);; envelope
1690                    (elmo-imap4-forward)
1691                    (push (elmo-imap4-parse-body) body);; body
1692                    (elmo-imap4-forward)
1693                    (push (elmo-imap4-parse-number) body));; body-fld-lines
1694                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
1695                    (push lines body));; body-fld-lines
1696                   (t
1697                    (backward-char)))));; no match...
1698
1699         ;; ...and then parse the third one here...
1700
1701         (when (eq (char-after (point)) ?\ );; body-ext-1part:
1702           (elmo-imap4-forward)
1703           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
1704           (setq body
1705                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
1706
1707         (assert (eq (char-after (point)) ?\)))
1708         (elmo-imap4-forward)
1709         (nreverse body)))))
1710
1711 (luna-define-method elmo-folder-initialize :around ((folder
1712                                                      elmo-imap4-folder)
1713                                                     name)
1714   (let ((default-user        elmo-imap4-default-user)
1715         (default-server      elmo-imap4-default-server)
1716         (default-port        elmo-imap4-default-port)
1717         (elmo-network-stream-type-alist
1718          (if elmo-imap4-stream-type-alist
1719              (append elmo-imap4-stream-type-alist
1720                      elmo-network-stream-type-alist)
1721            elmo-network-stream-type-alist)))
1722     (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
1723       ;; case: imap4-default-server is specified like
1724       ;; "hoge%imap.server@gateway".
1725       (setq default-user (elmo-match-string 1 default-server))
1726       (setq default-server (elmo-match-string 2 default-server)))
1727     (setq name (luna-call-next-method))
1728     (when (string-match
1729            "^\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
1730            name)
1731       (progn
1732         (if (match-beginning 1)
1733             (progn
1734               (elmo-imap4-folder-set-mailbox-internal
1735                folder
1736                (elmo-match-string 1 name))
1737               (if (eq (length (elmo-imap4-folder-mailbox-internal folder))
1738                       0)
1739                   ;; No information is specified other than folder type.
1740                   (elmo-imap4-folder-set-mailbox-internal
1741                    folder
1742                    elmo-imap4-default-mailbox)))
1743           (elmo-imap4-folder-set-mailbox-internal
1744            folder
1745            elmo-imap4-default-mailbox))
1746         ;; Setup slots for elmo-net-folder.
1747         (elmo-net-folder-set-user-internal
1748          folder
1749          (if (match-beginning 2)
1750              (elmo-match-substring 2 name 1)
1751            default-user))
1752         (elmo-net-folder-set-auth-internal
1753          folder
1754          (if (match-beginning 3)
1755              (intern (elmo-match-substring 3 name 1))
1756            (or elmo-imap4-default-authenticate-type 'clear)))
1757         (unless (elmo-net-folder-server-internal folder)
1758           (elmo-net-folder-set-server-internal folder default-server))
1759         (unless (elmo-net-folder-port-internal folder)
1760           (elmo-net-folder-set-port-internal folder default-port))
1761         (unless (elmo-net-folder-stream-type-internal folder)
1762           (elmo-net-folder-set-stream-type-internal
1763            folder
1764            (elmo-get-network-stream-type
1765             elmo-imap4-default-stream-type)))
1766         folder))))
1767
1768 ;;; ELMO IMAP4 folder
1769 (luna-define-method elmo-folder-expand-msgdb-path ((folder
1770                                                     elmo-imap4-folder))
1771   (convert-standard-filename
1772    (let ((mailbox (elmo-imap4-folder-mailbox-internal folder)))
1773      (if (string= "inbox" (downcase mailbox))
1774          (setq mailbox "inbox"))
1775      (if (eq (string-to-char mailbox) ?/)
1776          (setq mailbox (substring mailbox 1 (length mailbox))))
1777      (expand-file-name
1778       mailbox
1779       (expand-file-name
1780        (or (elmo-net-folder-user-internal folder) "nobody")
1781        (expand-file-name (or (elmo-net-folder-server-internal folder)
1782                              "nowhere")
1783                          (expand-file-name
1784                           "imap"
1785                           elmo-msgdb-dir)))))))
1786
1787 (luna-define-method elmo-folder-status-plugged ((folder
1788                                                  elmo-imap4-folder))
1789   (elmo-imap4-folder-status-plugged folder))
1790
1791 (defun elmo-imap4-folder-status-plugged (folder)
1792   (let ((session (elmo-imap4-get-session folder))
1793         (killed (elmo-msgdb-killed-list-load
1794                  (elmo-folder-msgdb-path folder)))
1795         status)
1796     (with-current-buffer (elmo-network-session-buffer session)
1797       (setq elmo-imap4-status-callback nil)
1798       (setq elmo-imap4-status-callback-data nil))
1799     (setq status (elmo-imap4-response-value
1800                   (elmo-imap4-send-command-wait
1801                    session
1802                    (list "status "
1803                          (elmo-imap4-mailbox
1804                           (elmo-imap4-folder-mailbox-internal folder))
1805                          " (uidnext messages)"))
1806                   'status))
1807     (cons
1808      (- (elmo-imap4-response-value status 'uidnext) 1)
1809      (if killed
1810          (-
1811           (elmo-imap4-response-value status 'messages)
1812           (elmo-msgdb-killed-list-length killed))
1813        (elmo-imap4-response-value status 'messages)))))
1814
1815 (luna-define-method elmo-folder-list-messages-plugged ((folder
1816                                                         elmo-imap4-folder)
1817                                                        &optional nohide)
1818   (elmo-imap4-list folder
1819                    (let ((max (elmo-msgdb-max-of-killed
1820                                (elmo-folder-killed-list-internal folder))))
1821                      (if (or nohide
1822                              (null (eq max 0)))
1823                          (format "uid %d:*" (1+ max))
1824                        "all"))))
1825
1826 (luna-define-method elmo-folder-list-unreads-plugged
1827   ((folder elmo-imap4-folder))
1828   (elmo-imap4-list folder "unseen"))
1829
1830 (luna-define-method elmo-folder-list-importants-plugged
1831   ((folder elmo-imap4-folder))
1832   (elmo-imap4-list folder "flagged"))
1833
1834 (luna-define-method elmo-folder-use-flag-p ((folder elmo-imap4-folder))
1835   (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
1836                      (elmo-imap4-folder-mailbox-internal folder))))
1837
1838 (luna-define-method elmo-folder-list-subfolders ((folder elmo-imap4-folder)
1839                                                  &optional one-level)
1840   (let* ((root (elmo-imap4-folder-mailbox-internal folder))
1841          (session (elmo-imap4-get-session folder))
1842          (prefix (elmo-folder-prefix-internal folder))
1843          (delim (or
1844                  (cdr
1845                   (elmo-string-matched-assoc
1846                    root
1847                    (with-current-buffer (elmo-network-session-buffer session)
1848                      elmo-imap4-server-namespace)))
1849                  elmo-imap4-default-hierarchy-delimiter))
1850          result append-serv type)
1851     ;; Append delimiter
1852     (if (and root
1853              (not (string= root ""))
1854              (not (string-match (concat "\\(.*\\)"
1855                                         (regexp-quote delim)
1856                                         "\\'")
1857                                 root)))
1858         (setq root (concat root delim)))
1859     (setq result (elmo-imap4-response-get-selectable-mailbox-list
1860                   (elmo-imap4-send-command-wait
1861                    session
1862                    (list "list " (elmo-imap4-mailbox root) " *"))))
1863     (unless (string= (elmo-net-folder-user-internal folder)
1864                      elmo-imap4-default-user)
1865       (setq append-serv (concat ":" (elmo-net-folder-user-internal folder))))
1866     (unless (eq (elmo-net-folder-auth-internal folder)
1867                 (or elmo-imap4-default-authenticate-type 'clear))
1868       (setq append-serv
1869             (concat append-serv "/"
1870                     (symbol-name (elmo-net-folder-auth-internal folder)))))
1871     (unless (string= (elmo-net-folder-server-internal folder)
1872                      elmo-imap4-default-server)
1873       (setq append-serv (concat append-serv "@"
1874                                 (elmo-net-folder-server-internal folder))))
1875     (unless (eq (elmo-net-folder-port-internal folder) elmo-imap4-default-port)
1876       (setq append-serv (concat append-serv ":"
1877                                 (int-to-string
1878                                  (elmo-net-folder-port-internal folder)))))
1879     (setq type (elmo-net-folder-stream-type-internal folder))
1880     (unless (eq (elmo-network-stream-type-symbol type)
1881                 elmo-imap4-default-stream-type)
1882       (if type
1883           (setq append-serv (concat append-serv
1884                                     (elmo-network-stream-type-spec-string
1885                                      type)))))
1886     (if one-level
1887         (let (folder folders ret)
1888           (while (setq folders (car result))
1889             (if (prog1
1890                     (string-match
1891                      (concat "^\\(" root "[^" delim "]" "+\\)" delim)
1892                           folders)
1893                   (setq folder (match-string 1 folders)))
1894                 (progn
1895                   (setq ret
1896                         (append ret
1897                                 (list
1898                                  (list
1899                                   (concat
1900                                    prefix
1901                                    (elmo-imap4-decode-folder-string folder)
1902                                    (and append-serv
1903                                         (eval append-serv)))))))
1904                   (setq result
1905                         (delq
1906                          nil
1907                          (mapcar '(lambda (fld)
1908                                     (unless
1909                                         (string-match
1910                                          (concat "^" (regexp-quote folder) delim)
1911                                          fld)
1912                                       fld))
1913                                  result))))
1914               (setq ret (append
1915                          ret
1916                          (list
1917                           (concat prefix
1918                                   (elmo-imap4-decode-folder-string folders)
1919                                   (and append-serv
1920                                        (eval append-serv))))))
1921               (setq result (cdr result))))
1922           ret)
1923       (mapcar (lambda (fld)
1924                 (concat prefix (elmo-imap4-decode-folder-string fld)
1925                         (and append-serv
1926                              (eval append-serv))))
1927               result))))
1928
1929 (luna-define-method elmo-folder-exists-p-plugged ((folder elmo-imap4-folder))
1930   (let ((session (elmo-imap4-get-session folder)))
1931     (if (string=
1932          (elmo-imap4-session-current-mailbox-internal session)
1933          (elmo-imap4-folder-mailbox-internal folder))
1934         t
1935       (elmo-imap4-session-select-mailbox
1936        session
1937        (elmo-imap4-folder-mailbox-internal folder)
1938        'force 'no-error))))
1939
1940 (luna-define-method elmo-folder-delete ((folder elmo-imap4-folder))
1941   (let ((session (elmo-imap4-get-session folder))
1942         msgs)
1943     (when (elmo-imap4-folder-mailbox-internal folder)
1944       (when (setq msgs (elmo-folder-list-messages folder))
1945         (elmo-folder-delete-messages folder msgs))
1946       (elmo-imap4-send-command-wait session "close")
1947       (elmo-imap4-send-command-wait
1948        session
1949        (list "delete "
1950              (elmo-imap4-mailbox
1951               (elmo-imap4-folder-mailbox-internal folder)))))))
1952
1953 (luna-define-method elmo-folder-rename-internal ((folder elmo-imap4-folder)
1954                                                  new-folder)
1955   (let ((session (elmo-imap4-get-session folder)))
1956     ;; make sure the folder is selected.
1957     (elmo-imap4-session-select-mailbox session
1958                                        (elmo-imap4-folder-mailbox-internal
1959                                         folder))
1960     (elmo-imap4-send-command-wait session "close")
1961     (elmo-imap4-send-command-wait
1962      session
1963      (list "rename "
1964            (elmo-imap4-mailbox
1965             (elmo-imap4-folder-mailbox-internal folder))
1966            " "
1967            (elmo-imap4-mailbox
1968             (elmo-imap4-folder-mailbox-internal new-folder))))))
1969
1970 (defun elmo-imap4-copy-messages (src-folder dst-folder numbers)
1971   (let ((session (elmo-imap4-get-session src-folder))
1972         (set-list (elmo-imap4-make-number-set-list numbers)))
1973     (elmo-imap4-session-select-mailbox session
1974                                        (elmo-imap4-folder-mailbox-internal
1975                                         src-folder))
1976     (when set-list
1977       (if (elmo-imap4-send-command-wait session
1978                                         (list
1979                                          (format
1980                                           (if elmo-imap4-use-uid
1981                                               "uid copy %s "
1982                                             "copy %s ")
1983                                           (cdr (car set-list)))
1984                                          (elmo-imap4-mailbox
1985                                           (elmo-imap4-folder-mailbox-internal
1986                                            dst-folder))))
1987           numbers))))
1988
1989 (defun elmo-imap4-set-flag (folder numbers flag &optional remove)
1990   "Set flag on messages.
1991 FOLDER is the ELMO folder structure.
1992 NUMBERS is the message numbers to be flagged.
1993 FLAG is the flag name.
1994 If optional argument REMOVE is non-nil, remove FLAG."
1995   (let ((session (elmo-imap4-get-session folder))
1996         set-list)
1997     (elmo-imap4-session-select-mailbox session
1998                                        (elmo-imap4-folder-mailbox-internal
1999                                         folder))
2000     (setq set-list (elmo-imap4-make-number-set-list numbers))
2001     (when set-list
2002       (with-current-buffer (elmo-network-session-buffer session)
2003         (setq elmo-imap4-fetch-callback nil)
2004         (setq elmo-imap4-fetch-callback-data nil))
2005       (elmo-imap4-send-command-wait
2006        session
2007        (format
2008         (if elmo-imap4-use-uid
2009             "uid store %s %sflags.silent (%s)"
2010           "store %s %sflags.silent (%s)")
2011         (cdr (car set-list))
2012         (if remove "-" "+")
2013         flag)))))
2014
2015 (luna-define-method elmo-folder-delete-messages-plugged
2016   ((folder elmo-imap4-folder) numbers)
2017   (let ((session (elmo-imap4-get-session folder)))
2018     (elmo-imap4-set-flag folder numbers "\\Deleted")
2019     (elmo-imap4-send-command-wait session "expunge")))
2020
2021 (defmacro elmo-imap4-detect-search-charset (string)
2022   (` (with-temp-buffer
2023        (insert (, string))
2024        (detect-mime-charset-region (point-min) (point-max)))))
2025
2026 (defun elmo-imap4-search-internal-primitive (folder session filter from-msgs)
2027   (let ((search-key (elmo-filter-key filter))
2028         (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"))
2029         charset)
2030     (cond
2031      ((string= "last" search-key)
2032       (let ((numbers (or from-msgs (elmo-folder-list-messages folder))))
2033         (nthcdr (max (- (length numbers)
2034                         (string-to-int (elmo-filter-value filter)))
2035                      0)
2036                 numbers)))
2037      ((string= "first" search-key)
2038       (let* ((numbers (or from-msgs (elmo-folder-list-messages folder)))
2039              (rest (nthcdr (string-to-int (elmo-filter-value filter) )
2040                            numbers)))
2041         (mapcar '(lambda (x) (delete x numbers)) rest)
2042         numbers))
2043      ((or (string= "since" search-key)
2044           (string= "before" search-key))
2045       (setq search-key (concat "sent" search-key))
2046       (elmo-imap4-response-value
2047        (elmo-imap4-send-command-wait session
2048                                      (format
2049                                       (if elmo-imap4-use-uid
2050                                           "uid search %s%s%s %s"
2051                                         "search %s%s%s %s")
2052                                       (if from-msgs
2053                                           (concat
2054                                            (if elmo-imap4-use-uid "uid ")
2055                                            (cdr
2056                                             (car
2057                                              (elmo-imap4-make-number-set-list
2058                                               from-msgs)))
2059                                            " ")
2060                                         "")
2061                                       (if (eq (elmo-filter-type filter)
2062                                               'unmatch)
2063                                           "not " "")
2064                                       search-key
2065                                       (elmo-date-get-description
2066                                        (elmo-date-get-datevec
2067                                         (elmo-filter-value filter)))))
2068        'search))
2069      (t
2070       (setq charset
2071             (if (eq (length (elmo-filter-value filter)) 0)
2072                 (setq charset 'us-ascii)
2073               (elmo-imap4-detect-search-charset
2074                (elmo-filter-value filter))))
2075       (elmo-imap4-response-value
2076        (elmo-imap4-send-command-wait session
2077                                      (list
2078                                       (if elmo-imap4-use-uid "uid ")
2079                                       "search "
2080                                       "CHARSET "
2081                                       (elmo-imap4-astring
2082                                        (symbol-name charset))
2083                                       " "
2084                                       (if from-msgs
2085                                           (concat
2086                                            (if elmo-imap4-use-uid "uid ")
2087                                            (cdr
2088                                             (car
2089                                              (elmo-imap4-make-number-set-list
2090                                               from-msgs)))
2091                                            " ")
2092                                         "")
2093                                       (if (eq (elmo-filter-type filter)
2094                                               'unmatch)
2095                                           "not " "")
2096                                       (format "%s%s "
2097                                               (if (member
2098                                                    (elmo-filter-key filter)
2099                                                    imap-search-keys)
2100                                                   ""
2101                                                 "header ")
2102                                               (elmo-filter-key filter))
2103                                       (elmo-imap4-astring
2104                                        (encode-mime-charset-string
2105                                         (elmo-filter-value filter) charset))))
2106        'search)))))
2107
2108 (defun elmo-imap4-search-internal (folder session condition from-msgs)
2109   (let (result)
2110     (cond
2111      ((vectorp condition)
2112       (setq result (elmo-imap4-search-internal-primitive
2113                     folder session condition from-msgs)))
2114      ((eq (car condition) 'and)
2115       (setq result (elmo-imap4-search-internal folder session (nth 1 condition)
2116                                                from-msgs)
2117             result (elmo-list-filter result
2118                                      (elmo-imap4-search-internal
2119                                       folder session (nth 2 condition)
2120                                       from-msgs))))
2121      ((eq (car condition) 'or)
2122       (setq result (elmo-imap4-search-internal
2123                     folder session (nth 1 condition) from-msgs)
2124             result (elmo-uniq-list
2125                     (nconc result
2126                            (elmo-imap4-search-internal
2127                             folder session (nth 2 condition) from-msgs)))
2128             result (sort result '<))))))
2129
2130 (luna-define-method elmo-folder-search ((folder elmo-imap4-folder)
2131                                         condition &optional numbers)
2132   (save-excursion
2133     (let ((session (elmo-imap4-get-session folder)))
2134       (elmo-imap4-session-select-mailbox
2135        session
2136        (elmo-imap4-folder-mailbox-internal folder))
2137       (elmo-imap4-search-internal folder session condition numbers))))
2138
2139 (luna-define-method elmo-folder-msgdb-create-plugged
2140   ((folder elmo-imap4-folder) numbers &rest args)
2141   (when numbers
2142     (let ((session (elmo-imap4-get-session folder))
2143           (headers
2144            (append
2145             '("Subject" "From" "To" "Cc" "Date"
2146               "Message-Id" "References" "In-Reply-To")
2147             elmo-msgdb-extra-fields))
2148           (total 0)
2149           (length (length numbers))
2150           rfc2060 set-list)
2151       (setq rfc2060 (memq 'imap4rev1
2152                           (elmo-imap4-session-capability-internal
2153                            session)))
2154       (message "Getting overview...")
2155       (elmo-imap4-session-select-mailbox
2156        session (elmo-imap4-folder-mailbox-internal folder))
2157       (setq set-list (elmo-imap4-make-number-set-list
2158                       numbers
2159                       elmo-imap4-overview-fetch-chop-length))
2160       ;; Setup callback.
2161       (with-current-buffer (elmo-network-session-buffer session)
2162         (setq elmo-imap4-current-msgdb nil
2163               elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
2164               elmo-imap4-fetch-callback-data (cons args
2165                                                    (elmo-folder-use-flag-p
2166                                                     folder)))
2167         (while set-list
2168           (elmo-imap4-send-command-wait
2169            session
2170            ;; get overview entity from IMAP4
2171            (format "%sfetch %s (%s rfc822.size flags)"
2172                    (if elmo-imap4-use-uid "uid " "")
2173                    (cdr (car set-list))
2174                    (if rfc2060
2175                        (format "body.peek[header.fields %s]" headers)
2176                      (format "%s" headers))))
2177           (when (> length elmo-display-progress-threshold)
2178             (setq total (+ total (car (car set-list))))
2179             (elmo-display-progress
2180              'elmo-imap4-msgdb-create "Getting overview..."
2181              (/ (* total 100) length)))
2182           (setq set-list (cdr set-list)))
2183         (message "Getting overview...done")
2184         elmo-imap4-current-msgdb))))
2185
2186 (luna-define-method elmo-folder-unmark-important-plugged
2187   ((folder elmo-imap4-folder) numbers)
2188   (elmo-imap4-set-flag folder numbers "\\Flagged" 'remove))
2189
2190 (luna-define-method elmo-folder-mark-as-important-plugged
2191   ((folder elmo-imap4-folder) numbers)
2192   (elmo-imap4-set-flag folder numbers "\\Flagged"))
2193
2194 (luna-define-method elmo-folder-unmark-read-plugged
2195   ((folder elmo-imap4-folder) numbers)
2196   (elmo-imap4-set-flag folder numbers "\\Seen" 'remove))
2197
2198 (luna-define-method elmo-folder-mark-as-read-plugged
2199   ((folder elmo-imap4-folder) numbers)
2200   (elmo-imap4-set-flag folder numbers "\\Seen"))
2201
2202 (luna-define-method elmo-message-use-cache-p ((folder elmo-imap4-folder)
2203                                               number)
2204   elmo-imap4-use-cache)
2205
2206 (luna-define-method elmo-folder-message-appendable-p ((folder elmo-imap4-folder))
2207   (if (elmo-folder-plugged-p folder)
2208       (not (elmo-imap4-session-read-only-internal
2209             (elmo-imap4-get-session folder)))
2210     elmo-enable-disconnected-operation)) ; offline refile.
2211
2212 (luna-define-method elmo-folder-check-plugged ((folder elmo-imap4-folder))
2213   (let ((session (elmo-imap4-get-session folder 'if-exists)))
2214     (when session
2215       (if (string=
2216            (elmo-imap4-session-current-mailbox-internal session)
2217            (elmo-imap4-folder-mailbox-internal folder))
2218           (if elmo-imap4-use-select-to-update-status
2219               (elmo-imap4-session-select-mailbox
2220                session
2221                (elmo-imap4-folder-mailbox-internal folder)
2222                'force)
2223             (elmo-imap4-session-check session))))))
2224
2225 (defsubst elmo-imap4-folder-diff-plugged (folder)
2226   (let ((session (elmo-imap4-get-session folder))
2227         messages
2228         response killed)
2229 ;;; (elmo-imap4-commit spec)
2230     (with-current-buffer (elmo-network-session-buffer session)
2231       (setq elmo-imap4-status-callback nil)
2232       (setq elmo-imap4-status-callback-data nil))
2233     (setq response
2234           (elmo-imap4-send-command-wait session
2235                                         (list
2236                                          "status "
2237                                          (elmo-imap4-mailbox
2238                                           (elmo-imap4-folder-mailbox-internal
2239                                            folder))
2240                                          " (unseen messages)")))
2241     (setq response (elmo-imap4-response-value response 'status))
2242     (setq messages (elmo-imap4-response-value response 'messages))
2243     (setq killed (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2244     (if killed
2245         (setq messages (- messages
2246                           (elmo-msgdb-killed-list-length
2247                            killed))))
2248     (cons (elmo-imap4-response-value response 'unseen)
2249           messages)))
2250
2251 (luna-define-method elmo-folder-diff-plugged ((folder elmo-imap4-folder))
2252   (elmo-imap4-folder-diff-plugged folder))
2253
2254 (luna-define-method elmo-folder-diff-async ((folder elmo-imap4-folder)
2255                                             &optional number-alist)
2256   (setq elmo-imap4-server-diff-async-callback
2257         elmo-folder-diff-async-callback)
2258   (setq elmo-imap4-server-diff-async-callback-data
2259         elmo-folder-diff-async-callback-data)
2260   (elmo-imap4-server-diff-async folder))
2261
2262 (luna-define-method elmo-folder-open :around ((folder elmo-imap4-folder)
2263                                               &optional load-msgdb)
2264   (if (elmo-folder-plugged-p folder)
2265       (let (session mailbox msgdb response tag)
2266         (condition-case err
2267             (progn
2268               (setq session (elmo-imap4-get-session folder)
2269                     mailbox (elmo-imap4-folder-mailbox-internal folder)
2270                     tag (elmo-imap4-send-command session
2271                                                  (list "select "
2272                                                        (elmo-imap4-mailbox
2273                                                         mailbox))))
2274               (if load-msgdb
2275                   (setq msgdb (elmo-msgdb-load folder)))
2276               (elmo-folder-set-killed-list-internal
2277                folder
2278                (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2279               (setq response (elmo-imap4-read-response session tag)))
2280           (quit
2281            (if response
2282                (elmo-imap4-session-set-current-mailbox-internal
2283                 session mailbox)
2284              (and session
2285                   (elmo-imap4-session-set-current-mailbox-internal
2286                    session nil))))
2287           (error
2288            (if response
2289                (elmo-imap4-session-set-current-mailbox-internal
2290                 session mailbox)
2291              (and session
2292                   (elmo-imap4-session-set-current-mailbox-internal
2293                    session nil)))))
2294         (if load-msgdb
2295             (elmo-folder-set-msgdb-internal
2296              folder
2297              (or msgdb (elmo-msgdb-load folder)))))
2298     (luna-call-next-method)))
2299
2300 ;; elmo-folder-open-internal: do nothing.
2301
2302 (luna-define-method elmo-find-fetch-strategy
2303   ((folder elmo-imap4-folder) entity &optional ignore-cache)
2304   (let ((number (elmo-msgdb-overview-entity-get-number entity))
2305         cache-file size message-id)
2306     (setq size (elmo-msgdb-overview-entity-get-size entity))
2307     (setq message-id (elmo-msgdb-overview-entity-get-id entity))
2308     (setq cache-file (elmo-file-cache-get message-id))
2309     (if (or ignore-cache
2310             (null (elmo-file-cache-status cache-file)))
2311         (if (and elmo-message-fetch-threshold
2312                  (integerp size)
2313                  (>= size elmo-message-fetch-threshold)
2314                  (or (not elmo-message-fetch-confirm)
2315                      (not (prog1 (y-or-n-p
2316                                   (format
2317                                    "Fetch entire message at once? (%dbytes)"
2318                                    size))
2319                             (message "")))))
2320             ;; Fetch message as imap message.
2321             (elmo-make-fetch-strategy 'section
2322                                       nil
2323                                       (elmo-message-use-cache-p
2324                                        folder number)
2325                                       (elmo-file-cache-path
2326                                        cache-file))
2327           ;; Don't use existing cache and fetch entire message at once.
2328           (elmo-make-fetch-strategy 'entire nil
2329                                     (elmo-message-use-cache-p
2330                                      folder number)
2331                                     (elmo-file-cache-path cache-file)))
2332       ;; Cache found and use it.
2333       (if (not ignore-cache)
2334           (if (eq (elmo-file-cache-status cache-file) 'section)
2335               ;; Fetch message with imap message.
2336               (elmo-make-fetch-strategy 'section
2337                                         t
2338                                         (elmo-message-use-cache-p
2339                                          folder number)
2340                                         (elmo-file-cache-path
2341                                          cache-file))
2342             (elmo-make-fetch-strategy 'entire
2343                                       t
2344                                       (elmo-message-use-cache-p
2345                                        folder number)
2346                                       (elmo-file-cache-path
2347                                        cache-file)))))))
2348
2349 (luna-define-method elmo-folder-create ((folder elmo-imap4-folder))
2350   (elmo-imap4-send-command-wait
2351    (elmo-imap4-get-session folder)
2352    (list "create "
2353          (elmo-imap4-mailbox
2354           (elmo-imap4-folder-mailbox-internal folder)))))
2355
2356 (luna-define-method elmo-folder-append-buffer
2357   ((folder elmo-imap4-folder) unread &optional number)
2358   (if (elmo-folder-plugged-p folder)
2359       (let ((session (elmo-imap4-get-session folder))
2360             send-buffer result)
2361         (elmo-imap4-session-select-mailbox session
2362                                            (elmo-imap4-folder-mailbox-internal
2363                                             folder))
2364         (setq send-buffer (elmo-imap4-setup-send-buffer))
2365         (unwind-protect
2366             (setq result
2367                   (elmo-imap4-send-command-wait
2368                    session
2369                    (list
2370                     "append "
2371                     (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal
2372                                          folder))
2373                     (if unread " " " (\\Seen) ")
2374                     (elmo-imap4-buffer-literal send-buffer))))
2375           (kill-buffer send-buffer))
2376         result)
2377     ;; Unplugged
2378     (if elmo-enable-disconnected-operation
2379         (elmo-folder-append-buffer-dop folder unread number)
2380       (error "Unplugged"))))
2381
2382 (eval-when-compile
2383   (defmacro elmo-imap4-identical-system-p (folder1 folder2)
2384     "Return t if FOLDER1 and FOLDER2 are in the same IMAP4 system."
2385     (` (and (string= (elmo-net-folder-server-internal (, folder1))
2386                      (elmo-net-folder-server-internal (, folder2)))
2387             (eq (elmo-net-folder-port-internal (, folder1))
2388                 (elmo-net-folder-port-internal (, folder2)))
2389             (string= (elmo-net-folder-user-internal (, folder1))
2390                      (elmo-net-folder-user-internal (, folder2)))))))
2391
2392 (luna-define-method elmo-folder-append-messages :around
2393   ((folder elmo-imap4-folder) src-folder numbers unread-marks
2394    &optional same-number)
2395   (if (and (eq (elmo-folder-type-internal src-folder) 'imap4)
2396            (elmo-imap4-identical-system-p folder src-folder)
2397            (elmo-folder-plugged-p folder))
2398       ;; Plugged
2399       (elmo-imap4-copy-messages src-folder folder numbers)
2400     (luna-call-next-method)))
2401
2402 (luna-define-method elmo-message-deletable-p ((folder elmo-imap4-folder)
2403                                               number)
2404   (if (elmo-folder-plugged-p folder)
2405       (not (elmo-imap4-session-read-only-internal
2406             (elmo-imap4-get-session folder)))
2407     elmo-enable-disconnected-operation)) ; offline refile.
2408
2409 ;(luna-define-method elmo-message-fetch-unplugged
2410 ;  ((folder elmo-imap4-folder)
2411 ;   number strategy  &optional section outbuf unseen)
2412 ;  (error "%d%s is not cached." number (if section
2413 ;                                         (format "(%s)" section)
2414 ;                                       "")))
2415
2416 (defsubst elmo-imap4-message-fetch (folder number strategy
2417                                            section outbuf unseen)
2418   (let ((session (elmo-imap4-get-session folder))
2419         response)
2420     (elmo-imap4-session-select-mailbox session
2421                                        (elmo-imap4-folder-mailbox-internal
2422                                         folder))
2423     (with-current-buffer (elmo-network-session-buffer session)
2424       (setq elmo-imap4-fetch-callback nil)
2425       (setq elmo-imap4-fetch-callback-data nil))
2426     (unless elmo-inhibit-display-retrieval-progress
2427       (setq elmo-imap4-display-literal-progress t))
2428     (unwind-protect
2429         (setq response
2430               (elmo-imap4-send-command-wait session
2431                                             (format
2432                                              (if elmo-imap4-use-uid
2433                                                  "uid fetch %s body%s[%s]"
2434                                                "fetch %s body%s[%s]")
2435                                              number
2436                                              (if unseen ".peek" "")
2437                                              (or section "")
2438                                              )))
2439       (setq elmo-imap4-display-literal-progress nil))
2440     (unless elmo-inhibit-display-retrieval-progress
2441       (elmo-display-progress 'elmo-imap4-display-literal-progress
2442                              "" 100)  ; remove progress bar.
2443       (message "Retrieving...done."))
2444     (if (setq response (elmo-imap4-response-bodydetail-text
2445                         (elmo-imap4-response-value-all
2446                          response 'fetch)))
2447         (with-current-buffer outbuf
2448           (erase-buffer)
2449           (insert response)))))
2450
2451 (luna-define-method elmo-message-fetch-plugged ((folder elmo-imap4-folder)
2452                                                 number strategy
2453                                                 &optional section
2454                                                 outbuf unseen)
2455   (elmo-imap4-message-fetch folder number strategy section outbuf unseen))
2456
2457 (luna-define-method elmo-message-fetch-field ((folder elmo-imap4-folder)
2458                                               number field)
2459   (let ((session (elmo-imap4-get-session folder)))
2460     (elmo-imap4-session-select-mailbox session
2461                                        (elmo-imap4-folder-mailbox-internal
2462                                         folder))
2463     (with-current-buffer (elmo-network-session-buffer session)
2464       (setq elmo-imap4-fetch-callback nil)
2465       (setq elmo-imap4-fetch-callback-data nil))
2466     (with-temp-buffer
2467       (insert
2468        (elmo-imap4-response-bodydetail-text
2469         (elmo-imap4-response-value
2470          (elmo-imap4-send-command-wait session
2471                                        (concat
2472                                         (if elmo-imap4-use-uid
2473                                             "uid ")
2474                                         (format
2475                                          "fetch %s (body.peek[header.fields (%s)])"
2476                                          number field)))
2477          'fetch)))
2478       (elmo-delete-cr-buffer)
2479       (goto-char (point-min))
2480       (std11-field-body (symbol-name field)))))
2481
2482
2483
2484 (require 'product)
2485 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2486
2487 ;;; elmo-imap4.el ends here