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 seen-list and result of use-flag-p.
 796 (defsubst elmo-imap4-fetch-callback-1-subr (entity flags app-data)
 797   "A msgdb entity callback function."
 798   (let* ((use-flag (cdr app-data))
 799          (app-data (car app-data))
 800          (seen (member (car entity) app-data))
 801          mark)
 802     (if (member "\\Flagged" flags)
 803         (elmo-msgdb-global-mark-set (car entity)
 804                                     elmo-msgdb-important-mark))
 805     (if (setq mark (elmo-msgdb-global-mark-get (car entity)))
 806         (unless (member "\\Seen" flags)
 807           (setq elmo-imap4-seen-messages
 808                 (cons
 809                  (elmo-msgdb-overview-entity-get-number entity)
 810                  elmo-imap4-seen-messages)))
 811       (setq mark (or (if (elmo-file-cache-status
 812                           (elmo-file-cache-get (car entity)))
 813                          ;; cached.
 814                          (if (member "\\Answered" flags)
 815                              elmo-msgdb-answered-cached-mark
 816                            (if (or seen
 817                                    (and use-flag
 818                                         (member "\\Seen" flags)))
 819                                nil
 820                              elmo-msgdb-unread-cached-mark))
 821                        (if (member "\\Answered" flags)
 822                            elmo-msgdb-answered-uncached-mark
 823                          (if (or seen
 824                                  (and use-flag
 825                                       (member "\\Seen" flags)))
 826                              (if elmo-imap4-use-cache
 827                                  elmo-msgdb-read-uncached-mark)
 828                            elmo-msgdb-new-mark))))))
 829     (setq elmo-imap4-current-msgdb
 830           (elmo-msgdb-append
 831            elmo-imap4-current-msgdb
 832            (list (list entity)
 833                  (list (cons (elmo-msgdb-overview-entity-get-number entity)
 834                              (car entity)))
 835                  (if mark
 836                      (list
 837                       (list (elmo-msgdb-overview-entity-get-number entity)
 838                             mark))))))))
 839
 840 ;; Current buffer is process buffer.
 841 (defun elmo-imap4-fetch-callback-1 (element app-data)
 842   (elmo-imap4-fetch-callback-1-subr
 843    (with-temp-buffer
 844      (insert (or (elmo-imap4-response-bodydetail-text element)
 845                  ""))
 846      ;; Delete CR.
 847      (goto-char (point-min))
 848      (while (search-forward "\r\n" nil t)
 849        (replace-match "\n"))
 850      (elmo-msgdb-create-overview-from-buffer
 851       (elmo-imap4-response-value element 'uid)
 852       (elmo-imap4-response-value element 'rfc822size)))
 853    (elmo-imap4-response-value element 'flags)
 854    app-data))
 855
 856 (defun elmo-imap4-parse-capability (string)
 857   (if (string-match "^\\*\\(.*\\)$" string)
 858       (elmo-read
 859        (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
 860
 861 (defun elmo-imap4-clear-login (session)
 862   (let ((elmo-imap4-debug-inhibit-logging t))
 863     (or
 864      (elmo-imap4-read-ok
 865       session
 866       (elmo-imap4-send-command
 867        session
 868        (list "login "
 869              (elmo-imap4-userid (elmo-network-session-user-internal session))
 870              " "
 871              (elmo-imap4-password
 872               (elmo-get-passwd (elmo-network-session-password-key session))))))
 873      (signal 'elmo-authenticate-error '(elmo-imap4-clear-login)))))
 874
 875 (defun elmo-imap4-auth-login (session)
 876   (let ((tag (elmo-imap4-send-command session "authenticate login"))
 877         (elmo-imap4-debug-inhibit-logging t))
 878     (or (elmo-imap4-read-continue-req session)
 879         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 880     (elmo-imap4-send-string session
 881                             (elmo-base64-encode-string
 882                              (elmo-network-session-user-internal session)))
 883     (or (elmo-imap4-read-continue-req session)
 884         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 885     (elmo-imap4-send-string session
 886                             (elmo-base64-encode-string
 887                              (elmo-get-passwd
 888                               (elmo-network-session-password-key session))))
 889     (or (elmo-imap4-read-ok session tag)
 890         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
 891     (setq elmo-imap4-status 'auth)))
 892
 893 (luna-define-method
 894   elmo-network-initialize-session-buffer :after ((session
 895                                                   elmo-imap4-session) buffer)
 896   (with-current-buffer buffer
 897     (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
 898     (setq elmo-imap4-seqno 0)
 899     (setq elmo-imap4-status 'initial)))
 900
 901 (luna-define-method elmo-network-initialize-session ((session
 902                                                       elmo-imap4-session))
 903   (let ((process (elmo-network-session-process-internal session)))
 904     (with-current-buffer (process-buffer process)
 905       ;; Skip garbage output from process before greeting.
 906       (while (and (memq (process-status process) '(open run))
 907                   (goto-char (point-max))
 908                   (forward-line -1)
 909                   (not (elmo-imap4-parse-greeting)))
 910         (accept-process-output process 1))
 911       (set-process-filter process 'elmo-imap4-arrival-filter)
 912       (set-process-sentinel process 'elmo-imap4-sentinel)
 913 ;;;   (while (and (memq (process-status process) '(open run))
 914 ;;;               (eq elmo-imap4-status 'initial))
 915 ;;;     (message "Waiting for server response...")
 916 ;;;     (accept-process-output process 1))
 917 ;;;   (message "")
 918       (unless (memq elmo-imap4-status '(nonauth auth))
 919         (signal 'elmo-open-error
 920                 (list 'elmo-network-initialize-session)))
 921       (elmo-imap4-session-set-capability-internal
 922        session
 923        (elmo-imap4-response-value
 924         (elmo-imap4-send-command-wait session "capability")
 925         'capability))
 926       (when (eq (elmo-network-stream-type-symbol
 927                  (elmo-network-session-stream-type-internal session))
 928                 'starttls)
 929         (or (memq 'starttls
 930                   (elmo-imap4-session-capability-internal session))
 931             (signal 'elmo-open-error
 932                     '(elmo-imap4-starttls-error)))
 933         (elmo-imap4-send-command-wait session "starttls")
 934         (starttls-negotiate process)
 935         (elmo-imap4-session-set-capability-internal
 936          session
 937          (elmo-imap4-response-value
 938           (elmo-imap4-send-command-wait session "capability")
 939           'capability))))))
 940
 941 (luna-define-method elmo-network-authenticate-session ((session
 942                                                         elmo-imap4-session))
 943   (with-current-buffer (process-buffer
 944                         (elmo-network-session-process-internal session))
 945     (let* ((auth (elmo-network-session-auth-internal session))
 946            (auth (if (listp auth) auth (list auth))))
 947       (unless (or (eq elmo-imap4-status 'auth)
 948                   (null auth))
 949         (cond
 950          ((eq 'clear (car auth))
 951           (elmo-imap4-clear-login session))
 952          ((eq 'login (car auth))
 953           (elmo-imap4-auth-login session))
 954          (t
 955           (let* ((elmo-imap4-debug-inhibit-logging t)
 956                  (sasl-mechanisms
 957                   (delq nil
 958                         (mapcar
 959                          '(lambda (cap)
 960                             (if (string-match "^auth=\\(.*\\)$"
 961                                               (symbol-name cap))
 962                                 (match-string 1 (upcase (symbol-name cap)))))
 963                          (elmo-imap4-session-capability-internal session))))
 964                  (mechanism
 965                   (sasl-find-mechanism
 966                    (delq nil
 967                          (mapcar '(lambda (cap) (upcase (symbol-name cap)))
 968                                  (if (listp auth)
 969                                      auth
 970                                    (list auth)))))) ;)
 971                  client name step response tag
 972                  sasl-read-passphrase)
 973             (unless mechanism
 974               (if (or elmo-imap4-force-login
 975                       (y-or-n-p
 976                        (format
 977                         "There's no %s capability in server. continue?"
 978                         (elmo-list-to-string
 979                          (elmo-network-session-auth-internal session)))))
 980                   (setq mechanism (sasl-find-mechanism
 981                                    sasl-mechanisms))
 982                 (signal 'elmo-authenticate-error
 983                         '(elmo-imap4-auth-no-mechanisms))))
 984             (setq client
 985                   (sasl-make-client
 986                    mechanism
 987                    (elmo-network-session-user-internal session)
 988                    "imap"
 989                    (elmo-network-session-server-internal session)))
 990 ;;;         (if elmo-imap4-auth-user-realm
 991 ;;;             (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
 992             (setq name (sasl-mechanism-name mechanism)
 993                   step (sasl-next-step client nil))
 994             (elmo-network-session-set-auth-internal
 995              session
 996              (intern (downcase name)))
 997             (setq sasl-read-passphrase
 998                   (function
 999                    (lambda (prompt)
1000                      (elmo-get-passwd
1001                       (elmo-network-session-password-key session)))))
1002             (setq tag
1003                   (elmo-imap4-send-command
1004                    session
1005                    (concat "AUTHENTICATE " name
1006                            (and (sasl-step-data step)
1007                                 (concat
1008                                  " "
1009                                  (elmo-base64-encode-string
1010                                   (sasl-step-data step)
1011                                   'no-lin-break))))))
1012             (catch 'done
1013               (while t
1014                 (setq response
1015                       (elmo-imap4-read-untagged
1016                        (elmo-network-session-process-internal session)))
1017                 (if (elmo-imap4-response-ok-p response)
1018                     (if (sasl-next-step client step)
1019                         ;; Bogus server?
1020                         (signal 'elmo-authenticate-error
1021                                 (list (intern
1022                                        (concat "elmo-imap4-auth-"
1023                                                (downcase name)))))
1024                       ;; The authentication process is finished.
1025                       (throw 'done nil)))
1026                 (unless (elmo-imap4-response-continue-req-p response)
1027                   ;; response is NO or BAD.
1028                   (signal 'elmo-authenticate-error
1029                           (list (intern
1030                                  (concat "elmo-imap4-auth-"
1031                                          (downcase name))))))
1032                 (sasl-step-set-data
1033                  step
1034                  (elmo-base64-decode-string
1035                   (elmo-imap4-response-value response 'continue-req)))
1036                 (setq step (sasl-next-step client step))
1037                 (setq tag
1038                       (elmo-imap4-send-string
1039                        session
1040                        (if (sasl-step-data step)
1041                            (elmo-base64-encode-string (sasl-step-data step)
1042                                                       'no-line-break)
1043                          ""))))))))))))
1044
1045 (luna-define-method elmo-network-setup-session ((session
1046                                                  elmo-imap4-session))
1047   (with-current-buffer (elmo-network-session-buffer session)
1048     (when (memq 'namespace (elmo-imap4-session-capability-internal session))
1049       (setq elmo-imap4-server-namespace
1050             (elmo-imap4-response-value
1051              (elmo-imap4-send-command-wait session "namespace")
1052              'namespace)))))
1053
1054 (defun elmo-imap4-setup-send-buffer (&optional string)
1055   (let ((send-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*"))
1056         (source-buf (unless string (current-buffer))))
1057     (save-excursion
1058       (save-match-data
1059         (set-buffer send-buf)
1060         (erase-buffer)
1061         (elmo-set-buffer-multibyte nil)
1062         (if string
1063             (insert string)
1064           (with-current-buffer source-buf
1065             (copy-to-buffer send-buf (point-min) (point-max))))
1066         (goto-char (point-min))
1067         (if (eq (re-search-forward "^$" nil t)
1068                 (point-max))
1069             (insert "\n"))
1070         (goto-char (point-min))
1071         (while (search-forward "\n" nil t)
1072           (replace-match "\r\n"))))
1073     send-buf))
1074
1075 (defun elmo-imap4-setup-send-buffer-from-file (file)
1076   (let ((tmp-buf (get-buffer-create
1077                   " *elmo-imap4-setup-send-buffer-from-file*")))
1078     (save-excursion
1079       (save-match-data
1080         (set-buffer tmp-buf)
1081         (erase-buffer)
1082         (as-binary-input-file
1083          (insert-file-contents file))
1084         (goto-char (point-min))
1085         (if (eq (re-search-forward "^$" nil t)
1086                 (point-max))
1087             (insert "\n"))
1088         (goto-char (point-min))
1089         (while (search-forward "\n" nil t)
1090           (replace-match "\r\n"))))
1091     tmp-buf))
1092
1093 (luna-define-method elmo-delete-message-safe ((folder elmo-imap4-folder)
1094                                               number msgid)
1095   (let ((session (elmo-imap4-get-session folder))
1096         candidates)
1097     (elmo-imap4-session-select-mailbox
1098      session
1099      (elmo-imap4-folder-mailbox-internal folder))
1100     (setq candidates
1101           (elmo-imap4-response-value
1102            (elmo-imap4-send-command-wait session
1103                                          (list
1104                                           (if elmo-imap4-use-uid
1105                                               "uid search header message-id "
1106                                             "search header message-id ")
1107                                           (elmo-imap4-field-body msgid)))
1108            'search))
1109     (if (memq number candidates)
1110         (elmo-folder-delete-messages folder (list number)))))
1111
1112 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1113   (funcall elmo-imap4-server-diff-async-callback
1114            (list (elmo-imap4-response-value status 'recent)
1115                  (elmo-imap4-response-value status 'unseen)
1116                  (elmo-imap4-response-value status 'messages))
1117            data))
1118
1119 (defun elmo-imap4-server-diff-async (folder)
1120   (let ((session (elmo-imap4-get-session folder)))
1121     ;; We should `check' folder to obtain newest information here.
1122     ;; But since there's no asynchronous check mechanism in elmo yet,
1123     ;; checking is not done here.
1124     (with-current-buffer (elmo-network-session-buffer session)
1125       (setq elmo-imap4-status-callback
1126             'elmo-imap4-server-diff-async-callback-1)
1127       (setq elmo-imap4-status-callback-data
1128             elmo-imap4-server-diff-async-callback-data))
1129     (elmo-imap4-send-command session
1130                              (list
1131                               "status "
1132                               (elmo-imap4-mailbox
1133                                (elmo-imap4-folder-mailbox-internal folder))
1134                               " (recent unseen messages)"))))
1135
1136 (luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder))
1137   (let ((session (elmo-imap4-get-session folder)))
1138     ;; commit.
1139     ;; (elmo-imap4-commit spec)
1140     (with-current-buffer (elmo-network-session-buffer session)
1141       (setq elmo-imap4-status-callback
1142             'elmo-imap4-server-diff-async-callback-1)
1143       (setq elmo-imap4-status-callback-data
1144             elmo-imap4-server-diff-async-callback-data))
1145     (elmo-imap4-send-command session
1146                              (list
1147                               "status "
1148                               (elmo-imap4-mailbox
1149                                (elmo-imap4-folder-mailbox-internal folder))
1150                               " (recent unseen messages)"))))
1151
1152 ;;; IMAP parser.
1153
1154 (defvar elmo-imap4-server-eol "\r\n"
1155   "The EOL string sent from the server.")
1156
1157 (defvar elmo-imap4-client-eol "\r\n"
1158   "The EOL string we send to the server.")
1159
1160 (defvar elmo-imap4-display-literal-progress nil)
1161
1162 (defun elmo-imap4-find-next-line ()
1163   "Return point at end of current line, taking into account literals.
1164 Return nil if no complete line has arrived."
1165   (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1166                                    elmo-imap4-server-eol)
1167                            nil t)
1168     (if (match-string 1)
1169         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1170             (progn
1171               (if (and elmo-imap4-display-literal-progress
1172                        (> (string-to-number (match-string 1))
1173                           (min elmo-display-retrieval-progress-threshold 100)))
1174                   (elmo-display-progress
1175                    'elmo-imap4-display-literal-progress
1176                    (format "Retrieving (%d/%d bytes)..."
1177                            (- (point-max) (point))
1178                            (string-to-number (match-string 1)))
1179                    (/ (- (point-max) (point))
1180                       (/ (string-to-number (match-string 1)) 100))))
1181               nil)
1182           (goto-char (+ (point) (string-to-number (match-string 1))))
1183           (elmo-imap4-find-next-line))
1184       (point))))
1185
1186 (defun elmo-imap4-sentinel (process string)
1187   (delete-process process))
1188
1189 (defun elmo-imap4-arrival-filter (proc string)
1190   "IMAP process filter."
1191   (when (buffer-live-p (process-buffer proc))
1192   (with-current-buffer (process-buffer proc)
1193     (elmo-imap4-debug "-> %s" string)
1194     (goto-char (point-max))
1195     (insert string)
1196     (let (end)
1197       (goto-char (point-min))
1198       (while (setq end (elmo-imap4-find-next-line))
1199         (save-restriction
1200           (narrow-to-region (point-min) end)
1201           (delete-backward-char (length elmo-imap4-server-eol))
1202           (goto-char (point-min))
1203           (unwind-protect
1204               (cond ((eq elmo-imap4-status 'initial)
1205                      (setq elmo-imap4-current-response
1206                            (list
1207                             (list 'greeting (elmo-imap4-parse-greeting)))))
1208                     ((or (eq elmo-imap4-status 'auth)
1209                          (eq elmo-imap4-status 'nonauth)
1210                          (eq elmo-imap4-status 'selected)
1211                          (eq elmo-imap4-status 'examine))
1212                      (setq elmo-imap4-current-response
1213                            (cons
1214                             (elmo-imap4-parse-response)
1215                             elmo-imap4-current-response)))
1216                     (t
1217                      (message "Unknown state %s in arrival filter"
1218                               elmo-imap4-status))))
1219           (delete-region (point-min) (point-max))))))))
1220
1221 ;; IMAP parser.
1222
1223 (defsubst elmo-imap4-forward ()
1224   (or (eobp) (forward-char 1)))
1225
1226 (defsubst elmo-imap4-parse-number ()
1227   (when (looking-at "[0-9]+")
1228     (prog1
1229         (string-to-number (match-string 0))
1230       (goto-char (match-end 0)))))
1231
1232 (defsubst elmo-imap4-parse-literal ()
1233   (when (looking-at "{\\([0-9]+\\)}\r\n")
1234     (let ((pos (match-end 0))
1235           (len (string-to-number (match-string 1))))
1236       (if (< (point-max) (+ pos len))
1237           nil
1238         (goto-char (+ pos len))
1239         (buffer-substring pos (+ pos len))))))
1240 ;;;     (list ' pos (+ pos len))))))
1241
1242 (defsubst elmo-imap4-parse-string ()
1243   (cond ((eq (char-after (point)) ?\")
1244          (forward-char 1)
1245          (let ((p (point)) (name ""))
1246            (skip-chars-forward "^\"\\\\")
1247            (setq name (buffer-substring p (point)))
1248            (while (eq (char-after (point)) ?\\)
1249              (setq p (1+ (point)))
1250              (forward-char 2)
1251              (skip-chars-forward "^\"\\\\")
1252              (setq name (concat name (buffer-substring p (point)))))
1253            (forward-char 1)
1254            name))
1255         ((eq (char-after (point)) ?{)
1256          (elmo-imap4-parse-literal))))
1257
1258 (defsubst elmo-imap4-parse-nil ()
1259   (if (looking-at "NIL")
1260       (goto-char (match-end 0))))
1261
1262 (defsubst elmo-imap4-parse-nstring ()
1263   (or (elmo-imap4-parse-string)
1264       (and (elmo-imap4-parse-nil)
1265            nil)))
1266
1267 (defsubst elmo-imap4-parse-astring ()
1268   (or (elmo-imap4-parse-string)
1269       (buffer-substring (point)
1270                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1271                             (goto-char (1- (match-end 0)))
1272                           (end-of-line)
1273                           (point)))))
1274
1275 (defsubst elmo-imap4-parse-address ()
1276   (let (address)
1277     (when (eq (char-after (point)) ?\()
1278       (elmo-imap4-forward)
1279       (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1280                               (elmo-imap4-forward))
1281                             (prog1 (elmo-imap4-parse-nstring)
1282                               (elmo-imap4-forward))
1283                             (prog1 (elmo-imap4-parse-nstring)
1284                               (elmo-imap4-forward))
1285                             (elmo-imap4-parse-nstring)))
1286       (when (eq (char-after (point)) ?\))
1287         (elmo-imap4-forward)
1288         address))))
1289
1290 (defsubst elmo-imap4-parse-address-list ()
1291   (if (eq (char-after (point)) ?\()
1292       (let (address addresses)
1293         (elmo-imap4-forward)
1294         (while (and (not (eq (char-after (point)) ?\)))
1295                     ;; next line for MS Exchange bug
1296                     (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1297                     (setq address (elmo-imap4-parse-address)))
1298           (setq addresses (cons address addresses)))
1299         (when (eq (char-after (point)) ?\))
1300           (elmo-imap4-forward)
1301           (nreverse addresses)))
1302     (assert (elmo-imap4-parse-nil))))
1303
1304 (defsubst elmo-imap4-parse-mailbox ()
1305   (let ((mailbox (elmo-imap4-parse-astring)))
1306     (if (string-equal "INBOX" (upcase mailbox))
1307         "INBOX"
1308       mailbox)))
1309
1310 (defun elmo-imap4-parse-greeting ()
1311   "Parse a IMAP greeting."
1312   (cond ((looking-at "\\* OK ")
1313          (setq elmo-imap4-status 'nonauth))
1314         ((looking-at "\\* PREAUTH ")
1315          (setq elmo-imap4-status 'auth))
1316         ((looking-at "\\* BYE ")
1317          (setq elmo-imap4-status 'closed))))
1318
1319 (defun elmo-imap4-parse-response ()
1320   "Parse a IMAP command response."
1321   (let (token)
1322     (case (setq token (elmo-read (current-buffer)))
1323       (+ (progn
1324            (skip-chars-forward " ")
1325            (list 'continue-req (buffer-substring (point) (point-max)))))
1326       (* (case (prog1 (setq token (elmo-read (current-buffer)))
1327                  (elmo-imap4-forward))
1328            (OK         (elmo-imap4-parse-resp-text-code))
1329            (NO         (elmo-imap4-parse-resp-text-code))
1330            (BAD        (elmo-imap4-parse-resp-text-code))
1331            (BYE        (elmo-imap4-parse-bye))
1332            (FLAGS      (list 'flags
1333                              (elmo-imap4-parse-flag-list)))
1334            (LIST       (list 'list (elmo-imap4-parse-data-list)))
1335            (LSUB       (list 'lsub (elmo-imap4-parse-data-list)))
1336            (SEARCH     (list
1337                         'search
1338                         (elmo-read (concat "("
1339                                       (buffer-substring (point) (point-max))
1340                                       ")"))))
1341            (STATUS     (elmo-imap4-parse-status))
1342            ;; Added
1343            (NAMESPACE  (elmo-imap4-parse-namespace))
1344            (CAPABILITY (list 'capability
1345                              (elmo-read
1346                               (concat "(" (downcase (buffer-substring
1347                                                      (point) (point-max)))
1348                                       ")"))))
1349            (ACL (elmo-imap4-parse-acl))
1350            (t       (case (prog1 (elmo-read (current-buffer))
1351                             (elmo-imap4-forward))
1352                       (EXISTS  (list 'exists token))
1353                       (RECENT  (list 'recent token))
1354                       (EXPUNGE (list 'expunge token))
1355                       (FETCH   (elmo-imap4-parse-fetch token))
1356                       (t       (list 'garbage (buffer-string)))))))
1357       (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1358              (list 'garbage (buffer-string))
1359            (case (prog1 (elmo-read (current-buffer))
1360                    (elmo-imap4-forward))
1361              (OK  (progn
1362                     (setq elmo-imap4-parsing nil)
1363                     (setq token (symbol-name token))
1364                     (elmo-unintern token)
1365                     (elmo-imap4-debug "*%s* OK arrived" token)
1366                     (setq elmo-imap4-reached-tag token)
1367                     (list 'ok (elmo-imap4-parse-resp-text-code))))
1368              (NO  (progn
1369                     (setq elmo-imap4-parsing nil)
1370                     (setq token (symbol-name token))
1371                     (elmo-unintern token)
1372                     (elmo-imap4-debug "*%s* NO arrived" token)
1373                     (setq elmo-imap4-reached-tag token)
1374                     (let (code text)
1375                       (when (eq (char-after (point)) ?\[)
1376                         (setq code (buffer-substring (point)
1377                                                      (search-forward "]")))
1378                         (elmo-imap4-forward))
1379                       (setq text (buffer-substring (point) (point-max)))
1380                       (list 'no (list code text)))))
1381              (BAD (progn
1382                     (setq elmo-imap4-parsing nil)
1383                     (elmo-imap4-debug "*%s* BAD arrived" token)
1384                     (setq token (symbol-name token))
1385                     (elmo-unintern token)
1386                     (setq elmo-imap4-reached-tag token)
1387                     (let (code text)
1388                       (when (eq (char-after (point)) ?\[)
1389                         (setq code (buffer-substring (point)
1390                                                      (search-forward "]")))
1391                         (elmo-imap4-forward))
1392                       (setq text (buffer-substring (point) (point-max)))
1393                       (list 'bad (list code text)))))
1394              (t   (list 'garbage (buffer-string)))))))))
1395
1396 (defun elmo-imap4-parse-bye ()
1397   (let (code text)
1398     (when (eq (char-after (point)) ?\[)
1399       (setq code (buffer-substring (point)
1400                                    (search-forward "]")))
1401       (elmo-imap4-forward))
1402     (setq text (buffer-substring (point) (point-max)))
1403     (list 'bye (list code text))))
1404
1405 (defun elmo-imap4-parse-text ()
1406   (goto-char (point-min))
1407   (when (search-forward "[" nil t)
1408     (search-forward "]")
1409     (elmo-imap4-forward))
1410   (list 'text (buffer-substring (point) (point-max))))
1411
1412 (defun elmo-imap4-parse-resp-text-code ()
1413   (when (eq (char-after (point)) ?\[)
1414     (elmo-imap4-forward)
1415     (cond ((search-forward "PERMANENTFLAGS " nil t)
1416            (list 'permanentflags (elmo-imap4-parse-flag-list)))
1417           ((search-forward "UIDNEXT " nil t)
1418            (list 'uidnext (elmo-read (current-buffer))))
1419           ((search-forward "UNSEEN " nil t)
1420            (list 'unseen (elmo-read (current-buffer))))
1421           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1422            (list 'uidvalidity (match-string 1)))
1423           ((search-forward "READ-ONLY" nil t)
1424            (list 'read-only t))
1425           ((search-forward "READ-WRITE" nil t)
1426            (list 'read-write t))
1427           ((search-forward "NEWNAME " nil t)
1428            (let (oldname newname)
1429              (setq oldname (elmo-imap4-parse-string))
1430              (elmo-imap4-forward)
1431              (setq newname (elmo-imap4-parse-string))
1432              (list 'newname newname oldname)))
1433           ((search-forward "TRYCREATE" nil t)
1434            (list 'trycreate t))
1435           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1436            (list 'appenduid
1437                  (list (match-string 1)
1438                        (string-to-number (match-string 2)))))
1439           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1440            (list 'copyuid (list (match-string 1)
1441                                 (match-string 2)
1442                                 (match-string 3))))
1443           ((search-forward "ALERT] " nil t)
1444            (message "IMAP server information: %s"
1445                     (buffer-substring (point) (point-max))))
1446           (t (list 'unknown)))))
1447
1448 (defun elmo-imap4-parse-data-list ()
1449   (let (flags delimiter mailbox)
1450     (setq flags (elmo-imap4-parse-flag-list))
1451     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1452       (setq delimiter (match-string 1))
1453       (goto-char (1+ (match-end 0)))
1454       (when (setq mailbox (elmo-imap4-parse-mailbox))
1455         (list mailbox flags delimiter)))))
1456
1457 (defsubst elmo-imap4-parse-header-list ()
1458   (when (eq (char-after (point)) ?\()
1459     (let (strlist)
1460       (while (not (eq (char-after (point)) ?\)))
1461         (elmo-imap4-forward)
1462         (push (elmo-imap4-parse-astring) strlist))
1463       (elmo-imap4-forward)
1464       (nreverse strlist))))
1465
1466 (defsubst elmo-imap4-parse-fetch-body-section ()
1467   (let ((section
1468          (buffer-substring (point)
1469                            (1-
1470                             (progn (re-search-forward "[] ]" nil t)
1471                                    (point))))))
1472     (if (eq (char-before) ? )
1473         (prog1
1474             (mapconcat 'identity
1475                        (cons section (elmo-imap4-parse-header-list)) " ")
1476           (search-forward "]" nil t))
1477       section)))
1478
1479 (defun elmo-imap4-parse-fetch (response)
1480   (when (eq (char-after (point)) ?\()
1481     (let (element list)
1482       (while (not (eq (char-after (point)) ?\)))
1483         (elmo-imap4-forward)
1484         (let ((token (elmo-imap4-fetch-read (current-buffer))))
1485           (elmo-imap4-forward)
1486           (setq element
1487                 (cond ((eq token 'UID)
1488                        (list 'uid (condition-case nil
1489                                       (elmo-read (current-buffer))
1490                                     (error nil))))
1491                       ((eq token 'FLAGS)
1492                        (list 'flags (elmo-imap4-parse-flag-list)))
1493                       ((eq token 'ENVELOPE)
1494                        (list 'envelope (elmo-imap4-parse-envelope)))
1495                       ((eq token 'INTERNALDATE)
1496                        (list 'internaldate (elmo-imap4-parse-string)))
1497                       ((eq token 'RFC822)
1498                        (list 'rfc822 (elmo-imap4-parse-nstring)))
1499                       ((eq token (intern elmo-imap4-rfc822-header))
1500                        (list 'rfc822header (elmo-imap4-parse-nstring)))
1501                       ((eq token (intern elmo-imap4-rfc822-text))
1502                        (list 'rfc822text (elmo-imap4-parse-nstring)))
1503                       ((eq token (intern elmo-imap4-rfc822-size))
1504                        (list 'rfc822size (elmo-read (current-buffer))))
1505                       ((eq token 'BODY)
1506                        (if (eq (char-before) ?\[)
1507                            (list
1508                             'bodydetail
1509                             (upcase (elmo-imap4-parse-fetch-body-section))
1510                             (and
1511                              (eq (char-after (point)) ?<)
1512                              (buffer-substring (1+ (point))
1513                                                (progn
1514                                                  (search-forward ">" nil t)
1515                                                  (point))))
1516                             (progn (elmo-imap4-forward)
1517                                    (elmo-imap4-parse-nstring)))
1518                          (list 'body (elmo-imap4-parse-body))))
1519                       ((eq token 'BODYSTRUCTURE)
1520                        (list 'bodystructure (elmo-imap4-parse-body)))))
1521           (setq list (cons element list))))
1522       (and elmo-imap4-fetch-callback
1523            (funcall elmo-imap4-fetch-callback
1524                     list elmo-imap4-fetch-callback-data))
1525       (list 'fetch list))))
1526
1527 (defun elmo-imap4-parse-status ()
1528   (let ((mailbox (elmo-imap4-parse-mailbox))
1529         status)
1530     (when (and mailbox (search-forward "(" nil t))
1531       (while (not (eq (char-after (point)) ?\)))
1532         (setq status
1533               (cons
1534                (let ((token (elmo-read (current-buffer))))
1535                  (cond ((eq token 'MESSAGES)
1536                         (list 'messages (elmo-read (current-buffer))))
1537                        ((eq token 'RECENT)
1538                         (list 'recent (elmo-read (current-buffer))))
1539                        ((eq token 'UIDNEXT)
1540                         (list 'uidnext (elmo-read (current-buffer))))
1541                        ((eq token 'UIDVALIDITY)
1542                         (and (looking-at " \\([0-9]+\\)")
1543                              (prog1 (list 'uidvalidity (match-string 1))
1544                                (goto-char (match-end 1)))))
1545                        ((eq token 'UNSEEN)
1546                         (list 'unseen (elmo-read (current-buffer))))
1547                        (t
1548                         (message
1549                          "Unknown status data %s in mailbox %s ignored"
1550                          token mailbox))))
1551                status))))
1552     (and elmo-imap4-status-callback
1553          (funcall elmo-imap4-status-callback
1554                   status
1555                   elmo-imap4-status-callback-data))
1556     (list 'status status)))
1557
1558
1559 (defmacro elmo-imap4-value (value)
1560   (` (if (eq (, value) 'NIL) nil
1561        (, value))))
1562
1563 (defmacro elmo-imap4-nth (pos list)
1564   (` (let ((value (nth (, pos) (, list))))
1565        (elmo-imap4-value value))))
1566
1567 (defun elmo-imap4-parse-namespace ()
1568   (list 'namespace
1569         (nconc
1570          (copy-sequence elmo-imap4-extra-namespace-alist)
1571          (elmo-imap4-parse-namespace-subr
1572           (elmo-read (concat "(" (buffer-substring
1573                                   (point) (point-max))
1574                              ")"))))))
1575
1576 (defun elmo-imap4-parse-namespace-subr (ns)
1577   (let (prefix delim namespace-alist default-delim)
1578     ;; 0: personal, 1: other, 2: shared
1579     (dotimes (i 3)
1580       (setq namespace-alist
1581             (nconc namespace-alist
1582                    (delq nil
1583                          (mapcar
1584                           (lambda (namespace)
1585                             (setq prefix (elmo-imap4-nth 0 namespace)
1586                                   delim (elmo-imap4-nth 1 namespace))
1587                             (if (and prefix delim
1588                                      (string-match
1589                                       (concat (regexp-quote delim) "\\'")
1590                                       prefix))
1591                                 (setq prefix (substring prefix 0
1592                                                         (match-beginning 0))))
1593                             (if (eq (length prefix) 0)
1594                                 (progn (setq default-delim delim) nil)
1595                               (cons
1596                                (concat "^\\("
1597                                        (if (string= (downcase prefix) "inbox")
1598                                            "[Ii][Nn][Bb][Oo][Xx]"
1599                                          (regexp-quote prefix))
1600                                        "\\).*$")
1601                                delim)))
1602                           (elmo-imap4-nth i ns))))))
1603     (if default-delim
1604         (setq namespace-alist
1605               (nconc namespace-alist
1606                      (list (cons "^.*$" default-delim)))))
1607     namespace-alist))
1608
1609 (defun elmo-imap4-parse-acl ()
1610   (let ((mailbox (elmo-imap4-parse-mailbox))
1611         identifier rights acl)
1612     (while (eq (char-after (point)) ?\ )
1613       (elmo-imap4-forward)
1614       (setq identifier (elmo-imap4-parse-astring))
1615       (elmo-imap4-forward)
1616       (setq rights (elmo-imap4-parse-astring))
1617       (setq acl (append acl (list (cons identifier rights)))))
1618     (list 'acl acl mailbox)))
1619
1620 (defun elmo-imap4-parse-flag-list ()
1621   (let ((str (buffer-substring (+ (point) 1)
1622                                (progn (search-forward ")" nil t)
1623                                       (- (point) 1)))))
1624     (unless (eq (length str) 0)
1625       (split-string str))))
1626
1627 (defun elmo-imap4-parse-envelope ()
1628   (when (eq (char-after (point)) ?\()
1629     (elmo-imap4-forward)
1630     (vector (prog1 (elmo-imap4-parse-nstring);; date
1631               (elmo-imap4-forward))
1632             (prog1 (elmo-imap4-parse-nstring);; subject
1633               (elmo-imap4-forward))
1634             (prog1 (elmo-imap4-parse-address-list);; from
1635               (elmo-imap4-forward))
1636             (prog1 (elmo-imap4-parse-address-list);; sender
1637               (elmo-imap4-forward))
1638             (prog1 (elmo-imap4-parse-address-list);; reply-to
1639               (elmo-imap4-forward))
1640             (prog1 (elmo-imap4-parse-address-list);; to
1641               (elmo-imap4-forward))
1642             (prog1 (elmo-imap4-parse-address-list);; cc
1643               (elmo-imap4-forward))
1644             (prog1 (elmo-imap4-parse-address-list);; bcc
1645               (elmo-imap4-forward))
1646             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
1647               (elmo-imap4-forward))
1648             (prog1 (elmo-imap4-parse-nstring);; message-id
1649               (elmo-imap4-forward)))))
1650
1651 (defsubst elmo-imap4-parse-string-list ()
1652   (cond ((eq (char-after (point)) ?\();; body-fld-param
1653          (let (strlist str)
1654            (elmo-imap4-forward)
1655            (while (setq str (elmo-imap4-parse-string))
1656              (push str strlist)
1657              (elmo-imap4-forward))
1658            (nreverse strlist)))
1659         ((elmo-imap4-parse-nil)
1660          nil)))
1661
1662 (defun elmo-imap4-parse-body-extension ()
1663   (if (eq (char-after (point)) ?\()
1664       (let (b-e)
1665         (elmo-imap4-forward)
1666         (push (elmo-imap4-parse-body-extension) b-e)
1667         (while (eq (char-after (point)) ?\ )
1668           (elmo-imap4-forward)
1669           (push (elmo-imap4-parse-body-extension) b-e))
1670         (assert (eq (char-after (point)) ?\)))
1671         (elmo-imap4-forward)
1672         (nreverse b-e))
1673     (or (elmo-imap4-parse-number)
1674         (elmo-imap4-parse-nstring))))
1675
1676 (defsubst elmo-imap4-parse-body-ext ()
1677   (let (ext)
1678     (when (eq (char-after (point)) ?\ );; body-fld-dsp
1679       (elmo-imap4-forward)
1680       (let (dsp)
1681         (if (eq (char-after (point)) ?\()
1682             (progn
1683               (elmo-imap4-forward)
1684               (push (elmo-imap4-parse-string) dsp)
1685               (elmo-imap4-forward)
1686               (push (elmo-imap4-parse-string-list) dsp)
1687               (elmo-imap4-forward))
1688           (assert (elmo-imap4-parse-nil)))
1689         (push (nreverse dsp) ext))
1690       (when (eq (char-after (point)) ?\ );; body-fld-lang
1691         (elmo-imap4-forward)
1692         (if (eq (char-after (point)) ?\()
1693             (push (elmo-imap4-parse-string-list) ext)
1694           (push (elmo-imap4-parse-nstring) ext))
1695         (while (eq (char-after (point)) ?\ );; body-extension
1696           (elmo-imap4-forward)
1697           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
1698     ext))
1699
1700 (defun elmo-imap4-parse-body ()
1701   (let (body)
1702     (when (eq (char-after (point)) ?\()
1703       (elmo-imap4-forward)
1704       (if (eq (char-after (point)) ?\()
1705           (let (subbody)
1706             (while (and (eq (char-after (point)) ?\()
1707                         (setq subbody (elmo-imap4-parse-body)))
1708               (push subbody body))
1709             (elmo-imap4-forward)
1710             (push (elmo-imap4-parse-string) body);; media-subtype
1711             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
1712               (elmo-imap4-forward)
1713               (if (eq (char-after (point)) ?\();; body-fld-param
1714                   (push (elmo-imap4-parse-string-list) body)
1715                 (push (and (elmo-imap4-parse-nil) nil) body))
1716               (setq body
1717                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
1718             (assert (eq (char-after (point)) ?\)))
1719             (elmo-imap4-forward)
1720             (nreverse body))
1721
1722         (push (elmo-imap4-parse-string) body);; media-type
1723         (elmo-imap4-forward)
1724         (push (elmo-imap4-parse-string) body);; media-subtype
1725         (elmo-imap4-forward)
1726         ;; next line for Sun SIMS bug
1727         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
1728         (if (eq (char-after (point)) ?\();; body-fld-param
1729             (push (elmo-imap4-parse-string-list) body)
1730           (push (and (elmo-imap4-parse-nil) nil) body))
1731         (elmo-imap4-forward)
1732         (push (elmo-imap4-parse-nstring) body);; body-fld-id
1733         (elmo-imap4-forward)
1734         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
1735         (elmo-imap4-forward)
1736         (push (elmo-imap4-parse-string) body);; body-fld-enc
1737         (elmo-imap4-forward)
1738         (push (elmo-imap4-parse-number) body);; body-fld-octets
1739
1740         ;; ok, we're done parsing the required parts, what comes now is one
1741         ;; of three things:
1742         ;;
1743         ;; envelope       (then we're parsing body-type-msg)
1744         ;; body-fld-lines (then we're parsing body-type-text)
1745         ;; body-ext-1part (then we're parsing body-type-basic)
1746         ;;
1747         ;; the problem is that the two first are in turn optionally followed
1748         ;; by the third.  So we parse the first two here (if there are any)...
1749
1750         (when (eq (char-after (point)) ?\ )
1751           (elmo-imap4-forward)
1752           (let (lines)
1753             (cond ((eq (char-after (point)) ?\();; body-type-msg:
1754                    (push (elmo-imap4-parse-envelope) body);; envelope
1755                    (elmo-imap4-forward)
1756                    (push (elmo-imap4-parse-body) body);; body
1757                    (elmo-imap4-forward)
1758                    (push (elmo-imap4-parse-number) body));; body-fld-lines
1759                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
1760                    (push lines body));; body-fld-lines
1761                   (t
1762                    (backward-char)))));; no match...
1763
1764         ;; ...and then parse the third one here...
1765
1766         (when (eq (char-after (point)) ?\ );; body-ext-1part:
1767           (elmo-imap4-forward)
1768           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
1769           (setq body
1770                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
1771
1772         (assert (eq (char-after (point)) ?\)))
1773         (elmo-imap4-forward)
1774         (nreverse body)))))
1775
1776 (luna-define-method elmo-folder-initialize :around ((folder
1777                                                      elmo-imap4-folder)
1778                                                     name)
1779   (let ((default-user   elmo-imap4-default-user)
1780         (default-server elmo-imap4-default-server)
1781         (default-port   elmo-imap4-default-port)
1782         (elmo-network-stream-type-alist
1783          (if elmo-imap4-stream-type-alist
1784              (append elmo-imap4-stream-type-alist
1785                      elmo-network-stream-type-alist)
1786            elmo-network-stream-type-alist))
1787         parse)
1788     (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
1789       ;; case: imap4-default-server is specified like
1790       ;; "hoge%imap.server@gateway".
1791       (setq default-user (elmo-match-string 1 default-server))
1792       (setq default-server (elmo-match-string 2 default-server)))
1793     (setq name (luna-call-next-method))
1794     ;; mailbox
1795     (setq parse (elmo-parse-token name ":"))
1796     (elmo-imap4-folder-set-mailbox-internal folder
1797                                             (elmo-imap4-encode-folder-string
1798                                              (car parse)))
1799     ;; user
1800     (setq parse (elmo-parse-prefixed-element ?: (cdr parse) "/"))
1801     (elmo-net-folder-set-user-internal folder
1802                                        (if (eq (length (car parse)) 0)
1803                                            default-user
1804                                          (car parse)))
1805     ;; auth
1806     (setq parse (elmo-parse-prefixed-element ?/ (cdr parse)))
1807     (elmo-net-folder-set-auth-internal
1808      folder
1809      (if (eq (length (car parse)) 0)
1810          (or elmo-imap4-default-authenticate-type 'clear)
1811        (intern (car parse))))
1812     (unless (elmo-net-folder-server-internal folder)
1813       (elmo-net-folder-set-server-internal folder default-server))
1814     (unless (elmo-net-folder-port-internal folder)
1815       (elmo-net-folder-set-port-internal folder default-port))
1816     (unless (elmo-net-folder-stream-type-internal folder)
1817       (elmo-net-folder-set-stream-type-internal
1818        folder
1819        (elmo-get-network-stream-type elmo-imap4-default-stream-type)))
1820     folder))
1821
1822 ;;; ELMO IMAP4 folder
1823 (luna-define-method elmo-folder-expand-msgdb-path ((folder
1824                                                     elmo-imap4-folder))
1825   (convert-standard-filename
1826    (let ((mailbox (elmo-imap4-folder-mailbox-internal folder)))
1827      (if (string= "inbox" (downcase mailbox))
1828          (setq mailbox "inbox"))
1829      (if (eq (string-to-char mailbox) ?/)
1830          (setq mailbox (substring mailbox 1 (length mailbox))))
1831      (expand-file-name
1832       mailbox
1833       (expand-file-name
1834        (or (elmo-net-folder-user-internal folder) "nobody")
1835        (expand-file-name (or (elmo-net-folder-server-internal folder)
1836                              "nowhere")
1837                          (expand-file-name
1838                           "imap"
1839                           elmo-msgdb-directory)))))))
1840
1841 (luna-define-method elmo-folder-status-plugged ((folder
1842                                                  elmo-imap4-folder))
1843   (elmo-imap4-folder-status-plugged folder))
1844
1845 (defun elmo-imap4-folder-status-plugged (folder)
1846   (let ((session (elmo-imap4-get-session folder))
1847         (killed (elmo-msgdb-killed-list-load
1848                  (elmo-folder-msgdb-path folder)))
1849         status)
1850     (with-current-buffer (elmo-network-session-buffer session)
1851       (setq elmo-imap4-status-callback nil)
1852       (setq elmo-imap4-status-callback-data nil))
1853     (setq status (elmo-imap4-response-value
1854                   (elmo-imap4-send-command-wait
1855                    session
1856                    (list "status "
1857                          (elmo-imap4-mailbox
1858                           (elmo-imap4-folder-mailbox-internal folder))
1859                          " (uidnext messages)"))
1860                   'status))
1861     (cons
1862      (- (elmo-imap4-response-value status 'uidnext) 1)
1863      (if killed
1864          (-
1865           (elmo-imap4-response-value status 'messages)
1866           (elmo-msgdb-killed-list-length killed))
1867        (elmo-imap4-response-value status 'messages)))))
1868
1869 (luna-define-method elmo-folder-list-messages-plugged ((folder
1870                                                         elmo-imap4-folder)
1871                                                        &optional nohide)
1872   (elmo-imap4-list folder
1873                    (let ((max (elmo-msgdb-max-of-killed
1874                                (elmo-folder-killed-list-internal folder))))
1875                      (if (or nohide
1876                              (null (eq max 0)))
1877                          (format "uid %d:*" (1+ max))
1878                        "all"))))
1879
1880 (luna-define-method elmo-folder-list-unreads-plugged
1881   ((folder elmo-imap4-folder))
1882   (elmo-imap4-list folder "unseen"))
1883
1884 (luna-define-method elmo-folder-list-importants-plugged
1885   ((folder elmo-imap4-folder))
1886   (elmo-imap4-list folder "flagged"))
1887
1888 (luna-define-method elmo-folder-list-answereds-plugged
1889   ((folder elmo-imap4-folder))
1890   (elmo-imap4-list folder "answered"))
1891
1892 (defun elmo-imap4-folder-list-any-plugged (folder)
1893   (elmo-imap4-list folder "or answered or unseen flagged"))
1894
1895 (luna-define-method elmo-folder-use-flag-p ((folder elmo-imap4-folder))
1896   (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
1897                      (elmo-imap4-folder-mailbox-internal folder))))
1898
1899 (luna-define-method elmo-folder-list-subfolders ((folder elmo-imap4-folder)
1900                                                  &optional one-level)
1901   (let* ((root (elmo-imap4-folder-mailbox-internal folder))
1902          (session (elmo-imap4-get-session folder))
1903          (prefix (elmo-folder-prefix-internal folder))
1904          (delim (or
1905                  (cdr
1906                   (elmo-string-matched-assoc
1907                    root
1908                    (with-current-buffer (elmo-network-session-buffer session)
1909                      elmo-imap4-server-namespace)))
1910                  elmo-imap4-default-hierarchy-delimiter))
1911          ;; Append delimiter when root with namespace.
1912          (root (if (and (match-end 1)
1913                         (string= (substring root (match-end 1))
1914                                  ""))
1915                    (concat root delim)
1916                  root))
1917          result append-serv type)
1918     (setq result (elmo-imap4-response-get-selectable-mailbox-list
1919                   (elmo-imap4-send-command-wait
1920                    session
1921                    (list "list " (elmo-imap4-mailbox root) " *"))))
1922     (when (or (not (string= (elmo-net-folder-user-internal folder)
1923                             elmo-imap4-default-user))
1924               (not (eq (elmo-net-folder-auth-internal folder)
1925                        (or elmo-imap4-default-authenticate-type 'clear))))
1926       (setq append-serv (concat ":" (elmo-net-folder-user-internal folder))))
1927     (unless (eq (elmo-net-folder-auth-internal folder)
1928                 (or elmo-imap4-default-authenticate-type 'clear))
1929       (setq append-serv
1930             (concat append-serv "/"
1931                     (symbol-name (elmo-net-folder-auth-internal folder)))))
1932     (unless (string= (elmo-net-folder-server-internal folder)
1933                      elmo-imap4-default-server)
1934       (setq append-serv (concat append-serv "@"
1935                                 (elmo-net-folder-server-internal folder))))
1936     (unless (eq (elmo-net-folder-port-internal folder) elmo-imap4-default-port)
1937       (setq append-serv (concat append-serv ":"
1938                                 (int-to-string
1939                                  (elmo-net-folder-port-internal folder)))))
1940     (setq type (elmo-net-folder-stream-type-internal folder))
1941     (unless (eq (elmo-network-stream-type-symbol type)
1942                 elmo-imap4-default-stream-type)
1943       (if type
1944           (setq append-serv (concat append-serv
1945                                     (elmo-network-stream-type-spec-string
1946                                      type)))))
1947     (if one-level
1948         (let ((re-delim (regexp-quote delim))
1949               (case-fold-search nil)
1950               folder ret has-child-p)
1951           ;; Append delimiter
1952           (when (and root
1953                      (not (string= root ""))
1954                      (not (string-match
1955                            (concat "\\(.*\\)" re-delim "\\'")
1956                            root)))
1957             (setq root (concat root delim)))
1958           (while (setq folder (car result))
1959             (when (string-match
1960                    (concat "^\\(" (regexp-quote root) "[^" re-delim "]" "+\\)"
1961                            re-delim)
1962                    folder)
1963               (setq folder (match-string 1 folder)))
1964             (setq has-child-p nil
1965                   result (delq
1966                           nil
1967                           (mapcar (lambda (fld)
1968                                     (if (string-match
1969                                          (concat "^" (regexp-quote folder)
1970                                                  "\\(" re-delim "\\|\\'\\)")
1971                                          fld)
1972                                         (progn (setq has-child-p t) nil)
1973                                       fld))
1974                                   (cdr result)))
1975                   folder (concat prefix
1976                                  (elmo-imap4-decode-folder-string folder)
1977                                  (and append-serv
1978                                       (eval append-serv)))
1979                   ret (append ret (if has-child-p
1980                                       (list (list folder))
1981                                     (list folder)))))
1982           ret)
1983       (mapcar (lambda (fld)
1984                 (concat prefix (elmo-imap4-decode-folder-string fld)
1985                         (and append-serv
1986                              (eval append-serv))))
1987               result))))
1988
1989 (luna-define-method elmo-folder-exists-p-plugged ((folder elmo-imap4-folder))
1990   (let ((session (elmo-imap4-get-session folder)))
1991     (if (string=
1992          (elmo-imap4-session-current-mailbox-internal session)
1993          (elmo-imap4-folder-mailbox-internal folder))
1994         t
1995       (elmo-imap4-session-select-mailbox
1996        session
1997        (elmo-imap4-folder-mailbox-internal folder)
1998        'force 'notify-bye))))
1999
2000 (luna-define-method elmo-folder-creatable-p ((folder elmo-imap4-folder))
2001   t)
2002
2003 (luna-define-method elmo-folder-writable-p ((folder elmo-imap4-folder))
2004   t)
2005
2006 (luna-define-method elmo-folder-delete :before ((folder elmo-imap4-folder))
2007   (let ((session (elmo-imap4-get-session folder))
2008         msgs)
2009     (when (elmo-imap4-folder-mailbox-internal folder)
2010       (when (setq msgs (elmo-folder-list-messages folder))
2011         (elmo-folder-delete-messages folder msgs))
2012       (elmo-imap4-send-command-wait session "close")
2013       (elmo-imap4-send-command-wait
2014        session
2015        (list "delete "
2016              (elmo-imap4-mailbox
2017               (elmo-imap4-folder-mailbox-internal folder)))))))
2018
2019 (luna-define-method elmo-folder-rename-internal ((folder elmo-imap4-folder)
2020                                                  new-folder)
2021   (let ((session (elmo-imap4-get-session folder)))
2022     ;; make sure the folder is selected.
2023     (elmo-imap4-session-select-mailbox session
2024                                        (elmo-imap4-folder-mailbox-internal
2025                                         folder))
2026     (elmo-imap4-send-command-wait session "close")
2027     (elmo-imap4-send-command-wait
2028      session
2029      (list "rename "
2030            (elmo-imap4-mailbox
2031             (elmo-imap4-folder-mailbox-internal folder))
2032            " "
2033            (elmo-imap4-mailbox
2034             (elmo-imap4-folder-mailbox-internal new-folder))))
2035     (elmo-imap4-session-set-current-mailbox-internal
2036      session (elmo-imap4-folder-mailbox-internal new-folder))))
2037
2038 (defun elmo-imap4-copy-messages (src-folder dst-folder numbers)
2039   (let ((session (elmo-imap4-get-session src-folder))
2040         (set-list (elmo-imap4-make-number-set-list
2041                    numbers
2042                    elmo-imap4-number-set-chop-length))
2043         succeeds)
2044     (elmo-imap4-session-select-mailbox session
2045                                        (elmo-imap4-folder-mailbox-internal
2046                                         src-folder))
2047     (while set-list
2048       (if (elmo-imap4-send-command-wait session
2049                                         (list
2050                                          (format
2051                                           (if elmo-imap4-use-uid
2052                                               "uid copy %s "
2053                                             "copy %s ")
2054                                           (cdr (car set-list)))
2055                                          (elmo-imap4-mailbox
2056                                           (elmo-imap4-folder-mailbox-internal
2057                                            dst-folder))))
2058           (setq succeeds (append succeeds numbers)))
2059       (setq set-list (cdr set-list)))
2060     succeeds))
2061
2062 (defun elmo-imap4-set-flag (folder numbers flag &optional remove)
2063   "Set flag on messages.
2064 FOLDER is the ELMO folder structure.
2065 NUMBERS is the message numbers to be flagged.
2066 FLAG is the flag name.
2067 If optional argument REMOVE is non-nil, remove FLAG."
2068   (let ((session (elmo-imap4-get-session folder))
2069         response set-list)
2070     (elmo-imap4-session-select-mailbox session
2071                                        (elmo-imap4-folder-mailbox-internal
2072                                         folder))
2073     (setq set-list (elmo-imap4-make-number-set-list
2074                     numbers
2075                     elmo-imap4-number-set-chop-length))
2076     (while set-list
2077       (with-current-buffer (elmo-network-session-buffer session)
2078         (setq elmo-imap4-fetch-callback nil)
2079         (setq elmo-imap4-fetch-callback-data nil))
2080       (unless (elmo-imap4-response-ok-p
2081                (elmo-imap4-send-command-wait
2082                 session
2083                 (format
2084                  (if elmo-imap4-use-uid
2085                      "uid store %s %sflags.silent (%s)"
2086                    "store %s %sflags.silent (%s)")
2087                  (cdr (car set-list))
2088                  (if remove "-" "+")
2089                  flag)))
2090         (setq response 'fail))
2091       (setq set-list (cdr set-list)))
2092     (not (eq response 'fail))))
2093
2094 (luna-define-method elmo-folder-delete-messages-plugged
2095   ((folder elmo-imap4-folder) numbers)
2096   (let ((session (elmo-imap4-get-session folder)))
2097     (elmo-imap4-set-flag folder numbers "\\Deleted")
2098     (elmo-imap4-send-command-wait session "expunge")))
2099
2100 (defmacro elmo-imap4-detect-search-charset (string)
2101   (` (with-temp-buffer
2102        (insert (, string))
2103        (detect-mime-charset-region (point-min) (point-max)))))
2104
2105 (defun elmo-imap4-search-internal-primitive (folder session filter from-msgs)
2106   (let ((search-key (elmo-filter-key filter))
2107         (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"
2108                             "larger" "smaller" "mark"))
2109         (total 0)
2110         (length (length from-msgs))
2111         charset set-list end results)
2112     (message "Searching...")
2113     (cond
2114      ((string= "last" search-key)
2115       (let ((numbers (or from-msgs (elmo-folder-list-messages folder))))
2116         (nthcdr (max (- (length numbers)
2117                         (string-to-int (elmo-filter-value filter)))
2118                      0)
2119                 numbers)))
2120      ((string= "first" search-key)
2121       (let* ((numbers (or from-msgs (elmo-folder-list-messages folder)))
2122              (rest (nthcdr (string-to-int (elmo-filter-value filter) )
2123                            numbers)))
2124         (mapcar '(lambda (x) (delete x numbers)) rest)
2125         numbers))
2126      ((string= "mark" search-key)
2127       (cond
2128        ((string= "unread" (elmo-filter-value filter))
2129         (elmo-folder-list-unreads folder))
2130        ((string= "important" (elmo-filter-value filter))
2131         (elmo-folder-list-importants folder))
2132        ((string= "answered" (elmo-filter-value filter))
2133         (elmo-folder-list-answereds folder))
2134        ((string= "any" (elmo-filter-value filter))
2135         (elmo-imap4-folder-list-any-plugged folder))))
2136      ((or (string= "since" search-key)
2137           (string= "before" search-key))
2138       (setq search-key (concat "sent" search-key)
2139             set-list (elmo-imap4-make-number-set-list
2140                       from-msgs
2141                       elmo-imap4-number-set-chop-length)
2142             end nil)
2143       (while (not end)
2144         (setq results
2145               (append
2146                results
2147                (elmo-imap4-response-value
2148                 (elmo-imap4-send-command-wait
2149                  session
2150                  (format
2151                   (if elmo-imap4-use-uid
2152                       "uid search %s%s%s %s"
2153                     "search %s%s%s %s")
2154                   (if from-msgs
2155                       (concat
2156                        (if elmo-imap4-use-uid "uid ")
2157                        (cdr (car set-list))
2158                        " ")
2159                     "")
2160                   (if (eq (elmo-filter-type filter)
2161                           'unmatch)
2162                       "not " "")
2163                   search-key
2164                   (elmo-date-get-description
2165                    (elmo-date-get-datevec
2166                     (elmo-filter-value filter)))))
2167                 'search)))
2168         (when (> length elmo-display-progress-threshold)
2169           (setq total (+ total (car (car set-list))))
2170           (elmo-display-progress
2171            'elmo-imap4-search "Searching..."
2172            (/ (* total 100) length)))
2173         (setq set-list (cdr set-list)
2174               end (null set-list)))
2175       results)
2176      (t
2177       (setq charset
2178             (if (eq (length (elmo-filter-value filter)) 0)
2179                 (setq charset 'us-ascii)
2180               (elmo-imap4-detect-search-charset
2181                (elmo-filter-value filter)))
2182             set-list (elmo-imap4-make-number-set-list
2183                       from-msgs
2184                       elmo-imap4-number-set-chop-length)
2185             end nil)
2186       (while (not end)
2187         (setq results
2188               (append
2189                results
2190                (elmo-imap4-response-value
2191                 (elmo-imap4-send-command-wait
2192                  session
2193                  (list
2194                   (if elmo-imap4-use-uid "uid ")
2195                   "search "
2196                   "CHARSET "
2197                   (elmo-imap4-astring
2198                    (symbol-name charset))
2199                   " "
2200                   (if from-msgs
2201                       (concat
2202                        (if elmo-imap4-use-uid "uid ")
2203                        (cdr (car set-list))
2204                        " ")
2205                     "")
2206                   (if (eq (elmo-filter-type filter)
2207                           'unmatch)
2208                       "not " "")
2209                   (format "%s%s "
2210                           (if (member
2211                                (elmo-filter-key filter)
2212                                imap-search-keys)
2213                               ""
2214                             "header ")
2215                           (elmo-filter-key filter))
2216                   (elmo-imap4-astring
2217                    (encode-mime-charset-string
2218                     (elmo-filter-value filter) charset))))
2219                 'search)))
2220         (when (> length elmo-display-progress-threshold)
2221           (setq total (+ total (car (car set-list))))
2222           (elmo-display-progress
2223            'elmo-imap4-search "Searching..."
2224            (/ (* total 100) length)))
2225         (setq set-list (cdr set-list)
2226               end (null set-list)))
2227       results))))
2228
2229 (defun elmo-imap4-search-internal (folder session condition from-msgs)
2230   (let (result)
2231     (cond
2232      ((vectorp condition)
2233       (setq result (elmo-imap4-search-internal-primitive
2234                     folder session condition from-msgs)))
2235      ((eq (car condition) 'and)
2236       (setq result (elmo-imap4-search-internal folder session (nth 1 condition)
2237                                                from-msgs)
2238             result (elmo-list-filter result
2239                                      (elmo-imap4-search-internal
2240                                       folder session (nth 2 condition)
2241                                       from-msgs))))
2242      ((eq (car condition) 'or)
2243       (setq result (elmo-imap4-search-internal
2244                     folder session (nth 1 condition) from-msgs)
2245             result (elmo-uniq-list
2246                     (nconc result
2247                            (elmo-imap4-search-internal
2248                             folder session (nth 2 condition) from-msgs)))
2249             result (sort result '<))))))
2250
2251 (luna-define-method elmo-folder-search :around ((folder elmo-imap4-folder)
2252                                                 condition &optional numbers)
2253   (if (elmo-folder-plugged-p folder)
2254       (save-excursion
2255         (let ((session (elmo-imap4-get-session folder)))
2256           (elmo-imap4-session-select-mailbox
2257            session
2258            (elmo-imap4-folder-mailbox-internal folder))
2259           (elmo-imap4-search-internal folder session condition numbers)))
2260     (luna-call-next-method)))
2261
2262 (luna-define-method elmo-folder-msgdb-create-plugged
2263   ((folder elmo-imap4-folder) numbers seen-list)
2264   (when numbers
2265     (let ((session (elmo-imap4-get-session folder))
2266           (headers
2267            (append
2268             '("Subject" "From" "To" "Cc" "Date"
2269               "Message-Id" "References" "In-Reply-To")
2270             elmo-msgdb-extra-fields))
2271           (total 0)
2272           (length (length numbers))
2273           rfc2060 set-list)
2274       (setq rfc2060 (memq 'imap4rev1
2275                           (elmo-imap4-session-capability-internal
2276                            session)))
2277       (message "Getting overview...")
2278       (elmo-imap4-session-select-mailbox
2279        session (elmo-imap4-folder-mailbox-internal folder))
2280       (setq set-list (elmo-imap4-make-number-set-list
2281                       numbers
2282                       elmo-imap4-overview-fetch-chop-length))
2283       ;; Setup callback.
2284       (with-current-buffer (elmo-network-session-buffer session)
2285         (setq elmo-imap4-current-msgdb nil
2286               elmo-imap4-seen-messages nil
2287               elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
2288               elmo-imap4-fetch-callback-data (cons seen-list
2289                                                    (elmo-folder-use-flag-p
2290                                                     folder)))
2291         (while set-list
2292           (elmo-imap4-send-command-wait
2293            session
2294            ;; get overview entity from IMAP4
2295            (format "%sfetch %s (%s rfc822.size flags)"
2296                    (if elmo-imap4-use-uid "uid " "")
2297                    (cdr (car set-list))
2298                    (if rfc2060
2299                        (format "body.peek[header.fields %s]" headers)
2300                      (format "%s" headers))))
2301           (when (> length elmo-display-progress-threshold)
2302             (setq total (+ total (car (car set-list))))
2303             (elmo-display-progress
2304              'elmo-imap4-msgdb-create "Getting overview..."
2305              (/ (* total 100) length)))
2306           (setq set-list (cdr set-list)))
2307         (message "Getting overview...done")
2308         (when elmo-imap4-seen-messages
2309           (elmo-imap4-set-flag folder elmo-imap4-seen-messages "\\Seen"))
2310         elmo-imap4-current-msgdb))))
2311
2312 (luna-define-method elmo-folder-unmark-important-plugged
2313   ((folder elmo-imap4-folder) numbers)
2314   (elmo-imap4-set-flag folder numbers "\\Flagged" 'remove))
2315
2316 (luna-define-method elmo-folder-mark-as-important-plugged
2317   ((folder elmo-imap4-folder) numbers)
2318   (elmo-imap4-set-flag folder numbers "\\Flagged"))
2319
2320 (luna-define-method elmo-folder-unmark-read-plugged
2321   ((folder elmo-imap4-folder) numbers)
2322   (elmo-imap4-set-flag folder numbers "\\Seen" 'remove))
2323
2324 (luna-define-method elmo-folder-mark-as-read-plugged
2325   ((folder elmo-imap4-folder) numbers)
2326   (elmo-imap4-set-flag folder numbers "\\Seen"))
2327
2328 (luna-define-method elmo-folder-unmark-answered-plugged
2329   ((folder elmo-imap4-folder) numbers)
2330   (elmo-imap4-set-flag folder numbers "\\Answered" 'remove))
2331
2332 (luna-define-method elmo-folder-mark-as-answered-plugged
2333   ((folder elmo-imap4-folder) numbers)
2334   (elmo-imap4-set-flag folder numbers "\\Answered"))
2335
2336 (luna-define-method elmo-message-use-cache-p ((folder elmo-imap4-folder)
2337                                               number)
2338   elmo-imap4-use-cache)
2339
2340 (luna-define-method elmo-folder-message-appendable-p ((folder elmo-imap4-folder))
2341   (if (elmo-folder-plugged-p folder)
2342       (not (elmo-imap4-session-read-only-internal
2343             (elmo-imap4-get-session folder)))
2344     elmo-enable-disconnected-operation)) ; offline refile.
2345
2346 (luna-define-method elmo-folder-check-plugged ((folder elmo-imap4-folder))
2347   (let ((session (elmo-imap4-get-session folder 'if-exists)))
2348     (when session
2349       (if (string=
2350            (elmo-imap4-session-current-mailbox-internal session)
2351            (elmo-imap4-folder-mailbox-internal folder))
2352           (if elmo-imap4-use-select-to-update-status
2353               (elmo-imap4-session-select-mailbox
2354                session
2355                (elmo-imap4-folder-mailbox-internal folder)
2356                'force)
2357             (elmo-imap4-session-check session))))))
2358
2359 (defsubst elmo-imap4-folder-diff-plugged (folder)
2360   (let ((session (elmo-imap4-get-session folder))
2361         messages new unread response killed)
2362 ;;; (elmo-imap4-commit spec)
2363     (with-current-buffer (elmo-network-session-buffer session)
2364       (setq elmo-imap4-status-callback nil)
2365       (setq elmo-imap4-status-callback-data nil))
2366     (setq response
2367           (elmo-imap4-send-command-wait session
2368                                         (list
2369                                          "status "
2370                                          (elmo-imap4-mailbox
2371                                           (elmo-imap4-folder-mailbox-internal
2372                                            folder))
2373                                          " (recent unseen messages)")))
2374     (setq response (elmo-imap4-response-value response 'status))
2375     (setq messages (elmo-imap4-response-value response 'messages))
2376     (setq killed (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2377     (if killed
2378         (setq messages (- messages
2379                           (elmo-msgdb-killed-list-length
2380                            killed))))
2381     (setq new (elmo-imap4-response-value response 'recent)
2382           unread (elmo-imap4-response-value response 'unseen))
2383     (if (< unread new) (setq new unread))
2384     (list new unread messages)))
2385
2386 (luna-define-method elmo-folder-diff-plugged ((folder elmo-imap4-folder))
2387   (elmo-imap4-folder-diff-plugged folder))
2388
2389 (luna-define-method elmo-folder-diff-async ((folder elmo-imap4-folder)
2390                                             &optional number-alist)
2391   (setq elmo-imap4-server-diff-async-callback
2392         elmo-folder-diff-async-callback)
2393   (setq elmo-imap4-server-diff-async-callback-data
2394         elmo-folder-diff-async-callback-data)
2395   (elmo-imap4-server-diff-async folder))
2396
2397 (luna-define-method elmo-folder-open :around ((folder elmo-imap4-folder)
2398                                               &optional load-msgdb)
2399   (if (elmo-folder-plugged-p folder)
2400       (let (session mailbox msgdb result response tag)
2401         (condition-case err
2402             (progn
2403               (setq session (elmo-imap4-get-session folder)
2404                     mailbox (elmo-imap4-folder-mailbox-internal folder)
2405                     tag (elmo-imap4-send-command session
2406                                                  (list "select "
2407                                                        (elmo-imap4-mailbox
2408                                                         mailbox))))
2409               (message "Selecting %s..."
2410                        (elmo-folder-name-internal folder))
2411               (if load-msgdb
2412                   (setq msgdb (elmo-msgdb-load folder 'silent)))
2413               (elmo-folder-set-killed-list-internal
2414                folder
2415                (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2416               (if (setq result (elmo-imap4-response-ok-p
2417                                 (setq response
2418                                       (elmo-imap4-read-response session tag))))
2419                   (progn
2420                     (elmo-imap4-session-set-current-mailbox-internal
2421                      session mailbox)
2422                     (elmo-imap4-session-set-read-only-internal
2423                      session
2424                      (nth 1 (assq 'read-only (assq 'ok response)))))
2425                 (elmo-imap4-session-set-current-mailbox-internal session nil)
2426                 (if (elmo-imap4-response-bye-p response)
2427                     (elmo-imap4-process-bye session)
2428                   (error (or
2429                           (elmo-imap4-response-error-text response)
2430                           (format "Select %s failed" mailbox)))))
2431               (message "Selecting %s...done"
2432                        (elmo-folder-name-internal folder))
2433               (elmo-folder-set-msgdb-internal
2434                folder msgdb))
2435           (quit
2436            (if (elmo-imap4-response-ok-p response)
2437                (elmo-imap4-session-set-current-mailbox-internal
2438                 session mailbox)
2439              (and session
2440                   (elmo-imap4-session-set-current-mailbox-internal
2441                    session nil))))
2442           (error
2443            (if (elmo-imap4-response-ok-p response)
2444                (elmo-imap4-session-set-current-mailbox-internal
2445                 session mailbox)
2446              (and session
2447                   (elmo-imap4-session-set-current-mailbox-internal
2448                    session nil))))))
2449     (luna-call-next-method)))
2450
2451 ;; elmo-folder-open-internal: do nothing.
2452
2453 (luna-define-method elmo-find-fetch-strategy
2454   ((folder elmo-imap4-folder) entity &optional ignore-cache)
2455   (let ((number (elmo-msgdb-overview-entity-get-number entity))
2456         cache-file size message-id)
2457     (setq size (elmo-msgdb-overview-entity-get-size entity))
2458     (setq message-id (elmo-msgdb-overview-entity-get-id entity))
2459     (setq cache-file (elmo-file-cache-get message-id))
2460     (if (or ignore-cache
2461             (null (elmo-file-cache-status cache-file)))
2462         (if (and elmo-message-fetch-threshold
2463                  (integerp size)
2464                  (>= size elmo-message-fetch-threshold)
2465                  (or (not elmo-message-fetch-confirm)
2466                      (not (prog1 (y-or-n-p
2467                                   (format
2468                                    "Fetch entire message at once? (%dbytes)"
2469                                    size))
2470                             (message "")))))
2471             ;; Fetch message as imap message.
2472             (elmo-make-fetch-strategy 'section
2473                                       nil
2474                                       (elmo-message-use-cache-p
2475                                        folder number)
2476                                       (elmo-file-cache-path
2477                                        cache-file))
2478           ;; Don't use existing cache and fetch entire message at once.
2479           (elmo-make-fetch-strategy 'entire nil
2480                                     (elmo-message-use-cache-p
2481                                      folder number)
2482                                     (elmo-file-cache-path cache-file)))
2483       ;; Cache found and use it.
2484       (if (not ignore-cache)
2485           (if (eq (elmo-file-cache-status cache-file) 'section)
2486               ;; Fetch message with imap message.
2487               (elmo-make-fetch-strategy 'section
2488                                         t
2489                                         (elmo-message-use-cache-p
2490                                          folder number)
2491                                         (elmo-file-cache-path
2492                                          cache-file))
2493             (elmo-make-fetch-strategy 'entire
2494                                       t
2495                                       (elmo-message-use-cache-p
2496                                        folder number)
2497                                       (elmo-file-cache-path
2498                                        cache-file)))))))
2499
2500 (luna-define-method elmo-folder-create-plugged ((folder elmo-imap4-folder))
2501   (elmo-imap4-send-command-wait
2502    (elmo-imap4-get-session folder)
2503    (list "create "
2504          (elmo-imap4-mailbox
2505           (elmo-imap4-folder-mailbox-internal folder)))))
2506
2507 (luna-define-method elmo-folder-append-buffer
2508   ((folder elmo-imap4-folder) unread &optional number)
2509   (if (elmo-folder-plugged-p folder)
2510       (let ((session (elmo-imap4-get-session folder))
2511             send-buffer result)
2512         (elmo-imap4-session-select-mailbox session
2513                                            (elmo-imap4-folder-mailbox-internal
2514                                             folder))
2515         (setq send-buffer (elmo-imap4-setup-send-buffer))
2516         (unwind-protect
2517             (setq result
2518                   (elmo-imap4-send-command-wait
2519                    session
2520                    (list
2521                     "append "
2522                     (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal
2523                                          folder))
2524                     (if unread " () " " (\\Seen) ")
2525                     (elmo-imap4-buffer-literal send-buffer))))
2526           (kill-buffer send-buffer))
2527         result)
2528     ;; Unplugged
2529     (if elmo-enable-disconnected-operation
2530         (elmo-folder-append-buffer-dop folder unread number)
2531       (error "Unplugged"))))
2532
2533 (eval-when-compile
2534   (defmacro elmo-imap4-identical-system-p (folder1 folder2)
2535     "Return t if FOLDER1 and FOLDER2 are in the same IMAP4 system."
2536     (` (and (string= (elmo-net-folder-server-internal (, folder1))
2537                      (elmo-net-folder-server-internal (, folder2)))
2538             (eq (elmo-net-folder-port-internal (, folder1))
2539                 (elmo-net-folder-port-internal (, folder2)))
2540             (string= (elmo-net-folder-user-internal (, folder1))
2541                      (elmo-net-folder-user-internal (, folder2)))))))
2542
2543 (luna-define-method elmo-folder-append-messages :around
2544   ((folder elmo-imap4-folder) src-folder numbers &optional same-number)
2545   (if (and (eq (elmo-folder-type-internal src-folder) 'imap4)
2546            (elmo-imap4-identical-system-p folder src-folder)
2547            (elmo-folder-plugged-p folder))
2548       ;; Plugged
2549       (prog1
2550           (elmo-imap4-copy-messages src-folder folder numbers)
2551         (elmo-progress-notify 'elmo-folder-move-messages (length numbers)))
2552     (luna-call-next-method)))
2553
2554 (luna-define-method elmo-message-deletable-p ((folder elmo-imap4-folder)
2555                                               number)
2556   (if (elmo-folder-plugged-p folder)
2557       (not (elmo-imap4-session-read-only-internal
2558             (elmo-imap4-get-session folder)))
2559     elmo-enable-disconnected-operation)) ; offline refile.
2560
2561 ;(luna-define-method elmo-message-fetch-unplugged
2562 ;  ((folder elmo-imap4-folder)
2563 ;   number strategy  &optional section outbuf unseen)
2564 ;  (error "%d%s is not cached." number (if section
2565 ;                                         (format "(%s)" section)
2566 ;                                       "")))
2567
2568 (defsubst elmo-imap4-message-fetch (folder number strategy
2569                                            section outbuf unseen)
2570   (let ((session (elmo-imap4-get-session folder))
2571         response)
2572     (elmo-imap4-session-select-mailbox session
2573                                        (elmo-imap4-folder-mailbox-internal
2574                                         folder))
2575     (with-current-buffer (elmo-network-session-buffer session)
2576       (setq elmo-imap4-fetch-callback nil)
2577       (setq elmo-imap4-fetch-callback-data nil))
2578     (unless elmo-inhibit-display-retrieval-progress
2579       (setq elmo-imap4-display-literal-progress t))
2580     (unwind-protect
2581         (setq response
2582               (elmo-imap4-send-command-wait session
2583                                             (format
2584                                              (if elmo-imap4-use-uid
2585                                                  "uid fetch %s body%s[%s]"
2586                                                "fetch %s body%s[%s]")
2587                                              number
2588                                              (if unseen ".peek" "")
2589                                              (or section "")
2590                                              )))
2591       (setq elmo-imap4-display-literal-progress nil))
2592     (unless elmo-inhibit-display-retrieval-progress
2593       (elmo-display-progress 'elmo-imap4-display-literal-progress
2594                              "Retrieving..." 100)  ; remove progress bar.
2595       (message "Retrieving...done."))
2596     (if (setq response (elmo-imap4-response-bodydetail-text
2597                         (elmo-imap4-response-value-all
2598                          response 'fetch)))
2599         (with-current-buffer outbuf
2600           (erase-buffer)
2601           (insert response)
2602           t))))
2603
2604 (luna-define-method elmo-message-fetch-plugged ((folder elmo-imap4-folder)
2605                                                 number strategy
2606                                                 &optional section
2607                                                 outbuf unseen)
2608   (elmo-imap4-message-fetch folder number strategy section outbuf unseen))
2609
2610 (luna-define-method elmo-message-fetch-field ((folder elmo-imap4-folder)
2611                                               number field)
2612   (let ((session (elmo-imap4-get-session folder)))
2613     (elmo-imap4-session-select-mailbox session
2614                                        (elmo-imap4-folder-mailbox-internal
2615                                         folder))
2616     (with-current-buffer (elmo-network-session-buffer session)
2617       (setq elmo-imap4-fetch-callback nil)
2618       (setq elmo-imap4-fetch-callback-data nil))
2619     (with-temp-buffer
2620       (insert
2621        (elmo-imap4-response-bodydetail-text
2622         (elmo-imap4-response-value
2623          (elmo-imap4-send-command-wait session
2624                                        (concat
2625                                         (if elmo-imap4-use-uid
2626                                             "uid ")
2627                                         (format
2628                                          "fetch %s (body.peek[header.fields (%s)])"
2629                                          number field)))
2630          'fetch)))
2631       (elmo-delete-cr-buffer)
2632       (goto-char (point-min))
2633       (std11-field-body (symbol-name field)))))
2634
2635 (luna-define-method elmo-folder-search-requires-msgdb-p ((folder
2636                                                           elmo-imap4-folder)
2637                                                          condition)
2638   nil)
2639
2640 (require 'product)
2641 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2642
2643 ;;; elmo-imap4.el ends here