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