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