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