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