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