elmo/elmo-imap4.el

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