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                 (or elmo-default-imap4-authenticate-type 'clear))
 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) delim)
 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 &optional nohide)
 753   (let* ((killed (and elmo-use-killed-list
 754                       (elmo-msgdb-killed-list-load
 755                        (elmo-msgdb-expand-path spec))))
 756          (max (elmo-msgdb-max-of-killed killed))
 757          numbers)
 758     (setq numbers (elmo-imap4-list spec
 759                                    (if (or nohide
 760                                            (null (eq max 0)))
 761                                        (format "uid %d:*" (1+ max))
 762                                      "all")))
 763     (elmo-living-messages numbers killed)))
 764
 765 (defun elmo-imap4-list-folder-unread (spec number-alist mark-alist
 766                                            unread-marks)
 767   (if (and (elmo-imap4-plugged-p spec)
 768            (elmo-imap4-use-flag-p spec))
 769       (elmo-imap4-list spec "unseen")
 770     (elmo-generic-list-folder-unread spec number-alist mark-alist
 771                                      unread-marks)))
 772
 773 (defun elmo-imap4-list-folder-important (spec number-alist)
 774   (if (and (elmo-imap4-plugged-p spec)
 775            (elmo-imap4-use-flag-p spec))
 776       (elmo-imap4-list spec "flagged")))
 777
 778 (defmacro elmo-imap4-detect-search-charset (string)
 779   (` (with-temp-buffer
 780        (insert (, string))
 781        (detect-mime-charset-region (point-min) (point-max)))))
 782
 783 (defun elmo-imap4-search-internal-primitive (spec session filter from-msgs)
 784   (let ((search-key (elmo-filter-key filter))
 785         (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"))
 786         charset)
 787     (cond
 788      ((string= "last" search-key)
 789       (let ((numbers (or from-msgs (elmo-imap4-list-folder spec))))
 790         (nthcdr (max (- (length numbers)
 791                         (string-to-int (elmo-filter-value filter)))
 792                      0)
 793                 numbers)))
 794      ((string= "first" search-key)
 795       (let* ((numbers (or from-msgs (elmo-imap4-list-folder spec)))
 796              (rest (nthcdr (string-to-int (elmo-filter-value filter) )
 797                            numbers)))
 798         (mapcar '(lambda (x) (delete x numbers)) rest)
 799         numbers))
 800      ((or (string= "since" search-key)
 801           (string= "before" search-key))
 802       (setq search-key (concat "sent" search-key))
 803       (elmo-imap4-response-value
 804        (elmo-imap4-send-command-wait session
 805                                      (format
 806                                       (if elmo-imap4-use-uid
 807                                           "uid search %s%s%s %s"
 808                                         "search %s%s%s %s")
 809                                       (if from-msgs
 810                                           (concat
 811                                            (if elmo-imap4-use-uid "uid ")
 812                                            (cdr
 813                                             (car
 814                                              (elmo-imap4-make-number-set-list
 815                                               from-msgs)))
 816                                            " ")
 817                                         "")
 818                                       (if (eq (elmo-filter-type filter)
 819                                               'unmatch)
 820                                           "not " "")
 821                                       search-key
 822                                       (elmo-date-get-description
 823                                        (elmo-date-get-datevec
 824                                         (elmo-filter-value filter)))))
 825        'search))
 826      (t
 827       (setq charset
 828             (if (eq (length (elmo-filter-value filter)) 0)
 829                 (setq charset 'us-ascii)
 830               (elmo-imap4-detect-search-charset
 831                (elmo-filter-value filter))))
 832       (elmo-imap4-response-value
 833        (elmo-imap4-send-command-wait session
 834                                      (list
 835                                       (if elmo-imap4-use-uid "uid ")
 836                                       "search "
 837                                       "CHARSET "
 838                                       (elmo-imap4-astring
 839                                        (symbol-name charset))
 840                                       " "
 841                                       (if from-msgs
 842                                           (concat
 843                                            (if elmo-imap4-use-uid "uid ")
 844                                            (cdr
 845                                             (car
 846                                              (elmo-imap4-make-number-set-list
 847                                               from-msgs)))
 848                                            " ")
 849                                         "")
 850                                       (if (eq (elmo-filter-type filter)
 851                                               'unmatch)
 852                                           "not " "")
 853                                       (format "%s%s "
 854                                               (if (member
 855                                                    (elmo-filter-key filter)
 856                                                    imap-search-keys)
 857                                                   ""
 858                                                 "header ")
 859                                               (elmo-filter-key filter))
 860                                       (elmo-imap4-astring
 861                                        (encode-mime-charset-string
 862                                         (elmo-filter-value filter) charset))))
 863        'search)))))
 864
 865 (defun elmo-imap4-search-internal (spec session condition from-msgs)
 866   (let (result)
 867     (cond
 868      ((vectorp condition)
 869       (setq result (elmo-imap4-search-internal-primitive
 870                     spec session condition from-msgs)))
 871      ((eq (car condition) 'and)
 872       (setq result (elmo-imap4-search-internal spec session (nth 1 condition)
 873                                                from-msgs)
 874             result (elmo-list-filter result
 875                                      (elmo-imap4-search-internal
 876                                       spec session (nth 2 condition)
 877                                       from-msgs))))
 878      ((eq (car condition) 'or)
 879       (setq result (elmo-imap4-search-internal
 880                     spec session (nth 1 condition) from-msgs)
 881             result (elmo-uniq-list
 882                     (nconc result
 883                            (elmo-imap4-search-internal
 884                             spec session (nth 2 condition) from-msgs)))
 885             result (sort result '<))))))
 886
 887
 888 (defun elmo-imap4-search (spec condition &optional from-msgs)
 889   (save-excursion
 890     (let ((session (elmo-imap4-get-session spec)))
 891       (elmo-imap4-session-select-mailbox
 892        session
 893        (elmo-imap4-spec-mailbox spec))
 894       (elmo-imap4-search-internal spec session condition from-msgs))))
 895
 896 (defun elmo-imap4-use-flag-p (spec)
 897   (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
 898                      (elmo-imap4-spec-mailbox spec))))
 899
 900 (static-cond
 901  ((fboundp 'float)
 902   ;; Emacs can parse dot symbol.
 903   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 904   (defvar elmo-imap4-rfc822-text "RFC822\.TEXT")
 905   (defvar elmo-imap4-rfc822-header "RFC822\.HEADER")
 906   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 907   (defvar elmo-imap4-header-fields "HEADER\.FIELDS")
 908   (defmacro elmo-imap4-replace-dot-symbols ()) ;; noop
 909   (defalias 'elmo-imap4-fetch-read 'read)
 910   )
 911  (t
 912   ;;; For Nemacs.
 913   ;; Cannot parse dot symbol.
 914   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 915   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 916   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 917   (defvar elmo-imap4-rfc822-text "RFC822_TEXT")
 918   (defvar elmo-imap4-rfc822-header "RFC822_HEADER")
 919   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 920   (defun elmo-imap4-fetch-read (buffer)
 921     (with-current-buffer buffer
 922       (let ((beg (point))
 923             token)
 924         (when (re-search-forward "[[ ]" nil t)
 925           (goto-char (match-beginning 0))
 926           (setq token (buffer-substring beg (point)))
 927           (cond ((string= token "RFC822.SIZE")
 928                  (intern elmo-imap4-rfc822-size))
 929                 ((string= token "RFC822.HEADER")
 930                  (intern elmo-imap4-rfc822-header))
 931                 ((string= token "RFC822.TEXT")
 932                  (intern elmo-imap4-rfc822-text))
 933                 ((string= token "HEADER\.FIELDS")
 934                  (intern elmo-imap4-header-fields))
 935                 (t (goto-char beg)
 936                    (elmo-read (current-buffer))))))))))
 937
 938 (defun elmo-imap4-make-number-set-list (msg-list &optional chop-length)
 939   "Make RFC2060's message set specifier from MSG-LIST.
 940 Returns a list of (NUMBER . SET-STRING).
 941 SET-STRING is the message set specifier described in RFC2060.
 942 NUMBER is contained message number in SET-STRING.
 943 Every SET-STRING does not contain number of messages longer than CHOP-LENGTH.
 944 If CHOP-LENGTH is not specified, message set is not chopped."
 945   (let (count cont-list set-list)
 946     (setq msg-list (sort (copy-sequence msg-list) '<))
 947     (while msg-list
 948       (setq cont-list nil)
 949       (setq count 0)
 950       (unless chop-length
 951         (setq chop-length (length msg-list)))
 952       (while (and (not (null msg-list))
 953                   (< count chop-length))
 954         (setq cont-list
 955               (elmo-number-set-append
 956                cont-list (car msg-list)))
 957         (incf count)
 958         (setq msg-list (cdr msg-list)))
 959       (setq set-list
 960             (cons
 961              (cons
 962               count
 963               (mapconcat
 964                (lambda (x)
 965                  (cond ((consp x)
 966                         (format "%s:%s" (car x) (cdr x)))
 967                        ((integerp x)
 968                         (int-to-string x))))
 969                cont-list
 970                ","))
 971              set-list)))
 972     (nreverse set-list)))
 973
 974 ;;
 975 ;; set mark
 976 ;; read-mark -> "\\Seen"
 977 ;; important -> "\\Flagged"
 978 ;;
 979 ;; (delete -> \\Deleted)
 980 (defun elmo-imap4-mark-set-on-msgs (spec msgs mark &optional unmark no-expunge)
 981   "SET flag of MSGS as MARK.
 982 If optional argument UNMARK is non-nil, unmark."
 983   (let ((session (elmo-imap4-get-session spec))
 984         set-list)
 985     (elmo-imap4-session-select-mailbox session
 986                                        (elmo-imap4-spec-mailbox spec))
 987     (setq set-list (elmo-imap4-make-number-set-list msgs))
 988     (when set-list
 989       (with-current-buffer (elmo-network-session-buffer session)
 990         (setq elmo-imap4-fetch-callback nil)
 991         (setq elmo-imap4-fetch-callback-data nil))
 992       (elmo-imap4-send-command-wait
 993        session
 994        (format
 995         (if elmo-imap4-use-uid
 996             "uid store %s %sflags.silent (%s)"
 997           "store %s %sflags.silent (%s)")
 998         (cdr (car set-list))
 999         (if unmark "-" "+")
1000         mark))
1001       (unless no-expunge
1002         (elmo-imap4-send-command-wait session "expunge")))
1003     t))
1004
1005 (defun elmo-imap4-mark-as-important (spec msgs)
1006   (and (elmo-imap4-use-flag-p spec)
1007        (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" nil 'no-expunge)))
1008
1009 (defun elmo-imap4-mark-as-read (spec msgs)
1010   (and (elmo-imap4-use-flag-p spec)
1011        (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" nil 'no-expunge)))
1012
1013 (defun elmo-imap4-unmark-important (spec msgs)
1014   (and (elmo-imap4-use-flag-p spec)
1015        (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" 'unmark
1016                                     'no-expunge)))
1017
1018 (defun elmo-imap4-mark-as-unread (spec msgs)
1019   (and (elmo-imap4-use-flag-p spec)
1020        (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" 'unmark 'no-expunge)))
1021
1022 (defun elmo-imap4-delete-msgs (spec msgs)
1023   (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted"))
1024
1025 (defun elmo-imap4-delete-msgs-no-expunge (spec msgs)
1026   (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted" nil 'no-expunge))
1027
1028 (defun elmo-imap4-msgdb-create-as-numlist (spec numlist new-mark already-mark
1029                                                 seen-mark important-mark
1030                                                 seen-list)
1031   "Create msgdb for SPEC for NUMLIST."
1032   (elmo-imap4-msgdb-create spec numlist new-mark already-mark
1033                            seen-mark important-mark seen-list t))
1034
1035 ;; Current buffer is process buffer.
1036 (defun elmo-imap4-fetch-callback (element app-data)
1037   (funcall elmo-imap4-fetch-callback
1038            (with-temp-buffer
1039              (insert (or (elmo-imap4-response-bodydetail-text element)
1040                          ""))
1041              ;; Delete CR.
1042              (goto-char (point-min))
1043              (while (search-forward "\r\n" nil t)
1044                (replace-match "\n"))
1045              (elmo-msgdb-create-overview-from-buffer
1046               (elmo-imap4-response-value element 'uid)
1047               (elmo-imap4-response-value element 'rfc822size)))
1048            (elmo-imap4-response-value element 'flags)
1049            app-data))
1050
1051 ;;
1052 ;; app-data:
1053 ;; cons of list
1054 ;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark
1055 ;; 4: seen-list
1056 ;; and result of use-flag-p.
1057 (defun elmo-imap4-fetch-callback-1 (entity flags app-data)
1058   "A msgdb entity callback function."
1059   (let* ((use-flag (cdr app-data))
1060          (app-data (car app-data))
1061          (seen (member (car entity) (nth 4 app-data)))
1062          mark)
1063     (if (member "\\Flagged" flags)
1064         (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data)))
1065     (setq mark (or (elmo-msgdb-global-mark-get (car entity))
1066                    (if (elmo-cache-exists-p (car entity)) ;; XXX
1067                        (if (or seen
1068                                (and use-flag
1069                                     (member "\\Seen" flags)))
1070                            nil
1071                          (nth 1 app-data))
1072                      (if (or seen
1073                              (and use-flag
1074                                   (member "\\Seen" flags)))
1075                          (if elmo-imap4-use-cache
1076                              (nth 2 app-data))
1077                        (nth 0 app-data)))))
1078     (setq elmo-imap4-current-msgdb
1079           (elmo-msgdb-append
1080            elmo-imap4-current-msgdb
1081            (list (list entity)
1082                  (list (cons (elmo-msgdb-overview-entity-get-number entity)
1083                              (car entity)))
1084                  (if mark
1085                      (list
1086                       (list (elmo-msgdb-overview-entity-get-number entity)
1087                             mark))))))))
1088
1089 (defun elmo-imap4-msgdb-create (spec numlist &rest args)
1090   "Create msgdb for SPEC."
1091   (when numlist
1092     (let ((session (elmo-imap4-get-session spec))
1093           (headers
1094            (append
1095             '("Subject" "From" "To" "Cc" "Date"
1096               "Message-Id" "References" "In-Reply-To")
1097             elmo-msgdb-extra-fields))
1098           (total 0)
1099           (length (length numlist))
1100           rfc2060 set-list)
1101       (setq rfc2060 (memq 'imap4rev1
1102                           (elmo-imap4-session-capability-internal
1103                            session)))
1104       (message "Getting overview...")
1105       (elmo-imap4-session-select-mailbox session
1106                                          (elmo-imap4-spec-mailbox spec))
1107       (setq set-list (elmo-imap4-make-number-set-list
1108                       numlist
1109                       elmo-imap4-overview-fetch-chop-length))
1110       ;; Setup callback.
1111       (with-current-buffer (elmo-network-session-buffer session)
1112         (setq elmo-imap4-current-msgdb nil
1113               elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
1114               elmo-imap4-fetch-callback-data (cons args
1115                                                    (elmo-imap4-use-flag-p
1116                                                     spec)))
1117         (while set-list
1118           (elmo-imap4-send-command-wait
1119            session
1120            ;; get overview entity from IMAP4
1121            (format "%sfetch %s (%s rfc822.size flags)"
1122                    (if elmo-imap4-use-uid "uid " "")
1123                    (cdr (car set-list))
1124                    (if rfc2060
1125                        (format "body.peek[header.fields %s]" headers)
1126                      (format "%s" headers))))
1127           (when (> length elmo-display-progress-threshold)
1128             (setq total (+ total (car (car set-list))))
1129             (elmo-display-progress
1130              'elmo-imap4-msgdb-create "Getting overview..."
1131              (/ (* total 100) length)))
1132           (setq set-list (cdr set-list)))
1133         (message "Getting overview...done")
1134         elmo-imap4-current-msgdb))))
1135
1136 (defun elmo-imap4-parse-capability (string)
1137   (if (string-match "^\\*\\(.*\\)$" string)
1138       (elmo-read
1139        (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
1140
1141 (defun elmo-imap4-clear-login (session)
1142   (let ((elmo-imap4-debug-inhibit-logging t))
1143     (or
1144      (elmo-imap4-read-ok
1145       session
1146       (elmo-imap4-send-command
1147        session
1148        (list "login "
1149              (elmo-imap4-userid (elmo-network-session-user-internal session))
1150              " "
1151              (elmo-imap4-password
1152               (elmo-get-passwd (elmo-network-session-password-key session))))))
1153      (signal 'elmo-authenticate-error '(elmo-imap4-clear-login)))))
1154
1155 (defun elmo-imap4-auth-login (session)
1156   (let ((tag (elmo-imap4-send-command session "authenticate login"))
1157         (elmo-imap4-debug-inhibit-logging t))
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-network-session-user-internal session)))
1163     (or (elmo-imap4-read-continue-req session)
1164         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1165     (elmo-imap4-send-string session
1166                             (elmo-base64-encode-string
1167                              (elmo-get-passwd
1168                               (elmo-network-session-password-key session))))
1169     (or (elmo-imap4-read-ok session tag)
1170         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1171     (setq elmo-imap4-status 'auth)))
1172
1173 (luna-define-method
1174   elmo-network-initialize-session-buffer :after ((session
1175                                                   elmo-imap4-session) buffer)
1176   (with-current-buffer buffer
1177     (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
1178     (setq elmo-imap4-seqno 0)
1179     (setq elmo-imap4-status 'initial)))
1180
1181 (luna-define-method elmo-network-initialize-session ((session
1182                                                       elmo-imap4-session))
1183   (let ((process (elmo-network-session-process-internal session)))
1184     (with-current-buffer (process-buffer process)
1185       ;; Skip garbage output from process before greeting.
1186       (while (and (memq (process-status process) '(open run))
1187                   (goto-char (point-max))
1188                   (forward-line -1)
1189                   (not (elmo-imap4-parse-greeting)))
1190         (accept-process-output process 1))
1191       (set-process-filter process 'elmo-imap4-arrival-filter)
1192       (set-process-sentinel process 'elmo-imap4-sentinel)
1193 ;;;   (while (and (memq (process-status process) '(open run))
1194 ;;;               (eq elmo-imap4-status 'initial))
1195 ;;;     (message "Waiting for server response...")
1196 ;;;     (accept-process-output process 1))
1197 ;;;   (message "")
1198       (unless (memq elmo-imap4-status '(nonauth auth))
1199         (signal 'elmo-open-error
1200                 (list 'elmo-network-initialize-session)))
1201       (elmo-imap4-session-set-capability-internal
1202        session
1203        (elmo-imap4-response-value
1204         (elmo-imap4-send-command-wait session "capability")
1205         'capability))
1206       (when (eq (elmo-network-stream-type-symbol
1207                  (elmo-network-session-stream-type-internal session))
1208                 'starttls)
1209         (or (memq 'starttls
1210                   (elmo-imap4-session-capability-internal session))
1211             (signal 'elmo-open-error
1212                     '(elmo-imap4-starttls-error)))
1213         (elmo-imap4-send-command-wait session "starttls")
1214         (starttls-negotiate process)))))
1215
1216 (luna-define-method elmo-network-authenticate-session ((session
1217                                                         elmo-imap4-session))
1218   (with-current-buffer (process-buffer
1219                         (elmo-network-session-process-internal session))
1220     (let* ((auth (elmo-network-session-auth-internal session))
1221            (auth (if (listp auth) auth (list auth))))
1222       (unless (or (eq elmo-imap4-status 'auth)
1223                   (null auth))
1224         (cond
1225          ((eq 'clear (car auth))
1226           (elmo-imap4-clear-login session))
1227          ((eq 'login (car auth))
1228           (elmo-imap4-auth-login session))
1229          (t
1230           (let* ((elmo-imap4-debug-inhibit-logging t)
1231                  (sasl-mechanisms
1232                   (delq nil
1233                         (mapcar
1234                          '(lambda (cap)
1235                             (if (string-match "^auth=\\(.*\\)$"
1236                                               (symbol-name cap))
1237                                 (match-string 1 (upcase (symbol-name cap)))))
1238                          (elmo-imap4-session-capability-internal session))))
1239                  (mechanism
1240                   (sasl-find-mechanism
1241                    (delq nil
1242                          (mapcar '(lambda (cap) (upcase (symbol-name cap)))
1243                                  (if (listp auth)
1244                                      auth
1245                                    (list auth)))))) ;)
1246                  client name step response tag
1247                  sasl-read-passphrase)
1248             (unless mechanism
1249               (if (or elmo-imap4-force-login
1250                       (y-or-n-p
1251                        (format
1252                         "There's no %s capability in server. continue?"
1253                         (elmo-list-to-string
1254                          (elmo-network-session-auth-internal session)))))
1255                   (setq mechanism (sasl-find-mechanism
1256                                    sasl-mechanisms))
1257                 (signal 'elmo-authenticate-error
1258                         '(elmo-imap4-auth-no-mechanisms))))
1259             (setq client
1260                   (sasl-make-client
1261                    mechanism
1262                    (elmo-network-session-user-internal session)
1263                    "imap"
1264                    (elmo-network-session-host-internal session)))
1265 ;;;         (if elmo-imap4-auth-user-realm
1266 ;;;             (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
1267             (setq name (sasl-mechanism-name mechanism)
1268                   step (sasl-next-step client nil))
1269             (elmo-network-session-set-auth-internal
1270              session
1271              (intern (downcase name)))
1272             (setq sasl-read-passphrase
1273                   (function
1274                    (lambda (prompt)
1275                      (elmo-get-passwd
1276                       (elmo-network-session-password-key session)))))
1277             (setq tag
1278                   (elmo-imap4-send-command
1279                    session
1280                    (concat "AUTHENTICATE " name
1281                            (and (sasl-step-data step)
1282                                 (concat
1283                                  " "
1284                                  (elmo-base64-encode-string
1285                                   (sasl-step-data step)
1286                                   'no-lin-break))))))
1287             (catch 'done
1288               (while t
1289                 (setq response
1290                       (elmo-imap4-read-untagged
1291                        (elmo-network-session-process-internal session)))
1292                 (if (elmo-imap4-response-ok-p response)
1293                     (if (sasl-next-step client step)
1294                         ;; Bogus server?
1295                         (signal 'elmo-authenticate-error
1296                                 (list (intern
1297                                        (concat "elmo-imap4-auth-"
1298                                                (downcase name)))))
1299                       ;; The authentication process is finished.
1300                       (throw 'done nil)))
1301                 (unless (elmo-imap4-response-continue-req-p response)
1302                   ;; response is NO or BAD.
1303                   (signal 'elmo-authenticate-error
1304                           (list (intern
1305                                  (concat "elmo-imap4-auth-"
1306                                          (downcase name))))))
1307                 (sasl-step-set-data
1308                  step
1309                  (elmo-base64-decode-string
1310                   (elmo-imap4-response-value response 'continue-req)))
1311                 (setq step (sasl-next-step client step))
1312                 (setq tag
1313                       (elmo-imap4-send-string
1314                        session
1315                        (if (sasl-step-data step)
1316                            (elmo-base64-encode-string (sasl-step-data step)
1317                                                       'no-line-break)
1318                          ""))))))))))))
1319
1320 (luna-define-method elmo-network-setup-session ((session
1321                                                  elmo-imap4-session))
1322   (with-current-buffer (elmo-network-session-buffer session)
1323     (when (memq 'namespace (elmo-imap4-session-capability-internal session))
1324       (setq elmo-imap4-server-namespace
1325             (elmo-imap4-response-value
1326              (elmo-imap4-send-command-wait session "namespace")
1327              'namespace)))))
1328
1329 (defun elmo-imap4-setup-send-buffer (string)
1330   (let ((tmp-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*")))
1331     (save-excursion
1332       (save-match-data
1333         (set-buffer tmp-buf)
1334         (erase-buffer)
1335         (elmo-set-buffer-multibyte nil)
1336         (insert string)
1337         (goto-char (point-min))
1338         (if (eq (re-search-forward "^$" nil t)
1339                 (point-max))
1340             (insert "\n"))
1341         (goto-char (point-min))
1342         (while (search-forward "\n" nil t)
1343           (replace-match "\r\n"))))
1344     tmp-buf))
1345
1346 (defun elmo-imap4-read-part (folder msg part)
1347   (let* ((spec (elmo-folder-get-spec folder))
1348          (session (elmo-imap4-get-session spec)))
1349     (elmo-imap4-session-select-mailbox session
1350                                        (elmo-imap4-spec-mailbox spec))
1351     (with-current-buffer (elmo-network-session-buffer session)
1352       (setq elmo-imap4-fetch-callback nil)
1353       (setq elmo-imap4-fetch-callback-data nil))
1354     (setq elmo-imap4-display-literal-progress t)
1355     (prog1
1356         (unwind-protect
1357             (elmo-delete-cr
1358              (elmo-imap4-response-bodydetail-text
1359               (elmo-imap4-response-value-all
1360                (elmo-imap4-send-command-wait session
1361                                              (format
1362                                               (if elmo-imap4-use-uid
1363                                                   "uid fetch %s body.peek[%s]"
1364                                                 "fetch %s body.peek[%s]")
1365                                               msg part))
1366                'fetch)))
1367           (setq elmo-imap4-display-literal-progress nil))
1368       (message "Retrieving...done."))))
1369
1370 (defun elmo-imap4-prefetch-msg (spec msg outbuf)
1371   (elmo-imap4-read-msg spec msg outbuf nil 'unseen))
1372
1373 (defun elmo-imap4-read-msg (spec msg outbuf
1374                                  &optional msgdb leave-seen-flag-untouched)
1375   (let ((session (elmo-imap4-get-session spec))
1376         response)
1377     (elmo-imap4-session-select-mailbox session
1378                                        (elmo-imap4-spec-mailbox spec))
1379     (with-current-buffer (elmo-network-session-buffer session)
1380       (setq elmo-imap4-fetch-callback nil)
1381       (setq elmo-imap4-fetch-callback-data nil))
1382     (setq elmo-imap4-display-literal-progress t)
1383     (unwind-protect
1384         (setq response
1385               (elmo-imap4-send-command-wait session
1386                                             (format
1387                                              (if elmo-imap4-use-uid
1388                                                  "uid fetch %s body%s[]"
1389                                                "fetch %s body%s[]")
1390                                              msg
1391                                              (if leave-seen-flag-untouched
1392                                                  ".peek" ""))))
1393       (setq elmo-imap4-display-literal-progress nil))
1394     (message "Retrieving...done.")
1395     (and (setq response (elmo-imap4-response-bodydetail-text
1396                          (elmo-imap4-response-value-all
1397                           response 'fetch )))
1398          (with-current-buffer outbuf
1399            (erase-buffer)
1400            (insert response)
1401            (elmo-delete-cr-get-content-type)))))
1402
1403 (defun elmo-imap4-setup-send-buffer-from-file (file)
1404   (let ((tmp-buf (get-buffer-create
1405                   " *elmo-imap4-setup-send-buffer-from-file*")))
1406     (save-excursion
1407       (save-match-data
1408         (set-buffer tmp-buf)
1409         (erase-buffer)
1410         (as-binary-input-file
1411          (insert-file-contents file))
1412         (goto-char (point-min))
1413         (if (eq (re-search-forward "^$" nil t)
1414                 (point-max))
1415             (insert "\n"))
1416         (goto-char (point-min))
1417         (while (search-forward "\n" nil t)
1418           (replace-match "\r\n"))))
1419     tmp-buf))
1420
1421 (defun elmo-imap4-delete-msgids (spec msgids)
1422   "If actual message-id is matched, then delete it."
1423   (let ((message-ids msgids)
1424         (i 0)
1425         (num (length msgids)))
1426     (while message-ids
1427       (setq i (+ 1 i))
1428       (message "Deleting message...%d/%d" i num)
1429       (elmo-imap4-delete-msg-by-id spec (car message-ids))
1430       (setq message-ids (cdr message-ids)))
1431     (elmo-imap4-send-command-wait (elmo-imap4-get-session spec) "expunge")))
1432
1433 (defun elmo-imap4-delete-msg-by-id (spec msgid)
1434   (let ((session (elmo-imap4-get-session spec)))
1435     (elmo-imap4-session-select-mailbox session
1436                                        (elmo-imap4-spec-mailbox spec))
1437     (elmo-imap4-delete-msgs-no-expunge
1438      spec
1439      (elmo-imap4-response-value
1440       (elmo-imap4-send-command-wait session
1441                                     (list
1442                                      (if elmo-imap4-use-uid
1443                                          "uid search header message-id "
1444                                        "search header message-id ")
1445                                      (elmo-imap4-field-body msgid)))
1446       'search))))
1447
1448 (defun elmo-imap4-append-msg-by-id (spec msgid)
1449   (let ((session (elmo-imap4-get-session spec))
1450         send-buf)
1451     (elmo-imap4-session-select-mailbox session
1452                                        (elmo-imap4-spec-mailbox spec))
1453     (setq send-buf (elmo-imap4-setup-send-buffer-from-file
1454                     (elmo-cache-get-path msgid)))
1455     (unwind-protect
1456         (elmo-imap4-send-command-wait
1457          session
1458          (list
1459           "append "
1460           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1461           " (\\Seen) "
1462           (elmo-imap4-buffer-literal send-buf)))
1463       (kill-buffer send-buf)))
1464   t)
1465
1466 (defun elmo-imap4-append-msg (spec string &optional msg no-see)
1467   (let ((session (elmo-imap4-get-session spec))
1468         send-buf)
1469     (elmo-imap4-session-select-mailbox session
1470                                        (elmo-imap4-spec-mailbox spec))
1471     (setq send-buf (elmo-imap4-setup-send-buffer string))
1472     (unwind-protect
1473         (elmo-imap4-send-command-wait
1474          session
1475          (list
1476           "append "
1477           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1478           (if no-see " " " (\\Seen) ")
1479           (elmo-imap4-buffer-literal send-buf)))
1480       (kill-buffer send-buf)))
1481   t)
1482
1483 (defun elmo-imap4-copy-msgs (dst-spec
1484                              msgs src-spec &optional expunge-it same-number)
1485   "Equivalence of hostname, username is assumed."
1486   (let ((session (elmo-imap4-get-session src-spec)))
1487     (elmo-imap4-session-select-mailbox session
1488                                        (elmo-imap4-spec-mailbox src-spec))
1489     (while msgs
1490       (elmo-imap4-send-command-wait session
1491                                     (list
1492                                      (format
1493                                       (if elmo-imap4-use-uid
1494                                           "uid copy %s "
1495                                         "copy %s ")
1496                                       (car msgs))
1497                                      (elmo-imap4-mailbox
1498                                       (elmo-imap4-spec-mailbox dst-spec))))
1499       (setq msgs (cdr msgs)))
1500     (when expunge-it
1501       (elmo-imap4-send-command-wait session "expunge"))
1502     t))
1503
1504 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1505   (funcall elmo-imap4-server-diff-async-callback
1506            (cons (elmo-imap4-response-value status 'unseen)
1507                  (elmo-imap4-response-value status 'messages))
1508            data))
1509
1510 (defun elmo-imap4-server-diff-async (spec)
1511   (let ((session (elmo-imap4-get-session spec)))
1512     ;; commit.
1513     ;; (elmo-imap4-commit spec)
1514     (with-current-buffer (elmo-network-session-buffer session)
1515       (setq elmo-imap4-status-callback
1516             'elmo-imap4-server-diff-async-callback-1)
1517       (setq elmo-imap4-status-callback-data
1518             elmo-imap4-server-diff-async-callback-data))
1519     (elmo-imap4-send-command session
1520                              (list
1521                               "status "
1522                               (elmo-imap4-mailbox
1523                                (elmo-imap4-spec-mailbox spec))
1524                               " (unseen messages)"))))
1525
1526 (defun elmo-imap4-server-diff (spec)
1527   "Get server status"
1528   (let ((session (elmo-imap4-get-session spec))
1529         response)
1530     ;; commit.
1531 ;;; (elmo-imap4-commit spec)
1532     (with-current-buffer (elmo-network-session-buffer session)
1533       (setq elmo-imap4-status-callback nil)
1534       (setq elmo-imap4-status-callback-data nil))
1535     (setq response
1536           (elmo-imap4-send-command-wait session
1537                                         (list
1538                                          "status "
1539                                          (elmo-imap4-mailbox
1540                                           (elmo-imap4-spec-mailbox spec))
1541                                          " (unseen messages)")))
1542     (setq response (elmo-imap4-response-value response 'status))
1543     (cons (elmo-imap4-response-value response 'unseen)
1544           (elmo-imap4-response-value response 'messages))))
1545
1546 (defun elmo-imap4-use-cache-p (spec number)
1547   elmo-imap4-use-cache)
1548
1549 (defun elmo-imap4-local-file-p (spec number)
1550   nil)
1551
1552 (defun elmo-imap4-port-label (spec)
1553   (concat "imap4"
1554           (if (elmo-imap4-spec-stream-type spec)
1555               (concat "!" (symbol-name
1556                            (elmo-network-stream-type-symbol
1557                             (elmo-imap4-spec-stream-type spec)))))))
1558
1559
1560 (defsubst elmo-imap4-portinfo (spec)
1561   (list (elmo-imap4-spec-hostname spec) (elmo-imap4-spec-port spec)))
1562
1563 (defun elmo-imap4-plugged-p (spec)
1564   (apply 'elmo-plugged-p
1565          (append (elmo-imap4-portinfo spec)
1566                  (list nil (quote (elmo-imap4-port-label spec))))))
1567
1568 (defun elmo-imap4-set-plugged (spec plugged add)
1569   (apply 'elmo-set-plugged plugged
1570          (append (elmo-imap4-portinfo spec)
1571                  (list nil nil (quote (elmo-imap4-port-label spec)) add))))
1572
1573 (defalias 'elmo-imap4-sync-number-alist 'elmo-generic-sync-number-alist)
1574
1575 ;;; IMAP parser.
1576
1577 (defvar elmo-imap4-server-eol "\r\n"
1578   "The EOL string sent from the server.")
1579
1580 (defvar elmo-imap4-client-eol "\r\n"
1581   "The EOL string we send to the server.")
1582
1583 (defvar elmo-imap4-display-literal-progress nil)
1584
1585 (defun elmo-imap4-find-next-line ()
1586   "Return point at end of current line, taking into account literals.
1587 Return nil if no complete line has arrived."
1588   (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1589                                    elmo-imap4-server-eol)
1590                            nil t)
1591     (if (match-string 1)
1592         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1593             (progn
1594               (if elmo-imap4-display-literal-progress
1595                   (message "Retrieving...(%d/%d bytes)"
1596                            (- (point-max) (point))
1597                            (string-to-number (match-string 1))))
1598               nil)
1599           (goto-char (+ (point) (string-to-number (match-string 1))))
1600           (elmo-imap4-find-next-line))
1601       (point))))
1602
1603 (defun elmo-imap4-sentinel (process string)
1604   (delete-process process))
1605
1606 (defun elmo-imap4-arrival-filter (proc string)
1607   "IMAP process filter."
1608   (when (buffer-live-p (process-buffer proc))
1609   (with-current-buffer (process-buffer proc)
1610     (elmo-imap4-debug "-> %s" string)
1611     (goto-char (point-max))
1612     (insert string)
1613     (let (end)
1614       (goto-char (point-min))
1615       (while (setq end (elmo-imap4-find-next-line))
1616         (save-restriction
1617           (narrow-to-region (point-min) end)
1618           (delete-backward-char (length elmo-imap4-server-eol))
1619           (goto-char (point-min))
1620           (unwind-protect
1621               (cond ((eq elmo-imap4-status 'initial)
1622                      (setq elmo-imap4-current-response
1623                            (list
1624                             (list 'greeting (elmo-imap4-parse-greeting)))))
1625                     ((or (eq elmo-imap4-status 'auth)
1626                          (eq elmo-imap4-status 'nonauth)
1627                          (eq elmo-imap4-status 'selected)
1628                          (eq elmo-imap4-status 'examine))
1629                      (setq elmo-imap4-current-response
1630                            (cons
1631                             (elmo-imap4-parse-response)
1632                             elmo-imap4-current-response)))
1633                     (t
1634                      (message "Unknown state %s in arrival filter"
1635                               elmo-imap4-status))))
1636           (delete-region (point-min) (point-max))))))))
1637
1638 ;; IMAP parser.
1639
1640 (defsubst elmo-imap4-forward ()
1641   (or (eobp) (forward-char 1)))
1642
1643 (defsubst elmo-imap4-parse-number ()
1644   (when (looking-at "[0-9]+")
1645     (prog1
1646         (string-to-number (match-string 0))
1647       (goto-char (match-end 0)))))
1648
1649 (defsubst elmo-imap4-parse-literal ()
1650   (when (looking-at "{\\([0-9]+\\)}\r\n")
1651     (let ((pos (match-end 0))
1652           (len (string-to-number (match-string 1))))
1653       (if (< (point-max) (+ pos len))
1654           nil
1655         (goto-char (+ pos len))
1656         (buffer-substring pos (+ pos len))))))
1657 ;;;     (list ' pos (+ pos len))))))
1658
1659 (defsubst elmo-imap4-parse-string ()
1660   (cond ((eq (char-after (point)) ?\")
1661          (forward-char 1)
1662          (let ((p (point)) (name ""))
1663            (skip-chars-forward "^\"\\\\")
1664            (setq name (buffer-substring p (point)))
1665            (while (eq (char-after (point)) ?\\)
1666              (setq p (1+ (point)))
1667              (forward-char 2)
1668              (skip-chars-forward "^\"\\\\")
1669              (setq name (concat name (buffer-substring p (point)))))
1670            (forward-char 1)
1671            name))
1672         ((eq (char-after (point)) ?{)
1673          (elmo-imap4-parse-literal))))
1674
1675 (defsubst elmo-imap4-parse-nil ()
1676   (if (looking-at "NIL")
1677       (goto-char (match-end 0))))
1678
1679 (defsubst elmo-imap4-parse-nstring ()
1680   (or (elmo-imap4-parse-string)
1681       (and (elmo-imap4-parse-nil)
1682            nil)))
1683
1684 (defsubst elmo-imap4-parse-astring ()
1685   (or (elmo-imap4-parse-string)
1686       (buffer-substring (point)
1687                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1688                             (goto-char (1- (match-end 0)))
1689                           (end-of-line)
1690                           (point)))))
1691
1692 (defsubst elmo-imap4-parse-address ()
1693   (let (address)
1694     (when (eq (char-after (point)) ?\()
1695       (elmo-imap4-forward)
1696       (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1697                               (elmo-imap4-forward))
1698                             (prog1 (elmo-imap4-parse-nstring)
1699                               (elmo-imap4-forward))
1700                             (prog1 (elmo-imap4-parse-nstring)
1701                               (elmo-imap4-forward))
1702                             (elmo-imap4-parse-nstring)))
1703       (when (eq (char-after (point)) ?\))
1704         (elmo-imap4-forward)
1705         address))))
1706
1707 (defsubst elmo-imap4-parse-address-list ()
1708   (if (eq (char-after (point)) ?\()
1709       (let (address addresses)
1710         (elmo-imap4-forward)
1711         (while (and (not (eq (char-after (point)) ?\)))
1712                     ;; next line for MS Exchange bug
1713                     (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1714                     (setq address (elmo-imap4-parse-address)))
1715           (setq addresses (cons address addresses)))
1716         (when (eq (char-after (point)) ?\))
1717           (elmo-imap4-forward)
1718           (nreverse addresses)))
1719     (assert (elmo-imap4-parse-nil))))
1720
1721 (defsubst elmo-imap4-parse-mailbox ()
1722   (let ((mailbox (elmo-imap4-parse-astring)))
1723     (if (string-equal "INBOX" (upcase mailbox))
1724         "INBOX"
1725       mailbox)))
1726
1727 (defun elmo-imap4-parse-greeting ()
1728   "Parse a IMAP greeting."
1729   (cond ((looking-at "\\* OK ")
1730          (setq elmo-imap4-status 'nonauth))
1731         ((looking-at "\\* PREAUTH ")
1732          (setq elmo-imap4-status 'auth))
1733         ((looking-at "\\* BYE ")
1734          (setq elmo-imap4-status 'closed))))
1735
1736 (defun elmo-imap4-parse-response ()
1737   "Parse a IMAP command response."
1738   (let (token)
1739     (case (setq token (elmo-read (current-buffer)))
1740       (+ (progn
1741            (skip-chars-forward " ")
1742            (list 'continue-req (buffer-substring (point) (point-max)))))
1743       (* (case (prog1 (setq token (elmo-read (current-buffer)))
1744                  (elmo-imap4-forward))
1745            (OK         (elmo-imap4-parse-resp-text-code))
1746            (NO         (elmo-imap4-parse-resp-text-code))
1747            (BAD        (elmo-imap4-parse-resp-text-code))
1748            (BYE        (elmo-imap4-parse-bye))
1749            (FLAGS      (list 'flags
1750                              (elmo-imap4-parse-flag-list)))
1751            (LIST       (list 'list (elmo-imap4-parse-data-list)))
1752            (LSUB       (list 'lsub (elmo-imap4-parse-data-list)))
1753            (SEARCH     (list
1754                         'search
1755                         (elmo-read (concat "("
1756                                       (buffer-substring (point) (point-max))
1757                                       ")"))))
1758            (STATUS     (elmo-imap4-parse-status))
1759            ;; Added
1760            (NAMESPACE  (elmo-imap4-parse-namespace))
1761            (CAPABILITY (list 'capability
1762                              (elmo-read
1763                               (concat "(" (downcase (buffer-substring
1764                                                      (point) (point-max)))
1765                                       ")"))))
1766            (ACL        (elmo-imap4-parse-acl))
1767            (t       (case (prog1 (elmo-read (current-buffer))
1768                             (elmo-imap4-forward))
1769                       (EXISTS  (list 'exists token))
1770                       (RECENT  (list 'recent token))
1771                       (EXPUNGE (list 'expunge token))
1772                       (FETCH   (elmo-imap4-parse-fetch token))
1773                       (t       (list 'garbage (buffer-string)))))))
1774       (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1775              (list 'garbage (buffer-string))
1776            (case (prog1 (elmo-read (current-buffer))
1777                    (elmo-imap4-forward))
1778              (OK  (progn
1779                     (setq elmo-imap4-parsing nil)
1780                     (setq token (symbol-name token))
1781                     (elmo-unintern token)
1782                     (elmo-imap4-debug "*%s* OK arrived" token)
1783                     (setq elmo-imap4-reached-tag token)
1784                     (list 'ok (elmo-imap4-parse-resp-text-code))))
1785              (NO  (progn
1786                     (setq elmo-imap4-parsing nil)
1787                     (setq token (symbol-name token))
1788                     (elmo-unintern token)
1789                     (elmo-imap4-debug "*%s* NO arrived" token)
1790                     (setq elmo-imap4-reached-tag token)
1791                     (let (code text)
1792                       (when (eq (char-after (point)) ?\[)
1793                         (setq code (buffer-substring (point)
1794                                                      (search-forward "]")))
1795                         (elmo-imap4-forward))
1796                       (setq text (buffer-substring (point) (point-max)))
1797                       (list 'no (list code text)))))
1798              (BAD (progn
1799                     (setq elmo-imap4-parsing nil)
1800                     (elmo-imap4-debug "*%s* BAD arrived" token)
1801                     (setq token (symbol-name token))
1802                     (elmo-unintern token)
1803                     (setq elmo-imap4-reached-tag token)
1804                     (let (code text)
1805                       (when (eq (char-after (point)) ?\[)
1806                         (setq code (buffer-substring (point)
1807                                                      (search-forward "]")))
1808                         (elmo-imap4-forward))
1809                       (setq text (buffer-substring (point) (point-max)))
1810                       (list 'bad (list code text)))))
1811              (t   (list 'garbage (buffer-string)))))))))
1812
1813 (defun elmo-imap4-parse-bye ()
1814   (let (code text)
1815     (when (eq (char-after (point)) ?\[)
1816       (setq code (buffer-substring (point)
1817                                    (search-forward "]")))
1818       (elmo-imap4-forward))
1819     (setq text (buffer-substring (point) (point-max)))
1820     (list 'bye (list code text))))
1821
1822 (defun elmo-imap4-parse-text ()
1823   (goto-char (point-min))
1824   (when (search-forward "[" nil t)
1825     (search-forward "]")
1826     (elmo-imap4-forward))
1827   (list 'text (buffer-substring (point) (point-max))))
1828
1829 (defun elmo-imap4-parse-resp-text-code ()
1830   (when (eq (char-after (point)) ?\[)
1831     (elmo-imap4-forward)
1832     (cond ((search-forward "PERMANENTFLAGS " nil t)
1833            (list 'permanentflags (elmo-imap4-parse-flag-list)))
1834           ((search-forward "UIDNEXT " nil t)
1835            (list 'uidnext (elmo-read (current-buffer))))
1836           ((search-forward "UNSEEN " nil t)
1837            (list 'unseen (elmo-read (current-buffer))))
1838           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1839            (list 'uidvalidity (match-string 1)))
1840           ((search-forward "READ-ONLY" nil t)
1841            (list 'read-only t))
1842           ((search-forward "READ-WRITE" nil t)
1843            (list 'read-write t))
1844           ((search-forward "NEWNAME " nil t)
1845            (let (oldname newname)
1846              (setq oldname (elmo-imap4-parse-string))
1847              (elmo-imap4-forward)
1848              (setq newname (elmo-imap4-parse-string))
1849              (list 'newname newname oldname)))
1850           ((search-forward "TRYCREATE" nil t)
1851            (list 'trycreate t))
1852           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1853            (list 'appenduid
1854                  (list (match-string 1)
1855                        (string-to-number (match-string 2)))))
1856           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1857            (list 'copyuid (list (match-string 1)
1858                                 (match-string 2)
1859                                 (match-string 3))))
1860           ((search-forward "ALERT] " nil t)
1861            (message "IMAP server information: %s"
1862                     (buffer-substring (point) (point-max))))
1863           (t (list 'unknown)))))
1864
1865 (defun elmo-imap4-parse-data-list ()
1866   (let (flags delimiter mailbox)
1867     (setq flags (elmo-imap4-parse-flag-list))
1868     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1869       (setq delimiter (match-string 1))
1870       (goto-char (1+ (match-end 0)))
1871       (when (setq mailbox (elmo-imap4-parse-mailbox))
1872         (list mailbox flags delimiter)))))
1873
1874 (defsubst elmo-imap4-parse-header-list ()
1875   (when (eq (char-after (point)) ?\()
1876     (let (strlist)
1877       (while (not (eq (char-after (point)) ?\)))
1878         (elmo-imap4-forward)
1879         (push (elmo-imap4-parse-astring) strlist))
1880       (elmo-imap4-forward)
1881       (nreverse strlist))))
1882
1883 (defsubst elmo-imap4-parse-fetch-body-section ()
1884   (let ((section
1885          (buffer-substring (point)
1886                            (1-
1887                             (progn (re-search-forward "[] ]" nil t)
1888                                    (point))))))
1889     (if (eq (char-before) ? )
1890         (prog1
1891             (mapconcat 'identity
1892                        (cons section (elmo-imap4-parse-header-list)) " ")
1893           (search-forward "]" nil t))
1894       section)))
1895
1896 (defun elmo-imap4-parse-fetch (response)
1897   (when (eq (char-after (point)) ?\()
1898     (let (element list)
1899       (while (not (eq (char-after (point)) ?\)))
1900         (elmo-imap4-forward)
1901         (let ((token (elmo-imap4-fetch-read (current-buffer))))
1902           (elmo-imap4-forward)
1903           (setq element
1904                 (cond ((eq token 'UID)
1905                        (list 'uid (condition-case nil
1906                                       (elmo-read (current-buffer))
1907                                     (error nil))))
1908                       ((eq token 'FLAGS)
1909                        (list 'flags (elmo-imap4-parse-flag-list)))
1910                       ((eq token 'ENVELOPE)
1911                        (list 'envelope (elmo-imap4-parse-envelope)))
1912                       ((eq token 'INTERNALDATE)
1913                        (list 'internaldate (elmo-imap4-parse-string)))
1914                       ((eq token 'RFC822)
1915                        (list 'rfc822 (elmo-imap4-parse-nstring)))
1916                       ((eq token (intern elmo-imap4-rfc822-header))
1917                        (list 'rfc822header (elmo-imap4-parse-nstring)))
1918                       ((eq token (intern elmo-imap4-rfc822-text))
1919                        (list 'rfc822text (elmo-imap4-parse-nstring)))
1920                       ((eq token (intern elmo-imap4-rfc822-size))
1921                        (list 'rfc822size (elmo-read (current-buffer))))
1922                       ((eq token 'BODY)
1923                        (if (eq (char-before) ?\[)
1924                            (list
1925                             'bodydetail
1926                             (upcase (elmo-imap4-parse-fetch-body-section))
1927                             (and
1928                              (eq (char-after (point)) ?<)
1929                              (buffer-substring (1+ (point))
1930                                                (progn
1931                                                  (search-forward ">" nil t)
1932                                                  (point))))
1933                             (progn (elmo-imap4-forward)
1934                                    (elmo-imap4-parse-nstring)))
1935                          (list 'body (elmo-imap4-parse-body))))
1936                       ((eq token 'BODYSTRUCTURE)
1937                        (list 'bodystructure (elmo-imap4-parse-body)))))
1938           (setq list (cons element list))))
1939       (and elmo-imap4-fetch-callback
1940            (elmo-imap4-fetch-callback list elmo-imap4-fetch-callback-data))
1941       (list 'fetch list))))
1942
1943 (defun elmo-imap4-parse-status ()
1944   (let ((mailbox (elmo-imap4-parse-mailbox))
1945         status)
1946     (when (and mailbox (search-forward "(" nil t))
1947       (while (not (eq (char-after (point)) ?\)))
1948         (setq status
1949               (cons
1950                (let ((token (elmo-read (current-buffer))))
1951                  (cond ((eq token 'MESSAGES)
1952                         (list 'messages (elmo-read (current-buffer))))
1953                        ((eq token 'RECENT)
1954                         (list 'recent (elmo-read (current-buffer))))
1955                        ((eq token 'UIDNEXT)
1956                         (list 'uidnext (elmo-read (current-buffer))))
1957                        ((eq token 'UIDVALIDITY)
1958                         (and (looking-at " \\([0-9]+\\)")
1959                              (prog1 (list 'uidvalidity (match-string 1))
1960                                (goto-char (match-end 1)))))
1961                        ((eq token 'UNSEEN)
1962                         (list 'unseen (elmo-read (current-buffer))))
1963                        (t
1964                         (message
1965                          "Unknown status data %s in mailbox %s ignored"
1966                          token mailbox))))
1967                status))))
1968     (and elmo-imap4-status-callback
1969          (funcall elmo-imap4-status-callback
1970                   status
1971                   elmo-imap4-status-callback-data))
1972     (list 'status status)))
1973
1974
1975 (defmacro elmo-imap4-value (value)
1976   (` (if (eq (, value) 'NIL) nil
1977        (, value))))
1978
1979 (defmacro elmo-imap4-nth (pos list)
1980   (` (let ((value (nth (, pos) (, list))))
1981        (elmo-imap4-value value))))
1982
1983 (defun elmo-imap4-parse-namespace ()
1984   (list 'namespace
1985         (nconc
1986          (copy-sequence elmo-imap4-extra-namespace-alist)
1987          (elmo-imap4-parse-namespace-subr
1988           (elmo-read (concat "(" (buffer-substring
1989                                   (point) (point-max))
1990                              ")"))))))
1991
1992 (defun elmo-imap4-parse-namespace-subr (ns)
1993   (let (prefix delim namespace-alist default-delim)
1994     ;; 0: personal, 1: other, 2: shared
1995     (dotimes (i 3)
1996       (setq namespace-alist
1997             (nconc namespace-alist
1998                    (delq nil
1999                          (mapcar
2000                           (lambda (namespace)
2001                             (setq prefix (elmo-imap4-nth 0 namespace)
2002                                   delim (elmo-imap4-nth 1 namespace))
2003                             (if (and prefix delim
2004                                      (string-match
2005                                       (concat (regexp-quote delim) "\\'")
2006                                       prefix))
2007                                 (setq prefix (substring prefix 0
2008                                                         (match-beginning 0))))
2009                             (if (eq (length prefix) 0)
2010                                 (progn (setq default-delim delim) nil)
2011                               (cons
2012                                (concat "^"
2013                                        (if (string= (downcase prefix) "inbox")
2014                                            "[Ii][Nn][Bb][Oo][Xx]"
2015                                          (regexp-quote prefix))
2016                                        ".*$")
2017                                delim)))
2018                           (elmo-imap4-nth i ns))))))
2019     (if default-delim
2020         (setq namespace-alist
2021               (nconc namespace-alist
2022                      (list (cons "^.*$" default-delim)))))
2023     namespace-alist))
2024
2025 (defun elmo-imap4-parse-acl ()
2026   (let ((mailbox (elmo-imap4-parse-mailbox))
2027         identifier rights acl)
2028     (while (eq (char-after (point)) ?\ )
2029       (elmo-imap4-forward)
2030       (setq identifier (elmo-imap4-parse-astring))
2031       (elmo-imap4-forward)
2032       (setq rights (elmo-imap4-parse-astring))
2033       (setq acl (append acl (list (cons identifier rights)))))
2034     (list 'acl acl mailbox)))
2035
2036 (defun elmo-imap4-parse-flag-list ()
2037   (let ((str (buffer-substring (+ (point) 1)
2038                                (progn (search-forward ")" nil t)
2039                                       (- (point) 1)))))
2040     (unless (eq (length str) 0)
2041       (split-string str))))
2042
2043 (defun elmo-imap4-parse-envelope ()
2044   (when (eq (char-after (point)) ?\()
2045     (elmo-imap4-forward)
2046     (vector (prog1 (elmo-imap4-parse-nstring);; date
2047               (elmo-imap4-forward))
2048             (prog1 (elmo-imap4-parse-nstring);; subject
2049               (elmo-imap4-forward))
2050             (prog1 (elmo-imap4-parse-address-list);; from
2051               (elmo-imap4-forward))
2052             (prog1 (elmo-imap4-parse-address-list);; sender
2053               (elmo-imap4-forward))
2054             (prog1 (elmo-imap4-parse-address-list);; reply-to
2055               (elmo-imap4-forward))
2056             (prog1 (elmo-imap4-parse-address-list);; to
2057               (elmo-imap4-forward))
2058             (prog1 (elmo-imap4-parse-address-list);; cc
2059               (elmo-imap4-forward))
2060             (prog1 (elmo-imap4-parse-address-list);; bcc
2061               (elmo-imap4-forward))
2062             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
2063               (elmo-imap4-forward))
2064             (prog1 (elmo-imap4-parse-nstring);; message-id
2065               (elmo-imap4-forward)))))
2066
2067 (defsubst elmo-imap4-parse-string-list ()
2068   (cond ((eq (char-after (point)) ?\();; body-fld-param
2069          (let (strlist str)
2070            (elmo-imap4-forward)
2071            (while (setq str (elmo-imap4-parse-string))
2072              (push str strlist)
2073              (elmo-imap4-forward))
2074            (nreverse strlist)))
2075         ((elmo-imap4-parse-nil)
2076          nil)))
2077
2078 (defun elmo-imap4-parse-body-extension ()
2079   (if (eq (char-after (point)) ?\()
2080       (let (b-e)
2081         (elmo-imap4-forward)
2082         (push (elmo-imap4-parse-body-extension) b-e)
2083         (while (eq (char-after (point)) ?\ )
2084           (elmo-imap4-forward)
2085           (push (elmo-imap4-parse-body-extension) b-e))
2086         (assert (eq (char-after (point)) ?\)))
2087         (elmo-imap4-forward)
2088         (nreverse b-e))
2089     (or (elmo-imap4-parse-number)
2090         (elmo-imap4-parse-nstring))))
2091
2092 (defsubst elmo-imap4-parse-body-ext ()
2093   (let (ext)
2094     (when (eq (char-after (point)) ?\ );; body-fld-dsp
2095       (elmo-imap4-forward)
2096       (let (dsp)
2097         (if (eq (char-after (point)) ?\()
2098             (progn
2099               (elmo-imap4-forward)
2100               (push (elmo-imap4-parse-string) dsp)
2101               (elmo-imap4-forward)
2102               (push (elmo-imap4-parse-string-list) dsp)
2103               (elmo-imap4-forward))
2104           (assert (elmo-imap4-parse-nil)))
2105         (push (nreverse dsp) ext))
2106       (when (eq (char-after (point)) ?\ );; body-fld-lang
2107         (elmo-imap4-forward)
2108         (if (eq (char-after (point)) ?\()
2109             (push (elmo-imap4-parse-string-list) ext)
2110           (push (elmo-imap4-parse-nstring) ext))
2111         (while (eq (char-after (point)) ?\ );; body-extension
2112           (elmo-imap4-forward)
2113           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
2114     ext))
2115
2116 (defun elmo-imap4-parse-body ()
2117   (let (body)
2118     (when (eq (char-after (point)) ?\()
2119       (elmo-imap4-forward)
2120       (if (eq (char-after (point)) ?\()
2121           (let (subbody)
2122             (while (and (eq (char-after (point)) ?\()
2123                         (setq subbody (elmo-imap4-parse-body)))
2124               (push subbody body))
2125             (elmo-imap4-forward)
2126             (push (elmo-imap4-parse-string) body);; media-subtype
2127             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
2128               (elmo-imap4-forward)
2129               (if (eq (char-after (point)) ?\();; body-fld-param
2130                   (push (elmo-imap4-parse-string-list) body)
2131                 (push (and (elmo-imap4-parse-nil) nil) body))
2132               (setq body
2133                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
2134             (assert (eq (char-after (point)) ?\)))
2135             (elmo-imap4-forward)
2136             (nreverse body))
2137
2138         (push (elmo-imap4-parse-string) body);; media-type
2139         (elmo-imap4-forward)
2140         (push (elmo-imap4-parse-string) body);; media-subtype
2141         (elmo-imap4-forward)
2142         ;; next line for Sun SIMS bug
2143         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
2144         (if (eq (char-after (point)) ?\();; body-fld-param
2145             (push (elmo-imap4-parse-string-list) body)
2146           (push (and (elmo-imap4-parse-nil) nil) body))
2147         (elmo-imap4-forward)
2148         (push (elmo-imap4-parse-nstring) body);; body-fld-id
2149         (elmo-imap4-forward)
2150         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
2151         (elmo-imap4-forward)
2152         (push (elmo-imap4-parse-string) body);; body-fld-enc
2153         (elmo-imap4-forward)
2154         (push (elmo-imap4-parse-number) body);; body-fld-octets
2155
2156         ;; ok, we're done parsing the required parts, what comes now is one
2157         ;; of three things:
2158         ;;
2159         ;; envelope       (then we're parsing body-type-msg)
2160         ;; body-fld-lines (then we're parsing body-type-text)
2161         ;; body-ext-1part (then we're parsing body-type-basic)
2162         ;;
2163         ;; the problem is that the two first are in turn optionally followed
2164         ;; by the third.  So we parse the first two here (if there are any)...
2165
2166         (when (eq (char-after (point)) ?\ )
2167           (elmo-imap4-forward)
2168           (let (lines)
2169             (cond ((eq (char-after (point)) ?\();; body-type-msg:
2170                    (push (elmo-imap4-parse-envelope) body);; envelope
2171                    (elmo-imap4-forward)
2172                    (push (elmo-imap4-parse-body) body);; body
2173                    (elmo-imap4-forward)
2174                    (push (elmo-imap4-parse-number) body));; body-fld-lines
2175                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
2176                    (push lines body));; body-fld-lines
2177                   (t
2178                    (backward-char)))));; no match...
2179
2180         ;; ...and then parse the third one here...
2181
2182         (when (eq (char-after (point)) ?\ );; body-ext-1part:
2183           (elmo-imap4-forward)
2184           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
2185           (setq body
2186                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
2187
2188         (assert (eq (char-after (point)) ?\)))
2189         (elmo-imap4-forward)
2190         (nreverse body)))))
2191
2192 (require 'product)
2193 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2194
2195 ;;; elmo-imap4.el ends here