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