elmo/elmo-imap4.el

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