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