elmo/elmo-imap4.el

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