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