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