elmo/elmo-imap4.el

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