elmo/elmo-imap4.el

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