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