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