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