elmo/elmo-imap4.el

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