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