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