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