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