elmo/elmo-imap4.el

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