elmo/elmo-imap4.el

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