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 ;; Current buffer is process buffer.
 793 (defun elmo-imap4-fetch-callback (element app-data)
 794   (funcall elmo-imap4-fetch-callback
 795            (with-temp-buffer
 796              (insert (or (elmo-imap4-response-bodydetail-text element)
 797                          ""))
 798              ;; Delete CR.
 799              (goto-char (point-min))
 800              (while (search-forward "\r\n" nil t)
 801                (replace-match "\n"))
 802              (elmo-msgdb-create-overview-from-buffer
 803               (elmo-imap4-response-value element 'uid)
 804               (elmo-imap4-response-value element 'rfc822size)))
 805            (elmo-imap4-response-value element 'flags)
 806            app-data))
 807
 808 ;;
 809 ;; app-data:
 810 ;; cons of list
 811 ;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark
 812 ;; 4: seen-list
 813 ;; and result of use-flag-p.
 814 (defun elmo-imap4-fetch-callback-1 (entity flags app-data)
 815   "A msgdb entity callback function."
 816   (let* ((use-flag (cdr app-data))
 817          (app-data (car app-data))
 818          (seen (member (car entity) (nth 4 app-data)))
 819          mark)
 820     (if (member "\\Flagged" flags)
 821         (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data)))
 822     (setq mark (or (elmo-msgdb-global-mark-get (car entity))
 823                    (if (elmo-file-cache-status
 824                         (elmo-file-cache-get (car entity)))
 825                        (if (or seen
 826                                (and use-flag
 827                                     (member "\\Seen" flags)))
 828                            nil
 829                          (nth 1 app-data))
 830                      (if (or seen
 831                              (and use-flag
 832                                   (member "\\Seen" flags)))
 833                          (if elmo-imap4-use-cache
 834                              (nth 2 app-data))
 835                        (nth 0 app-data)))))
 836     (setq elmo-imap4-current-msgdb
 837           (elmo-msgdb-append
 838            elmo-imap4-current-msgdb
 839            (list (list entity)
 840                  (list (cons (elmo-msgdb-overview-entity-get-number entity)
 841                              (car entity)))
 842                  (if mark
 843                      (list
 844                       (list (elmo-msgdb-overview-entity-get-number entity)
 845                             mark))))))))
 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            (elmo-imap4-fetch-callback list elmo-imap4-fetch-callback-data))
1496       (list 'fetch list))))
1497
1498 (defun elmo-imap4-parse-status ()
1499   (let ((mailbox (elmo-imap4-parse-mailbox))
1500         status)
1501     (when (and mailbox (search-forward "(" nil t))
1502       (while (not (eq (char-after (point)) ?\)))
1503         (setq status
1504               (cons
1505                (let ((token (elmo-read (current-buffer))))
1506                  (cond ((eq token 'MESSAGES)
1507                         (list 'messages (elmo-read (current-buffer))))
1508                        ((eq token 'RECENT)
1509                         (list 'recent (elmo-read (current-buffer))))
1510                        ((eq token 'UIDNEXT)
1511                         (list 'uidnext (elmo-read (current-buffer))))
1512                        ((eq token 'UIDVALIDITY)
1513                         (and (looking-at " \\([0-9]+\\)")
1514                              (prog1 (list 'uidvalidity (match-string 1))
1515                                (goto-char (match-end 1)))))
1516                        ((eq token 'UNSEEN)
1517                         (list 'unseen (elmo-read (current-buffer))))
1518                        (t
1519                         (message
1520                          "Unknown status data %s in mailbox %s ignored"
1521                          token mailbox))))
1522                status))))
1523     (and elmo-imap4-status-callback
1524          (funcall elmo-imap4-status-callback
1525                   status
1526                   elmo-imap4-status-callback-data))
1527     (list 'status status)))
1528
1529
1530 (defmacro elmo-imap4-value (value)
1531   (` (if (eq (, value) 'NIL) nil
1532        (, value))))
1533
1534 (defmacro elmo-imap4-nth (pos list)
1535   (` (let ((value (nth (, pos) (, list))))
1536        (elmo-imap4-value value))))
1537
1538 (defun elmo-imap4-parse-namespace ()
1539   (list 'namespace
1540         (nconc
1541          (copy-sequence elmo-imap4-extra-namespace-alist)
1542          (elmo-imap4-parse-namespace-subr
1543           (elmo-read (concat "(" (buffer-substring
1544                                   (point) (point-max))
1545                              ")"))))))
1546
1547 (defun elmo-imap4-parse-namespace-subr (ns)
1548   (let (prefix delim namespace-alist default-delim)
1549     ;; 0: personal, 1: other, 2: shared
1550     (dotimes (i 3)
1551       (setq namespace-alist
1552             (nconc namespace-alist
1553                    (delq nil
1554                          (mapcar
1555                           (lambda (namespace)
1556                             (setq prefix (elmo-imap4-nth 0 namespace)
1557                                   delim (elmo-imap4-nth 1 namespace))
1558                             (if (and prefix delim
1559                                      (string-match
1560                                       (concat (regexp-quote delim) "\\'")
1561                                       prefix))
1562                                 (setq prefix (substring prefix 0
1563                                                         (match-beginning 0))))
1564                             (if (eq (length prefix) 0)
1565                                 (progn (setq default-delim delim) nil)
1566                               (cons
1567                                (concat "^"
1568                                        (if (string= (downcase prefix) "inbox")
1569                                            "[Ii][Nn][Bb][Oo][Xx]"
1570                                          (regexp-quote prefix))
1571                                        ".*$")
1572                                delim)))
1573                           (elmo-imap4-nth i ns))))))
1574     (if default-delim
1575         (setq namespace-alist
1576               (nconc namespace-alist
1577                      (list (cons "^.*$" default-delim)))))
1578     namespace-alist))
1579
1580 (defun elmo-imap4-parse-acl ()
1581   (let ((mailbox (elmo-imap4-parse-mailbox))
1582         identifier rights acl)
1583     (while (eq (char-after (point)) ?\ )
1584       (elmo-imap4-forward)
1585       (setq identifier (elmo-imap4-parse-astring))
1586       (elmo-imap4-forward)
1587       (setq rights (elmo-imap4-parse-astring))
1588       (setq acl (append acl (list (cons identifier rights)))))
1589     (list 'acl acl mailbox)))
1590
1591 (defun elmo-imap4-parse-flag-list ()
1592   (let ((str (buffer-substring (+ (point) 1)
1593                                (progn (search-forward ")" nil t)
1594                                       (- (point) 1)))))
1595     (unless (eq (length str) 0)
1596       (split-string str))))
1597
1598 (defun elmo-imap4-parse-envelope ()
1599   (when (eq (char-after (point)) ?\()
1600     (elmo-imap4-forward)
1601     (vector (prog1 (elmo-imap4-parse-nstring);; date
1602               (elmo-imap4-forward))
1603             (prog1 (elmo-imap4-parse-nstring);; subject
1604               (elmo-imap4-forward))
1605             (prog1 (elmo-imap4-parse-address-list);; from
1606               (elmo-imap4-forward))
1607             (prog1 (elmo-imap4-parse-address-list);; sender
1608               (elmo-imap4-forward))
1609             (prog1 (elmo-imap4-parse-address-list);; reply-to
1610               (elmo-imap4-forward))
1611             (prog1 (elmo-imap4-parse-address-list);; to
1612               (elmo-imap4-forward))
1613             (prog1 (elmo-imap4-parse-address-list);; cc
1614               (elmo-imap4-forward))
1615             (prog1 (elmo-imap4-parse-address-list);; bcc
1616               (elmo-imap4-forward))
1617             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
1618               (elmo-imap4-forward))
1619             (prog1 (elmo-imap4-parse-nstring);; message-id
1620               (elmo-imap4-forward)))))
1621
1622 (defsubst elmo-imap4-parse-string-list ()
1623   (cond ((eq (char-after (point)) ?\();; body-fld-param
1624          (let (strlist str)
1625            (elmo-imap4-forward)
1626            (while (setq str (elmo-imap4-parse-string))
1627              (push str strlist)
1628              (elmo-imap4-forward))
1629            (nreverse strlist)))
1630         ((elmo-imap4-parse-nil)
1631          nil)))
1632
1633 (defun elmo-imap4-parse-body-extension ()
1634   (if (eq (char-after (point)) ?\()
1635       (let (b-e)
1636         (elmo-imap4-forward)
1637         (push (elmo-imap4-parse-body-extension) b-e)
1638         (while (eq (char-after (point)) ?\ )
1639           (elmo-imap4-forward)
1640           (push (elmo-imap4-parse-body-extension) b-e))
1641         (assert (eq (char-after (point)) ?\)))
1642         (elmo-imap4-forward)
1643         (nreverse b-e))
1644     (or (elmo-imap4-parse-number)
1645         (elmo-imap4-parse-nstring))))
1646
1647 (defsubst elmo-imap4-parse-body-ext ()
1648   (let (ext)
1649     (when (eq (char-after (point)) ?\ );; body-fld-dsp
1650       (elmo-imap4-forward)
1651       (let (dsp)
1652         (if (eq (char-after (point)) ?\()
1653             (progn
1654               (elmo-imap4-forward)
1655               (push (elmo-imap4-parse-string) dsp)
1656               (elmo-imap4-forward)
1657               (push (elmo-imap4-parse-string-list) dsp)
1658               (elmo-imap4-forward))
1659           (assert (elmo-imap4-parse-nil)))
1660         (push (nreverse dsp) ext))
1661       (when (eq (char-after (point)) ?\ );; body-fld-lang
1662         (elmo-imap4-forward)
1663         (if (eq (char-after (point)) ?\()
1664             (push (elmo-imap4-parse-string-list) ext)
1665           (push (elmo-imap4-parse-nstring) ext))
1666         (while (eq (char-after (point)) ?\ );; body-extension
1667           (elmo-imap4-forward)
1668           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
1669     ext))
1670
1671 (defun elmo-imap4-parse-body ()
1672   (let (body)
1673     (when (eq (char-after (point)) ?\()
1674       (elmo-imap4-forward)
1675       (if (eq (char-after (point)) ?\()
1676           (let (subbody)
1677             (while (and (eq (char-after (point)) ?\()
1678                         (setq subbody (elmo-imap4-parse-body)))
1679               (push subbody body))
1680             (elmo-imap4-forward)
1681             (push (elmo-imap4-parse-string) body);; media-subtype
1682             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
1683               (elmo-imap4-forward)
1684               (if (eq (char-after (point)) ?\();; body-fld-param
1685                   (push (elmo-imap4-parse-string-list) body)
1686                 (push (and (elmo-imap4-parse-nil) nil) body))
1687               (setq body
1688                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
1689             (assert (eq (char-after (point)) ?\)))
1690             (elmo-imap4-forward)
1691             (nreverse body))
1692
1693         (push (elmo-imap4-parse-string) body);; media-type
1694         (elmo-imap4-forward)
1695         (push (elmo-imap4-parse-string) body);; media-subtype
1696         (elmo-imap4-forward)
1697         ;; next line for Sun SIMS bug
1698         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
1699         (if (eq (char-after (point)) ?\();; body-fld-param
1700             (push (elmo-imap4-parse-string-list) body)
1701           (push (and (elmo-imap4-parse-nil) nil) body))
1702         (elmo-imap4-forward)
1703         (push (elmo-imap4-parse-nstring) body);; body-fld-id
1704         (elmo-imap4-forward)
1705         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
1706         (elmo-imap4-forward)
1707         (push (elmo-imap4-parse-string) body);; body-fld-enc
1708         (elmo-imap4-forward)
1709         (push (elmo-imap4-parse-number) body);; body-fld-octets
1710
1711         ;; ok, we're done parsing the required parts, what comes now is one
1712         ;; of three things:
1713         ;;
1714         ;; envelope       (then we're parsing body-type-msg)
1715         ;; body-fld-lines (then we're parsing body-type-text)
1716         ;; body-ext-1part (then we're parsing body-type-basic)
1717         ;;
1718         ;; the problem is that the two first are in turn optionally followed
1719         ;; by the third.  So we parse the first two here (if there are any)...
1720
1721         (when (eq (char-after (point)) ?\ )
1722           (elmo-imap4-forward)
1723           (let (lines)
1724             (cond ((eq (char-after (point)) ?\();; body-type-msg:
1725                    (push (elmo-imap4-parse-envelope) body);; envelope
1726                    (elmo-imap4-forward)
1727                    (push (elmo-imap4-parse-body) body);; body
1728                    (elmo-imap4-forward)
1729                    (push (elmo-imap4-parse-number) body));; body-fld-lines
1730                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
1731                    (push lines body));; body-fld-lines
1732                   (t
1733                    (backward-char)))));; no match...
1734
1735         ;; ...and then parse the third one here...
1736
1737         (when (eq (char-after (point)) ?\ );; body-ext-1part:
1738           (elmo-imap4-forward)
1739           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
1740           (setq body
1741                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
1742
1743         (assert (eq (char-after (point)) ?\)))
1744         (elmo-imap4-forward)
1745         (nreverse body)))))
1746
1747 (luna-define-method elmo-folder-initialize :around ((folder
1748                                                      elmo-imap4-folder)
1749                                                     name)
1750   (let ((default-user        elmo-imap4-default-user)
1751         (default-server      elmo-imap4-default-server)
1752         (default-port        elmo-imap4-default-port)
1753         (elmo-network-stream-type-alist
1754          (if elmo-imap4-stream-type-alist
1755              (append elmo-imap4-stream-type-alist
1756                      elmo-network-stream-type-alist)
1757            elmo-network-stream-type-alist)))
1758     (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
1759       ;; case: imap4-default-server is specified like
1760       ;; "hoge%imap.server@gateway".
1761       (setq default-user (elmo-match-string 1 default-server))
1762       (setq default-server (elmo-match-string 2 default-server)))
1763     (setq name (luna-call-next-method))
1764     (when (string-match
1765            "^\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
1766            name)
1767       (progn
1768         (if (match-beginning 1)
1769             (progn
1770               (elmo-imap4-folder-set-mailbox-internal
1771                folder
1772                (elmo-match-string 1 name))
1773               (if (eq (length (elmo-imap4-folder-mailbox-internal folder))
1774                       0)
1775                   ;; No information is specified other than folder type.
1776                   (elmo-imap4-folder-set-mailbox-internal
1777                    folder
1778                    elmo-imap4-default-mailbox)))
1779           (elmo-imap4-folder-set-mailbox-internal
1780            folder
1781            elmo-imap4-default-mailbox))
1782         ;; Setup slots for elmo-net-folder.
1783         (elmo-net-folder-set-user-internal
1784          folder
1785          (if (match-beginning 2)
1786              (elmo-match-substring 2 name 1)
1787            default-user))
1788         (elmo-net-folder-set-auth-internal
1789          folder
1790          (if (match-beginning 3)
1791              (intern (elmo-match-substring 3 name 1))
1792            elmo-imap4-default-authenticate-type))
1793         (unless (elmo-net-folder-server-internal folder)
1794           (elmo-net-folder-set-server-internal folder default-server))
1795         (unless (elmo-net-folder-port-internal folder)
1796           (elmo-net-folder-set-port-internal folder default-port))
1797         (unless (elmo-net-folder-stream-type-internal folder)
1798           (elmo-net-folder-set-stream-type-internal
1799            folder
1800            elmo-imap4-default-stream-type))
1801         folder))))
1802
1803 ;;; ELMO IMAP4 folder
1804 (luna-define-method elmo-folder-expand-msgdb-path ((folder
1805                                                     elmo-imap4-folder))
1806   (convert-standard-filename
1807    (let ((mailbox (elmo-imap4-folder-mailbox-internal folder)))
1808      (if (string= "inbox" (downcase mailbox))
1809          (setq mailbox "inbox"))
1810      (if (eq (string-to-char mailbox) ?/)
1811          (setq mailbox (substring mailbox 1 (length mailbox))))
1812      (expand-file-name
1813       mailbox
1814       (expand-file-name
1815        (or (elmo-net-folder-user-internal folder) "nobody")
1816        (expand-file-name (or (elmo-net-folder-server-internal folder)
1817                              "nowhere")
1818                          (expand-file-name
1819                           "imap"
1820                           elmo-msgdb-dir)))))))
1821
1822 (luna-define-method elmo-folder-status-plugged ((folder
1823                                                  elmo-imap4-folder))
1824   (elmo-imap4-folder-status-plugged folder))
1825
1826 (defun elmo-imap4-folder-status-plugged (folder)
1827   (let ((session (elmo-imap4-get-session folder))
1828         (killed (elmo-msgdb-killed-list-load
1829                  (elmo-folder-msgdb-path folder)))
1830         status)
1831     (with-current-buffer (elmo-network-session-buffer session)
1832       (setq elmo-imap4-status-callback nil)
1833       (setq elmo-imap4-status-callback-data nil))
1834     (setq status (elmo-imap4-response-value
1835                   (elmo-imap4-send-command-wait
1836                    session
1837                    (list "status "
1838                          (elmo-imap4-mailbox
1839                           (elmo-imap4-folder-mailbox-internal folder))
1840                          " (uidnext messages)"))
1841                   'status))
1842     (cons
1843      (- (elmo-imap4-response-value status 'uidnext) 1)
1844      (if killed
1845          (-
1846           (elmo-imap4-response-value status 'messages)
1847           (elmo-msgdb-killed-list-length killed))
1848        (elmo-imap4-response-value status 'messages)))))
1849
1850 (luna-define-method elmo-folder-list-messages-plugged ((folder
1851                                                         elmo-imap4-folder)
1852                                                        &optional nohide)
1853   (elmo-imap4-list folder
1854                    (let ((max (elmo-msgdb-max-of-killed
1855                                (elmo-folder-killed-list-internal folder))))
1856                      (if (or nohide
1857                              (null (eq max 0)))
1858                          (format "uid %d:*" (1+ max))
1859                        "all"))))
1860
1861 (luna-define-method elmo-folder-list-unreads-plugged
1862   ((folder elmo-imap4-folder))
1863   (elmo-imap4-list folder "unseen"))
1864
1865 (luna-define-method elmo-folder-list-importants-plugged
1866   ((folder elmo-imap4-folder))
1867   (elmo-imap4-list folder "flagged"))
1868
1869 (luna-define-method elmo-folder-use-flag-p ((folder elmo-imap4-folder))
1870   (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
1871                      (elmo-imap4-folder-mailbox-internal folder))))
1872
1873 (luna-define-method elmo-folder-list-subfolders ((folder elmo-imap4-folder)
1874                                                  &optional one-level)
1875   (let* ((root (elmo-imap4-folder-mailbox-internal folder))
1876          (session (elmo-imap4-get-session folder))
1877          (prefix (elmo-folder-prefix-internal folder))
1878          (delim (or
1879                  (cdr
1880                   (elmo-string-matched-assoc
1881                    root
1882                    (with-current-buffer (elmo-network-session-buffer session)
1883                      elmo-imap4-server-namespace)))
1884                  elmo-imap4-default-hierarchy-delimiter))
1885          result append-serv type)
1886     ;; Append delimiter
1887     (if (and root
1888              (not (string= root ""))
1889              (not (string-match (concat "\\(.*\\)"
1890                                         (regexp-quote delim)
1891                                         "\\'")
1892                                 root)))
1893         (setq root (concat root delim)))
1894     (setq result (elmo-imap4-response-get-selectable-mailbox-list
1895                   (elmo-imap4-send-command-wait
1896                    session
1897                    (list "list " (elmo-imap4-mailbox root) " *"))))
1898     (unless (string= (elmo-net-folder-user-internal folder)
1899                      elmo-imap4-default-user)
1900       (setq append-serv (concat ":" (elmo-net-folder-user-internal folder))))
1901     (unless (eq (elmo-net-folder-auth-internal folder)
1902                 elmo-imap4-default-authenticate-type)
1903       (setq append-serv
1904             (concat append-serv "/"
1905                     (symbol-name (elmo-net-folder-auth-internal folder)))))
1906     (unless (string= (elmo-net-folder-server-internal folder)
1907                      elmo-imap4-default-server)
1908       (setq append-serv (concat append-serv "@"
1909                                 (elmo-net-folder-server-internal folder))))
1910     (unless (eq (elmo-net-folder-port-internal folder) elmo-imap4-default-port)
1911       (setq append-serv (concat append-serv ":"
1912                                 (int-to-string
1913                                  (elmo-net-folder-port-internal folder)))))
1914     (setq type (elmo-net-folder-stream-type-internal folder))
1915     (unless (eq (elmo-network-stream-type-symbol type)
1916                 elmo-imap4-default-stream-type)
1917       (if type
1918           (setq append-serv (concat append-serv
1919                                     (elmo-network-stream-type-spec-string
1920                                      type)))))
1921     (if one-level
1922         (let (folder folders ret)
1923           (while (setq folders (car result))
1924             (if (prog1
1925                     (string-match
1926                      (concat "^\\(" root "[^" delim "]" "+\\)" delim)
1927                           folders)
1928                   (setq folder (match-string 1 folders)))
1929                 (progn
1930                   (setq ret
1931                         (append ret
1932                                 (list
1933                                  (list
1934                                   (concat
1935                                    prefix
1936                                    (elmo-imap4-decode-folder-string folder)
1937                                    (and append-serv
1938                                         (eval append-serv)))))))
1939                   (setq result
1940                         (delq
1941                          nil
1942                          (mapcar '(lambda (fld)
1943                                     (unless
1944                                         (string-match
1945                                          (concat "^" (regexp-quote folder))
1946                                          fld)
1947                                       fld))
1948                                  result))))
1949               (setq ret (append
1950                          ret
1951                          (list
1952                           (concat prefix
1953                                   (elmo-imap4-decode-folder-string folders)
1954                                   (and append-serv
1955                                        (eval append-serv))))))
1956               (setq result (cdr result))))
1957           ret)
1958       (mapcar (lambda (fld)
1959                 (concat prefix (elmo-imap4-decode-folder-string fld)
1960                         (and append-serv
1961                              (eval append-serv))))
1962               result))))
1963
1964 (luna-define-method elmo-folder-exists-p-plugged ((folder elmo-imap4-folder))
1965   (let ((session (elmo-imap4-get-session folder)))
1966     (if (string=
1967          (elmo-imap4-session-current-mailbox-internal session)
1968          (elmo-imap4-folder-mailbox-internal folder))
1969         t
1970       (elmo-imap4-session-select-mailbox
1971        session
1972        (elmo-imap4-folder-mailbox-internal folder)
1973        'force 'no-error))))
1974
1975 (luna-define-method elmo-folder-delete ((folder elmo-imap4-folder))
1976   (let ((session (elmo-imap4-get-session folder))
1977         msgs)
1978     (when (elmo-imap4-folder-mailbox-internal folder)
1979       (when (setq msgs (elmo-folder-list-messages folder))
1980         (elmo-folder-delete-messages folder msgs))
1981       (elmo-imap4-send-command-wait session "close")
1982       (elmo-imap4-send-command-wait
1983        session
1984        (list "delete "
1985              (elmo-imap4-mailbox
1986               (elmo-imap4-folder-mailbox-internal folder)))))))
1987
1988 (luna-define-method elmo-folder-rename-internal ((folder elmo-imap4-folder)
1989                                                  new-folder)
1990   (let ((session (elmo-imap4-get-session folder)))
1991     ;; make sure the folder is selected.
1992     (elmo-imap4-session-select-mailbox session
1993                                        (elmo-imap4-folder-mailbox-internal
1994                                         folder))
1995     (elmo-imap4-send-command-wait session "close")
1996     (elmo-imap4-send-command-wait
1997      session
1998      (list "rename "
1999            (elmo-imap4-mailbox
2000             (elmo-imap4-folder-mailbox-internal folder))
2001            " "
2002            (elmo-imap4-mailbox
2003             (elmo-imap4-folder-mailbox-internal new-folder))))))
2004
2005 (defun elmo-imap4-copy-messages (src-folder dst-folder numbers)
2006   (let ((session (elmo-imap4-get-session src-folder))
2007         (set-list (elmo-imap4-make-number-set-list numbers)))
2008     (elmo-imap4-session-select-mailbox session
2009                                        (elmo-imap4-folder-mailbox-internal
2010                                         src-folder))
2011     (when set-list
2012       (if (elmo-imap4-send-command-wait session
2013                                         (list
2014                                          (format
2015                                           (if elmo-imap4-use-uid
2016                                               "uid copy %s "
2017                                             "copy %s ")
2018                                           (cdr (car set-list)))
2019                                          (elmo-imap4-mailbox
2020                                           (elmo-imap4-folder-mailbox-internal
2021                                            dst-folder))))
2022           numbers))))
2023
2024 (defun elmo-imap4-set-flag (folder numbers flag &optional remove)
2025   "Set flag on messages.
2026 FOLDER is the ELMO folder structure.
2027 NUMBERS is the message numbers to be flagged.
2028 FLAG is the flag name.
2029 If optional argument REMOVE is non-nil, remove FLAG."
2030   (let ((session (elmo-imap4-get-session folder))
2031         set-list)
2032     (elmo-imap4-session-select-mailbox session
2033                                        (elmo-imap4-folder-mailbox-internal
2034                                         folder))
2035     (setq set-list (elmo-imap4-make-number-set-list numbers))
2036     (when set-list
2037       (with-current-buffer (elmo-network-session-buffer session)
2038         (setq elmo-imap4-fetch-callback nil)
2039         (setq elmo-imap4-fetch-callback-data nil))
2040       (elmo-imap4-send-command-wait
2041        session
2042        (format
2043         (if elmo-imap4-use-uid
2044             "uid store %s %sflags.silent (%s)"
2045           "store %s %sflags.silent (%s)")
2046         (cdr (car set-list))
2047         (if remove "-" "+")
2048         flag)))))
2049
2050 (luna-define-method elmo-folder-delete-messages-plugged
2051   ((folder elmo-imap4-folder) numbers)
2052   (let ((session (elmo-imap4-get-session folder)))
2053     (elmo-imap4-set-flag folder numbers "\\Deleted")
2054     (elmo-imap4-send-command-wait session "expunge")))
2055
2056 (defmacro elmo-imap4-detect-search-charset (string)
2057   (` (with-temp-buffer
2058        (insert (, string))
2059        (detect-mime-charset-region (point-min) (point-max)))))
2060
2061 (defun elmo-imap4-search-internal-primitive (folder session filter from-msgs)
2062   (let ((search-key (elmo-filter-key filter))
2063         (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"))
2064         charset)
2065     (cond
2066      ((string= "last" search-key)
2067       (let ((numbers (or from-msgs (elmo-folder-list-messages folder))))
2068         (nthcdr (max (- (length numbers)
2069                         (string-to-int (elmo-filter-value filter)))
2070                      0)
2071                 numbers)))
2072      ((string= "first" search-key)
2073       (let* ((numbers (or from-msgs (elmo-folder-list-messages folder)))
2074              (rest (nthcdr (string-to-int (elmo-filter-value filter) )
2075                            numbers)))
2076         (mapcar '(lambda (x) (delete x numbers)) rest)
2077         numbers))
2078      ((or (string= "since" search-key)
2079           (string= "before" search-key))
2080       (setq search-key (concat "sent" search-key))
2081       (elmo-imap4-response-value
2082        (elmo-imap4-send-command-wait session
2083                                      (format
2084                                       (if elmo-imap4-use-uid
2085                                           "uid search %s%s%s %s"
2086                                         "search %s%s%s %s")
2087                                       (if from-msgs
2088                                           (concat
2089                                            (if elmo-imap4-use-uid "uid ")
2090                                            (cdr
2091                                             (car
2092                                              (elmo-imap4-make-number-set-list
2093                                               from-msgs)))
2094                                            " ")
2095                                         "")
2096                                       (if (eq (elmo-filter-type filter)
2097                                               'unmatch)
2098                                           "not " "")
2099                                       search-key
2100                                       (elmo-date-get-description
2101                                        (elmo-date-get-datevec
2102                                         (elmo-filter-value filter)))))
2103        'search))
2104      (t
2105       (setq charset
2106             (if (eq (length (elmo-filter-value filter)) 0)
2107                 (setq charset 'us-ascii)
2108               (elmo-imap4-detect-search-charset
2109                (elmo-filter-value filter))))
2110       (elmo-imap4-response-value
2111        (elmo-imap4-send-command-wait session
2112                                      (list
2113                                       (if elmo-imap4-use-uid "uid ")
2114                                       "search "
2115                                       "CHARSET "
2116                                       (elmo-imap4-astring
2117                                        (symbol-name charset))
2118                                       " "
2119                                       (if from-msgs
2120                                           (concat
2121                                            (if elmo-imap4-use-uid "uid ")
2122                                            (cdr
2123                                             (car
2124                                              (elmo-imap4-make-number-set-list
2125                                               from-msgs)))
2126                                            " ")
2127                                         "")
2128                                       (if (eq (elmo-filter-type filter)
2129                                               'unmatch)
2130                                           "not " "")
2131                                       (format "%s%s "
2132                                               (if (member
2133                                                    (elmo-filter-key filter)
2134                                                    imap-search-keys)
2135                                                   ""
2136                                                 "header ")
2137                                               (elmo-filter-key filter))
2138                                       (elmo-imap4-astring
2139                                        (encode-mime-charset-string
2140                                         (elmo-filter-value filter) charset))))
2141        'search)))))
2142
2143 (defun elmo-imap4-search-internal (folder session condition from-msgs)
2144   (let (result)
2145     (cond
2146      ((vectorp condition)
2147       (setq result (elmo-imap4-search-internal-primitive
2148                     folder session condition from-msgs)))
2149      ((eq (car condition) 'and)
2150       (setq result (elmo-imap4-search-internal folder session (nth 1 condition)
2151                                                from-msgs)
2152             result (elmo-list-filter result
2153                                      (elmo-imap4-search-internal
2154                                       folder session (nth 2 condition)
2155                                       from-msgs))))
2156      ((eq (car condition) 'or)
2157       (setq result (elmo-imap4-search-internal
2158                     folder session (nth 1 condition) from-msgs)
2159             result (elmo-uniq-list
2160                     (nconc result
2161                            (elmo-imap4-search-internal
2162                             folder session (nth 2 condition) from-msgs)))
2163             result (sort result '<))))))
2164
2165 (luna-define-method elmo-folder-search ((folder elmo-imap4-folder)
2166                                         condition &optional numbers)
2167   (save-excursion
2168     (let ((session (elmo-imap4-get-session folder)))
2169       (elmo-imap4-session-select-mailbox
2170        session
2171        (elmo-imap4-folder-mailbox-internal folder))
2172       (elmo-imap4-search-internal folder session condition numbers))))
2173
2174 (luna-define-method elmo-folder-msgdb-create
2175   ((folder elmo-imap4-folder) numbers &rest args)
2176   (when numbers
2177     (let ((session (elmo-imap4-get-session folder))
2178           (headers
2179            (append
2180             '("Subject" "From" "To" "Cc" "Date"
2181               "Message-Id" "References" "In-Reply-To")
2182             elmo-msgdb-extra-fields))
2183           (total 0)
2184           (length (length numbers))
2185           rfc2060 set-list)
2186       (setq rfc2060 (memq 'imap4rev1
2187                           (elmo-imap4-session-capability-internal
2188                            session)))
2189       (message "Getting overview...")
2190       (elmo-imap4-session-select-mailbox
2191        session (elmo-imap4-folder-mailbox-internal folder))
2192       (setq set-list (elmo-imap4-make-number-set-list
2193                       numbers
2194                       elmo-imap4-overview-fetch-chop-length))
2195       ;; Setup callback.
2196       (with-current-buffer (elmo-network-session-buffer session)
2197         (setq elmo-imap4-current-msgdb nil
2198               elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
2199               elmo-imap4-fetch-callback-data (cons args
2200                                                    (elmo-folder-use-flag-p
2201                                                     folder)))
2202         (while set-list
2203           (elmo-imap4-send-command-wait
2204            session
2205            ;; get overview entity from IMAP4
2206            (format "%sfetch %s (%s rfc822.size flags)"
2207                    (if elmo-imap4-use-uid "uid " "")
2208                    (cdr (car set-list))
2209                    (if rfc2060
2210                        (format "body.peek[header.fields %s]" headers)
2211                      (format "%s" headers))))
2212           (when (> length elmo-display-progress-threshold)
2213             (setq total (+ total (car (car set-list))))
2214             (elmo-display-progress
2215              'elmo-imap4-msgdb-create "Getting overview..."
2216              (/ (* total 100) length)))
2217           (setq set-list (cdr set-list)))
2218         (message "Getting overview...done")
2219         elmo-imap4-current-msgdb))))
2220
2221 (luna-define-method elmo-folder-unmark-important-plugged
2222   ((folder elmo-imap4-folder) numbers)
2223   (elmo-imap4-set-flag folder numbers "\\Flagged" 'remove))
2224
2225 (luna-define-method elmo-folder-mark-as-important-plugged
2226   ((folder elmo-imap4-folder) numbers)
2227   (elmo-imap4-set-flag folder numbers "\\Flagged"))
2228
2229 (luna-define-method elmo-folder-unmark-read-plugged
2230   ((folder elmo-imap4-folder) numbers)
2231   (elmo-imap4-set-flag folder numbers "\\Seen" 'remove))
2232
2233 (luna-define-method elmo-folder-mark-as-read-plugged
2234   ((folder elmo-imap4-folder) numbers)
2235   (elmo-imap4-set-flag folder numbers "\\Seen"))
2236
2237 (luna-define-method elmo-message-use-cache-p ((folder elmo-imap4-folder)
2238                                               number)
2239   elmo-imap4-use-cache)
2240
2241 (luna-define-method elmo-folder-message-appendable-p ((folder elmo-imap4-folder))
2242   (if (elmo-folder-plugged-p folder)
2243       (not (elmo-imap4-session-read-only-internal
2244             (elmo-imap4-get-session folder)))
2245     elmo-enable-disconnected-operation)) ; offline refile.
2246
2247 (luna-define-method elmo-folder-check-plugged ((folder elmo-imap4-folder))
2248   (let ((session (elmo-imap4-get-session folder 'if-exists)))
2249     (when session
2250       (if (string=
2251            (elmo-imap4-session-current-mailbox-internal session)
2252            (elmo-imap4-folder-mailbox-internal folder))
2253           (if elmo-imap4-use-select-to-update-status
2254               (elmo-imap4-session-select-mailbox
2255                session
2256                (elmo-imap4-folder-mailbox-internal folder)
2257                'force)
2258             (elmo-imap4-session-check session))))))
2259
2260 (defsubst elmo-imap4-folder-diff-plugged (folder)
2261   (let ((session (elmo-imap4-get-session folder))
2262         messages
2263         response killed)
2264 ;;; (elmo-imap4-commit spec)
2265     (with-current-buffer (elmo-network-session-buffer session)
2266       (setq elmo-imap4-status-callback nil)
2267       (setq elmo-imap4-status-callback-data nil))
2268     (setq response
2269           (elmo-imap4-send-command-wait session
2270                                         (list
2271                                          "status "
2272                                          (elmo-imap4-mailbox
2273                                           (elmo-imap4-folder-mailbox-internal
2274                                            folder))
2275                                          " (unseen messages)")))
2276     (setq response (elmo-imap4-response-value response 'status))
2277     (setq messages (elmo-imap4-response-value response 'messages))
2278     (setq killed (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2279     (if killed
2280         (setq messages (- messages
2281                           (elmo-msgdb-killed-list-length
2282                            killed))))
2283     (cons (elmo-imap4-response-value response 'unseen)
2284           messages)))
2285
2286 (luna-define-method elmo-folder-diff-plugged ((folder elmo-imap4-folder))
2287   (elmo-imap4-folder-diff-plugged folder))
2288
2289 (luna-define-method elmo-folder-diff-async ((folder elmo-imap4-folder)
2290                                             &optional number-alist)
2291   (setq elmo-imap4-server-diff-async-callback
2292         elmo-folder-diff-async-callback)
2293   (setq elmo-imap4-server-diff-async-callback-data
2294         elmo-folder-diff-async-callback-data)
2295   (elmo-imap4-server-diff-async folder))
2296
2297 (luna-define-method elmo-folder-open :around ((folder elmo-imap4-folder))
2298   (if (elmo-folder-plugged-p folder)
2299       (let (session mailbox msgdb response tag)
2300         (condition-case err
2301             (progn
2302               (setq session (elmo-imap4-get-session folder)
2303                     mailbox (elmo-imap4-folder-mailbox-internal folder)
2304                     tag (elmo-imap4-send-command session
2305                                                  (list "select "
2306                                                        (elmo-imap4-mailbox
2307                                                         mailbox))))
2308               (setq msgdb (elmo-msgdb-load folder))
2309               (elmo-folder-set-killed-list-internal
2310                folder
2311                (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2312               (setq response (elmo-imap4-read-response session tag)))
2313           (quit
2314            (if response
2315                (elmo-imap4-session-set-current-mailbox-internal
2316                 session mailbox)
2317              (and session
2318                   (elmo-imap4-session-set-current-mailbox-internal
2319                    session nil))))
2320           (error
2321            (if response
2322                (elmo-imap4-session-set-current-mailbox-internal
2323                 session mailbox)
2324              (and session
2325                   (elmo-imap4-session-set-current-mailbox-internal
2326                    session nil)))))
2327         (elmo-folder-set-msgdb-internal folder
2328                                         (or msgdb (elmo-msgdb-load folder))))
2329     (luna-call-next-method)))
2330
2331 ;; elmo-folder-open-internal: do nothing.
2332
2333 (luna-define-method elmo-find-fetch-strategy
2334   ((folder elmo-imap4-folder) entity &optional ignore-cache)
2335   (let ((number (elmo-msgdb-overview-entity-get-number entity))
2336         cache-file size message-id)
2337     (setq size (elmo-msgdb-overview-entity-get-size entity))
2338     (setq message-id (elmo-msgdb-overview-entity-get-id entity))
2339     (setq cache-file (elmo-file-cache-get message-id))
2340     (if (or ignore-cache
2341             (null (elmo-file-cache-status cache-file)))
2342         (if (and elmo-message-fetch-threshold
2343                  (integerp size)
2344                  (>= size elmo-message-fetch-threshold)
2345                  (or (not elmo-message-fetch-confirm)
2346                      (not (prog1 (y-or-n-p
2347                                   (format
2348                                    "Fetch entire message at once? (%dbytes)"
2349                                    size))
2350                             (message "")))))
2351             ;; Fetch message as imap message.
2352             (elmo-make-fetch-strategy 'section
2353                                       nil
2354                                       (elmo-message-use-cache-p
2355                                        folder number)
2356                                       (elmo-file-cache-path
2357                                        cache-file))
2358           ;; Don't use existing cache and fetch entire message at once.
2359           (elmo-make-fetch-strategy 'entire nil
2360                                     (elmo-message-use-cache-p
2361                                      folder number)
2362                                     (elmo-file-cache-path cache-file)))
2363       ;; Cache found and use it.
2364       (if (not ignore-cache)
2365           (if (eq (elmo-file-cache-status cache-file) 'section)
2366               ;; Fetch message with imap message.
2367               (elmo-make-fetch-strategy 'section
2368                                         t
2369                                         (elmo-message-use-cache-p
2370                                          folder number)
2371                                         (elmo-file-cache-path
2372                                          cache-file))
2373             (elmo-make-fetch-strategy 'entire
2374                                       t
2375                                       (elmo-message-use-cache-p
2376                                        folder number)
2377                                       (elmo-file-cache-path
2378                                        cache-file)))))))
2379
2380 (luna-define-method elmo-folder-create ((folder elmo-imap4-folder))
2381   (elmo-imap4-send-command-wait
2382    (elmo-imap4-get-session folder)
2383    (list "create "
2384          (elmo-imap4-mailbox
2385           (elmo-imap4-folder-mailbox-internal folder)))))
2386
2387 (luna-define-method elmo-folder-append-buffer
2388   ((folder elmo-imap4-folder) unread &optional number)
2389   (let ((session (elmo-imap4-get-session folder))
2390         send-buffer result)
2391     (elmo-imap4-session-select-mailbox session
2392                                        (elmo-imap4-folder-mailbox-internal
2393                                         folder))
2394     (setq send-buffer (elmo-imap4-setup-send-buffer))
2395     (unwind-protect
2396         (setq result
2397               (elmo-imap4-send-command-wait
2398                session
2399                (list
2400                 "append "
2401                 (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal
2402                                      folder))
2403                 (if unread " " " (\\Seen) ")
2404                 (elmo-imap4-buffer-literal send-buffer))))
2405       (kill-buffer send-buffer))
2406     result))
2407
2408 (eval-when-compile
2409   (defmacro elmo-imap4-identical-system-p (folder1 folder2)
2410     "Return t if FOLDER1 and FOLDER2 are in the same IMAP4 system."
2411     (` (and (string= (elmo-net-folder-server-internal (, folder1))
2412                      (elmo-net-folder-server-internal (, folder2)))
2413             (eq (elmo-net-folder-port-internal (, folder1))
2414                 (elmo-net-folder-port-internal (, folder2)))
2415             (string= (elmo-net-folder-user-internal (, folder1))
2416                      (elmo-net-folder-user-internal (, folder2)))))))
2417
2418 (luna-define-method elmo-folder-append-messages :around
2419   ((folder elmo-imap4-folder) src-folder numbers unread-marks
2420    &optional same-number)
2421   (if (and (eq (elmo-folder-type-internal src-folder) 'imap4)
2422            (elmo-imap4-identical-system-p folder src-folder))
2423       (elmo-imap4-copy-messages src-folder folder numbers)
2424     (luna-call-next-method)))
2425
2426 (luna-define-method elmo-message-deletable-p ((folder elmo-imap4-folder)
2427                                               number)
2428   (if (elmo-folder-plugged-p folder)
2429       (not (elmo-imap4-session-read-only-internal
2430             (elmo-imap4-get-session folder)))
2431     elmo-enable-disconnected-operation)) ; offline refile.
2432
2433 (luna-define-method elmo-message-fetch-unplugged
2434   ((folder elmo-imap4-folder)
2435    number strategy  &optional section outbuf unseen)
2436   (let ((cache-file (elmo-file-cache-expand-path
2437                      (elmo-fetch-strategy-cache-path strategy)
2438                      section)))
2439     (if (and (elmo-fetch-strategy-use-cache strategy)
2440              (file-exists-p cache-file))
2441         (if outbuf
2442             (with-current-buffer outbuf
2443               (insert-file-contents-as-binary cache-file)
2444               t)
2445           (with-temp-buffer
2446             (insert-file-contents-as-binary cache-file)
2447             (buffer-string)))
2448       (error "%d%s is not cached." number (if section
2449                                               (format "(%s)" section)
2450                                             "")))))
2451
2452 (defsubst elmo-imap4-message-fetch (folder number strategy
2453                                            section outbuf unseen)
2454   (let ((session (elmo-imap4-get-session folder))
2455         response)
2456     (elmo-imap4-session-select-mailbox session
2457                                        (elmo-imap4-folder-mailbox-internal
2458                                         folder))
2459     (with-current-buffer (elmo-network-session-buffer session)
2460       (setq elmo-imap4-fetch-callback nil)
2461       (setq elmo-imap4-fetch-callback-data nil))
2462     (setq response
2463           (elmo-imap4-send-command-wait session
2464                                         (format
2465                                          (if elmo-imap4-use-uid
2466                                              "uid fetch %s body%s[%s]"
2467                                            "fetch %s body%s[%s]")
2468                                          number
2469                                          (if unseen ".peek" "")
2470                                          (or section "")
2471                                          )))
2472     (if (setq response (elmo-imap4-response-bodydetail-text
2473                         (elmo-imap4-response-value-all
2474                          response 'fetch)))
2475         (with-current-buffer outbuf
2476           (erase-buffer)
2477           (insert response)))))
2478
2479 (luna-define-method elmo-message-fetch-plugged ((folder elmo-imap4-folder)
2480                                                 number strategy
2481                                                 &optional section
2482                                                 outbuf unseen)
2483   (elmo-imap4-message-fetch folder number strategy section outbuf unseen))
2484
2485 (require 'product)
2486 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2487
2488 ;;; elmo-imap4.el ends here