elmo/elmo-imap4.el

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