elmo/elmo-imap4.el

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