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