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