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