elmo/elmo-imap4.el

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