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