elmo/elmo-imap4.el

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