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