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