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